1# Copyright (c) 1998-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
2# This program is free software; you can redistribute it and/or
3# modify it under the same terms as Perl itself.
4
5package LWP::Protocol::ldap;
6
7use Carp ();
8
9use HTTP::Status ();
10use HTTP::Negotiate ();
11use HTTP::Response ();
12use LWP::MediaTypes ();
13require LWP::Protocol;
14@ISA = qw(LWP::Protocol);
15
16$VERSION = "1.10";
17
18use strict;
19eval {
20  require Net::LDAP;
21};
22my $init_failed = $@ ? $@ : undef;
23
24sub request {
25  my($self, $request, $proxy, $arg, $size, $timeout) = @_;
26
27  $size = 4096 unless $size;
28
29  LWP::Debug::trace('()');
30
31  # check proxy
32  if (defined $proxy)
33  {
34    return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
35                 'You can not proxy through the ldap';
36  }
37
38  my $url = $request->url;
39  if ($url->scheme ne 'ldap') {
40    my $scheme = $url->scheme;
41    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
42            "LWP::Protocol::ldap::request called for '$scheme'";
43  }
44
45  # check method
46  my $method = $request->method;
47
48  unless ($method eq 'GET') {
49    return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
50                 'Library does not allow method ' .
51                 "$method for 'ldap:' URLs";
52  }
53
54  if ($init_failed) {
55    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
56            $init_failed;
57  }
58
59  my $host     = $url->host;
60  my $port     = $url->port;
61  my ($user, $password) = split(":", $url->userinfo, 2);
62
63  # Create an initial response object
64  my $response = new HTTP::Response &HTTP::Status::RC_OK, "Document follows";
65  $response->request($request);
66
67  my $ldap = new Net::LDAP($host, port => $port);
68
69  my $mesg = $ldap->bind($user, password => $password);
70
71  if ($mesg->code) {
72    my $res = new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
73         "LDAP return code " . $ldap->code;
74    $res->content_type("text/plain");
75    $res->content($ldap->error);
76    return $res;
77  }
78
79  my $dn = $url->dn;
80  my @attrs = $url->attributes;
81  my $scope = $url->scope || "base";
82  my $filter = $url->filter;
83  my @opts = (scope => $scope);
84
85  push @opts, "base" => $dn if $dn;
86  push @opts, "filter" => $filter if $filter;
87  push @opts, "attrs" => \@attrs if @attrs;
88
89  $mesg = $ldap->search(@opts);
90  if ($mesg->code) {
91    my $res = new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
92         "LDAP return code " . $ldap->code;
93    $res->content_type("text/plain");
94    $res->content($ldap->error);
95    return $res;
96  }
97  else {
98    my $content = "<head><title>Directory Search Results</title></head>\n<body>";
99    my $entry;
100    my $index;
101
102    for($index = 0 ; $entry = $mesg->entry($index) ; $index++ ) {
103      my $attr;
104
105      $content .= $index ? qq{<tr><th colspan="2"><hr>&nbsp</tr>\n} : "<table>";
106
107      $content .= qq{<tr><th colspan="2">} . $entry->dn . "</th></tr>\n";
108
109      foreach $attr ($entry->attributes) {
110        my $vals = $entry->get_value($attr, asref => 1);
111        my $val;
112
113        $content .= q{<tr><td align="right" valign="top"};
114        $content .= q{ rowspan="} . scalar(@$vals) . q{"}
115          if (@$vals > 1);
116        $content .= ">" . $attr  . "&nbsp</td>\n";
117
118        my $j = 0;
119        foreach $val (@$vals) {
120	  $val = qq!<a href="$val">$val</a>! if $val =~ /^https?:/;
121	  $val = qq!<a href="mailto:$val">$val</a>! if $val =~ /^[-\w]+\@[-.\w]+$/;
122          $content .= "<tr>" if $j++;
123          $content .= "<td>" . $val . "</td></tr>\n";
124        }
125      }
126    }
127
128    $content .= "</table>" if $index;
129    $content .= "<hr>";
130    $content .= $index ? sprintf("%s Match%s found",$index, $index>1 ? "es" : "")
131		       : "<b>No Matches found</b>";
132    $content .= "</body>\n";
133    $response->header('Content-Type' => 'text/html');
134    $response->header('Content-Length', length($content));
135    $response = $self->collect_once($arg, $response, $content)
136	if ($method ne 'HEAD');
137
138  }
139
140  $ldap->unbind;
141
142  $response;
143}
144
1451;
146