File Coverage

blib/lib/Apache/Session/Store/LDAP.pm
Criterion Covered Total %
statement 9 86 10.4
branch 0 42 0.0
condition 0 48 0.0
subroutine 3 10 30.0
pod 0 7 0.0
total 12 193 6.2


line stmt bran cond sub pod time code
1             package Apache::Session::Store::LDAP;
2              
3 1     1   7 use strict;
  1         2  
  1         32  
4 1     1   5 use vars qw($VERSION);
  1         2  
  1         38  
5 1     1   621 use Net::LDAP;
  1         194700  
  1         6  
6              
7             $VERSION = '0.5';
8              
9             sub new {
10 0     0 0   my $class = shift;
11 0           return bless {}, $class;
12             }
13              
14             sub insert {
15 0     0 0   my $self = shift;
16 0           my $session = shift;
17 0           $self->{args} = $session->{args};
18 0   0       $self->{args}->{ldapObjectClass} ||= 'applicationProcess';
19 0   0       $self->{args}->{ldapAttributeId} ||= 'cn';
20 0   0       $self->{args}->{ldapAttributeContent} ||= 'description';
21              
22             my $msg = $self->ldap->add(
23             $self->{args}->{ldapAttributeId} . "="
24             . $session->{data}->{_session_id} . ","
25             . $self->{args}->{ldapConfBase},
26             attrs => [
27             objectClass => $self->{args}->{ldapObjectClass},
28             $self->{args}->{ldapAttributeId} => $session->{data}->{_session_id},
29             $self->{args}->{ldapAttributeContent} => $session->{serialized},
30 0           ],
31             );
32              
33 0 0         $self->ldap->unbind() && delete $self->{ldap};
34 0 0         $self->logError($msg) if ( $msg->code );
35             }
36              
37             sub update {
38 0     0 0   my $self = shift;
39 0           my $session = shift;
40 0           $self->{args} = $session->{args};
41 0   0       $self->{args}->{ldapObjectClass} ||= 'applicationProcess';
42 0   0       $self->{args}->{ldapAttributeId} ||= 'cn';
43 0   0       $self->{args}->{ldapAttributeContent} ||= 'description';
44              
45             my $msg = $self->ldap->modify(
46             $self->{args}->{ldapAttributeId} . "="
47             . $session->{data}->{_session_id} . ","
48             . $self->{args}->{ldapConfBase},
49             replace =>
50             { $self->{args}->{ldapAttributeContent} => $session->{serialized}, },
51 0           );
52              
53 0 0         $self->ldap->unbind() && delete $self->{ldap};
54 0 0         $self->logError($msg) if ( $msg->code );
55             }
56              
57             sub materialize {
58 0     0 0   my $self = shift;
59 0           my $session = shift;
60 0           $self->{args} = $session->{args};
61 0   0       $self->{args}->{ldapObjectClass} ||= 'applicationProcess';
62 0   0       $self->{args}->{ldapAttributeId} ||= 'cn';
63 0   0       $self->{args}->{ldapAttributeContent} ||= 'description';
64              
65             my $msg = $self->ldap->search(
66             base => $self->{args}->{ldapAttributeId} . "="
67             . $session->{data}->{_session_id} . ","
68             . $self->{args}->{ldapConfBase},
69             filter => '(objectClass=' . $self->{args}->{ldapObjectClass} . ')',
70             scope => 'base',
71 0           attrs => [ $self->{args}->{ldapAttributeContent} ],
72             );
73              
74 0 0         $self->ldap->unbind() && delete $self->{ldap};
75 0 0         $self->logError($msg) if ( $msg->code );
76              
77 0           eval {
78             $session->{serialized} = $msg->shift_entry()
79 0           ->get_value( $self->{args}->{ldapAttributeContent} );
80             };
81              
82 0 0         if ( !defined $session->{serialized} ) {
83 0           die "Object does not exist in data store";
84             }
85             }
86              
87             sub remove {
88 0     0 0   my $self = shift;
89 0           my $session = shift;
90 0           $self->{args} = $session->{args};
91 0   0       $self->{args}->{ldapObjectClass} ||= 'applicationProcess';
92 0   0       $self->{args}->{ldapAttributeId} ||= 'cn';
93 0   0       $self->{args}->{ldapAttributeContent} ||= 'description';
94              
95             $self->ldap->delete( $self->{args}->{ldapAttributeId} . "="
96             . $session->{data}->{_session_id} . ","
97 0           . $self->{args}->{ldapConfBase} );
98              
99 0 0         $self->ldap->unbind() && delete $self->{ldap};
100             }
101              
102             sub ldap {
103 0     0 0   my $self = shift;
104 0 0         return $self->{ldap} if ( $self->{ldap} );
105              
106             # Parse servers configuration
107 0           my $useTls = 0;
108 0           my $tlsParam;
109 0           my @servers = ();
110 0           foreach my $server ( split /[\s,]+/, $self->{args}->{ldapServer} ) {
111 0 0         if ( $server =~ m{^ldap\+tls://([^/]+)/?\??(.*)$} ) {
112 0           $useTls = 1;
113 0           $server = $1;
114 0   0       $tlsParam = $2 || "";
115             }
116             else {
117 0           $useTls = 0;
118             }
119 0           push @servers, $server;
120             }
121              
122             # Compatibility
123 0   0       my $caFile = $self->{args}->{ldapCAFile} || $self->{args}->{caFile};
124 0   0       my $caPath = $self->{args}->{ldapCAPath} || $self->{args}->{caPath};
125              
126             # Connect
127             my $ldap = Net::LDAP->new(
128             \@servers,
129             onerror => undef,
130             verify => $self->{args}->{ldapVerify} || "require",
131             ( $caFile ? ( cafile => $caFile ) : () ),
132             ( $caPath ? ( capath => $caPath ) : () ),
133              
134             (
135             $self->{args}->{ldapPort}
136             ? ( port => $self->{args}->{ldapPort} )
137 0 0 0       : ()
    0          
    0          
    0          
138             ),
139             ) or die( 'Unable to connect to ' . join( ' ', @servers ) . ': ' . $@ );
140              
141             # Check SSL error for old Net::LDAP versions
142 0 0         if ( $Net::LDAP::VERSION < '0.64' ) {
143              
144             # CentOS7 has a bug in which IO::Socket::SSL will return a broken
145             # socket when certificate validation fails. Net::LDAP does not catch
146             # it, and the process ends up crashing.
147             # As a precaution, make sure the underlying socket is doing fine:
148 0 0 0       if ( $ldap->socket->isa('IO::Socket::SSL')
149             and $ldap->socket->errstr < 0 )
150             {
151 0           die( "SSL connection error: " . $ldap->socket->errstr );
152             }
153             }
154              
155             # Start TLS if needed
156 0 0         if ($useTls) {
157 0           my %h = split( /[&=]/, $tlsParam );
158 0   0       $h{verify} ||= ( $self->{args}->{ldapVerify} || "require" );
      0        
159 0 0 0       $h{cafile} ||= $caFile if ($caFile);
160 0 0 0       $h{capath} ||= $caPath if ($caPath);
161 0           my $start_tls = $ldap->start_tls(%h);
162 0 0         if ( $start_tls->code ) {
163 0           $self->logError($start_tls);
164 0           return;
165             }
166             }
167              
168             # Bind with credentials
169             my $bind = $ldap->bind( $self->{args}->{ldapBindDN},
170 0           password => $self->{args}->{ldapBindPassword} );
171 0 0         if ( $bind->code ) {
172 0           $self->logError($bind);
173 0           return;
174             }
175              
176 0           $self->{ldap} = $ldap;
177 0           return $ldap;
178             }
179              
180             sub logError {
181 0     0 0   my $self = shift;
182 0           my $ldap_operation = shift;
183 0           die "LDAP error " . $ldap_operation->code . ": " . $ldap_operation->error;
184             }
185              
186             1;
187              
188             =pod
189              
190             =head1 NAME
191              
192             Apache::Session::Store::LDAP - Use LDAP to store persistent objects
193              
194             =head1 SYNOPSIS
195              
196             use Apache::Session::Store::LDAP;
197              
198             my $store = new Apache::Session::Store::LDAP;
199              
200             $store->insert($ref);
201             $store->update($ref);
202             $store->materialize($ref);
203             $store->remove($ref);
204              
205             =head1 DESCRIPTION
206              
207             This module fulfills the storage interface of Apache::Session. The serialized
208             objects are stored in an LDAP directory file using the Net::LDAP Perl module.
209              
210             =head1 OPTIONS
211              
212             This module requires one argument in the usual Apache::Session style. The
213             keys ldapServer, ldapBase, ldapBindDN, ldapBindPassword are required. The keys
214             ldapPort, ldapObjectClass, ldapAttributeId, ldapAttributeContent are optional.
215             Example:
216              
217             tie %s, 'Apache::Session::LDAP', undef,
218             {
219             ldapServer => 'localhost',
220             ldapBase => 'dc=example,dc=com',
221             ldapBindDN => 'cn=admin,dc=example,dc=com',
222             ldapBindPassword => 'pass',
223             ldapObjectClass => 'applicationProcess',
224             ldapAttributeId => 'cn',
225             ldapAttributeContent => 'description',
226             };
227              
228             =head1 AUTHOR
229              
230             Xavier Guimard, Eguimard@E
231              
232             =head1 COPYRIGHT AND LICENSE
233              
234             Copyright (C) 2009, 2012 by Xavier Guimard
235             Copyright (C) 2014, 2015 by Clement Oudot
236              
237             This library is free software; you can redistribute it and/or modify
238             it under the same terms as Perl itself, either Perl version 5.10.0 or,
239             at your option, any later version of Perl 5 you may have available.
240              
241             =head1 SEE ALSO
242              
243             L
244              
245             =cut