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';

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 $sth = $dbh->prepare(q{
        select
                userid                  as uid,
                firstname               as givenName,
                surname                 as sn,
                cardnumber              as otherPager,
                email                   as mail
        from borrowers
        where
                cardnumber = ?
});

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 "# request = ", dump($reqData);

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

        my @entries;
        if ( $reqData->{'filter'}->{'equalityMatch'}->{'attributeDesc'} eq 'otherPager' ) {

                my $value = $reqData->{'filter'}->{'equalityMatch'}->{'assertionValue'} || die "no value?";

                $sth->execute( $value );

                warn "# ", $sth->rows, " results for: $value\n";

                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 );
                        $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			require 'config.pl' if -e 'config.pl';
26
27			my $dbh = DBI->connect($dsn . $database, $user,$passwd, { RaiseError => 1, AutoCommit => 0 }) \|\| die $DBI::errstr;
28
29	dpavlin	33	# Net::LDAP::Entry will lc all our attribute names anyway, so
30			# we don't really care about correctCapitalization for LDAP
31			# attributes which won't pass through DBI
32	dpavlin	32	my $sth = $dbh->prepare(q{
33			select
34			userid as uid,
35			firstname as givenName,
36			surname as sn,
37			cardnumber as otherPager,
38			email as mail
39			from borrowers
40			where
41			cardnumber = ?
42			});
43
44			use constant RESULT_OK => {
45			'matchedDN' => '',
46			'errorMessage' => '',
47			'resultCode' => LDAP_SUCCESS
48			};
49
50			# constructor
51			sub new {
52			my ($class, $sock) = @_;
53			my $self = $class->SUPER::new($sock);
54			print "connection from: ", $sock->peerhost(), "\n";
55			return $self;
56			}
57
58			# the bind operation
59			sub bind {
60			my $self = shift;
61			my $reqData = shift;
62			warn "# bind ",dump($reqData);
63			return RESULT_OK;
64			}
65
66			# the search operation
67			sub search {
68			my $self = shift;
69			my $reqData = shift;
70			print "searching...\n";
71
72			warn "# request = ", dump($reqData);
73
74			my $base = $reqData->{'baseObject'}; # FIXME use it?
75
76			my @entries;
77			if ( $reqData->{'filter'}->{'equalityMatch'}->{'attributeDesc'} eq 'otherPager' ) {
78
79			my $value = $reqData->{'filter'}->{'equalityMatch'}->{'assertionValue'} \|\| die "no value?";
80
81			$sth->execute( $value );
82
83			warn "# ", $sth->rows, " results for: $value\n";
84
85			while (my $row = $sth->fetchrow_hashref) {
86
87			warn "## row = ",dump( $row );
88
89			my $dn = 'uid=' . $row->{uid} \|\| die "no uid";
90			$dn =~ s{[@\.]}{,dc=}g;
91
92			my $entry = Net::LDAP::Entry->new;
93			$entry->dn( $dn );
94			$entry->add( %$row );
95
96			#warn "## entry ",dump( $entry );
97
98			push @entries, $entry;
99			}
100
101			} else {
102			warn "UNKNOWN request: ",dump( $reqData );
103			}
104
105			return RESULT_OK, @entries;
106			}
107
108			# the rest of the operations will return an "unwilling to perform"
109
110			1;