File Coverage: lib/Authen/SASL/Perl/NTLM.pm

# File Coverage

File: | lib/Authen/SASL/Perl/NTLM.pm
Coverage: | 95.7%

line | stmt | bran | cond | sub | pod | time | code
--- | --- | --- | --- | --- | --- | --- | ---
1 |  |  |  |  |  |  | package Authen::SASL::Perl::NTLM;
2 |  |  |  |  |  |  | # ABSTRACT: NTLM authentication plugin for Authen::SASL
3 |
4 | 1 1 1 |  |  | 1 |  | 7000 0 0 | use 5.006;
5 | 1 1 1 |  |  | 1 |  | 0 0 0 | use strict;
6 | 1 1 1 |  |  | 1 |  | 0 0 0 | use warnings;
7 |
8 | 1 1 1 |  |  | 1 |  | 0 0 0 | use Authen::NTLM ();
9 | 1 1 1 |  |  | 1 |  | 0 0 0 | use MIME::Base64 ();
10 |
11 | 1 1 1 |  |  | 1 |  | 4000 1001 0 | use parent qw(Authen::SASL::Perl);
12 |
13 |  |  |  |  |  |  | # do we need these?
14 |  |  |  |  |  |  | # sub _order { 1 }
15 |  |  |  |  |  |  | # sub _secflags { 0 };
16 |
17 | 1 |  |  | 1 | 0 | 0 | sub mechanism { 'NTLM' }
18 |
19 |  |  |  |  |  |  | #
20 |  |  |  |  |  |  | # Initialises the NTLM object and sets the domain, host, user, and password.
21 |  |  |  |  |  |  | #
22 |  |  |  |  |  |  | sub client_start {
23 | 4 |  |  | 4 | 0 | 0 | my ($self) = @_;
24 |
25 | 4 |  |  |  |  | 0 | $self->{need_step} = 1;
26 | 4 |  |  |  |  | 0 | $self->{error} = undef;
27 | 4 |  |  |  |  | 0 | $self->{stage} = 0;
28 |
29 | 4 |  |  |  |  | 0 | my $user = $self->_call('user');
30 |
31 |  |  |  |  |  |  | # Check for the domain in the username
32 | 4 |  |  |  |  | 0 | my $domain;
33 | 4 | 100 |  |  |  | 0 | ( $domain, $user ) = split( /\\/, $user ) if index( $user, '\\' ) > -1;
34 |
35 | 4 |  |  |  |  | 0 | $self->{ntlm} = Authen::NTLM->new(
36 |  |  |  |  |  |  | host => $self->host,
37 |  |  |  |  |  |  | domain => $domain,
38 |  |  |  |  |  |  | user => $user,
39 |  |  |  |  |  |  | password => $self->_call('pass'),
40 |  |  |  |  |  |  | );
41 |
42 | 4 |  |  |  |  | 0 | return q{};
43 |  |  |  |  |  |  | }
44 |
45 |  |  |  |  |  |  | #
46 |  |  |  |  |  |  | # If C<$challenge> is undefined, it will return a NTLM type 1 request
47 |  |  |  |  |  |  | # message.
48 |  |  |  |  |  |  | # Otherwise, C<$challenge> is assumed to be a NTLM type 2 challenge from
49 |  |  |  |  |  |  | # which the NTLM type 3 response will be generated and returned.
50 |  |  |  |  |  |  | #
51 |  |  |  |  |  |  | sub client_step {
52 | 8 |  |  | 8 | 0 | 0 | my ( $self, $challenge ) = @_;
53 |
54 | 8 | 100 |  |  |  | 0 | if ( defined $challenge ) {
55 |  |  |  |  |  |  | # The challenge has been decoded but Authen::NTLM expects it encoded
56 | 7 |  |  |  |  | 1000 | $challenge = MIME::Base64::encode_base64($challenge);
57 |
58 |  |  |  |  |  |  | # Empty challenge string needs to be undef if we want
59 |  |  |  |  |  |  | # Authen::NTLM::challenge() to generate a type 1 message
60 | 7 | 100 |  |  |  | 0 | $challenge = undef if $challenge eq '';
61 |  |  |  |  |  |  | }
62 |
63 | 8 |  |  |  |  | 0 | my $stage = ++$self->{stage};
64 | 8 | 100 100 |  |  |  | 0 | if ( $stage == 1 ) {
65 | 4 | 100 |  |  |  | 0 | $self->set_error('No challenge must be given for type 1 request')
66 |  |  |  |  |  |  | if $challenge;
67 |  |  |  |  |  |  | }
68 |  |  |  |  |  |  | elsif ( $stage == 2 ) {
69 | 3 |  |  |  |  | 0 | $self->set_success; # no more steps
70 | 3 | 100 |  |  |  | 0 | $self->set_error('No challenge was given for type 2 request')
71 |  |  |  |  |  |  | if !$challenge;
72 |  |  |  |  |  |  | }
73 |  |  |  |  |  |  | else {
74 | 1 |  |  |  |  | 0 | $self->set_error('Invalid step');
75 |  |  |  |  |  |  | }
76 | 8 | 100 |  |  |  | 0 | return '' if $self->error;
77 |
78 | 5 |  |  |  |  | 1000 | my $response = $self->{ntlm}->challenge($challenge);
79 |
80 |  |  |  |  |  |  | # The caller expects the response to be unencoded but
81 |  |  |  |  |  |  | # Authen::NTLM::challenge() has already encoded it
82 | 5 |  |  |  |  | 462026 | return MIME::Base64::decode_base64($response);
83 |  |  |  |  |  |  | }
84 |
85 |  |  |  |  |  |  | 1;
86 |
87 - 144 |  |
    =head1 SYNOPSIS

        use Authen::SASL qw(Perl);

        $sasl = Authen::SASL->new(
            mechanism => 'NTLM',
            callback  => {
                user => $username, # or "$domain\\$username"
                pass => $password,
            },
        );

        $client = $sasl->client_new(...);
        $client->client_start;
        $client->client_step('');
        $client->client_step($challenge);

    =head1 DESCRIPTION

    This module is a plugin for the L<Authen::SASL> framework that implements the
    client procedures to do NTLM authentication.

    Most users will probably only need this module indirectly, when you use
    another module that depends on Authen::SASL with NTLM authentication.
    E.g. connecting to an MS Exchange Server using Email::Sender, which
    depends on Net::SMTP(S) which in turn depends on Authen::SASL.

    You may see this when you get the following error message:

        No SASL mechanism found

    (Unfortunately, Authen::SASL currently doesn't tell you which SASL mechanism
    is missing.)

    =head1 CALLBACK

    The callbacks used are:

    =head2 Client

    =for :list
    = user
    The username to be used for authentication. The domain may optionally be
    specified as part of the C<user> string in the format C<"$domain\\$username">.
    = pass
    The user's password to be used for authentication.

    =head2 Server

    This module does not support server-side authentication.

    =head1 SEE ALSO

    L<Authen::SASL>, L<Authen::SASL::Perl>.

    =for Pod::Coverage mechanism client_start client_step

    =cut