/[virtual-ldap]/lib/LDAP/Koha.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /lib/LDAP/Koha.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 46 - (hide annotations)
Wed Apr 15 13:50:07 2009 UTC (14 years, 11 months ago) by dpavlin
File size: 5868 byte(s)
support different SQL queries for different objectClasses

- display DIE messages
- example organizationalUnit
- specify objectClass within SQL query (values separated by LF)

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 46 our $max_results = 3; # 100; # FIXME
26 dpavlin 36
27 dpavlin 46 our $objectclass = 'HrEduPerson';
28    
29     $SIG{__DIE__} = sub {
30     warn "!!! DIE ", @_;
31     die @_;
32     };
33    
34 dpavlin 32 require 'config.pl' if -e 'config.pl';
35    
36 dpavlin 43 my $dbh = DBI->connect($dsn . $database, $user,$passwd, { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
37 dpavlin 32
38 dpavlin 33 # Net::LDAP::Entry will lc all our attribute names anyway, so
39     # we don't really care about correctCapitalization for LDAP
40     # attributes which won't pass through DBI
41 dpavlin 46 my $objectclass_sql = {
42    
43     HrEduPerson => q{
44    
45 dpavlin 32 select
46 dpavlin 46 concat('uid=',trim(userid),',dc=ffzg,dc=hr') as dn,
47     'person
48     organizationalPerson
49     inetOrgPerson
50     hrEduPerson' as objectClass,
51    
52 dpavlin 38 trim(userid) as uid,
53 dpavlin 39 firstname as givenName,
54     surname as sn,
55     concat(firstname,' ',surname) as cn,
56 dpavlin 38
57     -- SAFEQ specific mappings from UMgr-LDAP.conf
58 dpavlin 46 cardnumber as objectGUID,
59 dpavlin 39 surname as displayName,
60 dpavlin 42 rfid_sid as pager,
61 dpavlin 39 email as mail,
62 dpavlin 44 categorycode as ou,
63 dpavlin 38 categorycode as organizationalUnit,
64 dpavlin 44 categorycode as memberOf,
65     categorycode as department,
66 dpavlin 39 concat('/home/',borrowernumber) as homeDirectory
67 dpavlin 32 from borrowers
68 dpavlin 46
69     },
70    
71     organizationalUnit => q{
72    
73     select
74     concat('ou=',categorycode) as dn,
75     'organizationalUnit
76     top' as objectClass,
77    
78     hex(md5(categorycode)) % 10000 as objectGUID,
79    
80     categorycode as ou,
81     description as displayName
82     from categories
83    
84     },
85 dpavlin 36 };
86 dpavlin 32
87 dpavlin 39 # we need reverse LDAP -> SQL mapping for where clause
88     my $ldap_sql_mapping = {
89     'uid' => 'userid',
90     'objectGUID' => 'borrowernumber',
91     'displayName' => 'surname',
92     'sn' => 'surname',
93 dpavlin 42 'pager' => 'rfid_sid',
94 dpavlin 36 };
95    
96     sub __sql_column {
97     my $name = shift;
98     $ldap_sql_mapping->{$name} || $name;
99     }
100    
101 dpavlin 32 use constant RESULT_OK => {
102     'matchedDN' => '',
103     'errorMessage' => '',
104     'resultCode' => LDAP_SUCCESS
105     };
106    
107     # constructor
108     sub new {
109     my ($class, $sock) = @_;
110     my $self = $class->SUPER::new($sock);
111     print "connection from: ", $sock->peerhost(), "\n";
112     return $self;
113     }
114    
115     # the bind operation
116     sub bind {
117     my $self = shift;
118     my $reqData = shift;
119     warn "# bind ",dump($reqData);
120     return RESULT_OK;
121     }
122    
123 dpavlin 39 our @values;
124     our @limits;
125    
126     sub __ldap_search_to_sql {
127     my ( $how, $what ) = @_;
128 dpavlin 44 warn "### __ldap_search_to_sql $how ",dump( $what ),"\n";
129 dpavlin 39 if ( $how eq 'equalityMatch' && defined $what ) {
130     my $name = $what->{attributeDesc} || warn "ERROR: no attributeDesc?";
131     my $value = $what->{assertionValue} || warn "ERROR: no assertionValue?";
132 dpavlin 46
133     if ( lc $name eq 'objectclass' ) {
134     $objectclass = $value;
135     } else {
136 dpavlin 39 push @limits, __sql_column($name) . ' = ?';
137     push @values, $value;
138     }
139     } elsif ( $how eq 'substrings' ) {
140     foreach my $substring ( @{ $what->{substrings} } ) {
141     my $name = $what->{type} || warn "ERROR: no type?";
142     while ( my($op,$value) = each %$substring ) {
143     push @limits, __sql_column($name) . ' LIKE ?';
144     if ( $op eq 'any' ) {
145     $value = '%' . $value . '%';
146     } else {
147     warn "UNSUPPORTED: op $op - using plain $value";
148     }
149     push @values, $value;
150     }
151     }
152     } elsif ( $how eq 'present' ) {
153     my $name = __sql_column( $what );
154     push @limits, "$name IS NOT NULL and length($name) > 1";
155     ## XXX length(foo) > 1 to avoid empty " " strings
156     } else {
157 dpavlin 44 warn "UNSUPPORTED: $how ",dump( $what );
158 dpavlin 39 }
159     }
160    
161 dpavlin 32 # the search operation
162     sub search {
163     my $self = shift;
164     my $reqData = shift;
165     print "searching...\n";
166    
167 dpavlin 36 warn "# " . localtime() . " request = ", dump($reqData);
168 dpavlin 32
169     my $base = $reqData->{'baseObject'}; # FIXME use it?
170    
171     my @entries;
172 dpavlin 36 if ( $reqData->{'filter'} ) {
173 dpavlin 32
174 dpavlin 36 my $sql_where = '';
175 dpavlin 39 @values = ();
176 dpavlin 32
177 dpavlin 45 foreach my $filter ( keys %{ $reqData->{'filter'} } ) {
178 dpavlin 32
179 dpavlin 45 warn "## filter $filter ", dump( $reqData->{'filter'}->{ $filter } ), "\n";
180 dpavlin 32
181 dpavlin 39 @limits = ();
182 dpavlin 36
183 dpavlin 45 if ( ref $reqData->{'filter'}->{ $filter } eq 'ARRAY' ) {
184 dpavlin 40
185 dpavlin 45 foreach my $filter ( @{ $reqData->{'filter'}->{ $filter } } ) {
186 dpavlin 40 warn "### filter ",dump($filter),$/;
187     foreach my $how ( keys %$filter ) {
188     if ( $how eq 'or' ) {
189     __ldap_search_to_sql( %$_ ) foreach ( @{ $filter->{$how} } );
190     } else {
191     __ldap_search_to_sql( $how, $filter->{$how} );
192     }
193     warn "## limits ",dump(@limits), " values ",dump(@values);
194 dpavlin 36 }
195     }
196 dpavlin 40
197 dpavlin 45 $sql_where .= ' ' . join( " $filter ", @limits );
198 dpavlin 40
199     } else {
200 dpavlin 45 __ldap_search_to_sql( $filter, $reqData->{'filter'}->{$filter} );
201 dpavlin 36 }
202    
203     }
204    
205     if ( $sql_where ) {
206     $sql_where = " where $sql_where";
207     }
208    
209 dpavlin 46 my $sql_select = $objectclass_sql->{ $objectclass } || die "can't find SQL query for $objectclass";
210    
211 dpavlin 44 warn "# SQL:\n$sql_select\n$sql_where\n# DATA: ",dump( @values );
212 dpavlin 36 my $sth = $dbh->prepare( $sql_select . $sql_where . " LIMIT $max_results" ); # XXX remove limit?
213     $sth->execute( @values );
214    
215     warn "# ", $sth->rows, " results for ",dump( $reqData->{'filter'} );
216    
217 dpavlin 32 while (my $row = $sth->fetchrow_hashref) {
218    
219 dpavlin 46 die "no objectClass column in $sql_select" unless defined $row->{objectClass};
220    
221     $row->{objectClass} = [ split(/\s+/, $row->{objectClass}) ] if $row->{objectClass} =~ m{\n};
222    
223 dpavlin 32 warn "## row = ",dump( $row );
224    
225 dpavlin 46 my $dn = delete( $row->{dn} ) || die "no dn in $sql_select";
226 dpavlin 32
227     my $entry = Net::LDAP::Entry->new;
228 dpavlin 40 $entry->dn( $dn );
229 dpavlin 32 $entry->add( %$row );
230    
231 dpavlin 40 #$entry->changetype( 'modify' );
232 dpavlin 32
233 dpavlin 40 warn "### entry ",$entry->dump( \*STDERR );
234    
235 dpavlin 32 push @entries, $entry;
236     }
237    
238     } else {
239     warn "UNKNOWN request: ",dump( $reqData );
240     }
241    
242     return RESULT_OK, @entries;
243     }
244    
245     # the rest of the operations will return an "unwilling to perform"
246    
247     1;

  ViewVC Help
Powered by ViewVC 1.1.26