1# ntlm.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net> 2# 3# This is an implementation of Microsoft's NTLM authentication mechanism. 4# 5# References: 6# http://www.innovation.ch/java/ntlm.html 7# http://davenport.sourceforge.net/ntlm.html 8# 9# ------------------------------------------------------------------------- 10# See the file "license.terms" for information on usage and redistribution 11# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12# ------------------------------------------------------------------------- 13 14package require Tcl 8.2; # tcl minimum version 15package require SASL 1.0; # tcllib 1.7 16package require des 1.0; # tcllib 1.8 17package require md4; # tcllib 1.4 18 19namespace eval ::SASL { 20 namespace eval NTLM { 21 variable version 1.1.1 22 variable rcsid {$Id: ntlm.tcl,v 1.8 2007/08/26 00:36:45 patthoyts Exp $} 23 array set NTLMFlags { 24 unicode 0x00000001 25 oem 0x00000002 26 req_target 0x00000004 27 unknown 0x00000008 28 sign 0x00000010 29 seal 0x00000020 30 datagram 0x00000040 31 lmkey 0x00000080 32 netware 0x00000100 33 ntlm 0x00000200 34 unknown 0x00000400 35 unknown 0x00000800 36 domain 0x00001000 37 server 0x00002000 38 share 0x00004000 39 NTLM2 0x00008000 40 targetinfo 0x00800000 41 128bit 0x20000000 42 keyexch 0x40000000 43 56bit 0x80000000 44 } 45 } 46} 47 48# ------------------------------------------------------------------------- 49 50proc ::SASL::NTLM::NTLM {context challenge args} { 51 upvar #0 $context ctx 52 incr ctx(step) 53 switch -exact -- $ctx(step) { 54 55 1 { 56 set ctx(realm) [eval [linsert $ctx(callback) end $context realm]] 57 set ctx(hostname) [eval [linsert $ctx(callback) end $context hostname]] 58 set ctx(response) [CreateGreeting $ctx(realm) $ctx(hostname)] 59 set result 1 60 } 61 62 2 { 63 array set params [Decode $challenge] 64 set user [eval [linsert $ctx(callback) end $context username]] 65 set pass [eval [linsert $ctx(callback) end $context password]] 66 if {[info exists params(domain)]} { 67 set ctx(realm) $params(domain) 68 } 69 set ctx(response) [CreateResponse \ 70 $ctx(realm) $ctx(hostname) \ 71 $user $pass $params(nonce) $params(flags)] 72 Decode $ctx(response) 73 set result 0 74 } 75 default { 76 return -code error "invalid state \"$ctx(step)" 77 } 78 } 79 return $result 80} 81 82# ------------------------------------------------------------------------- 83# NTLM client implementation 84# ------------------------------------------------------------------------- 85 86# The NMLM greeting. This is sent by the client to the server to initiate 87# the challenge response handshake. 88# This message contains the hostname (not domain qualified) and the 89# NT domain name for authentication. 90# 91proc ::SASL::NTLM::CreateGreeting {domainname hostname {flags {}}} { 92 set domain [encoding convertto ascii $domainname] 93 set host [encoding convertto ascii $hostname] 94 set d_len [string length $domain] 95 set h_len [string length $host] 96 set d_off [expr {32 + $h_len}] 97 if {[llength $flags] == 0} { 98 set flags {unicode oem ntlm server domain req_target} 99 } 100 set msg [binary format a8iississi \ 101 "NTLMSSP\x00" 1 [Flags $flags] \ 102 $d_len $d_len $d_off \ 103 $h_len $h_len 32] 104 append msg $host $domain 105 return $msg 106} 107 108# Create a NTLM server challenge. This is sent by a server in response to 109# a client type 1 message. The content of the type 2 message is variable 110# and depends upon the flags set by the client and server choices. 111# 112proc ::SASL::NTLM::CreateChallenge {domainname} { 113 SASL::md5_init 114 set target [encoding convertto ascii $domainname] 115 set t_len [string length $target] 116 set nonce [string range [binary format h* [SASL::CreateNonce]] 0 7] 117 set pad [string repeat \0 8] 118 set context [string repeat \0 8] 119 set msg [binary format a8issii \ 120 "NTLMSSP\x00" 2 \ 121 $t_len $t_len 48 \ 122 [Flags {ntlm unicode}]] 123 append msg $nonce $pad $context $pad $target 124 return $msg 125} 126 127# Compose the final client response. This contains the encoded username 128# and password, along with the server nonce value. 129# 130proc ::SASL::NTLM::CreateResponse {domainname hostname username passwd nonce flags} { 131 set lm_resp [LMhash $passwd $nonce] 132 set nt_resp [NThash $passwd $nonce] 133 134 set domain [string toupper $domainname] 135 set host [string toupper $hostname] 136 set user $username 137 set unicode [expr {$flags & 0x00000001}] 138 139 if {$unicode} { 140 set domain [to_unicode_le $domain] 141 set host [to_unicode_le $host] 142 set user [to_unicode_le $user] 143 } 144 145 set l_len [string length $lm_resp]; # LM response length 146 set n_len [string length $nt_resp]; # NT response length 147 set d_len [string length $domain]; # Domain name length 148 set h_len [string length $host]; # Host name length 149 set u_len [string length $user]; # User name length 150 set s_len 0 ; # Session key length 151 152 # The offsets to strings appended to the structure 153 set d_off [expr {0x40}]; # Fixed offset to Domain buffer 154 set u_off [expr {$d_off + $d_len}]; # Offset to user buffer 155 set h_off [expr {$u_off + $u_len}]; # Offset to host buffer 156 set l_off [expr {$h_off + $h_len}]; # Offset to LM hash 157 set n_off [expr {$l_off + $l_len}]; # Offset to NT hash 158 set s_off [expr {$n_off + $n_len}]; # Offset to Session key 159 160 set msg [binary format a8is4s4s4s4s4s4i \ 161 "NTLMSSP\x00" 3 \ 162 [list $l_len $l_len $l_off 0] \ 163 [list $n_len $n_len $n_off 0] \ 164 [list $d_len $d_len $d_off 0] \ 165 [list $u_len $u_len $u_off 0] \ 166 [list $h_len $h_len $h_off 0] \ 167 [list $s_len $s_len $s_off 0] \ 168 $flags] 169 append msg $domain $user $host $lm_resp $nt_resp 170 return $msg 171} 172 173proc ::SASL::NTLM::Debug {msg} { 174 array set d [Decode $msg] 175 if {[info exists d(flags)]} { 176 set d(flags) [list [format 0x%08x $d(flags)] [decodeflags $d(flags)]] 177 } 178 if {[info exists d(nonce)]} { set d(nonce) [base64::encode $d(nonce)] } 179 if {[info exists d(lmhash)]} { set d(lmhash) [base64::encode $d(lmhash)] } 180 if {[info exists d(nthash)]} { set d(nthash) [base64::encode $d(nthash)] } 181 return [array get d] 182} 183 184proc ::SASL::NTLM::Decode {msg} { 185 #puts [Debug $msg] 186 binary scan $msg a7ci protocol zero type 187 188 switch -exact -- $type { 189 1 { 190 binary scan $msg @12ississi flags dlen dlen2 doff hlen hlen2 hoff 191 binary scan $msg @${hoff}a${hlen} host 192 binary scan $msg @${doff}a${dlen} domain 193 return [list type $type flags [format 0x%08x $flags] \ 194 domain $domain host $host] 195 } 196 2 { 197 binary scan $msg @12ssiia8a8 dlen dlen2 doff flags nonce pad 198 set domain {}; binary scan $msg @${doff}a${dlen} domain 199 set unicode [expr {$flags & 0x00000001}] 200 if {$unicode} { 201 set domain [from_unicode_le $domain] 202 } 203 204 binary scan $nonce H* nonce_h 205 binary scan $pad H* pad_h 206 return [list type $type flags [format 0x%08x $flags] \ 207 domain $domain nonce $nonce] 208 } 209 3 { 210 binary scan $msg @12ssissississississii \ 211 lmlen lmlen2 lmoff \ 212 ntlen ntlen2 ntoff \ 213 dlen dlen2 doff \ 214 ulen ulen2 uoff \ 215 hlen hlen2 hoff \ 216 slen slen2 soff \ 217 flags 218 set domain {}; binary scan $msg @${doff}a${dlen} domain 219 set user {}; binary scan $msg @${uoff}a${ulen} user 220 set host {}; binary scan $msg @${hoff}a${hlen} host 221 set unicode [expr {$flags & 0x00000001}] 222 if {$unicode} { 223 set domain [from_unicode_le $domain] 224 set user [from_unicode_le $user] 225 set host [from_unicode_le $host] 226 } 227 binary scan $msg @${ntoff}a${ntlen} ntdata 228 binary scan $msg @${lmoff}a${lmlen} lmdata 229 binary scan $ntdata H* ntdata_h 230 binary scan $lmdata H* lmdata_h 231 return [list type $type flags [format 0x%08x $flags]\ 232 domain $domain host $host user $user \ 233 lmhash $lmdata nthash $ntdata] 234 } 235 default { 236 return -code error "invalid NTLM data: type not recognised" 237 } 238 } 239} 240 241proc ::SASL::NTLM::decodeflags {value} { 242 variable NTLMFlags 243 set result {} 244 foreach {flag mask} [array get NTLMFlags] { 245 if {$value & ($mask & 0xffffffff)} { 246 lappend result $flag 247 } 248 } 249 return $result 250} 251 252proc ::SASL::NTLM::Flags {flags} { 253 variable NTLMFlags 254 set result 0 255 foreach flag $flags { 256 if {![info exists NTLMFlags($flag)]} { 257 return -code error "invalid ntlm flag \"$flag\"" 258 } 259 set result [expr {$result | $NTLMFlags($flag)}] 260 } 261 return $result 262} 263 264# Convert a string to unicode in little endian byte order. 265proc ::SASL::NTLM::to_unicode_le {str} { 266 set result [encoding convertto unicode $str] 267 if {[string equal $::tcl_platform(byteOrder) "bigEndian"]} { 268 set r {} ; set n 0 269 while {[binary scan $result @${n}cc a b] == 2} { 270 append r [binary format cc $b $a] 271 incr n 2 272 } 273 set result $r 274 } 275 return $result 276} 277 278# Convert a little-endian unicode string to utf-8. 279proc ::SASL::NTLM::from_unicode_le {str} { 280 if {[string equal $::tcl_platform(byteOrder) "bigEndian"]} { 281 set r {} ; set n 0 282 while {[binary scan $str @${n}cc a b] == 2} { 283 append r [binary format cc $b $a] 284 incr n 2 285 } 286 set str $r 287 } 288 return [encoding convertfrom unicode $str] 289} 290 291proc ::SASL::NTLM::LMhash {password nonce} { 292 set magic "\x4b\x47\x53\x21\x40\x23\x24\x25" 293 set hash "" 294 set password [string range [string toupper $password][string repeat \0 14] 0 13] 295 foreach key [CreateDesKeys $password] { 296 append hash [DES::des -dir encrypt -weak -mode ecb -key $key $magic] 297 } 298 299 append hash [string repeat \0 5] 300 set res "" 301 foreach key [CreateDesKeys $hash] { 302 append res [DES::des -dir encrypt -weak -mode ecb -key $key $nonce] 303 } 304 305 return $res 306} 307 308proc ::SASL::NTLM::NThash {password nonce} { 309 set pass [to_unicode_le $password] 310 set hash [md4::md4 $pass] 311 append hash [string repeat \x00 5] 312 313 set res "" 314 foreach key [CreateDesKeys $hash] { 315 append res [DES::des -dir encrypt -weak -mode ecb -key $key $nonce] 316 } 317 318 return $res 319} 320 321# Convert a password into a 56 bit DES key according to the NTLM specs. 322# We do NOT fix the parity of each byte. If we did, then bit 0 of each 323# byte should be adjusted to give the byte odd parity. 324# 325proc ::SASL::NTLM::CreateDesKeys {key} { 326 # pad to 7 byte boundary with nuls. 327 set mod [expr {[string length $key] % 7}] 328 if {$mod != 0} { 329 append key [string repeat "\0" [expr {7 - $mod}]] 330 } 331 set len [string length $key] 332 set r "" 333 for {set n 0} {$n < $len} {incr n 7} { 334 binary scan $key @${n}c7 bytes 335 set b {} 336 lappend b [expr { [lindex $bytes 0] & 0xFF}] 337 lappend b [expr {(([lindex $bytes 0] & 0x01) << 7) | (([lindex $bytes 1] >> 1) & 0x7F)}] 338 lappend b [expr {(([lindex $bytes 1] & 0x03) << 6) | (([lindex $bytes 2] >> 2) & 0x3F)}] 339 lappend b [expr {(([lindex $bytes 2] & 0x07) << 5) | (([lindex $bytes 3] >> 3) & 0x1F)}] 340 lappend b [expr {(([lindex $bytes 3] & 0x0F) << 4) | (([lindex $bytes 4] >> 4) & 0x0F)}] 341 lappend b [expr {(([lindex $bytes 4] & 0x1F) << 3) | (([lindex $bytes 5] >> 5) & 0x07)}] 342 lappend b [expr {(([lindex $bytes 5] & 0x3F) << 2) | (([lindex $bytes 6] >> 6) & 0x03)}] 343 lappend b [expr {(([lindex $bytes 6] & 0x7F) << 1)}] 344 lappend r [binary format c* $b] 345 } 346 return $r; 347} 348 349# This is slower than the above in Tcl 8.4.9 350proc ::SASL::NTLM::CreateDesKeys2 {key} { 351 # pad to 7 byte boundary with nuls. 352 append key [string repeat "\0" [expr {7 - ([string length $key] % 7)}]] 353 binary scan $key B* bin 354 set len [string length $bin] 355 set r "" 356 for {set n 0} {$n < $len} {incr n} { 357 append r [string range $bin $n [incr n 6]] 0 358 } 359 # needs spliting into 8 byte keys. 360 return [binary format B* $r] 361} 362 363# ------------------------------------------------------------------------- 364 365# Register this SASL mechanism with the Tcllib SASL package. 366# 367if {[llength [package provide SASL]] != 0} { 368 ::SASL::register NTLM 50 ::SASL::NTLM::NTLM 369} 370 371package provide SASL::NTLM $::SASL::NTLM::version 372 373# ------------------------------------------------------------------------- 374# 375# Local variables: 376# indent-tabs-mode: nil 377# End: 378