1#!/usr/local/bin/perl
2
3package Authen::NTLM;
4use strict;
5use Authen::NTLM::DES;
6use Authen::NTLM::MD4;
7use MIME::Base64;
8use Digest::HMAC_MD5;
9
10use vars qw($VERSION @ISA @EXPORT);
11require Exporter;
12
13=head1 NAME
14
15Authen::NTLM - An NTLM authentication module
16
17=head1 SYNOPSIS
18
19    use Mail::IMAPClient;
20    use Authen::NTLM;
21    my $imap = Mail::IMAPClient->new(Server=>'imaphost');
22    ntlm_user($username);
23    ntlm_password($password);
24    $imap->authenticate("NTLM", Authen::NTLM::ntlm);
25    :
26    $imap->logout;
27    ntlm_reset;
28    :
29
30or
31
32    ntlmv2(1);
33    ntlm_user($username);
34    ntlm_host($host);
35    ntlm_password($password);
36    :
37
38or
39
40    my $ntlm = Authen::NTLM-> new(
41        host     => $host,
42        user     => $username,
43        domain   => $domain,
44        password => $password,
45        version  => 1,
46    );
47    $ntlm-> challenge;
48    :
49    $ntlm-> challenge($challenge);
50
51
52
53=head1 DESCRIPTION
54
55    This module provides methods to use NTLM authentication.  It can
56    be used as an authenticate method with the Mail::IMAPClient module
57    to perform the challenge/response mechanism for NTLM connections
58    or it can be used on its own for NTLM authentication with other
59    protocols (eg. HTTP).
60
61    The implementation is a direct port of the code from F<fetchmail>
62    which, itself, has based its NTLM implementation on F<samba>.  As
63    such, this code is not especially efficient, however it will still
64    take a fraction of a second to negotiate a login on a PII which is
65    likely to be good enough for most situations.
66
67=head2 FUNCTIONS
68
69=over 4
70
71=item ntlm_domain()
72
73    Set the domain to use in the NTLM authentication messages.
74    Returns the new domain.  Without an argument, this function
75    returns the current domain entry.
76
77=item ntlm_user()
78
79    Set the username to use in the NTLM authentication messages.
80    Returns the new username.  Without an argument, this function
81    returns the current username entry.
82
83=item ntlm_password()
84
85    Set the password to use in the NTLM authentication messages.
86    Returns the new password.  Without an argument, this function
87    returns the current password entry.
88
89=item ntlm_reset()
90
91    Resets the NTLM challenge/response state machine so that the next
92    call to C<ntlm()> will produce an initial connect message.
93
94=item ntlm()
95
96    Generate a reply to a challenge.  The NTLM protocol involves an
97    initial empty challenge from the server requiring a message
98    response containing the username and domain (which may be empty).
99    The first call to C<ntlm()> generates this first message ignoring
100    any arguments.
101
102    The second time it is called, it is assumed that the argument is
103    the challenge string sent from the server.  This will contain 8
104    bytes of data which are used in the DES functions to generate the
105    response authentication strings.  The result of the call is the
106    final authentication string.
107
108    If C<ntlm_reset()> is called, then the next call to C<ntlm()> will
109    start the process again allowing multiple authentications within
110    an application.
111
112=item ntlmv2()
113
114    Use NTLM v2 authentication.
115
116=back
117
118=head2 OBJECT API
119
120=over
121
122=item new %options
123
124Creates an object that accepts the following options: C<user>, C<host>,
125C<domain>, C<password>, C<version>.
126
127=item challenge [$challenge]
128
129If C<$challenge> is not supplied, first-stage challenge string is generated.
130Otherwise, the third-stage challenge is generated, where C<$challenge> is
131assumed to be extracted from the second stage of NTLM exchange. The result of
132the call is the final authentication string.
133
134=back
135
136=head1 AUTHOR
137
138    David (Buzz) Bussenschutt <davidbuzz@gmail.com> - current maintainer
139    Dmitry Karasik <dmitry@karasik.eu.org> - nice ntlmv2 patch, OO extensions.
140    Andrew Hobson <ahobson@infloop.com> - initial ntlmv2 code
141    Mark Bush <Mark.Bush@bushnet.demon.co.uk> - perl port
142    Eric S. Raymond - author of fetchmail
143    Andrew Tridgell and Jeremy Allison for SMB/Netbios code
144
145=head1 SEE ALSO
146
147L<perl>, L<Mail::IMAPClient>, L<LWP::Authen::Ntlm>
148
149=head1 HISTORY
150
151    1.09 - fix CPAN ticket # 70703
152    1.08 - fix CPAN ticket # 39925
153    1.07 - not publicly released
154    1.06 - relicense as GPL+ or Artistic
155    1.05 - add OO interface by Dmitry Karasik
156    1.04 - implementation of NTLMv2 by Andrew Hobson/Dmitry Karasik
157    1.03 - fixes long-standing 1 line bug L<http://rt.cpan.org/Public/Bug/Display.html?id=9521> - released by David Bussenschutt 9th Aug 2007
158    1.02 - released by Mark Bush 29th Oct 2001
159
160=cut
161
162$VERSION = "1.09";
163@ISA = qw(Exporter);
164@EXPORT = qw(ntlm ntlm_domain ntlm_user ntlm_password ntlm_reset ntlm_host ntlmv2);
165
166my $domain = "";
167my $user = "";
168my $password = "";
169
170my $str_hdr = "vvV";
171my $hdr_len = 8;
172my $ident = "NTLMSSP";
173
174my $msg1_f = 0x0000b207;
175my $msg1 = "Z8VV";
176my $msg1_hlen = 16 + ($hdr_len*2);
177
178my $msg2 = "Z8Va${hdr_len}Va8a8a${hdr_len}";
179my $msg2_hlen = 12 + $hdr_len + 20 + $hdr_len;
180
181my $msg3 = "Z8V";
182my $msg3_tl = "V";
183my $msg3_hlen = 12 + ($hdr_len*6) + 4;
184
185my $state = 0;
186
187my $host = "";
188my $ntlm_v2 = 0;
189my $ntlm_v2_msg3_flags = 0x88205;
190
191
192# Domain Name supplied on negotiate
193use constant NTLMSSP_NEGOTIATE_OEM_DOMAIN_SUPPLIED      => 0x00001000;
194# Workstation Name supplied on negotiate
195use constant NTLMSSP_NEGOTIATE_OEM_WORKSTATION_SUPPLIED => 0x00002000;
196# Try to use NTLMv2
197use constant NTLMSSP_NEGOTIATE_NTLM2                    => 0x00080000;
198
199
200# Object API
201
202sub new
203{
204   my ( $class, %opt) = @_;
205   for (qw(domain user password host)) {
206      $opt{$_} = "" unless defined $opt{$_};
207   }
208   $opt{version} ||= 1;
209   return bless { %opt }, $class;
210}
211
212sub challenge
213{
214   my ( $self, $challenge) = @_;
215   $state = defined $challenge;
216   ($user,$domain,$password,$host) = @{$self}{qw(user domain password host)};
217   $ntlm_v2 = ($self-> {version} eq '2') ? 1 : 0;
218   return ntlm($challenge);
219}
220
221eval "sub $_ { \$#_ ? \$_[0]->{$_} = \$_[1] : \$_[0]->{$_} }"
222   for qw(user domain password host version);
223
224# Function API
225
226sub ntlm_domain
227{
228  if (@_)
229  {
230    $domain = shift;
231  }
232  return $domain;
233}
234
235sub ntlm_user
236{
237  if (@_)
238  {
239    $user = shift;
240  }
241  return $user;
242}
243
244sub ntlm_password
245{
246  if (@_)
247  {
248    $password = shift;
249  }
250  return $password;
251}
252
253sub ntlm_reset
254{
255  $state = 0;
256}
257
258sub ntlmv2
259{
260  if (@_) {
261    $ntlm_v2 = shift;
262  }
263  return $ntlm_v2;
264}
265
266sub ntlm_host {
267  if (@_) {
268    $host = shift;
269  }
270  return $host;
271}
272
273sub ntlm
274{
275  my ($challenge) = @_;
276
277  my ($flags, $user_hdr, $domain_hdr,
278      $u_off, $d_off, $c_info, $lmResp, $ntResp, $lm_hdr,
279      $nt_hdr, $wks_hdr, $session_hdr, $lm_off, $nt_off,
280      $wks_off, $s_off, $u_user, $msg1_host, $host_hdr, $u_host);
281  my $response;
282  if ($state)
283  {
284
285    $challenge =~ s/^\s*//;
286    $challenge = decode_base64($challenge);
287    $c_info = &decode_challenge($challenge);
288    $u_user = &unicode($user);
289    if (!$ntlm_v2) {
290      $domain = substr($challenge, $c_info->{domain}{offset}, $c_info->{domain}{len});
291      $lmResp = &lmEncrypt($c_info->{data});
292      $ntResp = &ntEncrypt($c_info->{data});
293      $flags = pack($msg3_tl, $c_info->{flags});
294	 }
295	 elsif ($ntlm_v2 eq '1') {
296      $lmResp = &lmv2Encrypt($c_info->{data});
297      $ntResp = &ntv2Encrypt($c_info->{data}, $c_info->{target_data});
298      $flags = pack($msg3_tl, $ntlm_v2_msg3_flags);
299	 }
300    else {
301      $domain = &unicode($domain);#substr($challenge, $c_info->{domain}{offset}, $c_info->{domain}{len});
302      $lmResp = &lmEncrypt($c_info->{data});
303      $ntResp = &ntEncrypt($c_info->{data});
304      $flags = pack($msg3_tl, $c_info->{flags});
305    }
306    $u_host = &unicode(($host ? $host : $user));
307    $response = pack($msg3, $ident, 3);
308
309    $lm_off = $msg3_hlen;
310    $nt_off = $lm_off + length($lmResp);
311    $d_off = $nt_off + length($ntResp);
312    $u_off = $d_off + length($domain);
313    $wks_off = $u_off + length($u_user);
314    $s_off = $wks_off + length($u_host);
315    $lm_hdr = &hdr($lmResp, $msg3_hlen, $lm_off);
316    $nt_hdr = &hdr($ntResp, $msg3_hlen, $nt_off);
317    $domain_hdr = &hdr($domain, $msg3_hlen, $d_off);
318    $user_hdr = &hdr($u_user, $msg3_hlen, $u_off);
319    $wks_hdr = &hdr($u_host, $msg3_hlen, $wks_off);
320    $session_hdr = &hdr("", $msg3_hlen, $s_off);
321    $response .= $lm_hdr . $nt_hdr . $domain_hdr . $user_hdr .
322                 $wks_hdr . $session_hdr . $flags .
323		 $lmResp . $ntResp . $domain . $u_user . $u_host;
324  }
325  else # first response;
326  {
327    my $f = $msg1_f;
328    if (!length $domain) {
329      $f &= ~NTLMSSP_NEGOTIATE_OEM_DOMAIN_SUPPLIED;
330    }
331    $msg1_host = $user;
332    if ($ntlm_v2 and $ntlm_v2 eq '1') {
333      $f &= ~NTLMSSP_NEGOTIATE_OEM_WORKSTATION_SUPPLIED;
334      $f |= NTLMSSP_NEGOTIATE_NTLM2;
335      $msg1_host = "";
336    }
337
338    $response = pack($msg1, $ident, 1, $f);
339    $u_off = $msg1_hlen;
340    $d_off = $u_off + length($msg1_host);
341    $host_hdr = &hdr($msg1_host, $msg1_hlen, $u_off);
342    $domain_hdr = &hdr($domain, $msg1_hlen, $d_off);
343    $response .= $host_hdr . $domain_hdr . $msg1_host . $domain;
344    $state = 1;
345  }
346  return encode_base64($response, "");
347}
348
349sub hdr
350{
351  my ($string, $h_len, $offset) = @_;
352
353  my ($res, $len);
354  $len = length($string);
355  if ($string)
356  {
357    $res = pack($str_hdr, $len, $len, $offset);
358  }
359  else
360  {
361    $res = pack($str_hdr, 0, 0, $offset - $h_len);
362  }
363  return $res;
364}
365
366sub decode_challenge
367{
368  my ($challenge) = @_;
369
370  my $res;
371  my (@res, @hdr);
372  my $original = $challenge;
373
374  $res->{buffer} = $msg2_hlen < length $challenge
375  ? substr($challenge, $msg2_hlen) : '';
376  $challenge = substr($challenge, 0, $msg2_hlen);
377  @res = unpack($msg2, $challenge);
378  $res->{ident} = $res[0];
379  $res->{type} = $res[1];
380  @hdr = unpack($str_hdr, $res[2]);
381  $res->{domain}{len} = $hdr[0];
382  $res->{domain}{maxlen} = $hdr[1];
383  $res->{domain}{offset} = $hdr[2];
384  $res->{flags} = $res[3];
385  $res->{data} = $res[4];
386  $res->{reserved} = $res[5];
387  $res->{empty_hdr} = $res[6];
388  @hdr = unpack($str_hdr, $res[6]);
389  $res->{target}{len} = $hdr[0];
390  $res->{target}{maxlen} = $hdr[1];
391  $res->{target}{offset} = $hdr[2];
392  $res->{target_data} = substr($original, $hdr[2], $hdr[1]);
393
394  return $res;
395}
396
397sub unicode
398{
399  my ($string) = @_;
400  my ($reply, $c, $z) = ('');
401
402  $z = sprintf "%c", 0;
403  foreach $c (split //, $string)
404  {
405    $reply .= $c . $z;
406  }
407  return $reply;
408}
409
410sub NTunicode
411{
412  my ($string) = @_;
413  my ($reply, $c);
414
415  foreach $c (map {ord($_)} split(//, $string))
416  {
417    $reply .= pack("v", $c);
418  }
419  return $reply;
420}
421
422sub lmEncrypt
423{
424  my ($data) = @_;
425
426  my $p14 = substr($password, 0, 14);
427  $p14 =~ tr/a-z/A-Z/;
428  $p14 .= "\0"x(14-length($p14));
429  my $p21 = E_P16($p14);
430  $p21 .= "\0"x(21-length($p21));
431  my $p24 = E_P24($p21, $data);
432  return $p24;
433}
434
435sub ntEncrypt
436{
437  my ($data) = @_;
438
439  my $p21 = &E_md4hash;
440  $p21 .= "\0"x(21-length($p21));
441  my $p24 = E_P24($p21, $data);
442  return $p24;
443}
444
445sub E_md4hash
446{
447  my $wpwd = &NTunicode($password);
448  my $p16 = mdfour($wpwd);
449  return $p16;
450}
451
452sub lmv2Encrypt {
453  my ($data) = @_;
454
455  my $u_pass = &unicode($password);
456  my $ntlm_hash = mdfour($u_pass);
457
458  my $u_user = &unicode("\U$user\E");
459  my $u_domain = &unicode("$domain");
460  my $concat = $u_user . $u_domain;
461
462  my $hmac = Digest::HMAC_MD5->new($ntlm_hash);
463  $hmac->add($concat);
464  my $ntlm_v2_hash = $hmac->digest;
465
466  # Firefox seems to use this as its random challenge
467  my $random_challenge = "\0" x 8;
468
469  my $concat2 = $data . $random_challenge;
470
471  $hmac = Digest::HMAC_MD5->new($ntlm_v2_hash);
472  $hmac->add(substr($data, 0, 8) . $random_challenge);
473  my $r = $hmac->digest . $random_challenge;
474
475  return $r;
476}
477
478sub ntv2Encrypt {
479  my ($data, $target) = @_;
480
481  my $u_pass = &unicode($password);
482  my $ntlm_hash = mdfour($u_pass);
483
484  my $u_user = &unicode("\U$user\E");
485  my $u_domain = &unicode("$domain");
486  my $concat = $u_user . $u_domain;
487
488  my $hmac = Digest::HMAC_MD5->new($ntlm_hash);
489  $hmac->add($concat);
490  my $ntlm_v2_hash = $hmac->digest;
491
492  my $zero_long = "\000" x 4;
493  my $sig = pack("H8", "01010000");
494  my $time = pack("VV", (time + 11644473600) + 10000000);
495  my $rand = "\0" x 8;
496  my $blob = $sig . $zero_long . $time . $rand . $zero_long .
497      $target . $zero_long;
498
499  $concat = $data . $blob;
500
501  $hmac = Digest::HMAC_MD5->new($ntlm_v2_hash);
502  $hmac->add($concat);
503
504  my $d = $hmac->digest;
505
506  my $r = $d . $blob;
507
508  return $r;
509}
510
5111;
512