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.


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.2';
use fields qw(socket target);
use YAML qw/LoadFile/;

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

};

my $log_fh;

sub log {
        open($log_fh, '>', $config->{log_file}) || die "can't open ", $config->{log_file},": $!";
        $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);
        log_request($reqpdu);

        return 1 unless $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);
        print dump($request);
}

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 "## SEARCH $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);
        }

        print 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};
                                }
                        }
                }
        }
}


$ENV{LANG} = 'C'; # so we don't double-encode utf-8 if LANG is utf-8

my $listenersock = IO::Socket::INET->new(
        Listen => 5,
        Proto => 'tcp',
        Reuse => 1,
        LocalAddr => $config->{listen},
);


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')
        ;

run_proxy($listenersock,$targetsock);

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
7			use strict;
8			use warnings;
9
10			use IO::Select;
11			use IO::Socket;
12	dpavlin	16	use IO::Socket::SSL;
13	dpavlin	8	use warnings;
14			use Data::Dump qw/dump/;
15			use Convert::ASN1 qw(asn_read);
16			use Net::LDAP::ASN qw(LDAPRequest LDAPResponse);
17			our $VERSION = '0.2';
18			use fields qw(socket target);
19	dpavlin	10	use YAML qw/LoadFile/;
20	dpavlin	8
21	dpavlin	18	my $config = {
22			yaml_dir => './yaml/',
23			listen => 'localhost:1389',
24			upstream_ldap => 'ldap.ffzg.hr',
25			upstream_ssl => 1,
26			overlay_prefix => 'ffzg-',
27	dpavlin	27	log_file => 'log',
28	dpavlin	18
29			};
30
31	dpavlin	27	my $log_fh;
32
33			sub log {
34			open($log_fh, '>', $config->{log_file}) \|\| die "can't open ", $config->{log_file},": $!";
35			$log_fh->autoflush(1);
36			print $log_fh join("\n", @_),"\n";
37			}
38
39			BEGIN {
40			$SIG{'__WARN__'} = sub { warn @_; main::log(@_); }
41			}
42
43
44	dpavlin	18	if ( ! -d $config->{yaml_dir} ) {
45			warn "DISABLE ", $config->{yaml_dir}," data overlay";
46			}
47
48			warn "# config = ",dump( $config );
49
50	dpavlin	8	sub handle {
51			my $clientsocket=shift;
52			my $serversocket=shift;
53
54			# read from client
55			asn_read($clientsocket, my $reqpdu);
56			log_request($reqpdu);
57
58			return 1 unless $reqpdu;
59
60			# send to server
61			print $serversocket $reqpdu or die "Could not send PDU to server\n ";
62
63			# read from server
64			my $ready;
65			my $sel = IO::Select->new($serversocket);
66			for( $ready = 1 ; $ready ; $ready = $sel->can_read(0)) {
67			asn_read($serversocket, my $respdu) or return 1;
68			$respdu = log_response($respdu);
69			# and send the result to the client
70			print $clientsocket $respdu;
71			}
72
73			return 0;
74			}
75
76
77			sub log_request {
78			my $pdu=shift;
79
80			print '-' x 80,"\n";
81			print "Request ASN 1:\n";
82			Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
83			print "Request Perl:\n";
84			my $request = $LDAPRequest->decode($pdu);
85			print dump($request);
86			}
87
88			sub log_response {
89			my $pdu=shift;
90
91			print '-' x 80,"\n";
92			print "Response ASN 1:\n";
93			Convert::ASN1::asn_hexdump(\*STDOUT,$pdu);
94			print "Response Perl:\n";
95			my $response = $LDAPResponse->decode($pdu);
96
97			if ( defined $response->{protocolOp}->{searchResEntry} ) {
98			my $uid = $response->{protocolOp}->{searchResEntry}->{objectName};
99			warn "## SEARCH $uid";
100	dpavlin	10
101	dpavlin	19	my @attrs;
102
103	dpavlin	8	map {
104	dpavlin	19	if ( $_->{type} eq 'hrEduPersonUniqueNumber' ) {
105			foreach my $val ( @{ $_->{vals} } ) {
106			next if $val !~ m{.+:.+};
107			my ( $n, $v ) = split(/\s:\s/, $val );
108			push @attrs, { type => $_->{type} . '_' . $n, vals => [ $v ] };
109			}
110	dpavlin	8	}
111			} @{ $response->{protocolOp}->{searchResEntry}->{attributes} };
112
113	dpavlin	19	warn "# ++ attrs ",dump( @attrs );
114
115			push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, $_ foreach @attrs;
116
117	dpavlin	18	my $path = $config->{yaml_dir} . "$uid.yaml";
118	dpavlin	10	if ( -e $path ) {
119			my $data = LoadFile($path);
120			warn "# yaml = ",dump($data);
121	dpavlin	8
122	dpavlin	10	foreach my $type ( keys %$data ) {
123
124			my $vals = $data->{$type};
125
126	dpavlin	22	push @{ $response->{protocolOp}->{searchResEntry}->{attributes} }, {
127			type => $config->{overlay_prefix} . $type,
128			vals => ref($vals) eq 'ARRAY' ? $vals : [ $vals ],
129			};
130	dpavlin	10	}
131			}
132
133	dpavlin	8	$pdu = $LDAPResponse->encode($response);
134			}
135
136	dpavlin	10	print dump($response);
137
138	dpavlin	8	return $pdu;
139			}
140
141			sub run_proxy {
142			my $listenersock = shift;
143			my $targetsock=shift;
144
145			die "Could not create listener socket: $!\n" unless $listenersock;
146			die "Could not create connection to server: $!\n" unless $targetsock;
147
148			my $sel = IO::Select->new($listenersock);
149			my %Handlers;
150			while (my @ready = $sel->can_read) {
151			foreach my $fh (@ready) {
152			if ($fh == $listenersock) {
153			# let's create a new socket
154			my $psock = $listenersock->accept;
155			$sel->add($psock);
156			} else {
157			my $result = handle($fh,$targetsock);
158			if ($result) {
159			# we have finished with the socket
160			$sel->remove($fh);
161			$fh->close;
162			delete $Handlers{*$fh};
163			}
164			}
165			}
166			}
167			}
168
169
170	dpavlin	24	$ENV{LANG} = 'C'; # so we don't double-encode utf-8 if LANG is utf-8
171
172	dpavlin	8	my $listenersock = IO::Socket::INET->new(
173			Listen => 5,
174			Proto => 'tcp',
175			Reuse => 1,
176	dpavlin	18	LocalAddr => $config->{listen},
177	dpavlin	8	);
178
179
180	dpavlin	18	my $targetsock = $config->{upstream_ssl}
181			? IO::Socket::INET->new(
182			Proto => 'tcp',
183			PeerAddr => $config->{upstream_ldap},
184			PeerPort => 389,
185			)
186			: IO::Socket::SSL->new( $config->{upstream_ldap} . ':ldaps')
187			;
188	dpavlin	8
189			run_proxy($listenersock,$targetsock);
190
191			1;