/[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 44 - (hide annotations)
Wed Apr 15 11:06:27 2009 UTC (14 years, 11 months ago) by dpavlin
File size: 5467 byte(s)
dump a lot more debugging information

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

  ViewVC Help
Powered by ViewVC 1.1.26