1
# ntlm.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
3
# This is an implementation of Microsoft's NTLM authentication mechanism.
6
# http://www.innovation.ch/java/ntlm.html
7
# http://davenport.sourceforge.net/ntlm.html
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
# -------------------------------------------------------------------------
14
package require Tcl 8.2; # tcl minimum version
15
package require SASL 1.0; # tcllib 1.7
16
package require des 1.0; # tcllib 1.8
17
package require md4; # tcllib 1.4
19
namespace eval ::SASL {
21
variable version 1.1.1
22
variable rcsid {$Id: ntlm.tcl,v 1.8 2007/08/26 00:36:45 patthoyts Exp $}
48
# -------------------------------------------------------------------------
50
proc ::SASL::NTLM::NTLM {context challenge args} {
53
switch -exact -- $ctx(step) {
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)]
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)
69
set ctx(response) [CreateResponse \
70
$ctx(realm) $ctx(hostname) \
71
$user $pass $params(nonce) $params(flags)]
76
return -code error "invalid state \"$ctx(step)"
82
# -------------------------------------------------------------------------
83
# NTLM client implementation
84
# -------------------------------------------------------------------------
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.
91
proc ::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}
100
set msg [binary format a8iississi \
101
"NTLMSSP\x00" 1 [Flags $flags] \
102
$d_len $d_len $d_off \
104
append msg $host $domain
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.
112
proc ::SASL::NTLM::CreateChallenge {domainname} {
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 \
122
[Flags {ntlm unicode}]]
123
append msg $nonce $pad $context $pad $target
127
# Compose the final client response. This contains the encoded username
128
# and password, along with the server nonce value.
130
proc ::SASL::NTLM::CreateResponse {domainname hostname username passwd nonce flags} {
131
set lm_resp [LMhash $passwd $nonce]
132
set nt_resp [NThash $passwd $nonce]
134
set domain [string toupper $domainname]
135
set host [string toupper $hostname]
137
set unicode [expr {$flags & 0x00000001}]
140
set domain [to_unicode_le $domain]
141
set host [to_unicode_le $host]
142
set user [to_unicode_le $user]
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
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
160
set msg [binary format a8is4s4s4s4s4s4i \
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] \
169
append msg $domain $user $host $lm_resp $nt_resp
173
proc ::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)]]
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)] }
184
proc ::SASL::NTLM::Decode {msg} {
186
binary scan $msg a7ci protocol zero type
188
switch -exact -- $type {
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]
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}]
201
set domain [from_unicode_le $domain]
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]
210
binary scan $msg @12ssissississississii \
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}]
223
set domain [from_unicode_le $domain]
224
set user [from_unicode_le $user]
225
set host [from_unicode_le $host]
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]
236
return -code error "invalid NTLM data: type not recognised"
241
proc ::SASL::NTLM::decodeflags {value} {
244
foreach {flag mask} [array get NTLMFlags] {
245
if {$value & ($mask & 0xffffffff)} {
252
proc ::SASL::NTLM::Flags {flags} {
255
foreach flag $flags {
256
if {![info exists NTLMFlags($flag)]} {
257
return -code error "invalid ntlm flag \"$flag\""
259
set result [expr {$result | $NTLMFlags($flag)}]
264
# Convert a string to unicode in little endian byte order.
265
proc ::SASL::NTLM::to_unicode_le {str} {
266
set result [encoding convertto unicode $str]
267
if {[string equal $::tcl_platform(byteOrder) "bigEndian"]} {
269
while {[binary scan $result @${n}cc a b] == 2} {
270
append r [binary format cc $b $a]
278
# Convert a little-endian unicode string to utf-8.
279
proc ::SASL::NTLM::from_unicode_le {str} {
280
if {[string equal $::tcl_platform(byteOrder) "bigEndian"]} {
282
while {[binary scan $str @${n}cc a b] == 2} {
283
append r [binary format cc $b $a]
288
return [encoding convertfrom unicode $str]
291
proc ::SASL::NTLM::LMhash {password nonce} {
292
set magic "\x4b\x47\x53\x21\x40\x23\x24\x25"
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]
299
append hash [string repeat \0 5]
301
foreach key [CreateDesKeys $hash] {
302
append res [DES::des -dir encrypt -weak -mode ecb -key $key $nonce]
308
proc ::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]
314
foreach key [CreateDesKeys $hash] {
315
append res [DES::des -dir encrypt -weak -mode ecb -key $key $nonce]
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.
325
proc ::SASL::NTLM::CreateDesKeys {key} {
326
# pad to 7 byte boundary with nuls.
327
set mod [expr {[string length $key] % 7}]
329
append key [string repeat "\0" [expr {7 - $mod}]]
331
set len [string length $key]
333
for {set n 0} {$n < $len} {incr n 7} {
334
binary scan $key @${n}c7 bytes
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]
349
# This is slower than the above in Tcl 8.4.9
350
proc ::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]
356
for {set n 0} {$n < $len} {incr n} {
357
append r [string range $bin $n [incr n 6]] 0
359
# needs spliting into 8 byte keys.
360
return [binary format B* $r]
363
# -------------------------------------------------------------------------
365
# Register this SASL mechanism with the Tcllib SASL package.
367
if {[llength [package provide SASL]] != 0} {
368
::SASL::register NTLM 50 ::SASL::NTLM::NTLM
371
package provide SASL::NTLM $::SASL::NTLM::version
373
# -------------------------------------------------------------------------
376
# indent-tabs-mode: nil
added
removed
utils/sasl/ntlm.tcl
