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