src/auth/ntlm/fake/ntlm_fake_auth.pl.in

   1 #!@PERL@
   2 #
   3 ## Copyright (C) 1996-2020 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
  31 die ("Edit $0 to configure a domain!") unless (defined($authdomain));
  32
  33 while(<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
  62 sub 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.
  76 sub 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
 100 sub make_ntlm_hdr {
 101         return pack ("v v V", @_);
 102 }
 103
 104 #args: string to add, ref to payload
 105 # returns ntlm header.
 106 sub 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
 117 sub 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
 126 sub 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.
 140 sub 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
 155 sub 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
 172 sub 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
 184 use integer;
 185
 186 sub 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
 208 sub 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 }