git.rot13.org Git - virtual-ldap/blob - bin/ldap-roundcube.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 h2str {
  70         my $str = dump(@_);
  71         $str =~ s/\s//g;
  72         return $str;
  73 }
  74
  75 my $last_reqpdu = '';
  76 my $last_respdu;
  77
  78 sub handle {
  79         my $clientsocket=shift;
  80         my $serversocket=shift;
  81
  82         # read from client
  83         asn_read($clientsocket, my $reqpdu);
  84         if ( ! $reqpdu ) {
  85                 warn "# client closed connection\n";
  86                 return 0;
  87         }
  88
  89         if ( h2str($reqpdu) eq $last_reqpdu ) {
  90                 warn "# cache hit";
  91                 print $clientsocket $last_respdu || return 0;
  92                 return 1;
  93         }
  94
  95         my $request = $LDAPRequest->decode($reqpdu);
  96         warn "## request = ",dump($request);
  97
  98         my $request_filter;
  99         if (
 100                 exists $request->{searchRequest} &&
 101                 exists $request->{searchRequest}->{filter}
 102         ) {
 103                 my $filter = dump($request->{searchRequest}->{filter});
 104                 $filter =~ s/\s\s+/ /gs;
 105
 106                 warn "# FILTER $filter";
 107                 if ( $filter =~ m/(attributeDesc => "uid")/ ) { # mark uid serach from roundcube for new_user_identity
 108                         warn "filter uid $1";
 109                         $request_filter->{uid} = 1;
 110                 }
 111                 if ( $filter =~ m/(present => "jpegphoto")/ ) {
 112                         warn "hard-coded response for $1";
 113                         print $clientsocket $LDAPResponse->encode( {
 114                                 messageID  => $request->{messageID},
 115                                 searchResDone => { errorMessage => "", matchedDN => "", resultCode => 0 },
 116                         } ) || return 0;
 117                         return 1;
 118                 }
 119         }
 120
 121         $reqpdu = modify_request($reqpdu, $request);
 122
 123         # send to server
 124         print $serversocket $reqpdu or die "Could not send PDU to server\n ";
 125
 126         # read from server
 127         my $ready;
 128         my $sel = IO::Select->new($serversocket);
 129         for( $ready = 1 ; $ready ; $ready = $sel->can_read(0)) {
 130                 asn_read($serversocket, my $respdu);
 131                 if ( ! $respdu ) {
 132                         warn "server closed connection\n";
 133                         return 0;
 134                 }
 135
 136                 $respdu = modify_response($respdu, $reqpdu, $request, $request_filter);
 137
 138                 # cache
 139                 $last_reqpdu = h2str($request->{searchRequest});
 140                 warn "# last_reqpdu $last_reqpdu";
 141                 $last_respdu = $respdu;
 142
 143                 # and send the result to the client
 144                 print $clientsocket $respdu || return 0;
 145
 146
 147         }
 148
 149         return 1;
 150 }
 151
 152 sub modify_request {
 153         my ($pdu,$request)=@_;
 154
 155         die "empty pdu" unless $pdu;
 156
 157 #       print '-' x 80,"\n";
 158 #       print "Request ASN 1:\n";
 159 #       Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
 160 #       print "Request Perl:\n";
 161         if ( defined $request->{bindRequest} ) {
 162                 if ( $request->{bindRequest}->{name} =~ m{@} ) {
 163                         my $old = $request->{bindRequest}->{name};
 164                         $request->{bindRequest}->{name} =~ s/[@\.]/,dc=/g;
 165                         $request->{bindRequest}->{name} =~ s/^/uid=/;
 166                         print "rewrite bind cn $old -> ", $request->{bindRequest}->{name}, "\n";
 167                         Convert::ASN1::asn_hexdump(\*STDOUT,$pdu) if $debug;
 168                         $pdu = $LDAPRequest->encode($request);
 169                         Convert::ASN1::asn_hexdump(\*STDOUT,$pdu) if $debug;
 170                 }
 171         }
 172
 173         return $pdu;
 174 }
 175
 176 sub modify_response {
 177         my ($pdu,$reqpdu,$request,$request_filter)=@_;
 178         die "empty pdu" unless $pdu;
 179
 180 #       print '-' x 80,"\n";
 181 #       print "Response ASN 1:\n";
 182 #       Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
 183 #       print "Response Perl:\n";
 184         my $response = $LDAPResponse->decode($pdu);
 185
 186         if ( defined $response->{protocolOp}->{searchResEntry} ) {
 187                 my $uid = $response->{protocolOp}->{searchResEntry}->{objectName};
 188                 warn "# rewrite objectName $uid\n";
 189
 190                 my @attrs;
 191
 192                 foreach my $attr ( @{ $response->{protocolOp}->{searchResEntry}->{attributes} } ) {
 193                         if ( $attr->{type} =~ m/date/i ) {
 194                                 foreach my $i ( 0 .. $#{ $attr->{vals} } ) {
 195                                         $attr->{vals}->[$i] = "$1-$2-$3" if $attr->{vals}->[$i] =~ m/^([12]\d\d\d)([01]\d+)([0123]\d+)$/;
 196                                 }
 197 =for disable
 198                         } elsif ( $attr->{type} eq 'hrEduPersonUniqueNumber' ) {
 199                                 foreach my $val ( @{ $attr->{vals} } ) {
 200                                         next if $val !~ m{.+:.+};
 201                                         my ( $n, $v ) = split(/\s*:\s*/, $val );
 202                                         push @attrs, { type => $attr->{type} . '_' . $n, vals => [ $v ] };
 203                                 }
 204                         } elsif ( $attr->{type} eq 'hrEduPersonGroupMember' ) {
 205                                 foreach my $i ( 0 .. $#{ $attr->{vals} } ) {
 206                                         $attr->{vals}->[$i] =~ s/^u2010/p2010/gs && warn "FIXME group";
 207                                 }
 208                         } elsif ( $attr->{type} eq 'homePostalAddress' ) {
 209                                 foreach my $val ( @{ $attr->{vals} } ) {
 210                                         next if $val !~ m{^(.+)\s*,\s*(\d+)\s+(.+)};
 211                                         push @attrs,
 212                                                 { type => 'homePostalAddress_address', vals => [ $1 ] },
 213                                                 { type => 'homePostalAddress_zipcode', vals => [ $2 ] },
 214                                                 { type => 'homePostalAddress_city', vals => [ $3 ] };
 215                                 }
 216                         } elsif ( $attr->{type} eq 'mail' ) {
 217                                 my @emails;
 218                                 foreach my $i ( 0 .. $#{ $attr->{vals} } ) {
 219                                         my $e = $attr->{vals}->[$i];
 220                                         if ( $e =~ m/\s+/ ) {
 221                                                 push @emails, split(/\s+/, $e);
 222                                         } else {
 223                                                 push @emails, $e;
 224                                         }
 225                                 }
 226                                 $attr->{vals} = [ shift @emails ];
 227                                 foreach my $i ( 0 .. $#emails ) {
 228                                         push @attrs, { type => $attr->{type} . '_' . ( $i + 1 ) , vals => [ $emails[$i] ] };
 229                                 }
 230 =cut
 231                         } elsif ( $attr->{type} eq 'mail' ) {
 232                                 my @emails;
 233                                 foreach my $i ( 0 .. $#{ $attr->{vals} } ) {
 234                                         my $e = $attr->{vals}->[$i];
 235                                         if ( $e =~ m/\s+/ ) {
 236                                                 push @emails, split(/\s+/, $e);
 237                                         } else {
 238                                                 push @emails, $e;
 239                                         }
 240                                 }
 241                                 if ( $request_filter->{uid} ) { # only for new_user_identity plugin which does uid search
 242                                         $attr->{vals} = [ grep { m/\@ffzg/ } @emails ]; # remote all emails not @ffzg.hr @ffzg.unizg.hr
 243                                 }
 244                         } elsif ( $attr->{type} eq 'facsimileTelephoneNumber' ) {
 245                                 my @fax;
 246                                 foreach my $i ( 0 .. $#{ $attr->{vals} } ) {
 247                                         my $e = $attr->{vals}->[$i];
 248                                         push @fax, $e;
 249                                 }
 250                                 $attr->{vals} = [ grep { ! m/\Q+385 xx xxxx xxx\E/ } @fax ];
 251                         }
 252                 }
 253
 254                 warn "# ++ attrs ",dump( @attrs );
 255
 256                 push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, $_ foreach @attrs;
 257
 258 =for removed
 259                 my @additional_yamls = ( $uid );
 260                 foreach my $attr ( @{ $response->{protocolOp}->{searchResEntry}->{attributes} } ) {
 261                         foreach my $v ( @{ $attr->{vals} } ) {
 262                                 push @additional_yamls, $attr->{type} . '/' . $v;
 263                         }
 264                 }
 265
 266                 #warn "# additional_yamls ",dump( @additional_yamls );
 267
 268                 foreach my $path ( @additional_yamls ) {
 269                         my $full_path = $config->{yaml_dir} . '/' . $path . '.yaml';
 270                         next unless -e $full_path;
 271
 272                         my $data = LoadFile( $full_path );
 273                         warn "# $full_path yaml = ",dump($data);
 274
 275                         foreach my $type ( keys %$data ) {
 276
 277                                 my $vals = $data->{$type};
 278
 279                                 push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, {
 280                                         type => $config->{overlay_prefix} . $type,
 281                                         vals => ref($vals) eq 'ARRAY' ? $vals : [ $vals ],
 282                                 };
 283                         }
 284                 }
 285 =cut
 286
 287                 $pdu = $LDAPResponse->encode($response);
 288         }
 289
 290         warn "## response = ", dump($response);
 291
 292         return $pdu;
 293 }
 294
 295
 296 my $listenersock = IO::Socket::INET->new(
 297         Listen => 5,
 298         Proto => 'tcp',
 299         Reuse => 1,
 300         LocalAddr => $config->{listen},
 301 ) || die "can't open listen socket: $!";
 302
 303 our $server_sock;
 304
 305 sub connect_to_server {
 306         my $sock;
 307         if ( $config->{upstream_ssl} ) {
 308                 $sock = IO::Socket::SSL->new( $config->{upstream_ldap} . ':ldaps' );
 309         } else {
 310                 $sock = IO::Socket::INET->new(
 311                         Proto => 'tcp',
 312                         PeerAddr => $config->{upstream_ldap},
 313                         PeerPort => 389,
 314                 );
 315         }
 316         die "can't open ", $config->{upstream_ldap}, " $!\n" unless $sock;
 317         warn "## connected to ", $sock->peerhost, ":", $sock->peerport, "\n";
 318         return $sock;
 319 }
 320
 321 my $sel = IO::Select->new($listenersock);
 322 while (my @ready = $sel->can_read) {
 323         foreach my $fh (@ready) {
 324                 if ($fh == $listenersock) {
 325                         # let's create a new socket
 326                         my $psock = $listenersock->accept;
 327                         $sel->add($psock);
 328                         warn "## add $psock " . time;
 329                 } else {
 330                         $server_sock->{$fh} ||= connect_to_server;
 331                         if ( ! handle($fh,$server_sock->{$fh}) ) {
 332                                 warn "## remove $fh " . time;
 333                                 $sel->remove($server_sock->{$fh});
 334                                 $server_sock->{$fh}->close;
 335                                 delete $server_sock->{$fh};
 336                                 # we have finished with the socket
 337                                 $sel->remove($fh);
 338                                 $fh->close;
 339                         }
 340                 }
 341         }
 342 }
 343
 344 1;