home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _ee49f804959cc56b10ae872ac85f0de3 < prev    next >
Encoding:
Text File  |  2004-06-01  |  6.4 KB  |  196 lines
  1. package LWP::Authen::Ntlm;
  2.  
  3. use strict;
  4. use vars qw/$VERSION/;
  5.  
  6. $VERSION = '0.05';
  7.  
  8. use Authen::NTLM "1.02";
  9. use MIME::Base64 "2.12";
  10.  
  11. sub authenticate {
  12.     LWP::Debug::debug("authenticate() has been called");
  13.     my($class, $ua, $proxy, $auth_param, $response,
  14.        $request, $arg, $size) = @_;
  15.  
  16.     my($user, $pass) = $ua->get_basic_credentials($auth_param->{realm},
  17.                                                   $request->url, $proxy);
  18.  
  19.     unless(defined $user and defined $pass) {
  20.         LWP::Debug::debug("No username and password available from get_basic_credentials().  Returning unmodified response object");
  21.         return $response;
  22.     }
  23.  
  24.     if (!$ua->conn_cache()) {
  25.         LWP::Debug::debug("Keep alive not enabled, emitting a warning");
  26.         warn "The keep_alive option must be enabled for NTLM authentication to work.  NTLM authentication aborted.\n";
  27.         return $response;
  28.     }
  29.  
  30.     my($domain, $username) = split(/\\/, $user);
  31.  
  32.     ntlm_domain($domain);
  33.     ntlm_user($username);
  34.     ntlm_password($pass);
  35.  
  36.     my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
  37.  
  38.     # my ($challenge) = $response->header('WWW-Authenticate'); 
  39.     my $challenge;
  40.     foreach ($response->header('WWW-Authenticate')) { 
  41.         last if /^NTLM/ && ($challenge=$_);
  42.     }
  43.  
  44.     if ($challenge eq 'NTLM') {
  45.         # First phase, send handshake
  46.         LWP::Debug::debug("In first phase of NTLM authentication");
  47.         my $auth_value = "NTLM " . ntlm();
  48.         ntlm_reset();
  49.  
  50.         # Need to check this isn't a repeated fail!
  51.         my $r = $response;
  52.         my $retry_count = 0;
  53.         while ($r) {
  54.             my $auth = $r->request->header($auth_header);
  55.             ++$retry_count if ($auth && $auth eq $auth_value);
  56.             if ($retry_count > 2) {
  57.                     # here we know this failed before
  58.                     $response->header("Client-Warning" =>
  59.                               "Credentials for '$user' failed before");
  60.                     return $response;
  61.             }
  62.             $r = $r->previous;
  63.         }
  64.  
  65.         my $referral = $request->clone;
  66.         $referral->header($auth_header => $auth_value);
  67.         LWP::Debug::debug("Returning response object with auth header:\n$auth_header $auth_value");
  68.         return $ua->request($referral, $arg, $size, $response);
  69.     }
  70.     
  71.     else {
  72.         # Second phase, use the response challenge (unless non-401 code
  73.         #  was returned, in which case, we just send back the response
  74.         #  object, as is
  75.         LWP::Debug::debug("In second phase of NTLM authentication");
  76.         my $auth_value;
  77.         if ($response->code ne '401') {
  78.             LWP::Debug::debug("Response from server was not 401 Unauthorized, returning response object without auth headers");
  79.             return $response;
  80.         }
  81.         else {
  82.             my $challenge;
  83.             foreach ($response->header('WWW-Authenticate')) { 
  84.                 last if /^NTLM/ && ($challenge=$_);
  85.             }
  86.             $challenge =~ s/^NTLM //;
  87.             ntlm();
  88.             $auth_value = "NTLM " . ntlm($challenge);
  89.             ntlm_reset();
  90.         }
  91.  
  92.         my $referral = $request->clone;
  93.         $referral->header($auth_header => $auth_value);
  94.         LWP::Debug::debug("Returning response object with auth header:\n$auth_header $auth_value");
  95.         my $response2 = $ua->request($referral, $arg, $size, $response);
  96.         return $response2;
  97.     }
  98. }
  99.  
  100. 1;
  101.  
  102.  
  103. =head1 NAME
  104.  
  105. LWP::Authen::Ntlm - Library for enabling NTLM authentication (Microsoft) in LWP
  106.  
  107. =head1 SYNOPSIS
  108.  
  109.  use LWP::UserAgent;
  110.  use HTTP::Request::Common;
  111.  my $url = 'http://www.company.com/protected_page.html';
  112.  
  113.  # Set up the ntlm client and then the base64 encoded ntlm handshake message
  114.  my $ua = new LWP::UserAgent(keep_alive=>1);
  115.  $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');
  116.  
  117.  $request = GET $url;
  118.  print "--Performing request now...-----------\n";
  119.  $response = $ua->request($request);
  120.  print "--Done with request-------------------\n";
  121.  
  122.  if ($response->is_success) {print "It worked!->" . $response->code . "\n"}
  123.  else {print "It didn't work!->" . $response->code . "\n"}
  124.  
  125. =head1 DESCRIPTION
  126.  
  127. C<LWP::Authen::Ntlm> allows LWP to authenticate against servers that are using the 
  128. NTLM authentication scheme popularized by Microsoft.  This type of authentication is 
  129. common on intranets of Microsoft-centric organizations.
  130.  
  131. The module takes advantage of the Authen::NTLM module by Mark Bush.  Since there 
  132. is also another Authen::NTLM module available from CPAN by Yee Man Chan with an 
  133. entirely different interface, it is necessary to ensure that you have the correct 
  134. NTLM module.
  135.  
  136. In addition, there have been problems with incompatibilities between different 
  137. versions of Mime::Base64, which Bush's Authen::NTLM makes use of.  Therefore, it is 
  138. necessary to ensure that your Mime::Base64 module supports exporting of the 
  139. encode_base64 and decode_base64 functions.
  140.  
  141. =head1 USAGE
  142.  
  143. The module is used indirectly through LWP, rather than including it directly in your 
  144. code.  The LWP system will invoke the NTLM authentication when it encounters the 
  145. authentication scheme while attempting to retrieve a URL from a server.  In order 
  146. for the NTLM authentication to work, you must have a few things set up in your 
  147. code prior to attempting to retrieve the URL:
  148.  
  149. =over 4
  150.  
  151. =item *
  152.  
  153. Enable persistent HTTP connections
  154.  
  155. To do this, pass the "keep_alive=>1" option to the LWP::UserAgent when creating it, like this:
  156.  
  157.     my $ua = new LWP::UserAgent(keep_alive=>1);
  158.  
  159. =item *
  160.  
  161. Set the credentials on the UserAgent object
  162.  
  163. The credentials must be set like this:
  164.  
  165.    $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');
  166.  
  167. Note that you cannot use the HTTP::Request object's authorization_basic() method to set 
  168. the credentials.  Note, too, that the 'www.company.com:80' portion only sets credentials 
  169. on the specified port AND it is case-sensitive (this is due to the way LWP is coded, and 
  170. has nothing to do with LWP::Authen::Ntlm)
  171.  
  172. =back
  173.  
  174. If you run into trouble and need help troubleshooting your problems, try enabling LWP 
  175. debugging by putting this line at the top of your code:
  176.  
  177.     use LWP::Debug qw(+);
  178.  
  179. You should get copious debugging output, including messages from LWP::Authen::Ntlm itself.
  180.  
  181. =head1 AVAILABILITY
  182.  
  183. General queries regarding LWP should be made to the LWP Mailing List.
  184.  
  185. Questions specific to LWP::Authen::Ntlm can be forwarded to jtillman@bigfoot.com
  186.  
  187. =head1 COPYRIGHT
  188.  
  189. Copyright (c) 2002 James Tillman. All rights reserved. This
  190. program is free software; you can redistribute it and/or modify it
  191. under the same terms as Perl itself.
  192.  
  193. =head1 SEE ALSO
  194.  
  195. L<LWP>, L<LWP::UserAgent>, L<lwpcook>.
  196.