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
                trim(userid)                                    as uid,
                firstname                                               as givenName,
                surname                                                 as sn,
                concat(firstname,' ',surname)   as cn,

                -- SAFEQ specific mappings from UMgr-LDAP.conf
                concat(firstname,' ',surname)   as displayName,
                cardnumber                                              as otherPager,
                email                                                   as mail,
                categorycode                                    as organizationalUnit,
                borrowernumber                                  as objectGUID,
                concat('/home/',borrowernumber) as homeDirectory
        from borrowers
};

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

# 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' ) {
                                                my $name = __sql_column( $filter->{$how} );
                                                push @limits, "$name IS NOT NULL and length($name) > 1";
                                                ## XXX length(foo) > 1 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	dpavlin	38	trim(userid) as uid,
37			firstname as givenName,
38			surname as sn,
39			concat(firstname,' ',surname) as cn,
40
41			-- SAFEQ specific mappings from UMgr-LDAP.conf
42			concat(firstname,' ',surname) as displayName,
43			cardnumber as otherPager,
44			email as mail,
45			categorycode as organizationalUnit,
46			borrowernumber as objectGUID,
47			concat('/home/',borrowernumber) as homeDirectory
48	dpavlin	32	from borrowers
49	dpavlin	36	};
50	dpavlin	32
51	dpavlin	36	# needed for where clause
52			my $sql_ldap_mapping = {
53	dpavlin	38	'userid' => 'uid',
54			'borrowernumber' => 'objectGUID',
55	dpavlin	36	};
56
57			# attributes which are same for whole set, but somehow
58			# LDAP clients are sending they anyway and we don't
59			# have them in database
60			my $ldap_ignore = {
61			'objectclass' => 1,
62			};
63
64			my $ldap_sql_mapping;
65			while ( my ($sql,$ldap) = each %$sql_ldap_mapping ) {
66			$ldap_sql_mapping->{ $ldap } = $sql;
67			}
68
69			sub __sql_column {
70			my $name = shift;
71			$ldap_sql_mapping->{$name} \|\| $name;
72			}
73
74	dpavlin	32	use constant RESULT_OK => {
75			'matchedDN' => '',
76			'errorMessage' => '',
77			'resultCode' => LDAP_SUCCESS
78			};
79
80			# constructor
81			sub new {
82			my ($class, $sock) = @_;
83			my $self = $class->SUPER::new($sock);
84			print "connection from: ", $sock->peerhost(), "\n";
85			return $self;
86			}
87
88			# the bind operation
89			sub bind {
90			my $self = shift;
91			my $reqData = shift;
92			warn "# bind ",dump($reqData);
93			return RESULT_OK;
94			}
95
96			# the search operation
97			sub search {
98			my $self = shift;
99			my $reqData = shift;
100			print "searching...\n";
101
102	dpavlin	36	warn "# " . localtime() . " request = ", dump($reqData);
103	dpavlin	32
104			my $base = $reqData->{'baseObject'}; # FIXME use it?
105
106			my @entries;
107	dpavlin	36	if ( $reqData->{'filter'} ) {
108	dpavlin	32
109	dpavlin	36	my $sql_where = '';
110			my @values;
111	dpavlin	32
112	dpavlin	36	foreach my $join_with ( keys %{ $reqData->{'filter'} } ) {
113	dpavlin	32
114	dpavlin	36	warn "## join_with $join_with\n";
115	dpavlin	32
116	dpavlin	36	my @limits;
117
118			foreach my $filter ( @{ $reqData->{'filter'}->{ $join_with } } ) {
119			warn "### filter ",dump($filter),$/;
120			foreach my $how ( keys %$filter ) {
121			warn "### how $how\n";
122			if ( $how eq 'equalityMatch' && defined $filter->{$how} ) {
123			my $name = $filter->{$how}->{attributeDesc} \|\| warn "ERROR: no attributeDesc?";
124			my $value = $filter->{$how}->{assertionValue} \|\| warn "ERROR: no assertionValue?";
125			if ( ! $ldap_ignore->{ $name } ) {
126			push @limits, __sql_column($name) . ' = ?';
127			push @values, $value;
128			}
129			} elsif ( $how eq 'substrings' ) {
130			foreach my $substring ( @{ $filter->{$how}->{substrings} } ) {
131			my $name = $filter->{$how}->{type} \|\| warn "ERROR: no type?";
132			while ( my($op,$value) = each %$substring ) {
133			push @limits, __sql_column($name) . ' LIKE ?';
134			if ( $op eq 'any' ) {
135			$value = '%' . $value . '%';
136			} else {
137			warn "UNSUPPORTED: op $op - using plain $value";
138			}
139			push @values, $value;
140			}
141			}
142			} elsif ( $how eq 'present' ) {
143	dpavlin	38	my $name = __sql_column( $filter->{$how} );
144			push @limits, "$name IS NOT NULL and length($name) > 1";
145			## XXX length(foo) > 1 to avoid empty " " strings
146	dpavlin	36	} else {
147			warn "UNSUPPORTED: how $how ",dump( $filter );
148			}
149			warn "## limits ",dump(@limits), " values ",dump(@values);
150			}
151			}
152
153			$sql_where .= ' ' . join( " $join_with ", @limits );
154
155			}
156
157			if ( $sql_where ) {
158			$sql_where = " where $sql_where";
159			}
160
161			warn "# SQL:\n$sql_select $sql_where\n# DATA: ",dump( @values );
162			my $sth = $dbh->prepare( $sql_select . $sql_where . " LIMIT $max_results" ); # XXX remove limit?
163			$sth->execute( @values );
164
165			warn "# ", $sth->rows, " results for ",dump( $reqData->{'filter'} );
166
167	dpavlin	32	while (my $row = $sth->fetchrow_hashref) {
168
169			warn "## row = ",dump( $row );
170
171			my $dn = 'uid=' . $row->{uid} \|\| die "no uid";
172			$dn =~ s{[@\.]}{,dc=}g;
173
174			my $entry = Net::LDAP::Entry->new;
175	dpavlin	36	$entry->dn( $dn . $base );
176	dpavlin	32	$entry->add( %$row );
177
178	dpavlin	36	#warn "### entry ",dump( $entry );
179	dpavlin	32
180			push @entries, $entry;
181			}
182
183			} else {
184			warn "UNKNOWN request: ",dump( $reqData );
185			}
186
187			return RESULT_OK, @entries;
188			}
189
190			# the rest of the operations will return an "unwilling to perform"
191
192			1;