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