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
	$r->log_error("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)
    {
	$r->log_error("Wrong password/user (rc=$rc/$errno/$smberr): $self->{userdomain}\\$self->{username} for " . $r -> uri) ;
	print STDERR "[$$] AuthenNTLM: rc = $rc  ntlmhash = $self->{usernthash}\n" if ($debug) ; 
	return ;
    }

    if ($rc)
    {
	$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 =  $r->headers_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 handler : method
{
    my ($class, $r) = @_ ;
    my $type ;
    my $nonce = '' ;
    my $self ;
    my $conn = $r -> connection ;
    my $connhdr = $r -> headers_in -> {'Connection'} ;