1#!@PERL@
2#
3## Copyright (C) 1996-2021 The Squid Software Foundation and contributors
4##
5## Squid software is distributed under GPLv2+ license and includes
6## contributions from numerous individuals and organizations.
7## Please see the COPYING and CONTRIBUTORS files for details.
8##
9#
10# (C) 2000 Francesco Chemolli <kinkie@kame.usr.dsi.unimi.it>
11# Distributed freely under the terms of the GNU General Public License,
12# version 2 or later. For the licensing terms, see the file COPYING that
13# came with Squid.
14#
15# This is a dummy NTLM authentication module for Squid.
16# It performs the NTLM challenge, but then it doesn't verify the
17# user's credentials, it just takes the client's domain and username
18# at face value.
19# It's included mostly for demonstration purposes.
20#
21# TODO: use command-line arguments
22
23#use MIME::Base64;
24
25$|=1;
26#$authdomain="your_domain_goes_here";
27$challenge="deadbeef";
28
29$authdomain=$ARGV[0] if ($#ARGV >=0);
30
31die ("Edit $0 to configure a domain!") unless (defined($authdomain));
32
33while(<STDIN>) {
34	chop;
35	if (substr($_, 0, 2) eq "YR") {
36		print "TT ".encode_base64(&make_ntlm_static_challenge);
37		next;
38	}
39	$got=substr($_,3);
40	%res=decode_ntlm_any(decode_base64($got));
41#	print STDERR "got: ".hash_to_string(%res);
42	if (!res) {										# broken NTLM, deny
43		print "BH Couldn't decode NTLM packet\n";
44		next;
45	}
46	if ($res{type} eq "negotiate") { # ok, send a challenge
47		print "BH Squid-helper protocol error: unexpected negotiate-request\n";
48		next;
49	}
50	if ($res{type} eq "challenge") { # Huh? WE are the challengers.
51		print "BH Squid-helper protocol error: unexpected challenge-request\n";
52		next;
53	}
54	if ($res{type} eq "authentication") {
55		print "AF $res{domain}\\$res{user}\n";
56		next;
57	}
58	print "BH internal error\n";	# internal error
59}
60
61
62sub make_ntlm_static_challenge {
63	$rv = pack ("a8 V", "NTLMSSP", 0x2);
64	$payload = "";
65
66	$rv .= add_to_data(uc($authdomain),\$payload);
67	$rv .= pack ("V Z8 v8", 0x18206, $challenge,0,0,0,0,0,0,0x3a,0);
68	#flags, challenge, 8 bytes of unknown stuff
69
70	return $rv.$payload;
71}
72
73#gets as argument the decoded authenticate packet.
74#returns either undef (failure to decode) or an hash with the decoded
75# fields.
76sub decode_ntlm_authentication {
77	my ($got)=$_[0];
78	my ($signature, $type, %rv, $hdr, $rest);
79	($signature, $type, $rest) = unpack ("a8 V a*",$got);
80	return unless ($signature eq "NTLMSSP\0");
81	return unless ($type == 0x3);
82	$rv{type}="authentication";
83	($hdr, $rest) = unpack ("a8 a*", $rest);
84	$rv{lmresponse}=get_from_data($hdr,$got);
85	($hdr, $rest) = unpack ("a8 a*", $rest);
86	$rv{ntresponse}=get_from_data($hdr,$got);
87	($hdr, $rest) = unpack ("a8 a*", $rest);
88	$rv{domain}=get_from_data($hdr,$got);
89	($hdr, $rest) = unpack ("a8 a*", $rest);
90	$rv{user}=get_from_data($hdr,$got);
91	($hdr, $rest) = unpack ("a8 a*", $rest);
92	$rv{workstation}=get_from_data($hdr,$got);
93	($hdr, $rest) = unpack ("a8 a*", $rest);
94	$rv{sessionkey}=get_from_data($hdr,$got);
95	$rv{flags}=unpack("V",$rest);
96	return %rv;
97}
98
99#args: len, maxlen, offset
100sub make_ntlm_hdr {
101	return pack ("v v V", @_);
102}
103
104#args: string to add, ref to payload
105# returns ntlm header.
106sub add_to_data {
107	my ($toadd, $pl) = @_;
108	my ($offset);
109#	$toadd.='\0' unless ($toadd[-1]=='\0'); #broken
110	$offset=48+length $pl;  #48 is the length of the header
111	$$pl.=$toadd;
112	return make_ntlm_hdr (length $toadd, length $toadd, $offset);
113}
114
115#args: encoded descriptor, entire decoded packet
116# returns the decoded data
117sub get_from_data {
118	my($desc,$packet) = @_;
119	my($offset,$length, $rv);
120	($length, undef, $offset) = unpack ("v v V", $desc);
121	return unless ($length+$offset <= length $packet);
122	$rv = unpack ("x$offset a$length",$packet);
123	return $rv;
124}
125
126sub hash_to_string {
127	my (%hash) = @_;
128	my ($rv);
129	foreach (sort keys %hash) {
130		$rv.=$_." => ".$hash{$_}."\n";
131	}
132	return $rv;
133}
134
135
136#more decoder functions, added more for debugging purposes
137#than for any real use in the application.
138#args: the base64-decoded packet
139#returns: either undef or an hash describing the packet.
140sub decode_ntlm_negotiate {
141	my($got)=$_[0];
142	my($signature, $type, %rv, $hdr, $rest);
143	($signature, $type, $rest) = unpack ("a8 V a*",$got);
144	return unless ($signature eq "NTLMSSP\0");
145	return unless ($type == 0x1);
146	$rv{type}="negotiate";
147	($rv{flags}, $rest)=unpack("V a*",$rest);
148	($hdr, $rest) = unpack ("a8 a*", $rest);
149	$rv{domain}=get_from_data($hdr,$got);
150	($hdr, $rest) = unpack ("a8 a*", $rest);
151	$rv{workstation}=get_from_data($hdr,$got);
152	return %rv;
153}
154
155sub decode_ntlm_challenge {
156	my($got)=$_[0];
157	my($signature, $type, %rv, $hdr, $rest, $j);
158	($signature, $type, $rest) = unpack ("a8 V a*",$got);
159	return unless ($signature eq "NTLMSSP\0");
160	return unless ($type == 0x2);
161	$rv{type}="challenge";
162	($rv{flags}, $rest)=unpack("V a*",$rest);
163	($rv{challenge}, $rest)=unpack("a8 a*",$rest);
164	for ($j=0;$j<8;$j++) {				# don't shoot on the programmer, please.
165		($rv{"context.$j"},$rest)=unpack("v a*",$rest);
166	}
167	return %rv;
168}
169
170#decodes any NTLMSSP packet.
171#arg: the encoded packet, returns an hash with packet info
172sub decode_ntlm_any {
173	my($got)=$_[0];
174	my ($signature, $type);
175	($signature, $type, undef) = unpack ("a8 V a*",$got);
176	return unless ($signature eq "NTLMSSP\0");
177	return decode_ntlm_negotiate($got) if ($type == 1);
178	return decode_ntlm_challenge($got) if ($type == 2);
179	return decode_ntlm_authentication($got) if ($type == 3);
180	return undef;									# default
181}
182
183
184use integer;
185
186sub encode_base64 ($;$)
187{
188    my $res = "";
189    my $eol = $_[1];
190    $eol = "\n" unless defined $eol;
191    pos($_[0]) = 0;                          # ensure start at the beginning
192    while ($_[0] =~ /(.{1,45})/gs) {
193	$res .= substr(pack('u', $1), 1);
194	chop($res);
195    }
196    $res =~ tr|` -_|AA-Za-z0-9+/|;               # `# help emacs
197    # fix padding at the end
198    my $padding = (3 - length($_[0]) % 3) % 3;
199    $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
200    # break encoded string into lines of no more than 76 characters each
201    if (length $eol) {
202	$res =~ s/(.{1,76})/$1$eol/g;
203    }
204    $res;
205}
206
207
208sub decode_base64 ($)
209{
210    local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123]
211
212    my $str = shift;
213    my $res = "";
214
215    $str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars
216    if (length($str) % 4) {
217	require Carp;
218	Carp::carp("Length of base64 data not a multiple of 4")
219    }
220    $str =~ s/=+$//;                        # remove padding
221    $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
222    while ($str =~ /(.{1,60})/gs) {
223	my $len = chr(32 + length($1)*3/4); # compute length byte
224	$res .= unpack("u", $len . $1 );    # uudecode
225    }
226    $res;
227}
228