lib/LDAP/Koha.pm

package LDAP::Koha;

use strict;
use warnings;
use Data::Dump qw/dump/;

use lib '../lib';
use Net::LDAP::Constant qw(LDAP_SUCCESS);
use Net::LDAP::Server;
use base 'Net::LDAP::Server';
use fields qw();

use DBI;

# XXX test with:
#
# ldapsearch -h localhost -p 2389 -b dc=ffzg,dc=hr -x 'otherPager=200903160021'
#

our $dsn      = 'DBI:mysql:dbname=';
our $database = 'koha';
our $user     = 'unconfigured-user';
our $passwd   = 'unconfigured-password';

our $max_results = 3; # 100; # FIXME

require 'config.pl' if -e 'config.pl';

my $dbh = DBI->connect($dsn . $database, $user,$passwd, { RaiseError => 1, AutoCommit => 0 }) || die $DBI::errstr;

# Net::LDAP::Entry will lc all our attribute names anyway, so
# we don't really care about correctCapitalization for LDAP
# attributes which won't pass through DBI
my $sql_select = q{
        select
                userid                  as uid,
                firstname               as givenName,
                surname                 as sn,
                concat(
                        firstname,
                        ' ',
                        surname
                )                               as cn,
                cardnumber              as otherPager,
                email                   as mail
        from borrowers
};

# needed for where clause
my $sql_ldap_mapping = {
        'userid'        => 'uid',
};

# attributes which are same for whole set, but somehow
# LDAP clients are sending they anyway and we don't
# have them in database
my $ldap_ignore = {
        'objectclass' => 1,
};

my $ldap_sql_mapping;
while ( my ($sql,$ldap) = each %$sql_ldap_mapping ) {
        $ldap_sql_mapping->{ $ldap } = $sql;
}

sub __sql_column {
        my $name = shift;
        $ldap_sql_mapping->{$name} || $name;
}

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

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

# the bind operation
sub bind {
        my $self = shift;
        my $reqData = shift;
        warn "# bind ",dump($reqData);
        return RESULT_OK;
}

# the search operation
sub search {
        my $self = shift;
        my $reqData = shift;
        print "searching...\n";

        warn "# " . localtime() . " request = ", dump($reqData);

        my $base = $reqData->{'baseObject'}; # FIXME use it?

        my @entries;
        if ( $reqData->{'filter'} ) {

                my $sql_where = '';
                my @values;

                foreach my $join_with ( keys %{ $reqData->{'filter'} } ) {

                        warn "## join_with $join_with\n";

                        my @limits;

                        foreach my $filter ( @{ $reqData->{'filter'}->{ $join_with } } ) {
                                warn "### filter ",dump($filter),$/;
                                foreach my $how ( keys %$filter ) {
                                        warn "### how $how\n";
                                        if ( $how eq 'equalityMatch' && defined $filter->{$how} ) {
                                                my $name = $filter->{$how}->{attributeDesc} || warn "ERROR: no attributeDesc?";
                                                my $value = $filter->{$how}->{assertionValue} || warn "ERROR: no assertionValue?";
                                                if ( ! $ldap_ignore->{ $name } ) {
                                                                push @limits, __sql_column($name) . ' = ?';
                                                                push @values, $value;
                                                }
                                        } elsif ( $how eq 'substrings' ) {
                                                foreach my $substring ( @{ $filter->{$how}->{substrings} } ) {
                                                        my $name = $filter->{$how}->{type} || warn "ERROR: no type?";
                                                        while ( my($op,$value) = each %$substring ) {
                                                                push @limits, __sql_column($name) . ' LIKE ?';
                                                                if ( $op eq 'any' ) {
                                                                        $value = '%' . $value . '%';
                                                                } else {
                                                                        warn "UNSUPPORTED: op $op - using plain $value";
                                                                }
                                                                push @values, $value;
                                                        }
                                                }
                                        } elsif ( $how eq 'present' ) {
                                                push @limits, __sql_column( $filter->{$how} ) . ' IS NOT NULL';
                                                ## XXX add and length(foo) > 0 to avoid empty strings?
                                        } else {
                                                warn "UNSUPPORTED: how $how ",dump( $filter );
                                        }
                                        warn "## limits ",dump(@limits), " values ",dump(@values);
                                }
                        }

                        $sql_where .= ' ' . join( " $join_with ", @limits );

                }

                if ( $sql_where ) {
                        $sql_where = " where $sql_where";
                }

                warn "# SQL:\n$sql_select $sql_where\n# DATA: ",dump( @values );
                my $sth = $dbh->prepare( $sql_select . $sql_where . " LIMIT $max_results" ); # XXX remove limit?
                $sth->execute( @values );

                warn "# ", $sth->rows, " results for ",dump( $reqData->{'filter'} );

                while (my $row = $sth->fetchrow_hashref) {

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

                        my $dn = 'uid=' . $row->{uid} || die "no uid";
                        $dn =~ s{[@\.]}{,dc=}g;

                        my $entry = Net::LDAP::Entry->new;
                        $entry->dn( $dn . $base );
                        $entry->add( %$row );

                        #warn "### entry ",dump( $entry );

                        push @entries, $entry;
                }

        } else {
                warn "UNKNOWN request: ",dump( $reqData );
        }

        return RESULT_OK, @entries;
}

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

1;
1	dpavlin	32	package LDAP::Koha;
2
3			use strict;
4			use warnings;
5			use Data::Dump qw/dump/;
6
7			use lib '../lib';
8			use Net::LDAP::Constant qw(LDAP_SUCCESS);
9			use Net::LDAP::Server;
10			use base 'Net::LDAP::Server';
11			use fields qw();
12
13			use DBI;
14
15			# XXX test with:
16			#
17			# ldapsearch -h localhost -p 2389 -b dc=ffzg,dc=hr -x 'otherPager=200903160021'
18			#
19
20			our $dsn = 'DBI:mysql:dbname=';
21			our $database = 'koha';
22			our $user = 'unconfigured-user';
23			our $passwd = 'unconfigured-password';
24
25	dpavlin	36	our $max_results = 3; # 100; # FIXME
26
27	dpavlin	32	require 'config.pl' if -e 'config.pl';
28
29			my $dbh = DBI->connect($dsn . $database, $user,$passwd, { RaiseError => 1, AutoCommit => 0 }) \|\| die $DBI::errstr;
30
31	dpavlin	33	# Net::LDAP::Entry will lc all our attribute names anyway, so
32			# we don't really care about correctCapitalization for LDAP
33			# attributes which won't pass through DBI
34	dpavlin	36	my $sql_select = q{
35	dpavlin	32	select
36			userid as uid,
37			firstname as givenName,
38			surname as sn,
39	dpavlin	35	concat(
40			firstname,
41			' ',
42			surname
43			) as cn,
44	dpavlin	32	cardnumber as otherPager,
45			email as mail
46			from borrowers
47	dpavlin	36	};
48	dpavlin	32
49	dpavlin	36	# needed for where clause
50			my $sql_ldap_mapping = {
51			'userid' => 'uid',
52			};
53
54			# attributes which are same for whole set, but somehow
55			# LDAP clients are sending they anyway and we don't
56			# have them in database
57			my $ldap_ignore = {
58			'objectclass' => 1,
59			};
60
61			my $ldap_sql_mapping;
62			while ( my ($sql,$ldap) = each %$sql_ldap_mapping ) {
63			$ldap_sql_mapping->{ $ldap } = $sql;
64			}
65
66			sub __sql_column {
67			my $name = shift;
68			$ldap_sql_mapping->{$name} \|\| $name;
69			}
70
71	dpavlin	32	use constant RESULT_OK => {
72			'matchedDN' => '',
73			'errorMessage' => '',
74			'resultCode' => LDAP_SUCCESS
75			};
76
77			# constructor
78			sub new {
79			my ($class, $sock) = @_;
80			my $self = $class->SUPER::new($sock);
81			print "connection from: ", $sock->peerhost(), "\n";
82			return $self;
83			}
84
85			# the bind operation
86			sub bind {
87			my $self = shift;
88			my $reqData = shift;
89			warn "# bind ",dump($reqData);
90			return RESULT_OK;
91			}
92
93			# the search operation
94			sub search {
95			my $self = shift;
96			my $reqData = shift;
97			print "searching...\n";
98
99	dpavlin	36	warn "# " . localtime() . " request = ", dump($reqData);
100	dpavlin	32
101			my $base = $reqData->{'baseObject'}; # FIXME use it?
102
103			my @entries;
104	dpavlin	36	if ( $reqData->{'filter'} ) {
105	dpavlin	32
106	dpavlin	36	my $sql_where = '';
107			my @values;
108	dpavlin	32
109	dpavlin	36	foreach my $join_with ( keys %{ $reqData->{'filter'} } ) {
110	dpavlin	32
111	dpavlin	36	warn "## join_with $join_with\n";
112	dpavlin	32
113	dpavlin	36	my @limits;
114
115			foreach my $filter ( @{ $reqData->{'filter'}->{ $join_with } } ) {
116			warn "### filter ",dump($filter),$/;
117			foreach my $how ( keys %$filter ) {
118			warn "### how $how\n";
119			if ( $how eq 'equalityMatch' && defined $filter->{$how} ) {
120			my $name = $filter->{$how}->{attributeDesc} \|\| warn "ERROR: no attributeDesc?";
121			my $value = $filter->{$how}->{assertionValue} \|\| warn "ERROR: no assertionValue?";
122			if ( ! $ldap_ignore->{ $name } ) {
123			push @limits, __sql_column($name) . ' = ?';
124			push @values, $value;
125			}
126			} elsif ( $how eq 'substrings' ) {
127			foreach my $substring ( @{ $filter->{$how}->{substrings} } ) {
128			my $name = $filter->{$how}->{type} \|\| warn "ERROR: no type?";
129			while ( my($op,$value) = each %$substring ) {
130			push @limits, __sql_column($name) . ' LIKE ?';
131			if ( $op eq 'any' ) {
132			$value = '%' . $value . '%';
133			} else {
134			warn "UNSUPPORTED: op $op - using plain $value";
135			}
136			push @values, $value;
137			}
138			}
139			} elsif ( $how eq 'present' ) {
140			push @limits, __sql_column( $filter->{$how} ) . ' IS NOT NULL';
141			## XXX add and length(foo) > 0 to avoid empty strings?
142			} else {
143			warn "UNSUPPORTED: how $how ",dump( $filter );
144			}
145			warn "## limits ",dump(@limits), " values ",dump(@values);
146			}
147			}
148
149			$sql_where .= ' ' . join( " $join_with ", @limits );
150
151			}
152
153			if ( $sql_where ) {
154			$sql_where = " where $sql_where";
155			}
156
157			warn "# SQL:\n$sql_select $sql_where\n# DATA: ",dump( @values );
158			my $sth = $dbh->prepare( $sql_select . $sql_where . " LIMIT $max_results" ); # XXX remove limit?
159			$sth->execute( @values );
160
161			warn "# ", $sth->rows, " results for ",dump( $reqData->{'filter'} );
162
163	dpavlin	32	while (my $row = $sth->fetchrow_hashref) {
164
165			warn "## row = ",dump( $row );
166
167			my $dn = 'uid=' . $row->{uid} \|\| die "no uid";
168			$dn =~ s{[@\.]}{,dc=}g;
169
170			my $entry = Net::LDAP::Entry->new;
171	dpavlin	36	$entry->dn( $dn . $base );
172	dpavlin	32	$entry->add( %$row );
173
174	dpavlin	36	#warn "### entry ",dump( $entry );
175	dpavlin	32
176			push @entries, $entry;
177			}
178
179			} else {
180			warn "UNKNOWN request: ",dump( $reqData );
181			}
182
183			return RESULT_OK, @entries;
184			}
185
186			# the rest of the operations will return an "unwilling to perform"
187
188			1;