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