A3C/LDAP/Server.pm

package A3C::LDAP::Server;

use strict;
use warnings;

use Net::LDAP::Constant qw(
        LDAP_SUCCESS
        LDAP_STRONG_AUTH_NOT_SUPPORTED
        LDAP_UNAVAILABLE
        LDAP_OPERATIONS_ERROR
);
use Net::LDAP::Server;
use Net::LDAP::Filter;
use base 'Net::LDAP::Server';
use fields qw(upstream);

use A3C::LDAP;
use Data::Dump qw/dump/;

use constant RESULT_OK => {
        'matchedDN' => '',
        'errorMessage' => '',
        'resultCode' => LDAP_SUCCESS
};

# constructor
sub new {
        my ($class, $sock) = @_;
        my $self = $class->SUPER::new($sock);
        printf "Accepted connection from: %s\n", $sock->peerhost();
        return $self;
}

# the bind operation
sub bind {
        my ($self,$req) = @_;

        warn "## bind req = ",dump($req);

        defined($req->{authentication}->{simple}) or return {
                matchedDN => '',
                errorMessage => '',
                resultCode => LDAP_STRONG_AUTH_NOT_SUPPORTED,
        };

        $self->{upstream} ||= A3C::LDAP->new->ldap or return {
                matchedDN => '',
                errorMessage => $@,
                resultCode => LDAP_UNAVAILABLE,
        };

        warn "## upstream = ",dump( $self->{upstream} );
#       warn "upstream not Net::LDAP but ",ref($self->{upstream}) unless ref($self->{upstream}) eq 'Net::LDAP';

        return RESULT_OK;
}

# the search operation
sub search {
        my ($self,$req) = @_;

        warn "## search req = ",dump( $req );

        if ( ! $self->{upstream} ) {
                warn "search without bind";
                return {
                        matchedDN => '',
                        errorMessage => 'dude, bind first',
                        resultCode => LDAP_OPERATIONS_ERROR,
                };
        }

        my $filter;
        if (defined $req->{filter}) {
                # $req->{filter} is a ASN1-decoded tree; luckily, this is exactly the
                # internal representation Net::LDAP::Filter uses.  [FIXME] Eventually
                # Net::LDAP::Filter should provide a corresponding constructor.
                bless($req->{filter}, 'Net::LDAP::Filter');
                $filter = $req->{filter}->as_string;
#               $filter = '(&' . $req->{filter}->as_string
#                                          . '(objectClass=hrEduPerson)(host=aai.irb.hr))';
        }

        warn "search upstream for $filter";

        my $search = $self->{upstream}->search(
                base => $req->{baseObject},
                scope => $req->{scope},
                deref => $req->{derefAliases},
                sizelimit => $req->{sizeLimit},
                timelimit => $req->{timeLimit},
                typesonly => $req->{typesOnly},
                filter => $filter,
                attrs => $req->{attributes},
                raw => qr/.*/,
        );

        warn "# search = ",dump( $search );

        if ( $search->code != LDAP_SUCCESS ) {
                warn "ERROR: ",$search->code,": ",$search->server_error;
                return {
                        matchedDN => '',
                        errorMessage => $search->server_error,
                        resultCode => $search->code,
                };
        };

        my @entries = $search->entries;
        warn "## got ", $search->count, " entries for ", $filter;
        foreach my $entry (@entries) {
                $entry->changetype('add');  # Don't record changes.
#               foreach my $attr ($entry->attributes) {
#                       if ($attr =~ /;lang-en$/) { 
#                               $entry->delete($attr);
#                       }
#               }
        }

        warn "## entries = ",dump( @entries );
        return RESULT_OK, @entries;
}

# the rest of the operations will return an "unwilling to perform"

1;
1	package A3C::LDAP::Server;
2
3	use strict;
4	use warnings;
5
6	use Net::LDAP::Constant qw(
7	LDAP_SUCCESS
8	LDAP_STRONG_AUTH_NOT_SUPPORTED
9	LDAP_UNAVAILABLE
10	LDAP_OPERATIONS_ERROR
11	);
12	use Net::LDAP::Server;
13	use Net::LDAP::Filter;
14	use base 'Net::LDAP::Server';
15	use fields qw(upstream);
16
17	use A3C::LDAP;
18	use Data::Dump qw/dump/;
19
20	use constant RESULT_OK => {
21	'matchedDN' => '',
22	'errorMessage' => '',
23	'resultCode' => LDAP_SUCCESS
24	};
25
26	# constructor
27	sub new {
28	my ($class, $sock) = @_;
29	my $self = $class->SUPER::new($sock);
30	printf "Accepted connection from: %s\n", $sock->peerhost();
31	return $self;
32	}
33
34	# the bind operation
35	sub bind {
36	my ($self,$req) = @_;
37
38	warn "## bind req = ",dump($req);
39
40	defined($req->{authentication}->{simple}) or return {
41	matchedDN => '',
42	errorMessage => '',
43	resultCode => LDAP_STRONG_AUTH_NOT_SUPPORTED,
44	};
45
46	$self->{upstream} \|\|= A3C::LDAP->new->ldap or return {
47	matchedDN => '',
48	errorMessage => $@,
49	resultCode => LDAP_UNAVAILABLE,
50	};
51
52	warn "## upstream = ",dump( $self->{upstream} );
53	# warn "upstream not Net::LDAP but ",ref($self->{upstream}) unless ref($self->{upstream}) eq 'Net::LDAP';
54
55	return RESULT_OK;
56	}
57
58	# the search operation
59	sub search {
60	my ($self,$req) = @_;
61
62	warn "## search req = ",dump( $req );
63
64	if ( ! $self->{upstream} ) {
65	warn "search without bind";
66	return {
67	matchedDN => '',
68	errorMessage => 'dude, bind first',
69	resultCode => LDAP_OPERATIONS_ERROR,
70	};
71	}
72
73	my $filter;
74	if (defined $req->{filter}) {
75	# $req->{filter} is a ASN1-decoded tree; luckily, this is exactly the
76	# internal representation Net::LDAP::Filter uses. [FIXME] Eventually
77	# Net::LDAP::Filter should provide a corresponding constructor.
78	bless($req->{filter}, 'Net::LDAP::Filter');
79	$filter = $req->{filter}->as_string;
80	# $filter = '(&' . $req->{filter}->as_string
81	# . '(objectClass=hrEduPerson)(host=aai.irb.hr))';
82	}
83
84	warn "search upstream for $filter";
85
86	my $search = $self->{upstream}->search(
87	base => $req->{baseObject},
88	scope => $req->{scope},
89	deref => $req->{derefAliases},
90	sizelimit => $req->{sizeLimit},
91	timelimit => $req->{timeLimit},
92	typesonly => $req->{typesOnly},
93	filter => $filter,
94	attrs => $req->{attributes},
95	raw => qr/.*/,
96	);
97
98	warn "# search = ",dump( $search );
99
100	if ( $search->code != LDAP_SUCCESS ) {
101	warn "ERROR: ",$search->code,": ",$search->server_error;
102	return {
103	matchedDN => '',
104	errorMessage => $search->server_error,
105	resultCode => $search->code,
106	};
107	};
108
109	my @entries = $search->entries;
110	warn "## got ", $search->count, " entries for ", $filter;
111	foreach my $entry (@entries) {
112	$entry->changetype('add'); # Don't record changes.
113	# foreach my $attr ($entry->attributes) {
114	# if ($attr =~ /;lang-en$/) {
115	# $entry->delete($attr);
116	# }
117	# }
118	}
119
120	warn "## entries = ",dump( @entries );
121	return RESULT_OK, @entries;
122	}
123
124	# the rest of the operations will return an "unwilling to perform"
125
126	1;