virtual-ldap/bin/ldap-rewrite.pl

#!/usr/bin/perl
# Copyright (c) 2006 Hans Klunder <hans.klunder@bigfoot.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

# It's modified by Dobrica Pavlinusic <dpavlin@rot13.org> to include following:
#
# * rewrite LDAP bind request cn: username@domain.com -> uid=username,dc=domain,dc=com
# * rewrite search responses:
# ** expand key:value pairs from hrEduPersonUniqueNumber into hrEduPersonUniqueNumber_key
# ** augment response with yaml/dn.yaml data (for external data import)

use strict;
use warnings;

use IO::Select;
use IO::Socket;
use IO::Socket::SSL;
use warnings;
use Data::Dump qw/dump/;
use Convert::ASN1 qw(asn_read);
use Net::LDAP::ASN qw(LDAPRequest LDAPResponse);
our $VERSION = '0.3';
use fields qw(socket target);
use YAML qw/LoadFile/;

my $debug = 0;

my $config = {
        yaml_dir => './yaml/',
        listen => shift @ARGV || 'localhost:1389',
        upstream_ldap => 'ldap.ffzg.hr',
        upstream_ssl => 1,
        overlay_prefix => 'ffzg-',
#       log_file => 'log/ldap-rewrite.log',

};

my $log_fh;

sub log {
        return unless $config->{log_file};

        if ( ! $log_fh ) {
                open($log_fh, '>>', $config->{log_file}) || die "can't open ", $config->{log_file},": $!";
                print $log_fh "# " . time;
        }
        $log_fh->autoflush(1);
        print $log_fh join("\n", @_),"\n";
}

BEGIN {
        $SIG{'__WARN__'} = sub { warn @_; main::log(@_); }
}


if ( ! -d $config->{yaml_dir} ) {
        warn "DISABLE ", $config->{yaml_dir}," data overlay";
}

warn "# config = ",dump( $config );

sub handle {
        my $clientsocket=shift;
        my $serversocket=shift;

        # read from client
        asn_read($clientsocket, my $reqpdu);
        if ( ! $reqpdu ) {
                warn "client closed connection\n";
                return 0;
        }
        $reqpdu = log_request($reqpdu);

        # send to server
        print $serversocket $reqpdu or die "Could not send PDU to server\n ";
        
        # read from server
        my $ready;
        my $sel = IO::Select->new($serversocket);
        for( $ready = 1 ; $ready ; $ready = $sel->can_read(0)) {
                asn_read($serversocket, my $respdu);
                if ( ! $respdu ) {
                        warn "server closed connection\n";
                        return 0;
                }
                $respdu = log_response($respdu);
                # and send the result to the client
                print $clientsocket $respdu || return 0;
        }

        return 1;
}


sub log_request {
        my $pdu=shift;

        die "empty pdu" unless $pdu;

#       print '-' x 80,"\n";
#       print "Request ASN 1:\n";
#       Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
#       print "Request Perl:\n";
        my $request = $LDAPRequest->decode($pdu);
        warn "## request = ",dump($request);

        if ( defined $request->{bindRequest} ) {
                if ( $request->{bindRequest}->{name} =~ m{@} ) {
                        my $old = $request->{bindRequest}->{name};
                        $request->{bindRequest}->{name} =~ s/[@\.]/,dc=/g;
                        $request->{bindRequest}->{name} =~ s/^/uid=/;
                        warn "rewrite bind cn $old -> ", $request->{bindRequest}->{name};
                        Convert::ASN1::asn_hexdump(\*STDOUT,$pdu) if $debug;
                        $pdu = $LDAPRequest->encode($request);
                        Convert::ASN1::asn_hexdump(\*STDOUT,$pdu) if $debug;
                }
        }

        return $pdu;
}

sub log_response {
        my $pdu=shift;
        die "empty pdu" unless $pdu;

#       print '-' x 80,"\n";
#       print "Response ASN 1:\n";
#       Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
#       print "Response Perl:\n";
        my $response = $LDAPResponse->decode($pdu);

        if ( defined $response->{protocolOp}->{searchResEntry} ) {
                my $uid = $response->{protocolOp}->{searchResEntry}->{objectName};
                warn "## objectName $uid";

                my @attrs;

                foreach my $attr ( @{ $response->{protocolOp}->{searchResEntry}->{attributes} } ) {
                        if ( $attr->{type} =~ m/date/i ) {
                                foreach my $i ( 0 .. $#{ $attr->{vals} } ) {
                                        $attr->{vals}->[$i] = "$1-$2-$3" if $attr->{vals}->[$i] =~ m/^([12]\d\d\d)([01]\d+)([0123]\d+)$/;
                                }
                        } elsif ( $attr->{type} eq 'hrEduPersonUniqueNumber' ) {
                                foreach my $val ( @{ $attr->{vals} } ) {
                                        next if $val !~ m{.+:.+};
                                        my ( $n, $v ) = split(/\s*:\s*/, $val );
                                        push @attrs, { type => $attr->{type} . '_' . $n, vals => [ $v ] };
                                }
                        } elsif ( $attr->{type} eq 'hrEduPersonGroupMember' ) {
                                foreach my $i ( 0 .. $#{ $attr->{vals} } ) {
                                        $attr->{vals}->[$i] =~ s/^u2010/p2010/gs && warn "FIXME group";
                                }
                        }
                }

                warn "# ++ attrs ",dump( @attrs );

                push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, $_ foreach @attrs;

                my @additional_yamls = ( $uid );
                foreach my $attr ( @{ $response->{protocolOp}->{searchResEntry}->{attributes} } ) {
                        foreach my $v ( @{ $attr->{vals} } ) {
                                push @additional_yamls, $attr->{type} . '/' . $v;
                        }
                }

                #warn "# additional_yamls ",dump( @additional_yamls );

                foreach my $path ( @additional_yamls ) {
                        my $full_path = $config->{yaml_dir} . '/' . $path . '.yaml';
                        next unless -e $full_path;

                        my $data = LoadFile( $full_path );
                        warn "# $full_path yaml = ",dump($data);

                        foreach my $type ( keys %$data ) {

                                my $vals = $data->{$type};

                                push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, {
                                        type => $config->{overlay_prefix} . $type,
                                        vals => ref($vals) eq 'ARRAY' ? $vals : [ $vals ],
                                };
                        }
                }

                $pdu = $LDAPResponse->encode($response);
        }

        warn "## response = ", dump($response);

        return $pdu;
}


my $listenersock = IO::Socket::INET->new(
        Listen => 5,
        Proto => 'tcp',
        Reuse => 1,
        LocalAddr => $config->{listen},
) || die "can't open listen socket: $!";

our $server_sock;

sub connect_to_server {
        my $sock;
        if ( $config->{upstream_ssl} ) {
                $sock = IO::Socket::SSL->new( $config->{upstream_ldap} . ':ldaps' );
        } else {
                $sock = IO::Socket::INET->new(
                        Proto => 'tcp',
                        PeerAddr => $config->{upstream_ldap},
                        PeerPort => 389,
                );
        }
        die "can't open ", $config->{upstream_ldap}, " $!\n" unless $sock;
        warn "## connected to ", $sock->peerhost, ":", $sock->peerport, "\n";
        return $sock;
}

my $sel = IO::Select->new($listenersock);
while (my @ready = $sel->can_read) {
        foreach my $fh (@ready) {
                if ($fh == $listenersock) {
                        # let's create a new socket
                        my $psock = $listenersock->accept;
                        $sel->add($psock);
                        warn "## add $psock " . time;
                } else {
                        $server_sock->{$fh} ||= connect_to_server;
                        if ( ! handle($fh,$server_sock->{$fh}) ) {
                                warn "## remove $fh " . time;
                                $sel->remove($server_sock->{$fh});
                                $server_sock->{$fh}->close;
                                delete $server_sock->{$fh};
                                # we have finished with the socket
                                $sel->remove($fh);
                                $fh->close;
                        }
                }
        }
}

1;
1	dpavlin	8	#!/usr/bin/perl
2			# Copyright (c) 2006 Hans Klunder <hans.klunder@bigfoot.com>. All rights reserved.
3			# This program is free software; you can redistribute it and/or
4			# modify it under the same terms as Perl itself.
5
6	dpavlin	61	# It's modified by Dobrica Pavlinusic <dpavlin@rot13.org> to include following:
7			#
8			# * rewrite LDAP bind request cn: username@domain.com -> uid=username,dc=domain,dc=com
9			# * rewrite search responses:
10			# ** expand key:value pairs from hrEduPersonUniqueNumber into hrEduPersonUniqueNumber_key
11			# ** augment response with yaml/dn.yaml data (for external data import)
12	dpavlin	8
13			use strict;
14			use warnings;
15
16			use IO::Select;
17			use IO::Socket;
18	dpavlin	16	use IO::Socket::SSL;
19	dpavlin	8	use warnings;
20			use Data::Dump qw/dump/;
21			use Convert::ASN1 qw(asn_read);
22			use Net::LDAP::ASN qw(LDAPRequest LDAPResponse);
23	dpavlin	61	our $VERSION = '0.3';
24	dpavlin	8	use fields qw(socket target);
25	dpavlin	10	use YAML qw/LoadFile/;
26	dpavlin	8
27	dpavlin	70	my $debug = 0;
28	dpavlin	61
29	dpavlin	18	my $config = {
30			yaml_dir => './yaml/',
31	dpavlin	37	listen => shift @ARGV \|\| 'localhost:1389',
32	dpavlin	18	upstream_ldap => 'ldap.ffzg.hr',
33			upstream_ssl => 1,
34			overlay_prefix => 'ffzg-',
35	dpavlin	66	# log_file => 'log/ldap-rewrite.log',
36	dpavlin	18
37			};
38
39	dpavlin	27	my $log_fh;
40
41			sub log {
42	dpavlin	66	return unless $config->{log_file};
43
44	dpavlin	28	if ( ! $log_fh ) {
45			open($log_fh, '>>', $config->{log_file}) \|\| die "can't open ", $config->{log_file},": $!";
46			print $log_fh "# " . time;
47			}
48	dpavlin	27	$log_fh->autoflush(1);
49			print $log_fh join("\n", @_),"\n";
50			}
51
52			BEGIN {
53			$SIG{'__WARN__'} = sub { warn @_; main::log(@_); }
54			}
55
56
57	dpavlin	18	if ( ! -d $config->{yaml_dir} ) {
58			warn "DISABLE ", $config->{yaml_dir}," data overlay";
59			}
60
61			warn "# config = ",dump( $config );
62
63	dpavlin	8	sub handle {
64			my $clientsocket=shift;
65			my $serversocket=shift;
66
67			# read from client
68			asn_read($clientsocket, my $reqpdu);
69	dpavlin	61	if ( ! $reqpdu ) {
70	dpavlin	73	warn "client closed connection\n";
71			return 0;
72	dpavlin	61	}
73			$reqpdu = log_request($reqpdu);
74	dpavlin	8
75			# send to server
76			print $serversocket $reqpdu or die "Could not send PDU to server\n ";
77
78			# read from server
79			my $ready;
80			my $sel = IO::Select->new($serversocket);
81			for( $ready = 1 ; $ready ; $ready = $sel->can_read(0)) {
82	dpavlin	73	asn_read($serversocket, my $respdu);
83			if ( ! $respdu ) {
84			warn "server closed connection\n";
85			return 0;
86			}
87	dpavlin	8	$respdu = log_response($respdu);
88			# and send the result to the client
89	dpavlin	73	print $clientsocket $respdu \|\| return 0;
90	dpavlin	8	}
91
92	dpavlin	73	return 1;
93	dpavlin	8	}
94
95
96			sub log_request {
97			my $pdu=shift;
98
99	dpavlin	73	die "empty pdu" unless $pdu;
100
101	dpavlin	28	# print '-' x 80,"\n";
102			# print "Request ASN 1:\n";
103			# Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
104			# print "Request Perl:\n";
105	dpavlin	8	my $request = $LDAPRequest->decode($pdu);
106	dpavlin	28	warn "## request = ",dump($request);
107	dpavlin	61
108			if ( defined $request->{bindRequest} ) {
109			if ( $request->{bindRequest}->{name} =~ m{@} ) {
110			my $old = $request->{bindRequest}->{name};
111			$request->{bindRequest}->{name} =~ s/[@\.]/,dc=/g;
112	dpavlin	69	$request->{bindRequest}->{name} =~ s/^/uid=/;
113	dpavlin	61	warn "rewrite bind cn $old -> ", $request->{bindRequest}->{name};
114			Convert::ASN1::asn_hexdump(\*STDOUT,$pdu) if $debug;
115			$pdu = $LDAPRequest->encode($request);
116			Convert::ASN1::asn_hexdump(\*STDOUT,$pdu) if $debug;
117			}
118			}
119
120			return $pdu;
121	dpavlin	8	}
122
123			sub log_response {
124			my $pdu=shift;
125	dpavlin	73	die "empty pdu" unless $pdu;
126	dpavlin	8
127	dpavlin	28	# print '-' x 80,"\n";
128			# print "Response ASN 1:\n";
129			# Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
130			# print "Response Perl:\n";
131	dpavlin	8	my $response = $LDAPResponse->decode($pdu);
132
133			if ( defined $response->{protocolOp}->{searchResEntry} ) {
134			my $uid = $response->{protocolOp}->{searchResEntry}->{objectName};
135	dpavlin	37	warn "## objectName $uid";
136	dpavlin	10
137	dpavlin	19	my @attrs;
138
139	dpavlin	84	foreach my $attr ( @{ $response->{protocolOp}->{searchResEntry}->{attributes} } ) {
140			if ( $attr->{type} =~ m/date/i ) {
141			foreach my $i ( 0 .. $#{ $attr->{vals} } ) {
142	dpavlin	86	$attr->{vals}->[$i] = "$1-$2-$3" if $attr->{vals}->[$i] =~ m/^([12]\d\d\d)([01]\d+)([0123]\d+)$/;
143	dpavlin	84	}
144			} elsif ( $attr->{type} eq 'hrEduPersonUniqueNumber' ) {
145			foreach my $val ( @{ $attr->{vals} } ) {
146	dpavlin	19	next if $val !~ m{.+:.+};
147			my ( $n, $v ) = split(/\s:\s/, $val );
148	dpavlin	85	push @attrs, { type => $attr->{type} . '_' . $n, vals => [ $v ] };
149	dpavlin	19	}
150	dpavlin	100	} elsif ( $attr->{type} eq 'hrEduPersonGroupMember' ) {
151			foreach my $i ( 0 .. $#{ $attr->{vals} } ) {
152			$attr->{vals}->[$i] =~ s/^u2010/p2010/gs && warn "FIXME group";
153			}
154	dpavlin	8	}
155	dpavlin	84	}
156	dpavlin	8
157	dpavlin	19	warn "# ++ attrs ",dump( @attrs );
158
159			push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, $_ foreach @attrs;
160
161	dpavlin	99	my @additional_yamls = ( $uid );
162			foreach my $attr ( @{ $response->{protocolOp}->{searchResEntry}->{attributes} } ) {
163			foreach my $v ( @{ $attr->{vals} } ) {
164			push @additional_yamls, $attr->{type} . '/' . $v;
165			}
166			}
167	dpavlin	8
168	dpavlin	99	#warn "# additional_yamls ",dump( @additional_yamls );
169
170			foreach my $path ( @additional_yamls ) {
171			my $full_path = $config->{yaml_dir} . '/' . $path . '.yaml';
172			next unless -e $full_path;
173
174			my $data = LoadFile( $full_path );
175			warn "# $full_path yaml = ",dump($data);
176
177	dpavlin	10	foreach my $type ( keys %$data ) {
178
179			my $vals = $data->{$type};
180
181	dpavlin	22	push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, {
182			type => $config->{overlay_prefix} . $type,
183			vals => ref($vals) eq 'ARRAY' ? $vals : [ $vals ],
184			};
185	dpavlin	10	}
186			}
187
188	dpavlin	8	$pdu = $LDAPResponse->encode($response);
189			}
190
191	dpavlin	28	warn "## response = ", dump($response);
192	dpavlin	10
193	dpavlin	8	return $pdu;
194			}
195
196
197			my $listenersock = IO::Socket::INET->new(
198			Listen => 5,
199			Proto => 'tcp',
200			Reuse => 1,
201	dpavlin	18	LocalAddr => $config->{listen},
202	dpavlin	29	) \|\| die "can't open listen socket: $!";
203	dpavlin	8
204	dpavlin	73	our $server_sock;
205	dpavlin	8
206	dpavlin	73	sub connect_to_server {
207			my $sock;
208			if ( $config->{upstream_ssl} ) {
209			$sock = IO::Socket::SSL->new( $config->{upstream_ldap} . ':ldaps' );
210			} else {
211			$sock = IO::Socket::INET->new(
212			Proto => 'tcp',
213			PeerAddr => $config->{upstream_ldap},
214			PeerPort => 389,
215			);
216			}
217			die "can't open ", $config->{upstream_ldap}, " $!\n" unless $sock;
218			warn "## connected to ", $sock->peerhost, ":", $sock->peerport, "\n";
219			return $sock;
220			}
221	dpavlin	8
222	dpavlin	73	my $sel = IO::Select->new($listenersock);
223			while (my @ready = $sel->can_read) {
224			foreach my $fh (@ready) {
225			if ($fh == $listenersock) {
226			# let's create a new socket
227			my $psock = $listenersock->accept;
228			$sel->add($psock);
229			warn "## add $psock " . time;
230			} else {
231			$server_sock->{$fh} \|\|= connect_to_server;
232			if ( ! handle($fh,$server_sock->{$fh}) ) {
233			warn "## remove $fh " . time;
234			$sel->remove($server_sock->{$fh});
235			$server_sock->{$fh}->close;
236			delete $server_sock->{$fh};
237			# we have finished with the socket
238			$sel->remove($fh);
239			$fh->close;
240			}
241			}
242			}
243			}
244	dpavlin	8
245			1;