view release on metacpan or  search on metacpan

AuthenNTLM.pm  view on Meta::CPAN

    my ($self, $r) = @_ ;

    if (!$self -> {smbhandle})
        {
        $self -> {lock} = undef ; # reset lock in case anything has gone wrong
        MP2 ?  $r->log_error("SMB Server connection not open in state 3 for " . $r -> uri) 
	    : $r->log_reason("SMB Server connection not open in state 3 for " . $r -> uri) ;
        return ;
        }

    my $rc ;

    print STDERR "[$$] AuthenNTLM: Verify user $self->{username} via smb server\n" if ($debug) ;

    if ($self -> {basic})
	{
	$rc = Authen::Smb::Valid_User_Auth ($self -> {smbhandle}, $self->{username}, $self -> {password}) ;
	}
    else
	{
	$rc = Authen::Smb::Valid_User_Auth ($self -> {smbhandle}, $self->{username}, $self -> {usernthash}, 1, $self->{userdomain}) ;
	}
    my $errno  = Authen::Smb::SMBlib_errno ;
    my $smberr = Authen::Smb::SMBlib_SMB_Error ;
    Authen::Smb::Valid_User_Disconnect ($self -> {smbhandle}) if ($self -> {smbhandle}) ;
    $self -> {smbhandle} = undef ;
    $self -> {lock}      = undef ;

    if ($rc == &Authen::Smb::NTV_LOGON_ERROR)
        {
        MP2 ? $r->log_error("Wrong password/user (rc=$rc/$errno/$smberr): $self->{userdomain}\\$self->{username} for " . $r -> uri) : $r->log_reason("Wrong password/user (rc=$rc/$errno/$smberr): $self->{userdomain}\\$self->{username} for " . $r -> ur...
        print STDERR "[$$] AuthenNTLM: rc = $rc  ntlmhash = $self->{usernthash}\n" if ($debug) ; 
        return ;
        }

    if ($rc)
        {
        MP2 ? $r->log_reason("SMB Server error $rc/$errno/$smberr for " . $r -> uri) : $r->log_reason("SMB Server error $rc/$errno/$smberr for " . $r -> uri) ;
        return ;
        }

    return 1 ;
    }


sub map_user

    {
     my ($self, $r) = @_ ;

     if ($self -> {splitdomainprefix} == 1) 
         {
	     return lc("$self->{username}") ;
	 } else {
	     return lc("$self->{userdomain}\\$self->{username}") ;
	 }
    }



sub substr_unicode 
    {
    my ($data, $off,  $len) = @_ ;

    my $i = 0 ; 
    my $end = $off + $len ;
    my $result = '' ;
    for ($i = $off ; $i < $end ; $i += 2)
        {# for now we simply ignore high order byte
        $result .=  substr ($data, $i,  1) ;
        }

    return $result ;
    }


sub get_msg_data

    {
    my ($self, $r) = @_ ;

    my $auth_line = MP2 ? $r->headers_in->{$r->proxyreq ? 'Proxy-Authorization' : 'Authorization'} 
                            : $r -> header_in ($r->proxyreq ? 'Proxy-Authorization' : 'Authorization') ;

    $self -> {ntlm}  = 0 ;
    $self -> {basic} = 0 ;
    if ($debug)
        {
        $auth_line =~ /^(.*?)\s+/ ;
        my $type = $1 ;
        print STDERR "[$$] AuthenNTLM: Authorization Header " 
	    . (defined($auth_line)?($debug > 1?$auth_line:$type):'<not given>') . "\n" if ($debug) ;
        }
    if ($self -> {authntlm} && ($auth_line =~ /^NTLM\s+(.*?)$/i))
	{
	$self -> {ntlm} = 1 ;
	}
    elsif ($self -> {authbasic} && ($auth_line =~ /^Basic\s+(.*?)$/i))
	{
	$self -> {basic}  = 1 ;
	}
    else
	{
	return undef ;
	}

    my $data = MIME::Base64::decode($1) ;


    if ($debug > 1)
        {
        my @out ;
        for (my $i = 0; $i < length($data); $i++)
            {
            push @out, unpack('C', substr($data, $i, 1)) ;
            }
        print STDERR "[$$] AuthenNTLM: Got: " . join (' ', @out). "\n" ;
        }

    return $data ;
    }



sub get_msg

    {
    my ($self, $r) = @_ ;

    my $data = $self -> get_msg_data ($r) ;
    return undef if (!$data) ;

    if ($self -> {ntlm})
        {
        my ($protocol, $type) = unpack ('Z8C', $data) ;
        return $self -> get_msg1 ($r, $data) if ($type == 1) ;
        return $self -> get_msg3 ($r, $data) if ($type == 3) ;
        return $type ;
        }
    elsif ($self -> {basic})
        {
        return $self -> get_basic ($r, $data) ;
        }
    return undef ;
    }



sub get_msg1

    {
    my ($self, $r, $data) = @_ ;

    my ($protocol, $type, $zero, $flags1, $flags2, $zero2, $dom_len, $x1, $dom_off, $x2, $host_len, $x3, $host_off, $x4) = unpack ('Z8Ca3CCa2vvvvvvvv', $data) ;
    my $host   = $host_off?substr ($data, $host_off, $host_len):'' ;
    my $domain = $dom_off?substr ($data, $dom_off,  $dom_len):'' ;

    $self -> {domain} = $dom_len?$domain:$self -> {defaultdomain} ;
    $self -> {host}   = $host_len?$host:'' ;

    $self -> {accept_unicode} = $flags1 & 0x01;

    if ($debug)
        {
        my @flag1str;
        foreach my $i ( sort keys %msgflags1 ) 
            {
            push @flag1str, $msgflags1{ $i } if $flags1 & $i;
            }
        my $flag1str = join( ",", @flag1str );

        my @flag2str;
        foreach my $i ( sort keys %msgflags2 ) 
            {
            push @flag2str, $msgflags2{ $i } if $flags2 & $i;
            }
            my $flag2str = join( ",", @flag2str );
    
        print STDERR "[$$] AuthenNTLM: protocol=$protocol, type=$type, flags1=$flags1($flag1str), " 
	    . "flags2=$flags2($flag2str), domain length=$dom_len, domain offset=$dom_off, "
	    . "host length=$host_len, host offset=$host_off, host=$host, domain=$domain\n" ;
        }


    return $type ;
    }


sub set_msg2

    {
    my ($self, $r, $nonce) = @_ ;

    my $charencoding = $self->{ accept_unicode } ? $invflags1{ NEGOTIATE_UNICODE } : $invflags1{ NEGOTIATE_OEM };

    my $flags2 = $invflags2{ NEGOTIATE_ALWAYS_SIGN } | $invflags2{ NEGOTIATE_NTLM };

    my $data = pack ('Z8Ca7vvCCa2a8a8', 'NTLMSSP', 2, '', 40, 0, $charencoding,  $flags2, '', $nonce, '') ;

    my $header = 'NTLM '. MIME::Base64::encode($data, '') ;

    if ($debug)
        {
        if ($debug > 1)
            {
            my @out ;
            for (my $i = 0; $i < length($data); $i++)
                {
                push @out, unpack('C', substr($data, $i, 1)) ;
                }
            print STDERR "[$$] AuthenNTLM: Send: " . join (' ', @out). "\n" ;
            }
        print STDERR "[$$] AuthenNTLM: charencoding = $charencoding\n";
        print STDERR "[$$] AuthenNTLM: flags2 = $flags2\n";
        print STDERR "[$$] AuthenNTLM: nonce=$nonce\n" if ($debug > 1);
        print STDERR "[$$] AuthenNTLM: Send header: " . ($debug > 1?$header:'NTLM ...') . "\n" ;
        }

	return $header;
    }


sub get_msg3

    {
    my ($self, $r, $data) = @_ ;

    my ($protocol, $type, $zero, 
        $lm_len,  $l1, $lm_off,
        $nt_len,   $l3, $nt_off,
        $dom_len, $x1, $dom_off,
        $user_len, $x3, $user_off,
        $host_len, $x5, $host_off,
        $msg_len
        ) = unpack ('Z8Ca3vvVvvVvvVvvVvvVv', $data) ;
    
    my $lm     = $lm_off  ? substr ($data, $lm_off,   $lm_len):'' ;
    my $nt     = $nt_off  ? substr ($data, $nt_off,   $nt_len):'' ;
    my $user   = $user_off ? ($self->{accept_unicode} ? substr_unicode ($data, $user_off, $user_len) : substr( $data, $user_off, $user_len ) ) :'' ;
    my $host   = $host_off ? ($self->{accept_unicode} ? substr_unicode ($data, $host_off, $host_len) : substr( $data, $host_off, $host_len ) ) :'' ;
    my $domain = $dom_off ? ($self->{accept_unicode} ? substr_unicode ($data, $dom_off,  $dom_len) : substr( $data, $dom_off, $dom_len ) ) :'' ;

    $self -> {userdomain} = $dom_len?$domain:$self -> {defaultdomain} ;
    $self -> {username}   = $user ;
    $self -> {usernthash} = $nt_len ? $nt : $lm;

    if ($debug)
        {
        print STDERR "[$$] AuthenNTLM: protocol=$protocol, type=$type, user=$user, "
	    . "host=$host, domain=$domain, msg_len=$msg_len\n" ;
        }


    return $type ;
    }

sub get_basic

    {
    my ($self, $r, $data) = @_ ;

    ($self -> {username}, $self -> {password}) = split (/:/, $data)  ;

    my ($domain, $username) = split (/\\|\//, $self -> {username}) ;
    if ($username)
	{
	$self -> {domain} = $domain ;
	$self -> {username} = $username ;
	}
    else
	{
	$self -> {domain} = $self -> {defaultdomain} ;
	}

    $self -> {userdomain} = $self -> {domain} ; 

    if ($debug)
        {
        print STDERR "[$$] AuthenNTLM: basic auth username = $self->{domain}\\$self->{username}\n" ;
        }

    return -1 ;
    }


sub DESTROY

    {
    my ($self) = @_ ;

    Authen::Smb::Valid_User_Disconnect ($self -> {smbhandle}) if ($self -> {smbhandle}) ;
    }

sub handler1 ($$) { &run }
sub handler2 : method { &run }

*handler = MP2 ? \&handler2 : \&handler1;

sub run
   {
    my ($class, $r) = @_ ;