# -*- tcl -*- Tcl Module ########## Repository Information Block ### # @@ Meta Begin # Package SASL 1.2.0 # Meta as::origin http://sf.net/projects/tcllib # Meta category Simple Authentication and Security Layer (SASL) # Meta description Implementation of SASL mechanisms for Tcl # Meta license BSD # Meta platform tcl # Meta require md5 # Meta require otp # Meta require {Tcl 8.2} # Meta subject authentication SASL # @@ Meta End ########## ########## Requirements Enforcement Code ### package require md5 package require otp package require Tcl 8.2 ########## ########## Package Declaration Code ### package provide SASL 1.2.0 ########## # sasl.tcl - Copyright (C) 2005 Pat Thoyts # # This is an implementation of a general purpose SASL library for use in # Tcl scripts. # # References: # Myers, J., "Simple Authentication and Security Layer (SASL)", # RFC 2222, October 1997. # Rose, M.T., "TclSASL", "http://beepcore-tcl.sourceforge.net/tclsasl.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 namespace eval ::SASL { variable version 1.2.0 variable rcsid {$Id: sasl.tcl,v 1.8 2006/09/01 14:40:14 patthoyts Exp $} variable uid if {![info exists uid]} { set uid 0 } variable mechanisms if {![info exists mechanisms]} { set mechanisms [list] } } # SASL::mechanisms -- # # Return a list of available SASL mechanisms. By default only the # client implementations are given but if type is set to server then # the list of available server mechanisms is returned. # No mechanism with a preference value less than 'minimum' will be # returned. # The list is sorted by the security preference with the most secure # mechanisms given first. # proc ::SASL::mechanisms {{type client} {minimum 0}} { variable mechanisms set r [list] foreach mech $mechanisms { if {[lindex $mech 0] < $minimum} { continue } switch -exact -- $type { client { if {[string length [lindex $mech 2]] > 0} { lappend r [lindex $mech 1] } } server { if {[string length [lindex $mech 3]] > 0} { lappend r [lindex $mech 1] } } default { return -code error "invalid type \"$type\":\ must be either client or server" } } } return $r } # SASL::register -- # # Register a new SASL mechanism with a security preference. Higher # preference values are chosen before lower valued mechanisms. # If no server implementation is available then an empty string # should be provided for the serverproc parameter. # proc ::SASL::register {mechanism preference clientproc {serverproc {}}} { variable mechanisms set ndx [lsearch -regexp $mechanisms $mechanism] set mech [list $preference $mechanism $clientproc $serverproc] if {$ndx == -1} { lappend mechanisms $mech } else { set mechanisms [lreplace $mechanisms $ndx $ndx $mech] } set mechanisms [lsort -index 0 -decreasing -integer $mechanisms] return } # SASL::uid -- # # Return a unique integer. # proc ::SASL::uid {} { variable uid return [incr uid] } # SASL::response -- # # Get the reponse string from the SASL state. # proc ::SASL::response {context} { upvar #0 $context ctx return $ctx(response) } # SASL::reset -- # # Reset the SASL state. This permits the same instance to be reused # for a new round of authentication. # proc ::SASL::reset {context} { upvar #0 $context ctx array set ctx [list step 0 response "" valid false count 0] return $context } # SASL::cleanup -- # # Free any resources used with the SASL state. # proc ::SASL::cleanup {context} { if {[info exists $context]} { unset $context } return } # SASL::new -- # # Create a new SASL instance. # proc ::SASL::new {args} { set context [namespace current]::[uid] upvar #0 $context ctx array set ctx [list mech {} callback {} proc {} service smtp server {} \ step 0 response "" valid false type client count 0] eval [linsert $args 0 [namespace origin configure] $context] return $context } # SASL::configure -- # # Configure the SASL state. # proc ::SASL::configure {context args} { variable mechanisms upvar #0 $context ctx while {[string match -* [set option [lindex $args 0]]]} { switch -exact -- $option { -service { set ctx(service) [Pop args 1] } -server - -serverFQDN { set ctx(server) [Pop args 1] } -mech - -mechanism { set mech [string toupper [Pop args 1]] set ctx(proc) {} foreach m $mechanisms { if {[string equal [lindex $m 1] $mech]} { set ctx(mech) $mech if {[string equal $ctx(type) "server"]} { set ctx(proc) [lindex $m 3] } else { set ctx(proc) [lindex $m 2] } break } } if {[string equal $ctx(proc) {}]} { return -code error "mechanism \"$mech\" not available:\ must be one of those given by \[sasl::mechanisms\]" } } -callback - -callbacks { set ctx(callback) [Pop args 1] } -type { set type [Pop args 1] if {[lsearch -exact {server client} $type] != -1} { set ctx(type) $type if {![string equal $ctx(mech) ""]} { configure $context -mechanism $ctx(mech) } } else { return -code error "bad value \"$type\":\ must be either client or server" } } default { return -code error "bad option \"$option\":\ must be one of -mechanism, -service, -server -type\ or -callbacks" } } Pop args } } proc ::SASL::step {context challenge args} { upvar #0 $context ctx incr ctx(count) return [eval [linsert $args 0 $ctx(proc) $context $challenge]] } proc ::SASL::Pop {varname {nth 0}} { upvar $varname args set r [lindex $args $nth] set args [lreplace $args $nth $nth] return $r } proc ::SASL::md5_init {} { variable md5_inited if {[info exists md5_inited]} {return} else {set md5_inited 1} # Deal with either version of md5. We'd like version 2 but someone # may have already loaded version 1. set md5major [lindex [split [package require md5] .] 0] if {$md5major < 2} { # md5 v1, no options, and returns a hex string ready for us. proc ::SASL::md5_hex {data} { return [::md5::md5 $data] } proc ::SASL::md5_bin {data} { return [binary format H* [::md5::md5 $data]] } proc ::SASL::hmac_hex {pass data} { return [::md5::hmac $pass $data] } proc ::SASL::hmac_bin {pass data} { return [binary format H* [::md5::hmac $pass $data]] } } else { # md5 v2 requires -hex to return hash as hex-encoded non-binary string. proc ::SASL::md5_hex {data} { return [string tolower [::md5::md5 -hex $data]] } proc ::SASL::md5_bin {data} { return [::md5::md5 $data] } proc ::SASL::hmac_hex {pass data} { return [::md5::hmac -hex -key $pass $data] } proc ::SASL::hmac_bin {pass data} { return [::md5::hmac -key $pass $data] } } } # ------------------------------------------------------------------------- # CRAM-MD5 SASL MECHANISM # # Implementation of the Challenge-Response Authentication Mechanism # (RFC2195). # # Comments: # This mechanism passes a server generated string containing # a timestamp and has the client generate an MD5 HMAC using the # shared secret as the key and the server string as the data. # The downside of this protocol is that the server must have access # to the plaintext password. # proc ::SASL::CRAM-MD5:client {context challenge args} { upvar #0 $context ctx md5_init if {$ctx(step) != 0} { return -code error "unexpected state: CRAM-MD5 has only 1 step" } if {[string length $challenge] == 0} { set ctx(response) "" return 1 } set password [eval $ctx(callback) [list $context password]] set username [eval $ctx(callback) [list $context username]] set reply [hmac_hex $password $challenge] set reply "$username [string tolower $reply]" set ctx(response) $reply incr ctx(step) return 0 } proc ::SASL::CRAM-MD5:server {context clientrsp args} { upvar #0 $context ctx md5_init incr ctx(step) switch -exact -- $ctx(step) { 1 { set ctx(realm) [eval $ctx(callback) [list $context realm]] set ctx(response) "<[pid].[clock seconds]@$ctx(realm)>" return 1 } 2 { foreach {user hash} $clientrsp break set hash [string tolower $hash] set pass [eval $ctx(callback) [list $context password $user $ctx(realm)]] set check [hmac_bin $pass $ctx(response)] binary scan $check H* cx if {[string equal $cx $hash]} { return 0 } else { return -code error "authentication failed" } } default { return -code error "invalid state" } } } ::SASL::register CRAM-MD5 30 ::SASL::CRAM-MD5:client ::SASL::CRAM-MD5:server # ------------------------------------------------------------------------- # PLAIN SASL MECHANISM # # Implementation of the single step login SASL mechanism (RFC2595). # # Comments: # A single step mechanism in which the authorization ID, the # authentication ID and password are all transmitted in plain # text. This should not be used unless the channel is secured by # some other means (such as SSL/TLS). # proc ::SASL::PLAIN:client {context challenge args} { upvar #0 $context ctx incr ctx(step) set authzid [eval $ctx(callback) [list $context login]] set username [eval $ctx(callback) [list $context username]] set password [eval $ctx(callback) [list $context password]] set ctx(response) "$authzid\x00$username\x00$password" return 0 } proc ::SASL::PLAIN:server {context clientrsp args} { upvar \#0 $context ctx if {[string length $clientrsp] < 1} { set ctx(response) "" return 1 } else { foreach {authzid authid pass} [split $clientrsp \0] break set realm [eval $ctx(callback) [list $context realm]] set check [eval $ctx(callback) [list $context password $authid $realm]] if {[string equal $pass $check]} { return 0 } else { return -code error "authentication failed" } } } ::SASL::register PLAIN 10 ::SASL::PLAIN:client ::SASL::PLAIN:server # ------------------------------------------------------------------------- # LOGIN SASL MECHANISM # # Implementation of the two step login SASL mechanism. # # Comments: # This is an unofficial but widely deployed SASL mechanism somewhat # akin to the PLAIN mechanism. Both the authentication ID and password # are transmitted in plain text in response to server prompts. # # NOT RECOMMENDED for use in new protocol implementations. # proc ::SASL::LOGIN:client {context challenge args} { upvar #0 $context ctx if {$ctx(step) == 0 && [string length $challenge] == 0} { set ctx(response) "" return 1 } incr ctx(step) switch -exact -- $ctx(step) { 1 { set ctx(response) [eval $ctx(callback) [list $context username]] set r 1 } 2 { set ctx(response) [eval $ctx(callback) [list $context password]] set r 0 } default { return -code error "unexpected state \"$ctx(step)\":\ LOGIN has only 2 steps" } } return $r } proc ::SASL::LOGIN:server {context clientrsp args} { upvar #0 $context ctx incr ctx(step) switch -exact -- $ctx(step) { 1 { set ctx(response) "Username:" return 1 } 2 { set ctx(username) $clientrsp set ctx(response) "Password:" return 1 } 3 { set user $ctx(username) set realm [eval $ctx(callback) [list $context realm]] set pass [eval $ctx(callback) [list $context password $user $realm]] if {[string equal $clientrsp $pass]} { return 0 } else { return -code error "authentication failed" } } default { return -code error "invalid state" } } } ::SASL::register LOGIN 20 ::SASL::LOGIN:client ::SASL::LOGIN:server # ------------------------------------------------------------------------- # ANONYMOUS SASL MECHANISM # # Implementation of the ANONYMOUS SASL mechanism (RFC2245). # # Comments: # # proc ::SASL::ANONYMOUS:client {context challenge args} { upvar #0 $context ctx set user [eval $ctx(callback) [list $context username]] set realm [eval $ctx(callback) [list $context realm]] set ctx(response) $user@$realm return 0 } proc ::SASL::ANONYMOUS:server {context clientrsp args} { upvar #0 $context ctx set ctx(response) "" if {[string length $clientrsp] < 1} { if {$ctx(count) > 2} { return -code error "authentication failed" } return 1 } else { set ctx(trace) $clientrsp return 0 } } ::SASL::register ANONYMOUS 5 ::SASL::ANONYMOUS:client ::SASL::ANONYMOUS:server # ------------------------------------------------------------------------- # DIGEST-MD5 SASL MECHANISM # # Implementation of the DIGEST-MD5 SASL mechanism (RFC2831). # # Comments: # proc ::SASL::DIGEST-MD5:client {context challenge args} { variable digest_md5_noncecount upvar #0 $context ctx md5_init if {$ctx(step) == 0 && [string length $challenge] == 0} { set ctx(response) "" return 1 } incr ctx(step) set result 0 switch -exact -- $ctx(step) { 1 { array set params [DigestParameters $challenge] if {![info exists digest_md5_noncecount]} { set digest_md5_noncecount 0 } set nonce $params(nonce) set cnonce [CreateNonce] set noncecount [format %08u [incr digest_md5_noncecount]] set qop auth set username [eval $ctx(callback) [list $context username]] set password [eval $ctx(callback) [list $context password]] if {[info exists params(realm)]} { set realm $params(realm) } else { set realm [eval $ctx(callback) [list $context realm]] } set uri "$ctx(service)/$realm" set R [DigestResponse $username $realm $password $uri \ $qop $nonce $noncecount $cnonce] set ctx(response) "username=\"$username\",realm=\"$realm\",nonce=\"$nonce\",nc=\"$noncecount\",cnonce=\"$cnonce\",digest-uri=\"$uri\",response=\"$R\",qop=$qop" set result 1 } 2 { set ctx(response) "" set result 0 } default { return -code error "invalid state" } } return $result } proc ::SASL::DIGEST-MD5:server {context challenge args} { variable digest_md5_noncecount upvar #0 $context ctx md5_init incr ctx(step) set result 0 switch -exact -- $ctx(step) { 1 { set realm [eval $ctx(callback) [list $context realm]] set ctx(nonce) [CreateNonce] set ctx(response) "realm=\"$realm\",nonce=\"$ctx(nonce)\",qop=\"auth\",charset=utf-8,algorithm=md5-sess" set result 1 } 2 { array set params [DigestParameters $challenge] set realm [eval $ctx(callback) [list $context realm]] set password [eval $ctx(callback)\ [list $context password $params(username) $realm]] set uri "$ctx(service)/$realm" set R [DigestResponse $params(username) $realm $password \ $uri auth $ctx(nonce) $params(nc) $params(cnonce)] if {[string equal $R $params(response)]} { set R2 [DigestResponse $params(username) $realm $password \ $uri auth $ctx(nonce) $params(nc) $params(cnonce)] set ctx(response) "rspauth=$R2" set ctx(nc) $params(nc) set result 1 } else { return -code error "authentication failed" } } 3 { set ctx(response) "" set result 0 } default { return -code error "invalid state" } } return $result } # RFC 2831 2.1 # Char categories as per spec... # Build up a regexp for splitting the challenge into key value pairs. proc ::SASL::DigestParameters {challenge} { set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?=\\\{\\\} \t" set tok {0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\-\|\~\!\#\$\%\&\*\+\.\^\_\`} set sqot {(?:\'(?:\\.|[^\'\\])*\')} set dqot {(?:\"(?:\\.|[^\"\\])*\")} set parameters {} regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[${tok}\]+))(?:\[${sep}\]+|$)" $challenge {\1 \2 } parameters return $parameters } # RFC 2831 2.1.2.1 # proc ::SASL::DigestResponse {user realm pass uri qop nonce noncecount cnonce} { set A1 [md5_bin "$user:$realm:$pass"] set A2 "AUTHENTICATE:$uri" if {![string equal $qop "auth"]} { append A2 :[string repeat 0 32] } set A1h [md5_hex "${A1}:$nonce:$cnonce"] set A2h [md5_hex $A2] set R [md5_hex $A1h:$nonce:$noncecount:$cnonce:$qop:$A2h] return $R } # RFC 2831 2.1.2.2 # proc ::SASL::DigestResponse2 {user realm pass uri qop nonce noncecount cnonce} { set A1 [md5_bin "$user:$realm:$pass"] set A2 ":$uri" if {![string equal $qop "auth"]} { append A2 :[string repeat 0 32] } set A1h [md5_hex "${A1}:$nonce:$cnonce"] set A2h [md5_hex $A2] set R [md5_hex $A1h:$nonce:$noncecount:$cnonce:$qop:$A2h] return $R } # Get 16 random bytes for a nonce value. If we can use /dev/random, do so # otherwise we hash some values. # proc ::SASL::CreateNonce {} { set bytes {} if {[file readable /dev/random]} { catch { set f [open /dev/random r] fconfigure $f -translation binary -buffering none set bytes [read $f 16] close $f } } if {[string length $bytes] < 1} { set bytes [md5_bin [clock seconds]:[pid]:[expr {rand()}]] } return [binary scan $bytes h* r; set r] } ::SASL::register DIGEST-MD5 40 \ ::SASL::DIGEST-MD5:client ::SASL::DIGEST-MD5:server # ------------------------------------------------------------------------- # OTP SASL MECHANISM # # Implementation of the OTP SASL mechanism (RFC2444). # # Comments: # # RFC 2289: A One-Time Password System # RFC 2444: OTP SASL Mechanism # RFC 2243: OTP Extended Responses # Client initializes with authid\0authzid # Server responds with extended OTP responses # eg: otp-md5 498 bi32123 ext # Client responds with otp result as: # hex:xxxxxxxxxxxxxxxx # or # word:WWWW WWW WWWW WWWW WWWW # # To support changing the otp sequence the extended commands have: # init-hex::: # eg: init-hex:xxxxxxxxxxxx:md5 499 seed987:xxxxxxxxxxxxxx # or init-word proc ::SASL::OTP:client {context challenge args} { upvar #0 $context ctx package require otp incr ctx(step) switch -exact -- $ctx(step) { 1 { set authzid [eval $ctx(callback) [list $context login]] set username [eval $ctx(callback) [list $context username]] set ctx(response) "$authzid\x00$username" set cont 1 } 2 { foreach {type count seed ext} $challenge break set type [lindex [split $type -] 1] if {[lsearch -exact {md4 md5 sha1 rmd160} $type] == -1} { return -code error "unsupported digest algorithm \"$type\":\ must be one of md4, md5, sha1 or rmd160" } set challenge [lrange $challenge 3 end] set password [eval $ctx(callback) [list $context password]] set otp [::otp::otp-$type -words -seed $seed \ -count $count $password] if {[string match "ext*" $ext]} { set otp word:$otp } set ctx(response) $otp set cont 0 } default { return -code error "unexpected state \"$ctx(step)\":\ the SASL OTP mechanism only has 2 steps" } } return $cont } ::SASL::register OTP 35 ::SASL::OTP:client # ------------------------------------------------------------------------- package provide SASL $::SASL::version # ------------------------------------------------------------------------- # # Local variables: # indent-tabs-mode: nil # End: