1
# sasl.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
3
# This is an implementation of a general purpose SASL library for use in
7
# Myers, J., "Simple Authentication and Security Layer (SASL)",
8
# RFC 2222, October 1997.
9
# Rose, M.T., "TclSASL", "http://beepcore-tcl.sourceforge.net/tclsasl.html"
11
# -------------------------------------------------------------------------
12
# See the file "license.terms" for information on usage and redistribution
13
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14
# -------------------------------------------------------------------------
16
package require Tcl 8.2
18
namespace eval ::SASL {
19
variable version 1.3.2
20
variable rcsid {$Id: sasl.tcl,v 1.12 2008/01/29 00:51:39 patthoyts Exp $}
23
if {![info exists uid]} { set uid 0 }
26
if {![info exists mechanisms]} {
33
# Return a list of available SASL mechanisms. By default only the
34
# client implementations are given but if type is set to server then
35
# the list of available server mechanisms is returned.
36
# No mechanism with a preference value less than 'minimum' will be
38
# The list is sorted by the security preference with the most secure
39
# mechanisms given first.
41
proc ::SASL::mechanisms {{type client} {minimum 0}} {
44
foreach mech $mechanisms {
45
if {[lindex $mech 0] < $minimum} { continue }
46
switch -exact -- $type {
48
if {[string length [lindex $mech 2]] > 0} {
49
lappend r [lindex $mech 1]
53
if {[string length [lindex $mech 3]] > 0} {
54
lappend r [lindex $mech 1]
58
return -code error "invalid type \"$type\":\
59
must be either client or server"
68
# Register a new SASL mechanism with a security preference. Higher
69
# preference values are chosen before lower valued mechanisms.
70
# If no server implementation is available then an empty string
71
# should be provided for the serverproc parameter.
73
proc ::SASL::register {mechanism preference clientproc {serverproc {}}} {
75
set ndx [lsearch -regexp $mechanisms $mechanism]
76
set mech [list $preference $mechanism $clientproc $serverproc]
78
lappend mechanisms $mech
80
set mechanisms [lreplace $mechanisms $ndx $ndx $mech]
82
set mechanisms [lsort -index 0 -decreasing -integer $mechanisms]
88
# Return a unique integer.
97
# Get the reponse string from the SASL state.
99
proc ::SASL::response {context} {
100
upvar #0 $context ctx
101
return $ctx(response)
106
# Reset the SASL state. This permits the same instance to be reused
107
# for a new round of authentication.
109
proc ::SASL::reset {context {step 0}} {
110
upvar #0 $context ctx
111
array set ctx [list step $step response "" valid false count 0]
117
# Free any resources used with the SASL state.
119
proc ::SASL::cleanup {context} {
120
if {[info exists $context]} {
128
# Create a new SASL instance.
130
proc ::SASL::new {args} {
131
set context [namespace current]::[uid]
132
upvar #0 $context ctx
133
array set ctx [list mech {} callback {} proc {} service smtp server {} \
134
step 0 response "" valid false type client count 0]
135
eval [linsert $args 0 [namespace origin configure] $context]
141
# Configure the SASL state.
143
proc ::SASL::configure {context args} {
145
upvar #0 $context ctx
146
while {[string match -* [set option [lindex $args 0]]]} {
147
switch -exact -- $option {
149
set ctx(service) [Pop args 1]
151
-server - -serverFQDN {
152
set ctx(server) [Pop args 1]
155
set mech [string toupper [Pop args 1]]
157
foreach m $mechanisms {
158
if {[string equal [lindex $m 1] $mech]} {
160
if {[string equal $ctx(type) "server"]} {
161
set ctx(proc) [lindex $m 3]
163
set ctx(proc) [lindex $m 2]
168
if {[string equal $ctx(proc) {}]} {
169
return -code error "mechanism \"$mech\" not available:\
170
must be one of those given by \[sasl::mechanisms\]"
173
-callback - -callbacks {
174
set ctx(callback) [Pop args 1]
177
set type [Pop args 1]
178
if {[lsearch -exact {server client} $type] != -1} {
180
if {![string equal $ctx(mech) ""]} {
181
configure $context -mechanism $ctx(mech)
184
return -code error "bad value \"$type\":\
185
must be either client or server"
189
return -code error "bad option \"$option\":\
190
must be one of -mechanism, -service, -server -type\
199
proc ::SASL::step {context challenge args} {
200
upvar #0 $context ctx
202
return [eval [linsert $args 0 $ctx(proc) $context $challenge]]
206
proc ::SASL::Pop {varname {nth 0}} {
208
set r [lindex $args $nth]
209
set args [lreplace $args $nth $nth]
213
proc ::SASL::md5_init {} {
215
if {[info exists md5_inited]} {return} else {set md5_inited 1}
216
# Deal with either version of md5. We'd like version 2 but someone
217
# may have already loaded version 1.
218
set md5major [lindex [split [package require md5] .] 0]
220
# md5 v1, no options, and returns a hex string ready for us.
221
proc ::SASL::md5_hex {data} { return [::md5::md5 $data] }
222
proc ::SASL::md5_bin {data} { return [binary format H* [::md5::md5 $data]] }
223
proc ::SASL::hmac_hex {pass data} { return [::md5::hmac $pass $data] }
224
proc ::SASL::hmac_bin {pass data} { return [binary format H* [::md5::hmac $pass $data]] }
226
# md5 v2 requires -hex to return hash as hex-encoded non-binary string.
227
proc ::SASL::md5_hex {data} { return [string tolower [::md5::md5 -hex $data]] }
228
proc ::SASL::md5_bin {data} { return [::md5::md5 $data] }
229
proc ::SASL::hmac_hex {pass data} { return [::md5::hmac -hex -key $pass $data] }
230
proc ::SASL::hmac_bin {pass data} { return [::md5::hmac -key $pass $data] }
234
# -------------------------------------------------------------------------
236
# CRAM-MD5 SASL MECHANISM
238
# Implementation of the Challenge-Response Authentication Mechanism
242
# This mechanism passes a server generated string containing
243
# a timestamp and has the client generate an MD5 HMAC using the
244
# shared secret as the key and the server string as the data.
245
# The downside of this protocol is that the server must have access
246
# to the plaintext password.
248
proc ::SASL::CRAM-MD5:client {context challenge args} {
249
upvar #0 $context ctx
251
if {$ctx(step) != 0} {
252
return -code error "unexpected state: CRAM-MD5 has only 1 step"
254
if {[string length $challenge] == 0} {
258
set password [eval $ctx(callback) [list $context password]]
259
set username [eval $ctx(callback) [list $context username]]
260
set reply [hmac_hex $password $challenge]
261
set reply "$username [string tolower $reply]"
262
set ctx(response) $reply
267
proc ::SASL::CRAM-MD5:server {context clientrsp args} {
268
upvar #0 $context ctx
271
switch -exact -- $ctx(step) {
273
set ctx(realm) [eval $ctx(callback) [list $context realm]]
274
set ctx(response) "<[pid].[clock seconds]@$ctx(realm)>"
278
foreach {user hash} $clientrsp break
279
set hash [string tolower $hash]
280
set pass [eval $ctx(callback) [list $context password $user $ctx(realm)]]
281
set check [hmac_bin $pass $ctx(response)]
282
binary scan $check H* cx
283
if {[string equal $cx $hash]} {
286
return -code error "authentication failed"
290
return -code error "invalid state"
295
::SASL::register CRAM-MD5 30 ::SASL::CRAM-MD5:client ::SASL::CRAM-MD5:server
297
# -------------------------------------------------------------------------
298
# PLAIN SASL MECHANISM
300
# Implementation of the single step login SASL mechanism (RFC2595).
303
# A single step mechanism in which the authorization ID, the
304
# authentication ID and password are all transmitted in plain
305
# text. This should not be used unless the channel is secured by
306
# some other means (such as SSL/TLS).
308
proc ::SASL::PLAIN:client {context challenge args} {
309
upvar #0 $context ctx
311
set authzid [eval $ctx(callback) [list $context login]]
312
set username [eval $ctx(callback) [list $context username]]
313
set password [eval $ctx(callback) [list $context password]]
314
set ctx(response) "$authzid\x00$username\x00$password"
318
proc ::SASL::PLAIN:server {context clientrsp args} {
319
upvar \#0 $context ctx
320
if {[string length $clientrsp] < 1} {
324
foreach {authzid authid pass} [split $clientrsp \0] break
325
set realm [eval $ctx(callback) [list $context realm]]
326
set check [eval $ctx(callback) [list $context password $authid $realm]]
327
if {[string equal $pass $check]} {
330
return -code error "authentication failed"
335
::SASL::register PLAIN 10 ::SASL::PLAIN:client ::SASL::PLAIN:server
337
# -------------------------------------------------------------------------
338
# LOGIN SASL MECHANISM
340
# Implementation of the two step login SASL mechanism.
343
# This is an unofficial but widely deployed SASL mechanism somewhat
344
# akin to the PLAIN mechanism. Both the authentication ID and password
345
# are transmitted in plain text in response to server prompts.
347
# NOT RECOMMENDED for use in new protocol implementations.
349
proc ::SASL::LOGIN:client {context challenge args} {
350
upvar #0 $context ctx
351
if {$ctx(step) == 0 && [string length $challenge] == 0} {
356
switch -exact -- $ctx(step) {
358
set ctx(response) [eval $ctx(callback) [list $context username]]
362
set ctx(response) [eval $ctx(callback) [list $context password]]
366
return -code error "unexpected state \"$ctx(step)\":\
367
LOGIN has only 2 steps"
373
proc ::SASL::LOGIN:server {context clientrsp args} {
374
upvar #0 $context ctx
376
switch -exact -- $ctx(step) {
378
set ctx(response) "Username:"
382
set ctx(username) $clientrsp
383
set ctx(response) "Password:"
387
set user $ctx(username)
388
set realm [eval $ctx(callback) [list $context realm]]
389
set pass [eval $ctx(callback) [list $context password $user $realm]]
390
if {[string equal $clientrsp $pass]} {
393
return -code error "authentication failed"
397
return -code error "invalid state"
402
::SASL::register LOGIN 20 ::SASL::LOGIN:client ::SASL::LOGIN:server
404
# -------------------------------------------------------------------------
405
# ANONYMOUS SASL MECHANISM
407
# Implementation of the ANONYMOUS SASL mechanism (RFC2245).
412
proc ::SASL::ANONYMOUS:client {context challenge args} {
413
upvar #0 $context ctx
414
set user [eval $ctx(callback) [list $context username]]
415
set realm [eval $ctx(callback) [list $context realm]]
416
set ctx(response) $user@$realm
420
proc ::SASL::ANONYMOUS:server {context clientrsp args} {
421
upvar #0 $context ctx
423
if {[string length $clientrsp] < 1} {
424
if {$ctx(count) > 2} {
425
return -code error "authentication failed"
429
set ctx(trace) $clientrsp
434
::SASL::register ANONYMOUS 5 ::SASL::ANONYMOUS:client ::SASL::ANONYMOUS:server
436
# -------------------------------------------------------------------------
438
# DIGEST-MD5 SASL MECHANISM
440
# Implementation of the DIGEST-MD5 SASL mechanism (RFC2831).
444
proc ::SASL::DIGEST-MD5:client {context challenge args} {
445
upvar #0 $context ctx
447
if {$ctx(step) == 0 && [string length $challenge] == 0} {
448
if {[info exists ctx(challenge)]} {
449
set challenge $ctx(challenge)
457
switch -exact -- $ctx(step) {
459
set ctx(challenge) $challenge
460
array set params [DigestParameters $challenge]
462
if {![info exists ctx(noncecount)]} {
463
set ctx(noncecount) 0
465
set nonce $params(nonce)
466
set cnonce [CreateNonce]
467
set noncecount [format %08u [incr ctx(noncecount)]]
470
# support the 'charset' parameter.
471
set username [eval $ctx(callback) [list $context username]]
472
set password [eval $ctx(callback) [list $context password]]
473
set encoding iso8859-1
474
if {[info exists params(charset)]} {
475
set encoding $params(charset)
477
set username [encoding convertto $encoding $username]
478
set password [encoding convertto $encoding $password]
480
if {[info exists params(realm)]} {
481
set realm $params(realm)
483
set realm [eval $ctx(callback) [list $context realm]]
486
set uri "$ctx(service)/$realm"
487
set R [DigestResponse $username $realm $password $uri \
488
$qop $nonce $noncecount $cnonce]
490
set ctx(response) "username=\"$username\",realm=\"$realm\",nonce=\"$nonce\",nc=\"$noncecount\",cnonce=\"$cnonce\",digest-uri=\"$uri\",response=\"$R\",qop=$qop"
491
if {[info exists params(charset)]} {
492
append ctx(response) ",charset=$params(charset)"
502
return -code error "invalid state"
508
proc ::SASL::DIGEST-MD5:server {context challenge args} {
509
upvar #0 $context ctx
513
switch -exact -- $ctx(step) {
515
set realm [eval $ctx(callback) [list $context realm]]
516
set ctx(nonce) [CreateNonce]
518
set ctx(response) "realm=\"$realm\",nonce=\"$ctx(nonce)\",qop=\"auth\",charset=utf-8,algorithm=md5-sess"
522
array set params [DigestParameters $challenge]
523
set realm [eval $ctx(callback) [list $context realm]]
524
set password [eval $ctx(callback)\
525
[list $context password $params(username) $realm]]
526
set uri "$ctx(service)/$realm"
527
set nc [format %08u [expr {$ctx(nc) + 1}]]
528
set R [DigestResponse $params(username) $realm $password \
529
$uri auth $ctx(nonce) $nc $params(cnonce)]
530
if {[string equal $R $params(response)]} {
531
set R2 [DigestResponse $params(username) $realm $password \
532
$uri auth $ctx(nonce) $nc $params(cnonce)]
533
set ctx(response) "rspauth=$R2"
537
return -code error "authentication failed"
545
return -code error "invalid state"
552
# Char categories as per spec...
553
# Build up a regexp for splitting the challenge into key value pairs.
554
proc ::SASL::DigestParameters {challenge} {
555
set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?=\\\{\\\} \t"
556
set tok {0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\-\|\~\!\#\$\%\&\*\+\.\^\_\`}
557
set sqot {(?:\'(?:\\.|[^\'\\])*\')}
558
set dqot {(?:\"(?:\\.|[^\"\\])*\")}
560
regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[${tok}\]+))(?:\[${sep}\]+|$)" $challenge {\1 \2 } parameters
566
proc ::SASL::DigestResponse {user realm pass uri qop nonce noncecount cnonce} {
567
set A1 [md5_bin "$user:$realm:$pass"]
568
set A2 "AUTHENTICATE:$uri"
569
if {![string equal $qop "auth"]} {
570
append A2 :[string repeat 0 32]
572
set A1h [md5_hex "${A1}:$nonce:$cnonce"]
573
set A2h [md5_hex $A2]
574
set R [md5_hex $A1h:$nonce:$noncecount:$cnonce:$qop:$A2h]
580
proc ::SASL::DigestResponse2 {user realm pass uri qop nonce noncecount cnonce} {
581
set A1 [md5_bin "$user:$realm:$pass"]
583
if {![string equal $qop "auth"]} {
584
append A2 :[string repeat 0 32]
586
set A1h [md5_hex "${A1}:$nonce:$cnonce"]
587
set A2h [md5_hex $A2]
588
set R [md5_hex $A1h:$nonce:$noncecount:$cnonce:$qop:$A2h]
592
# Get 16 random bytes for a nonce value. If we can use /dev/random, do so
593
# otherwise we hash some values.
595
proc ::SASL::CreateNonce {} {
597
if {[file readable /dev/urandom]} {
599
set f [open /dev/urandom r]
600
fconfigure $f -translation binary -buffering none
601
set bytes [read $f 16]
605
if {[string length $bytes] < 1} {
606
set bytes [md5_bin [clock seconds]:[pid]:[expr {rand()}]]
608
return [binary scan $bytes h* r; set r]
611
::SASL::register DIGEST-MD5 40 \
612
::SASL::DIGEST-MD5:client ::SASL::DIGEST-MD5:server
614
# -------------------------------------------------------------------------
618
# Implementation of the OTP SASL mechanism (RFC2444).
622
# RFC 2289: A One-Time Password System
623
# RFC 2444: OTP SASL Mechanism
624
# RFC 2243: OTP Extended Responses
625
# Client initializes with authid\0authzid
626
# Server responds with extended OTP responses
627
# eg: otp-md5 498 bi32123 ext
628
# Client responds with otp result as:
629
# hex:xxxxxxxxxxxxxxxx
631
# word:WWWW WWW WWWW WWWW WWWW
633
# To support changing the otp sequence the extended commands have:
634
# init-hex:<current>:<new params>:<new>
635
# eg: init-hex:xxxxxxxxxxxx:md5 499 seed987:xxxxxxxxxxxxxx
638
proc ::SASL::OTP:client {context challenge args} {
639
upvar #0 $context ctx
642
switch -exact -- $ctx(step) {
644
set authzid [eval $ctx(callback) [list $context login]]
645
set username [eval $ctx(callback) [list $context username]]
646
set ctx(response) "$authzid\x00$username"
650
foreach {type count seed ext} $challenge break
651
set type [lindex [split $type -] 1]
652
if {[lsearch -exact {md4 md5 sha1 rmd160} $type] == -1} {
653
return -code error "unsupported digest algorithm \"$type\":\
654
must be one of md4, md5, sha1 or rmd160"
656
set challenge [lrange $challenge 3 end]
657
set password [eval $ctx(callback) [list $context password]]
658
set otp [::otp::otp-$type -word -seed $seed \
659
-count $count $password]
660
if {[string match "ext*" $ext]} {
663
set ctx(response) $otp
667
return -code error "unexpected state \"$ctx(step)\":\
668
the SASL OTP mechanism only has 2 steps"
674
::SASL::register OTP 45 ::SASL::OTP:client
676
# -------------------------------------------------------------------------
678
package provide SASL $::SASL::version
680
# -------------------------------------------------------------------------
683
# indent-tabs-mode: nil
added
removed
utils/sasl/sasl.tcl
