git.rot13.org Git - virtual-ldap/blob - lib/LDAP/Koha.pm

   1 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 our $max_results = 3; # 100; # FIXME
  26
  27 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 # 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 my $sql_select = q{
  35         select
  36                 userid                  as uid,
  37                 firstname               as givenName,
  38                 surname                 as sn,
  39                 concat(
  40                         firstname,
  41                         ' ',
  42                         surname
  43                 )                               as cn,
  44                 cardnumber              as otherPager,
  45                 email                   as mail
  46         from borrowers
  47 };
  48
  49 # 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 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         warn "# " . localtime() . " request = ", dump($reqData);
 100
 101         my $base = $reqData->{'baseObject'}; # FIXME use it?
 102
 103         my @entries;
 104         if ( $reqData->{'filter'} ) {
 105
 106                 my $sql_where = '';
 107                 my @values;
 108
 109                 foreach my $join_with ( keys %{ $reqData->{'filter'} } ) {
 110
 111                         warn "## join_with $join_with\n";
 112
 113                         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                 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                         $entry->dn( $dn . $base );
 172                         $entry->add( %$row );
 173
 174                         #warn "### entry ",dump( $entry );
 175
 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;