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