git.rot13.org Git - virtual-ldap/blob - 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 = 0;
  28
  29 my $config = {
  30         yaml_dir => './yaml/',
  31         listen => shift @ARGV || 'localhost:1389',
  32         upstream_ldap => 'ldap.ffzg.hr',
  33         upstream_ssl => 1,
  34         overlay_prefix => 'ffzg-',
  35 #       log_file => 'log/ldap-rewrite.log',
  36
  37 };
  38
  39 my $log_fh;
  40
  41 sub log {
  42         return unless $config->{log_file};
  43
  44         if ( ! $log_fh ) {
  45                 open($log_fh, '>>', $config->{log_file}) || die "can't open ", $config->{log_file},": $!";
  46                 print $log_fh "# " . time;
  47         }
  48         $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 if ( ! -d $config->{yaml_dir} ) {
  58         warn "DISABLE ", $config->{yaml_dir}," data overlay";
  59 }
  60
  61 warn "# config = ",dump( $config );
  62
  63 sub handle {
  64         my $clientsocket=shift;
  65         my $serversocket=shift;
  66
  67         # read from client
  68         asn_read($clientsocket, my $reqpdu);
  69         if ( ! $reqpdu ) {
  70                 warn "client closed connection\n";
  71                 return 0;
  72         }
  73         $reqpdu = log_request($reqpdu);
  74
  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                 asn_read($serversocket, my $respdu);
  83                 if ( ! $respdu ) {
  84                         warn "server closed connection\n";
  85                         return 0;
  86                 }
  87                 $respdu = log_response($respdu);
  88                 # and send the result to the client
  89                 print $clientsocket $respdu || return 0;
  90         }
  91
  92         return 1;
  93 }
  94
  95
  96 sub log_request {
  97         my $pdu=shift;
  98
  99         die "empty pdu" unless $pdu;
 100
 101 #       print '-' x 80,"\n";
 102 #       print "Request ASN 1:\n";
 103 #       Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
 104 #       print "Request Perl:\n";
 105         my $request = $LDAPRequest->decode($pdu);
 106         warn "## request = ",dump($request);
 107
 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                         $request->{bindRequest}->{name} =~ s/^/uid=/;
 113                         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 }
 122
 123 sub log_response {
 124         my $pdu=shift;
 125         die "empty pdu" unless $pdu;
 126
 127 #       print '-' x 80,"\n";
 128 #       print "Response ASN 1:\n";
 129 #       Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
 130 #       print "Response Perl:\n";
 131         my $response = $LDAPResponse->decode($pdu);
 132
 133         if ( defined $response->{protocolOp}->{searchResEntry} ) {
 134                 my $uid = $response->{protocolOp}->{searchResEntry}->{objectName};
 135                 warn "## objectName $uid";
 136
 137                 my @attrs;
 138
 139                 foreach my $attr ( @{ $response->{protocolOp}->{searchResEntry}->{attributes} } ) {
 140                         if ( $attr->{type} =~ m/date/i ) {
 141                                 foreach my $i ( 0 .. $#{ $attr->{vals} } ) {
 142                                         $attr->{vals}->[$i] = "$1-$2-$3" if $attr->{vals}->[$i] =~ m/^([12]\d\d\d)([01]\d+)([0123]\d+)$/;
 143                                 }
 144                         } elsif ( $attr->{type} eq 'hrEduPersonUniqueNumber' ) {
 145                                 foreach my $val ( @{ $attr->{vals} } ) {
 146                                         next if $val !~ m{.+:.+};
 147                                         my ( $n, $v ) = split(/\s*:\s*/, $val );
 148                                         push @attrs, { type => $attr->{type} . '_' . $n, vals => [ $v ] };
 149                                 }
 150                         }
 151                 }
 152
 153                 warn "# ++ attrs ",dump( @attrs );
 154
 155                 push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, $_ foreach @attrs;
 156
 157                 my $path = $config->{yaml_dir} . "$uid.yaml";
 158                 if ( -e $path ) {
 159                         my $data = LoadFile($path);
 160                         warn "# yaml = ",dump($data);
 161
 162                         foreach my $type ( keys %$data ) {
 163
 164                                 my $vals = $data->{$type};
 165
 166                                 push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, {
 167                                         type => $config->{overlay_prefix} . $type,
 168                                         vals => ref($vals) eq 'ARRAY' ? $vals : [ $vals ],
 169                                 };
 170                         }
 171                 }
 172
 173                 $pdu = $LDAPResponse->encode($response);
 174         }
 175
 176         warn "## response = ", dump($response);
 177
 178         return $pdu;
 179 }
 180
 181
 182 my $listenersock = IO::Socket::INET->new(
 183         Listen => 5,
 184         Proto => 'tcp',
 185         Reuse => 1,
 186         LocalAddr => $config->{listen},
 187 ) || die "can't open listen socket: $!";
 188
 189 our $server_sock;
 190
 191 sub connect_to_server {
 192         my $sock;
 193         if ( $config->{upstream_ssl} ) {
 194                 $sock = IO::Socket::SSL->new( $config->{upstream_ldap} . ':ldaps' );
 195         } else {
 196                 $sock = IO::Socket::INET->new(
 197                         Proto => 'tcp',
 198                         PeerAddr => $config->{upstream_ldap},
 199                         PeerPort => 389,
 200                 );
 201         }
 202         die "can't open ", $config->{upstream_ldap}, " $!\n" unless $sock;
 203         warn "## connected to ", $sock->peerhost, ":", $sock->peerport, "\n";
 204         return $sock;
 205 }
 206
 207 my $sel = IO::Select->new($listenersock);
 208 while (my @ready = $sel->can_read) {
 209         foreach my $fh (@ready) {
 210                 if ($fh == $listenersock) {
 211                         # let's create a new socket
 212                         my $psock = $listenersock->accept;
 213                         $sel->add($psock);
 214                         warn "## add $psock " . time;
 215                 } else {
 216                         $server_sock->{$fh} ||= connect_to_server;
 217                         if ( ! handle($fh,$server_sock->{$fh}) ) {
 218                                 warn "## remove $fh " . time;
 219                                 $sel->remove($server_sock->{$fh});
 220                                 $server_sock->{$fh}->close;
 221                                 delete $server_sock->{$fh};
 222                                 # we have finished with the socket
 223                                 $sel->remove($fh);
 224                                 $fh->close;
 225                         }
 226                 }
 227         }
 228 }
 229
 230 1;