SourceFormat Enforcement

[thirdparty/squid.git] / helpers / ntlm_auth / fake / ntlm_fake_auth.pl.in

#!@PERL@
#
## Copyright (C) 1996-2015 The Squid Software Foundation and contributors
##
## Squid software is distributed under GPLv2+ license and includes
## contributions from numerous individuals and organizations.
## Please see the COPYING and CONTRIBUTORS files for details.
##
#
# (C) 2000 Francesco Chemolli <kinkie@kame.usr.dsi.unimi.it>
# Distributed freely under the terms of the GNU General Public License,
# version 2. For the licensing terms, see the file COPYING that
# came with Squid.
#
# This is a dummy NTLM authentication module for Squid.
# It performs the NTLM challenge, but then it doesn't verify the
# user's credentials, it just takes the client's domain and username
# at face value.
# It's included mostly for demonstration purposes.
# 
# TODO: use command-line arguments

#use MIME::Base64;

$|=1;
#$authdomain="your_domain_goes_here";
$challenge="deadbeef";

$authdomain=$ARGV[0] if ($#ARGV >=0);

die ("Edit $0 to configure a domain!") unless (defined($authdomain));

while(<STDIN>) {
	chop;
	if (substr($_, 0, 2) eq "YR") {
		print "TT ".encode_base64(&make_ntlm_static_challenge);
		next;
	}
	$got=substr($_,3);
	%res=decode_ntlm_any(decode_base64($got));
#	print STDERR "got: ".hash_to_string(%res);
	if (!res) {										# broken NTLM, deny
		print "BH Couldn't decode NTLM packet\n";
		next;
	}
	if ($res{type} eq "negotiate") { # ok, send a challenge
		print "BH Squid-helper protocol error: unexpected negotiate-request\n";
		next;
	}
	if ($res{type} eq "challenge") { # Huh? WE are the challengers.
		print "BH Squid-helper protocol error: unexpected challenge-request\n";
		next;
	}
	if ($res{type} eq "authentication") {
		print "AF $res{domain}\\$res{user}\n";
		next;
	}
	print "BH internal error\n";	# internal error
}


sub make_ntlm_static_challenge {
	$rv = pack ("a8 V", "NTLMSSP", 0x2);
	$payload = "";

	$rv .= add_to_data(uc($authdomain),\$payload);
	$rv .= pack ("V Z8 v8", 0x18206, $challenge,0,0,0,0,0,0,0x3a,0);
	#flags, challenge, 8 bytes of unknown stuff

	return $rv.$payload;
}

#gets as argument the decoded authenticate packet.
#returns either undef (failure to decode) or an hash with the decoded
# fields.
sub decode_ntlm_authentication {
	my ($got)=$_[0];
	my ($signature, $type, %rv, $hdr, $rest);
	($signature, $type, $rest) = unpack ("a8 V a*",$got);
	return unless ($signature eq "NTLMSSP\0");
	return unless ($type == 0x3);
	$rv{type}="authentication";
	($hdr, $rest) = unpack ("a8 a*", $rest);
	$rv{lmresponse}=get_from_data($hdr,$got);
	($hdr, $rest) = unpack ("a8 a*", $rest);
	$rv{ntresponse}=get_from_data($hdr,$got);
	($hdr, $rest) = unpack ("a8 a*", $rest);
	$rv{domain}=get_from_data($hdr,$got);
	($hdr, $rest) = unpack ("a8 a*", $rest);
	$rv{user}=get_from_data($hdr,$got);
	($hdr, $rest) = unpack ("a8 a*", $rest);
	$rv{workstation}=get_from_data($hdr,$got);
	($hdr, $rest) = unpack ("a8 a*", $rest);
	$rv{sessionkey}=get_from_data($hdr,$got);
	$rv{flags}=unpack("V",$rest);
	return %rv;
}

#args: len, maxlen, offset
sub make_ntlm_hdr {
	return pack ("v v V", @_);
}

#args: string to add, ref to payload
# returns ntlm header.
sub add_to_data {
	my ($toadd, $pl) = @_;
	my ($offset);
#	$toadd.='\0' unless ($toadd[-1]=='\0'); #broken
	$offset=48+length $pl;  #48 is the length of the header
	$$pl.=$toadd;
	return make_ntlm_hdr (length $toadd, length $toadd, $offset);
}

#args: encoded descriptor, entire decoded packet
# returns the decoded data
sub get_from_data {
	my($desc,$packet) = @_;
	my($offset,$length, $rv);
	($length, undef, $offset) = unpack ("v v V", $desc);
	return unless ($length+$offset <= length $packet);
	$rv = unpack ("x$offset a$length",$packet);
	return $rv;
}

sub hash_to_string {
	my (%hash) = @_;
	my ($rv);
	foreach (sort keys %hash) {
		$rv.=$_." => ".$hash{$_}."\n";
	}
	return $rv;
}


#more decoder functions, added more for debugging purposes
#than for any real use in the application.
#args: the base64-decoded packet
#returns: either undef or an hash describing the packet.
sub decode_ntlm_negotiate {
	my($got)=$_[0];
	my($signature, $type, %rv, $hdr, $rest);
	($signature, $type, $rest) = unpack ("a8 V a*",$got);
	return unless ($signature eq "NTLMSSP\0");
	return unless ($type == 0x1);
	$rv{type}="negotiate";
	($rv{flags}, $rest)=unpack("V a*",$rest);
	($hdr, $rest) = unpack ("a8 a*", $rest);
	$rv{domain}=get_from_data($hdr,$got);
	($hdr, $rest) = unpack ("a8 a*", $rest);
	$rv{workstation}=get_from_data($hdr,$got);
	return %rv;
}

sub decode_ntlm_challenge {
	my($got)=$_[0];
	my($signature, $type, %rv, $hdr, $rest, $j);
	($signature, $type, $rest) = unpack ("a8 V a*",$got);
	return unless ($signature eq "NTLMSSP\0");
	return unless ($type == 0x2);
	$rv{type}="challenge";
	($rv{flags}, $rest)=unpack("V a*",$rest);
	($rv{challenge}, $rest)=unpack("a8 a*",$rest);
	for ($j=0;$j<8;$j++) {				# don't shoot on the programmer, please.
		($rv{"context.$j"},$rest)=unpack("v a*",$rest);
	}
	return %rv;
}

#decodes any NTLMSSP packet.
#arg: the encoded packet, returns an hash with packet info
sub decode_ntlm_any {
	my($got)=$_[0];
	my ($signature, $type);
	($signature, $type, undef) = unpack ("a8 V a*",$got);
	return unless ($signature eq "NTLMSSP\0");
	return decode_ntlm_negotiate($got) if ($type == 1);
	return decode_ntlm_challenge($got) if ($type == 2);
	return decode_ntlm_authentication($got) if ($type == 3);
	return undef;									# default
}


use integer;

sub encode_base64 ($;$)
{
    my $res = "";
    my $eol = $_[1];
    $eol = "\n" unless defined $eol;
    pos($_[0]) = 0;                          # ensure start at the beginning
    while ($_[0] =~ /(.{1,45})/gs) {
	$res .= substr(pack('u', $1), 1);
	chop($res);
    }
    $res =~ tr|` -_|AA-Za-z0-9+/|;               # `# help emacs
    # fix padding at the end
    my $padding = (3 - length($_[0]) % 3) % 3;
    $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
    # break encoded string into lines of no more than 76 characters each
    if (length $eol) {
	$res =~ s/(.{1,76})/$1$eol/g;
    }
    $res;
}


sub decode_base64 ($)
{
    local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123]

    my $str = shift;
    my $res = "";

    $str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars
    if (length($str) % 4) {
	require Carp;
	Carp::carp("Length of base64 data not a multiple of 4")
    }
    $str =~ s/=+$//;                        # remove padding
    $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
    while ($str =~ /(.{1,60})/gs) {
	my $len = chr(32 + length($1)*3/4); # compute length byte
	$res .= unpack("u", $len . $1 );    # uudecode
    }
    $res;
}