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 = 1;

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

};

my $log_fh;

sub log {
        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 "WARNING no reqpdu\n";
                return 1;
        }
        $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) or return 1;
                $respdu = log_response($respdu);
                # and send the result to the client
                print $clientsocket $respdu;
        }

        return 0;
}


sub log_request {
        my $pdu=shift;

#       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;

#       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;

                map {
                        if ( $_->{type} eq 'hrEduPersonUniqueNumber' ) {
                                foreach my $val ( @{ $_->{vals} } ) {
                                        next if $val !~ m{.+:.+};
                                        my ( $n, $v ) = split(/\s*:\s*/, $val );
                                        push @attrs, { type => $_->{type} . '_' . $n, vals => [ $v ] };
                                }
                        }
                } @{ $response->{protocolOp}->{searchResEntry}->{attributes} };

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

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

                my $path = $config->{yaml_dir} . "$uid.yaml";
                if ( -e $path ) {
                        my $data = LoadFile($path);
                        warn "# 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;
}

sub run_proxy {
        my $listenersock = shift;
        my $targetsock=shift;

        die "Could not create listener socket: $!\n" unless $listenersock;
        die "Could not create connection to server: $!\n" unless $targetsock;

        my $sel = IO::Select->new($listenersock);
        my %Handlers;
        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);
                        } else {
                                my $result = handle($fh,$targetsock);
                                if ($result) {
                                        # we have finished with the socket
                                        $sel->remove($fh);
                                        $fh->close;
                                        delete $Handlers{*$fh};
                                }
                        }
                }
        }
}


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


my $targetsock = $config->{upstream_ssl}
        ? IO::Socket::INET->new(
                Proto => 'tcp',
                PeerAddr => $config->{upstream_ldap},
                PeerPort => 389,
        )
        : IO::Socket::SSL->new( $config->{upstream_ldap} . ':ldaps')
        || die "can't open upstream socket: $!";

run_proxy($listenersock,$targetsock);

1;
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 = 1;
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',
36
37	};
38
39	my $log_fh;
40
41	sub log {
42	if ( ! $log_fh ) {
43	open($log_fh, '>>', $config->{log_file}) \|\| die "can't open ", $config->{log_file},": $!";
44	print $log_fh "# " . time;
45	}
46	$log_fh->autoflush(1);
47	print $log_fh join("\n", @_),"\n";
48	}
49
50	BEGIN {
51	$SIG{'__WARN__'} = sub { warn @_; main::log(@_); }
52	}
53
54
55	if ( ! -d $config->{yaml_dir} ) {
56	warn "DISABLE ", $config->{yaml_dir}," data overlay";
57	}
58
59	warn "# config = ",dump( $config );
60
61	sub handle {
62	my $clientsocket=shift;
63	my $serversocket=shift;
64
65	# read from client
66	asn_read($clientsocket, my $reqpdu);
67	if ( ! $reqpdu ) {
68	warn "WARNING no reqpdu\n";
69	return 1;
70	}
71	$reqpdu = log_request($reqpdu);
72
73	# send to server
74	print $serversocket $reqpdu or die "Could not send PDU to server\n ";
75
76	# read from server
77	my $ready;
78	my $sel = IO::Select->new($serversocket);
79	for( $ready = 1 ; $ready ; $ready = $sel->can_read(0)) {
80	asn_read($serversocket, my $respdu) or return 1;
81	$respdu = log_response($respdu);
82	# and send the result to the client
83	print $clientsocket $respdu;
84	}
85
86	return 0;
87	}
88
89
90	sub log_request {
91	my $pdu=shift;
92
93	# print '-' x 80,"\n";
94	# print "Request ASN 1:\n";
95	# Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
96	# print "Request Perl:\n";
97	my $request = $LDAPRequest->decode($pdu);
98	warn "## request = ",dump($request);
99
100	if ( defined $request->{bindRequest} ) {
101	if ( $request->{bindRequest}->{name} =~ m{@} ) {
102	my $old = $request->{bindRequest}->{name};
103	$request->{bindRequest}->{name} =~ s/[@\.]/,dc=/g;
104	$request->{bindRequest}->{name} =~ s/^/uid=/;
105	warn "rewrite bind cn $old -> ", $request->{bindRequest}->{name};
106	Convert::ASN1::asn_hexdump(\*STDOUT,$pdu) if $debug;
107	$pdu = $LDAPRequest->encode($request);
108	Convert::ASN1::asn_hexdump(\*STDOUT,$pdu) if $debug;
109	}
110	}
111
112	return $pdu;
113	}
114
115	sub log_response {
116	my $pdu=shift;
117
118	# print '-' x 80,"\n";
119	# print "Response ASN 1:\n";
120	# Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
121	# print "Response Perl:\n";
122	my $response = $LDAPResponse->decode($pdu);
123
124	if ( defined $response->{protocolOp}->{searchResEntry} ) {
125	my $uid = $response->{protocolOp}->{searchResEntry}->{objectName};
126	warn "## objectName $uid";
127
128	my @attrs;
129
130	map {
131	if ( $_->{type} eq 'hrEduPersonUniqueNumber' ) {
132	foreach my $val ( @{ $_->{vals} } ) {
133	next if $val !~ m{.+:.+};
134	my ( $n, $v ) = split(/\s:\s/, $val );
135	push @attrs, { type => $_->{type} . '_' . $n, vals => [ $v ] };
136	}
137	}
138	} @{ $response->{protocolOp}->{searchResEntry}->{attributes} };
139
140	warn "# ++ attrs ",dump( @attrs );
141
142	push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, $_ foreach @attrs;
143
144	my $path = $config->{yaml_dir} . "$uid.yaml";
145	if ( -e $path ) {
146	my $data = LoadFile($path);
147	warn "# yaml = ",dump($data);
148
149	foreach my $type ( keys %$data ) {
150
151	my $vals = $data->{$type};
152
153	push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, {
154	type => $config->{overlay_prefix} . $type,
155	vals => ref($vals) eq 'ARRAY' ? $vals : [ $vals ],
156	};
157	}
158	}
159
160	$pdu = $LDAPResponse->encode($response);
161	}
162
163	warn "## response = ", dump($response);
164
165	return $pdu;
166	}
167
168	sub run_proxy {
169	my $listenersock = shift;
170	my $targetsock=shift;
171
172	die "Could not create listener socket: $!\n" unless $listenersock;
173	die "Could not create connection to server: $!\n" unless $targetsock;
174
175	my $sel = IO::Select->new($listenersock);
176	my %Handlers;
177	while (my @ready = $sel->can_read) {
178	foreach my $fh (@ready) {
179	if ($fh == $listenersock) {
180	# let's create a new socket
181	my $psock = $listenersock->accept;
182	$sel->add($psock);
183	} else {
184	my $result = handle($fh,$targetsock);
185	if ($result) {
186	# we have finished with the socket
187	$sel->remove($fh);
188	$fh->close;
189	delete $Handlers{*$fh};
190	}
191	}
192	}
193	}
194	}
195
196
197	my $listenersock = IO::Socket::INET->new(
198	Listen => 5,
199	Proto => 'tcp',
200	Reuse => 1,
201	LocalAddr => $config->{listen},
202	) \|\| die "can't open listen socket: $!";
203
204
205	my $targetsock = $config->{upstream_ssl}
206	? IO::Socket::INET->new(
207	Proto => 'tcp',
208	PeerAddr => $config->{upstream_ldap},
209	PeerPort => 389,
210	)
211	: IO::Socket::SSL->new( $config->{upstream_ldap} . ':ldaps')
212	\|\| die "can't open upstream socket: $!";
213
214	run_proxy($listenersock,$targetsock);
215
216	1;