diff options
| author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
|---|---|---|
| committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
| commit | ea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch) | |
| tree | 6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/sasl | |
| parent | b5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff) | |
| parent | 7c621da28f07e449ad90c387344f07a453927569 (diff) | |
| download | blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2 | |
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/modules/sasl')
| -rw-r--r-- | tcllib/modules/sasl/ChangeLog | 194 | ||||
| -rw-r--r-- | tcllib/modules/sasl/gtoken.man | 27 | ||||
| -rw-r--r-- | tcllib/modules/sasl/gtoken.tcl | 92 | ||||
| -rw-r--r-- | tcllib/modules/sasl/ntlm.man | 36 | ||||
| -rw-r--r-- | tcllib/modules/sasl/ntlm.tcl | 375 | ||||
| -rw-r--r-- | tcllib/modules/sasl/ntlm.test | 92 | ||||
| -rw-r--r-- | tcllib/modules/sasl/pkgIndex.tcl | 11 | ||||
| -rw-r--r-- | tcllib/modules/sasl/sasl.man | 340 | ||||
| -rw-r--r-- | tcllib/modules/sasl/sasl.tcl | 682 | ||||
| -rw-r--r-- | tcllib/modules/sasl/sasl.test | 291 | ||||
| -rw-r--r-- | tcllib/modules/sasl/scram.man | 36 | ||||
| -rw-r--r-- | tcllib/modules/sasl/scram.tcl | 503 | ||||
| -rw-r--r-- | tcllib/modules/sasl/scram.test | 99 |
13 files changed, 2778 insertions, 0 deletions
diff --git a/tcllib/modules/sasl/ChangeLog b/tcllib/modules/sasl/ChangeLog new file mode 100644 index 0000000..12e19e6 --- /dev/null +++ b/tcllib/modules/sasl/ChangeLog @@ -0,0 +1,194 @@ +2014-01-21 Andreas Kupries <andreask@activestate.com> + + * pkgIndex.tcl: Ticket [861f53ff24]. Added proper initialization + * sal.tcl: to CreateNonce when falling back to md5 (no + * sasl.man: dev/urandom). Bumped version to 1.3.3. + +2013-12-07 Andreas Kupries <andreask@activestate.com> + + * gtoken.man: Added mini manpages for the SASL mechanisms + * ntlm.man: residing in their own packages. They mainly + * scram.man: refer back to the main SASL documentation. + +2013-12-06 Andreas Kupries <andreask@activestate.com> + + * ntlm.tcl: [Ticket 5030721806]: Applied the supplied diff, + * ntlm.test: removed 'domain' flag from defaults for a Type 1 + * pkgIndex.tcl: greeting message. Updated testsuite. Bumped + version to 1.1.2 + +2013-12-06 Andreas Kupries <andreask@activestate.com> + + * sasl.man: Ticket [b8f35b9883]. Added references for SCRAM mechanism + * sasl.test: and package. Fixed missing cleanup of test variable. + * scram.tcl: New package SASL::SCRAM and testsuite, provided + * scram.test: by <sgolovan@nes.ru> + +2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-01-29 Pat Thoyts <patthoyts@users.sourceforge.net> + + * sasl.tcl: Added support for the 'charset' parameter in DIGEST-MD5 + for gsasl servers which are picky about this. + * sasl.tcl: digest-md5 noncecount parameter moved into context + array so it is only used for maintained connections. + +2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-08-26 Pat Thoyts <patthoyts@users.sourceforge.net> + + * sasl.tcl: Fix bug #1545306 noncecount mishandled in DIGEST-MD5. + Enable support for re-authentication in client via SASL::reset + * ntlm.tcl: Applied patch #1653431 to make use of the returned NT + domain if present. + * gtoken.tcl: Applied patch #1774859 from Sergei Golovan to handle + failed authentication. + +2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * sasl.man: Fixed all warnings due to use of now deprecated + commands. Added a section about how to give feedback. + +2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-10-02 Pat Thoyts <patthoyts@users.sourceforge.net> + + * sasl.tcl (::SASL::CreateNonce): Acquire random data from + /dev/urandom to avoid blocking. + * pkgIndex.tcl: Increment patchlevel + +2006-09-14 Pat Thoyts <patthoyts@users.sourceforge.net> + + * ntlm.tcl: bug 1557494 - added support for OEM-type + * ntlm.test: NTLM packets (provided by Mark Janssen) + * pkgIndex.tcl: Increment NTLM version to 1.1.0 + +2006-09-02 Pat Thoyts <patthoyts@users.sourceforge.net> + + * sasl.tcl: Incremented package version to 1.3.0, updated + * sasl.man: the manual page to cover the OTP mechanism + * sasl.test: and added a test for OTP client functionality. + * pkgIndex.tcl: + +2006-09-01 Pat Thoyts <patthoyts@users.sourceforge.net> + + * sasl.tcl: Support OTP mechanism (depends upon the otp module). + client only, awaiting tests. + +2006-04-26 Pat Thoyts <patthoyts@users.sourceforge.net> + + * all: Incremented version to 1.2.0 + * sasl.man: Updated documentation. + * sasl.tcl: Implemented DIGEST-MD5 server. Enhanced the mechanisms + command so we can obtain either client or server + mechanisms. Added a threshold value to the mechanisms + command to set minimum security. Changed register to + uniquely register mechanisms to permit re-sourcing + the script. + +2006-04-20 Pat Thoyts <patthoyts@users.sourceforge.net> + + * sasl.tcl: Applied patch for #1412021 from Sergei Golovan to + * sasl.test: make sure the service is set. Added test. + + * all: Incremented SASL version to 1.1.0 + * sasl.tcl: Fixed the common mechanisms to all do the right + * sasl.test: thing when handed an empty challenge. The client + should always begin with SASL::step $ctx "" to see + if there is anything to send in the initial round. + * gtoken.tcl: Support the X-GOOGLE-TOKEN SASL mechanism. Done + * sasl.man: as separate package due to additional dependencies + (http and tls required) + +2006-01-26 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * sasl.test: More boilerplate simplified via use of test support. + * ntlm.test: (And hooked into the new common test support code). + +2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * sasl.test: Hooked into the new common test support code. + +2005-10-11 Pat Thoyts <patthoyts@users.sourceforge.net> + + * ntlm.tcl: bug #1323295 - NTLM requires little endian unicode + strings. Fixed generation on big-endian systems (eg: sparc). + +2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-10-06 Pat Thoyts <patthoyts@users.sourceforge.net> + + * sasl.man: Added documentation. + +2005-10-05 Pat Thoyts <patthoyts@users.sourceforge.net> + + * ntlm.tcl: Use tcllib 1.8 des module. Added NTLM tests. Fix to + * ntlm.test: work with tcl 8.2. + +2005-09-19 Pat Thoyts <patthoyts@users.sourceforge.net> + + * sasl.tcl: Fixed 8.4isms and specified requirement to Tcl 8.2 + +2005-04-22 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * saslclient.tcl: Moved example out of the module into a new + directory 'sasl/' under the examples tree. + +2005-02-11 Pat Thoyts <patthoyts@users.sourceforge.net> + + * sasl.test: Added some tests. + * sasl.tcl: Changed namespace and package to SASL. + * ntlm.tcl: + +2005-01-20 Pat Thoyts <patthoyts@users.sourceforge.net> + + * sasl.tcl: Initial version (DIGEST-MD5, CRAM-MD5, PLAIN, LOGIN) + * ntlm.tcl: Implementation of Microsoft NTLM as SASL mechanism. + * saslclient.tcl: SMTP-SASL test harness. + diff --git a/tcllib/modules/sasl/gtoken.man b/tcllib/modules/sasl/gtoken.man new file mode 100644 index 0000000..cd682e1 --- /dev/null +++ b/tcllib/modules/sasl/gtoken.man @@ -0,0 +1,27 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin SASL::XGoogleToken n 1.0.1] +[keywords authentication] +[keywords SASL XGoogleToken] +[copyright {2006, Pat Thoyts <patthoyts@users.sourceforge.net>}] +[moddesc {Simple Authentication and Security Layer (SASL)}] +[titledesc {Implementation of SASL NTLM mechanism for Tcl}] +[category Networking] +[require Tcl 8.2] +[require SASL::XGoogleToken [opt 1.0.1]] +[description] +[para] + +This package provides the XGoogleToken authentication mechanism for +the Simple Authentication and Security Layer (SASL). + +[para] Please read the documentation for package [package sasl] +for details. + +[include ../common-text/tls-security-notes.inc] + +[section AUTHORS] +Pat Thoyts + +[vset CATEGORY sasl] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/sasl/gtoken.tcl b/tcllib/modules/sasl/gtoken.tcl new file mode 100644 index 0000000..aec9ef9 --- /dev/null +++ b/tcllib/modules/sasl/gtoken.tcl @@ -0,0 +1,92 @@ +# gtoken.tcl - Copyright (C) 2006 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# This is an implementation of Google's X-GOOGLE-TOKEN authentication +# mechanism. This actually passes the login details to the Google +# accounts server which gives us a short lived token that may be passed +# over an insecure link. +# +# ------------------------------------------------------------------------- +# 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 +package require SASL +package require http +package require tls + +namespace eval ::SASL { + namespace eval XGoogleToken { + variable URLa https://www.google.com/accounts/ClientAuth + variable URLb https://www.google.com/accounts/IssueAuthToken + + # Should use autoproxy and register autoproxy::tls_socket + # Leave to application author? + if {![info exists ::http::urlTypes(https)]} { + http::register https 443 tls::socket + } + } +} + +proc ::SASL::XGoogleToken::client {context challenge args} { + upvar #0 $context ctx + variable URLa + variable URLb + set reply "" + set err "" + + if {$ctx(step) != 0} { + return -code error "unexpected state: X-GOOGLE-TOKEN has only 1 step" + } + set username [eval $ctx(callback) [list $context username]] + set password [eval $ctx(callback) [list $context password]] + set query [http::formatQuery Email $username Passwd $password \ + PersistentCookie false source googletalk] + set tok [http::geturl $URLa -query $query -timeout 30000] + if {[http::status $tok] eq "ok"} { + foreach line [split [http::data $tok] \n] { + array set g [split $line =] + } + if {![info exists g(Error)]} { + set query [http::formatQuery SID $g(SID) LSID $g(LSID) \ + service mail Session true] + set tok2 [http::geturl $URLb -query $query -timeout 30000] + + if {[http::status $tok2] eq "ok"} { + set reply "\0$username\0[http::data $tok2]" + } else { + set err [http::error $tok2] + } + http::cleanup $tok2 + } else { + set err "Invalid username or password" + } + } else { + set err [http::error $tok] + } + http::cleanup $tok + + if {[string length $err] > 0} { + return -code error $err + } else { + set ctx(response) $reply + incr ctx(step) + } + return 0 +} + +# ------------------------------------------------------------------------- + +# Register this SASL mechanism with the Tcllib SASL package. +# +if {[llength [package provide SASL]] != 0} { + ::SASL::register X-GOOGLE-TOKEN 40 ::SASL::XGoogleToken::client +} + +package provide SASL::XGoogleToken 1.0.1 + +# ------------------------------------------------------------------------- +# +# Local variables: +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/sasl/ntlm.man b/tcllib/modules/sasl/ntlm.man new file mode 100644 index 0000000..9be149c --- /dev/null +++ b/tcllib/modules/sasl/ntlm.man @@ -0,0 +1,36 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin SASL::NTLM n 1.1.2] +[keywords authentication] +[keywords SASL NTLM] +[copyright {2005-2006, Pat Thoyts <patthoyts@users.sourceforge.net>}] +[moddesc {Simple Authentication and Security Layer (SASL)}] +[titledesc {Implementation of SASL NTLM mechanism for Tcl}] +[category Networking] +[require Tcl 8.2] +[require SASL::NTLM [opt 1.1.2]] +[description] +[para] + +This package provides the NTLM authentication mechanism for +the Simple Authentication and Security Layer (SASL). + +[para] Please read the documentation for package [package sasl] +for details. + +[section "REFERENCES"] + +[list_begin enumerated] + +[enum] + No official specification is available. However, + [uri http://davenport.sourceforge.net/ntlm.html] provides a good + description. + +[list_end] + +[section AUTHORS] +Pat Thoyts + +[vset CATEGORY sasl] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/sasl/ntlm.tcl b/tcllib/modules/sasl/ntlm.tcl new file mode 100644 index 0000000..f7762e9 --- /dev/null +++ b/tcllib/modules/sasl/ntlm.tcl @@ -0,0 +1,375 @@ +# 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 { + 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 1.1.2 + +# ------------------------------------------------------------------------- +# +# Local variables: +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/sasl/ntlm.test b/tcllib/modules/sasl/ntlm.test new file mode 100644 index 0000000..8771323 --- /dev/null +++ b/tcllib/modules/sasl/ntlm.test @@ -0,0 +1,92 @@ +# sasl.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Tests for the Tcllib SASL package +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# RCS: @(#) $Id: ntlm.test,v 1.5 2006/10/09 21:41:41 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +support { + use base64/base64.tcl base64 + useLocal sasl.tcl SASL +} +testing { + useLocal ntlm.tcl SASL::NTLM +} + +# ------------------------------------------------------------------------- +# Tests +# ------------------------------------------------------------------------- + +proc NTLMCallback {context command args} { + upvar #0 $context ctx + switch -exact -- $command { + login { return "" } + username { return "user" } + password { return "SecREt01" } + realm { return DOMAIN } + hostname { return WORKSTATION } + default { + return -code error "oops: client needs to write $command" + } + } +} + +# ------------------------------------------------------------------------- + +# +# Sample NTLM messages from +# http://davenport.sf.net/ntlm.html: NTLM HTTP Authentication +# +variable Chk; array set Chk {} +set Chk(1) TlRMTVNTUAABAAAAByIAAAYABgArAAAACwALACAAAABXT1JLU1RBVElPTkRPTUFJTg== +set Chk(2) [join {TlRMTVNTUAACAAAADAAMADAAAAABAoEAASNFZ4mrze8 + AAAAAAAAAAGIAYgA8AAAARABPAE0AQQBJAE4AAgAMAEQATwBNAEEASQBOAAEADABTA + EUAUgBWAEUAUgAEABQAZABvAG0AYQBpAG4ALgBjAG8AbQADACIAcwBlAHIAdgBlAHI + ALgBkAG8AbQBhAGkAbgAuAGMAbwBtAAAAAAA=}] +set Chk(3) [join {TlRMTVNTUAADAAAAGAAYAGoAAAAYABgAggAAAAwADABAAAAACAAI + AEwAAAAWABYAVAAAAAAAAACaAAAAAQKBAEQATwBNAEEASQBOAHUAcwBlAHIAVwBPAF + IASwBTAFQAQQBUAEkATwBOAMM3zVy9RPyXgqZnr21CfG3mfCDC0+d8ViWpjBwx6BhH + Rmspst9GgPOZWPuMITqcxg==} {}] + +test SASL-NTLM-1.0 {NTLM client challenge} { + list [catch { + set ctx [SASL::new -mechanism NTLM -callback NTLMCallback] + SASL::step $ctx "" + set response [SASL::response $ctx] + SASL::cleanup $ctx + base64::encode -maxlen 0 $response + } res] $res +} [list 0 $Chk(1)] + +test SASL-NTLM-1.1 {NTLM client response} { + list [catch { + set ctx [SASL::new -mechanism NTLM -callback NTLMCallback] + SASL::step $ctx "" + SASL::step $ctx [base64::decode $Chk(2)] + set response [SASL::response $ctx] + SASL::cleanup $ctx + base64::encode -maxlen 0 $response + } res] $res +} [list 0 $Chk(3)] + +# ------------------------------------------------------------------------- + +unset Chk +testsuiteCleanup + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/sasl/pkgIndex.tcl b/tcllib/modules/sasl/pkgIndex.tcl new file mode 100644 index 0000000..b5910c3 --- /dev/null +++ b/tcllib/modules/sasl/pkgIndex.tcl @@ -0,0 +1,11 @@ +# pkgIndex.tcl -*- tcl -*- +# Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net> +# $Id: pkgIndex.tcl,v 1.11 2008/01/29 00:51:39 patthoyts Exp $ +if {![package vsatisfies [package provide Tcl] 8.2]} { + # PRAGMA: returnok + return +} +package ifneeded SASL 1.3.3 [list source [file join $dir sasl.tcl]] +package ifneeded SASL::NTLM 1.1.2 [list source [file join $dir ntlm.tcl]] +package ifneeded SASL::XGoogleToken 1.0.1 [list source [file join $dir gtoken.tcl]] +package ifneeded SASL::SCRAM 0.1 [list source [file join $dir scram.tcl]] diff --git a/tcllib/modules/sasl/sasl.man b/tcllib/modules/sasl/sasl.man new file mode 100644 index 0000000..13245cb --- /dev/null +++ b/tcllib/modules/sasl/sasl.man @@ -0,0 +1,340 @@ +[comment {-*- tcl -*- doctools manpage}] +[vset SASL_VERSION 1.3.3] +[manpage_begin SASL n [vset SASL_VERSION]] +[keywords authentication] +[keywords SASL] +[copyright {2005-2006, Pat Thoyts <patthoyts@users.sourceforge.net>}] +[moddesc {Simple Authentication and Security Layer (SASL)}] +[titledesc {Implementation of SASL mechanisms for Tcl}] +[category Networking] +[require Tcl 8.2] +[require SASL [opt [vset SASL_VERSION]]] +[description] +[para] + +The Simple Authentication and Security Layer (SASL) is a framework +for providing authentication and authorization to comunications +protocols. The SASL framework is structured to permit negotiation +among a number of authentication mechanisms. SASL may be used in +SMTP, IMAP and HTTP authentication. It is also in use in XMPP, LDAP +and BEEP. See [sectref MECHANISMS] for the set of available SASL +mechanisms provided with tcllib. + +[para] + +The SASL framework operates using a simple multi-step challenge +response mechanism. All the mechanisms work the same way although the +number of steps may vary. In this implementation a callback procedure +must be provided from which the SASL framework will obtain users +details. See [sectref "CALLBACK PROCEDURE"] for details of this +procedure. + +[section {COMMANDS}] + +[list_begin definitions] + +[call [cmd "::SASL::new"] [arg "option value [opt ...]"]] + +Contruct a new SASL context. See [sectref OPTIONS] for details of the +possible options to this command. A context token is required for most +of the SASL procedures. + +[call [cmd "::SASL::configure"] [arg "option value"] [opt [arg "..."]]] + +Modify and inspect the SASL context option. See [sectref OPTIONS] for +further details. + +[call [cmd "::SASL::step"] [arg "context"] [arg "challenge"] [opt [arg "..."]]] + +This is the core procedure for using the SASL framework. The +[cmd step] procedure should be called until it returns 0. Each step takes a +server challenge string and the response is calculated and stored in +the context. Each mechanism may require one or more steps. For some +steps there may be no server challenge required in which case an empty +string should be provided for this parameter. All mechanisms should accept +an initial empty challenge. + +[call [cmd "::SASL::response"] [arg "context"]] + +Returns the next response string that should be sent to the server. + +[call [cmd "::SASL::reset"] [arg "context"]] + +Re-initialize the SASL context. Discards any internal state and +permits the token to be reused. + +[call [cmd "::SASL::cleanup"] [arg "context"]] + +Release all resources associated with the SASL context. The context +token may not be used again after this procedure has been called. + +[call [cmd "::SASL::mechanisms"] [opt [arg "type"]] [opt [arg "minimum"]]] + +Returns a list of all the available SASL mechanisms. The list is +sorted by the mechanism preference value (see [cmd register]) with the +preferred mechanisms and the head of the list. Any mechanism with a +preference value less than the[arg minimum] (which defaults to 0) is removed +from the returned list. This permits a security threshold to be set. Mechanisms +with a preference less that 25 transmit authentication are particularly +susceptible to eavesdropping and should not be provided unless a secure +channel is in use (eg: tls). +[para] +The [arg type] parameter +may be one of [arg client] or [arg server] and defaults to [arg client]. +Only mechanisms that have an implementation matching the [arg type] are +returned (this permits servers to correctly declare support only for +mechanisms that actually provide a server implementation). + +[call [cmd "::SASL::register"] [arg "mechanism"] [arg "preference"] \ + [arg "clientproc"] [opt [arg "serverproc"]]] + +New mechanisms can be added to the package by registering the +mechanism name and the implementing procedures. The server procedure +is optional. The preference value is an integer that is used to order +the list returned by the [cmd mechanisms] command. Higher values +indicate a preferred mechanism. If the mechanism is already registered +then the recorded values are updated. + +[list_end] + +[section "OPTIONS"] + +[list_begin definitions] + +[def [option "-callback"]] + +Specify a command to be evaluated when the SASL mechanism requires +information about the user. The command is called with the current +SASL context and a name specifying the information desired. See +[sectref EXAMPLES]. + +[def [option "-mechanism"]] + +Set the SASL mechanism to be used. See [cmd mechanisms] for a list of +supported authentication mechanisms. + +[def [option "-service"]] + +Set the service type for this context. Some mechanisms may make use of +this parameter (eg DIGEST-MD5, GSSAPI and Kerberos). If not set it +defaults to an empty string. If the [option -type] is set to 'server' +then this option should be set to a valid service identity. Some +examples of valid service names are smtp, ldap, beep and xmpp. + +[def [option "-server"]] + +This option is used to set the server name used in SASL challenges +when operating as a SASL server. + +[def [option "-type"]] + +The context type may be one of 'client' or 'server'. The default is to +operate as a client application and respond to server +challenges. Mechanisms may be written to support server-side SASL and +setting this option will cause each [cmd step] to issue the next +challenge. A new context must be created for each incoming client +connection when in server mode. + +[list_end] + +[section "CALLBACK PROCEDURE"] + +When the SASL framework requires any user details it will call the +procedure provided when the context was created with an argument that +specfies the item of information required. +[para] +In all cases a single response string should be returned. + +[list_begin definitions] + +[def "login"] + +The callback procedure should return the users authorization identity. +Return an empty string unless this is to be different to the authentication +identity. Read [lb]1[rb] for a discussion about the specific meaning of +authorization and authentication identities within SASL. + +[def "username"] + +The callback procedure should return the users authentication identity. +Read [lb]1[rb] for a discussion about the specific meaning of +authorization and authentication identities within SASL. + +[def "password"] + +The callback procedure should return the password that matches the +authentication identity as used within the current realm. +[para] +For server mechanisms the password callback should always be called with +the authentication identity and the realm as the first two parameters. + +[def "realm"] + +Some SASL mechanisms use realms to partition authentication identities. +The realm string is protocol dependent and is often the current DNS +domain or in the case of the NTLM mechanism it is the Windows NT domain name. + +[def "hostname"] + +Returns the client host name - typically [lb]info host[rb]. + +[list_end] + +[section "MECHANISMS"] + +[list_begin definitions] + +[def "ANONYMOUS"] + +As used in FTP this mechanism only passes an email address for +authentication. The ANONYMOUS mechanism is specified in [lb]2[rb]. + +[def "PLAIN"] + +This is the simplest mechanism. The users authentication details are +transmitted in plain text. This mechanism should not be provided +unless an encrypted link is in use - typically after SSL or TLS has +been negotiated. + +[def "LOGIN"] + +The LOGIN [lb]1[rb] mechanism transmits the users details with base64 +encoding. This is no more secure than PLAIN and likewise should not be +used without a secure link. + +[def "CRAM-MD5"] + +This mechanism avoids sending the users password over the network in +plain text by hashing the password with a server provided random value +(known as a nonce). A disadvantage of this mechanism is that the +server must maintain a database of plaintext passwords for +comparison. CRAM-MD5 was defined in [lb]4[rb]. + +[def "DIGEST-MD5"] + +This mechanism improves upon the CRAM-MD5 mechanism by avoiding the +need for the server to store plaintext passwords. With digest +authentication the server needs to store the MD5 digest of the users +password which helps to make the system more secure. As in CRAM-MD5 +the password is hashed with a server nonce and other data before being +transmitted across the network. Specified in [lb]3[rb]. + +[def "OTP"] + +OTP is the One-Time Password system described in RFC 2289 [lb]6[rb]. +This mechanism is secure against replay attacks and also avoids storing +password or password equivalents on the server. Only a digest of a seed +and a passphrase is ever transmitted across the network. Requires the +[package otp] package from tcllib and one or more of the cryptographic +digest packages (md5 or sha-1 are the most commonly used). + +[def "NTLM"] + +This is a proprietary protocol developed by Microsoft [lb]5[rb] and is +in common use for authenticating users in a Windows network +environment. NTLM uses DES encryption and MD4 digests of the users +password to authenticate a connection. Certain weaknesses have been +found in NTLM and thus there are a number of versions of the protocol. +As this mechanism has additional dependencies it is made available as +a separate sub-package. To enable this mechanism your application must +load the [package SASL::NTLM] package. + +[def "X-GOOGLE-TOKEN"] + +This is a proprietary protocol developed by Google and used for +authenticating users for the Google Talk service. This mechanism makes +a pair of HTTP requests over an SSL channel and so this mechanism +depends upon the availability of the tls and http packages. To enable +this mechanism your application must load the [package SASL::XGoogleToken] package. +In addition you are recommended to make use of the autoproxy package to +handle HTTP proxies reasonably transparently. + +[def "SCRAM"] + +This is a protocol specified in RFC 5802 [lb]7[rb]. To enable this mechanism +your application must load the [package SASL::SCRAM] package. + +[list_end] + +[section "EXAMPLES"] + +See the examples subdirectory for more complete samples using SASL +with network protocols. The following should give an idea how the SASL +commands are to be used. In reality this should be event +driven. Each time the [cmd step] command is called, the last server +response should be provided as the command argument so that the SASL +mechanism can take appropriate action. + +[example { +proc ClientCallback {context command args} { + switch -exact -- $command { + login { return "" } + username { return $::tcl_platform(user) } + password { return "SecRet" } + realm { return "" } + hostname { return [info host] } + default { return -code error unxpected } + } +} + +proc Demo {{mech PLAIN}} { + set ctx [SASL::new -mechanism $mech -callback ClientCallback] + set challenge "" + while {1} { + set more_steps [SASL::step $ctx challenge] + puts "Send '[SASL::response $ctx]'" + puts "Read server response into challenge var" + if {!$more_steps} {break} + } + SASL::cleanup $ctx +} +}] + +[section "REFERENCES"] + +[list_begin enumerated] + +[enum] + Myers, J. "Simple Authentication and Security Layer (SASL)", + RFC 2222, October 1997. + ([uri http://www.ietf.org/rfc/rfc2222.txt]) + +[enum] + Newman, C. "Anonymous SASL Mechanism", + RFC 2245, November 1997. + ([uri http://www.ietf.org/rfc/rfc2245.txt]) + +[enum] + Leach, P., Newman, C. "Using Digest Authentication as a SASL + Mechanism", RFC 2831, May 2000, + ([uri http://www.ietf.org/rfc/rfc2831.txt]) + +[enum] + Klensin, J., Catoe, R. and Krumviede, P., + "IMAP/POP AUTHorize Extension for Simple Challenge/Response" + RFC 2195, September 1997. + ([uri http://www.ietf.org/rfc/rfc2195.txt]) + +[enum] + No official specification is available. However, + [uri http://davenport.sourceforge.net/ntlm.html] provides a good + description. + +[enum] + Haller, N. et al., "A One-Time Password System", + RFC 2289, February 1998, + ([uri http://www.ieft.org/rfc/rfc2289.txt]) + +[enum] + Newman, C. et al., "Salted Challenge Response Authentication Mechanism (SCRAM) SASL and GSS-API Mechanisms", + RFC 5802, July 2010, + ([uri http://www.ieft.org/rfc/rfc5802.txt]) + +[list_end] + +[section AUTHORS] +Pat Thoyts + +[vset CATEGORY sasl] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/sasl/sasl.tcl b/tcllib/modules/sasl/sasl.tcl new file mode 100644 index 0000000..c54acb6 --- /dev/null +++ b/tcllib/modules/sasl/sasl.tcl @@ -0,0 +1,682 @@ +# sasl.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# 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 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 {step 0}} { + upvar #0 $context ctx + array set ctx [list step $step 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} { + upvar #0 $context ctx + md5_init + if {$ctx(step) == 0 && [string length $challenge] == 0} { + if {[info exists ctx(challenge)]} { + set challenge $ctx(challenge) + } else { + set ctx(response) "" + return 1 + } + } + incr ctx(step) + set result 0 + switch -exact -- $ctx(step) { + 1 { + set ctx(challenge) $challenge + array set params [DigestParameters $challenge] + + if {![info exists ctx(noncecount)]} { + set ctx(noncecount) 0 + } + set nonce $params(nonce) + set cnonce [CreateNonce] + set noncecount [format %08u [incr ctx(noncecount)]] + set qop auth + + # support the 'charset' parameter. + set username [eval $ctx(callback) [list $context username]] + set password [eval $ctx(callback) [list $context password]] + set encoding iso8859-1 + if {[info exists params(charset)]} { + set encoding $params(charset) + } + set username [encoding convertto $encoding $username] + set password [encoding convertto $encoding $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" + if {[info exists params(charset)]} { + append ctx(response) ",charset=$params(charset)" + } + 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} { + 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(nc) 0 + 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 nc [format %08u [expr {$ctx(nc) + 1}]] + set R [DigestResponse $params(username) $realm $password \ + $uri auth $ctx(nonce) $nc $params(cnonce)] + if {[string equal $R $params(response)]} { + set R2 [DigestResponse $params(username) $realm $password \ + $uri auth $ctx(nonce) $nc $params(cnonce)] + set ctx(response) "rspauth=$R2" + incr ctx(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/urandom]} { + catch { + set f [open /dev/urandom r] + fconfigure $f -translation binary -buffering none + set bytes [read $f 16] + close $f + } + } + if {[string length $bytes] < 1} { + md5_init + 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:<current>:<new params>:<new> +# 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 -word -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 45 ::SASL::OTP:client + +# ------------------------------------------------------------------------- + +package provide SASL 1.3.3 + +# ------------------------------------------------------------------------- +# +# Local variables: +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/sasl/sasl.test b/tcllib/modules/sasl/sasl.test new file mode 100644 index 0000000..8d6790e --- /dev/null +++ b/tcllib/modules/sasl/sasl.test @@ -0,0 +1,291 @@ +# sasl.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Tests for the Tcllib SASL package +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# RCS: @(#) $Id: sasl.test,v 1.10 2008/01/29 00:51:39 patthoyts Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useLocal sasl.tcl SASL +} + +# ------------------------------------------------------------------------- +# Tests +# ------------------------------------------------------------------------- + +proc SASLCallback {clientblob context command args} { + upvar #0 $context ctx + switch -exact -- $command { + login { return "" } + username { return "tester" } + password { return "secret" } + realm { return "tcllib.sourceforge.net" } + hostname { return [info host] } + default { + return -code error "oops: client needs to write $command" + } + } +} + +# ------------------------------------------------------------------------- + +test SASL-1.0 {Check mechanisms preference sorting} { + list [catch { + set M $::SASL::mechanisms + set ::SASL::mechanisms {} + SASL::register TEST-1 10 client server + SASL::register TEST-3 100 client + SASL::register TEST-2 50 client + set r [SASL::mechanisms] + set ::SASL::mechanisms $M + set r + } res] $res +} [list 0 [list TEST-3 TEST-2 TEST-1]] + +test SASL-1.1 {Check mechanisms type parameter} { + list [catch { + set M $::SASL::mechanisms + set ::SASL::mechanisms {} + SASL::register TEST-1 10 client server + SASL::register TEST-3 100 client + SASL::register TEST-2 50 client + set r [list [SASL::mechanisms client] [SASL::mechanisms server]] + set ::SASL::mechanisms $M + set r + } res] $res +} [list 0 [list [list TEST-3 TEST-2 TEST-1] [list TEST-1]]] + +test SASL-1.2 {Check mechanisms preference minimum} { + list [catch { + set M $::SASL::mechanisms + set ::SASL::mechanisms {} + SASL::register TEST-1 10 client server + SASL::register TEST-3 100 client + SASL::register TEST-2 50 client + set r [list [SASL::mechanisms client 50] [SASL::mechanisms client 80]] + set ::SASL::mechanisms $M + set r + } res] $res +} [list 0 [list [list TEST-3 TEST-2] [list TEST-3]]] + +# ------------------------------------------------------------------------- + +test SASL-PLAIN-1.0 {} { + list [catch { + set ctx [SASL::new -mechanism PLAIN \ + -callback [list SASLCallback 0]] + SASL::step $ctx "" + set r [SASL::response $ctx] + SASL::cleanup $ctx + set r + } res] $res +} [list 0 "\x00tester\x00secret"] + +# ------------------------------------------------------------------------- + +test SASL-LOGIN-2.0 {Check basic LOGIN operation} { + list [catch { + set r {} + set ctx [SASL::new -mechanism LOGIN \ + -callback [list SASLCallback 0]] + SASL::step $ctx "VXNlcm5hbWU6" + lappend r [SASL::response $ctx] + SASL::step $ctx "UGFzc3dvcmQ6" + lappend r [SASL::response $ctx] + SASL::cleanup $ctx + set r + } res] $res +} [list 0 [list tester secret]] + +test SASL-LOGIN-2.1 {Check initial NULL challenge is ignored.} { + list [catch { + set r {} + set ctx [SASL::new -mechanism LOGIN \ + -callback [list SASLCallback 0]] + SASL::step $ctx "" + lappend r [SASL::response $ctx] + SASL::step $ctx "VXNlcm5hbWU6" + lappend r [SASL::response $ctx] + SASL::step $ctx "UGFzc3dvcmQ6" + lappend r [SASL::response $ctx] + SASL::cleanup $ctx + set r + } res] $res +} [list 0 [list {} tester secret]] + +# ------------------------------------------------------------------------- + +test SASL-CRAMMD5-3.0 {} { + list [catch { + set ctx [SASL::new -mechanism CRAM-MD5 \ + -callback [list SASLCallback 0]] + SASL::step $ctx "<1234.987654321@tcllib.sourceforge.net>" + set r [SASL::response $ctx] + SASL::cleanup $ctx + set r + } res] $res +} [list 0 [list tester c7e3043702b782d70716bd1e21d6e2f7]] + +test SASL-CRAMMD5-3.1 {} { + list [catch { + set ctx [SASL::new -mechanism CRAM-MD5 \ + -callback [list SASLCallback 0]] + SASL::step $ctx "" + set r1 [SASL::response $ctx] + SASL::step $ctx "" + set r2 [SASL::response $ctx] + SASL::cleanup $ctx + list $r1 $r2 + } res] $res +} {0 {{} {}}} + +test SASL-CRAMMD5-3.2 {} { + list [catch { + set ctx [SASL::new -mechanism CRAM-MD5 \ + -callback [list SASLCallback 0]] + SASL::step $ctx "<1234.987654321@tcllib.sourceforge.net>" + set r [SASL::response $ctx] + SASL::step $ctx "" + set r2 [SASL::response $ctx] + SASL::cleanup $ctx + list $r $r2 + } res] $res +} [list 1 "unexpected state: CRAM-MD5 has only 1 step"] + +test SASL-CRAMMD5-3.3 {} { + list [catch { + set ctx [SASL::new -mechanism CRAM-MD5 \ + -callback [list SASLCallback 0]] + SASL::step $ctx "<1234.987654321@tcllib.sourceforge.net>" + set r1 [SASL::response $ctx] + SASL::step $ctx "" + set r2 [SASL::response $ctx] + SASL::cleanup $ctx + list $r1 $r2 + } res] $res +} [list 1 "unexpected state: CRAM-MD5 has only 1 step"] + +# ------------------------------------------------------------------------- + +test SASL-DIGESTMD5-4.0 {Basic check of DIGEST-MD5 operation} { + list [catch { + set ctx [SASL::new -mechanism DIGEST-MD5 \ + -callback [list SASLCallback 0]] + SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\"" + set r [split [SASL::response $ctx] ,] + SASL::cleanup $ctx + foreach thing $r { + set x [split $thing =] + set R([lindex $x 0]) [lindex [lindex $x 1] 0] + } + set A1 [SASL::md5_bin "tester:tcllib.sourceforge.net:secret"] + set A2 "AUTHENTICATE:smtp/tcllib.sourceforge.net" + set A3 [SASL::md5_hex "$A1:$R(nonce):$R(cnonce)"] + set A4 [SASL::md5_hex $A2] + set r [SASL::md5_hex "$A3:0123456789:$R(nc):$R(cnonce):auth:$A4"] + string compare $r $R(response) + } res] $res +} [list 0 0] + +test SASL-DIGESTMD5-4.1 {Check initial empty challenge is accepted.} { + list [catch { + set ctx [SASL::new -mechanism DIGEST-MD5 \ + -callback [list SASLCallback 0]] + SASL::step $ctx "" + SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\"" + set r [split [SASL::response $ctx] ,] + SASL::cleanup $ctx + foreach thing $r { + set x [split $thing =] + set R([lindex $x 0]) [lindex [lindex $x 1] 0] + } + set A1 [SASL::md5_bin "tester:tcllib.sourceforge.net:secret"] + set A2 "AUTHENTICATE:smtp/tcllib.sourceforge.net" + set A3 [SASL::md5_hex "$A1:$R(nonce):$R(cnonce)"] + set A4 [SASL::md5_hex $A2] + set r [SASL::md5_hex "$A3:0123456789:$R(nc):$R(cnonce):auth:$A4"] + string compare $r $R(response) + } res] $res +} [list 0 0] + +test SASL-DIGESTMD5-4.2 "bug #1412021: ensure service used correctly" { + list [catch { + set service xmpp + set ctx [SASL::new -mechanism DIGEST-MD5 -service $service \ + -callback [list SASLCallback 0]] + SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\"" + set r [split [SASL::response $ctx] ,] + SASL::cleanup $ctx + foreach thing $r { + set x [split $thing =] + set R([lindex $x 0]) [lindex [lindex $x 1] 0] + } + set A1 [SASL::md5_bin "tester:tcllib.sourceforge.net:secret"] + set A2 "AUTHENTICATE:$service/tcllib.sourceforge.net" + set A3 [SASL::md5_hex "$A1:$R(nonce):$R(cnonce)"] + set A4 [SASL::md5_hex $A2] + set r [SASL::md5_hex "$A3:0123456789:$R(nc):$R(cnonce):auth:$A4"] + string compare $r $R(response) + } res] $res +} [list 0 0] + +test SASL-DIGESTMD5-4.3 "check for support of charset parameter" { + list [catch { + set service xmpp + set ctx [SASL::new -mechanism DIGEST-MD5 -service $service \ + -callback [list SASLCallback 0]] + SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\",charset=utf-8" + array set p [SASL::DigestParameters [SASL::response $ctx]] + SASL::cleanup $ctx + info exists p(charset) + } res] $res +} [list 0 1] +unset p ;# TODO convert to tcltest 2 + +test SASL-DIGESTMD5-4.4 "check parsing of spaces in params" { + list [catch { + set service xmpp + set ctx [SASL::new -mechanism DIGEST-MD5 -service $service \ + -callback [list SASLCallback 0]] + SASL::step $ctx "nonce=\"0123456789\", realm=\"tcllib.sourceforge.net\", charset=utf-8" + set r {} + foreach {k v} [SASL::DigestParameters [SASL::response $ctx]] { lappend r $k } + SASL::cleanup $ctx + lsort $r + } res] $res +} [list 0 {charset cnonce digest-uri nc nonce qop realm response username}] + +test SASL-OTP-5.0 {Check basic OTP (otp-md5) operation} { + list [catch { + set r {} + set ctx [SASL::new -mechanism OTP \ + -callback [list SASLCallback 0]] + SASL::step $ctx "" + lappend r [SASL::response $ctx] + SASL::step $ctx "otp-md5 5 test5 ext" + lappend r [SASL::response $ctx] + SASL::cleanup $ctx + set r + } res] $res +} [list 0 [list "\x00tester" "word:RIG ACRE TALL CALL OAR NEIL"]] + +# ------------------------------------------------------------------------- + +testsuiteCleanup + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/sasl/scram.man b/tcllib/modules/sasl/scram.man new file mode 100644 index 0000000..b459a53 --- /dev/null +++ b/tcllib/modules/sasl/scram.man @@ -0,0 +1,36 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin SASL::SCRAM n 0.1] +[keywords authentication] +[keywords SASL SCRAM] +[copyright {2013 Sergei Golovan <sgolovan@nes.ru>}] +[moddesc {Simple Authentication and Security Layer (SASL)}] +[titledesc {Implementation of SASL SCRAM mechanism for Tcl}] +[category Networking] +[require Tcl 8.2] +[require SASL::SCRAM [opt 0.1]] +[description] +[para] + +This package provides the SCRAM authentication mechanism for +the Simple Authentication and Security Layer (SASL). + +[para] Please read the documentation for package [package sasl] +for details. + +[section "REFERENCES"] + +[list_begin enumerated] + +[enum] + Newman, C. et al., "Salted Challenge Response Authentication Mechanism (SCRAM) SASL and GSS-API Mechanisms", + RFC 5802, July 2010, + ([uri http://www.ieft.org/rfc/rfc5802.txt]) + +[list_end] + +[section AUTHORS] +Sergei Golovan + +[vset CATEGORY sasl] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/sasl/scram.tcl b/tcllib/modules/sasl/scram.tcl new file mode 100644 index 0000000..7f13d53 --- /dev/null +++ b/tcllib/modules/sasl/scram.tcl @@ -0,0 +1,503 @@ +# scram.tcl - Copyright (c) 2013 Sergei Golovan <sgolovan@nes.ru> +# +# This is an implementation of SCRAM-* SASL authentication +# mechanism (RFC-5802). +# +# ------------------------------------------------------------------------- +# 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 +package require SASL +package require sha1 +package require base64 + +namespace eval ::SASL::SCRAM {} + +# ::SASL::SCRAM::Map -- +# +# Map comma and equal sign to their codes in authzid and username +# (section 5.1, a and n attributes) +# +# Arguments: +# string string subject to mapping +# +# Result: +# The given string with , replaced by =2C and = replaced by =3D +# +# Side effects: +# None +# +# Comment: +# Since comma, equal sign, 2, C, 3, D are all in ASCII, +# [encoding convertto utf-8 [Map]] gives the same result as +# [Map [encoding convertto utf-8]], so the latter is used here +# despite the former is correct formally + +proc ::SASL::SCRAM::Map {string} { + string map {, =2C = =3D} $string +} + +# ::SASL::SCRAM::Unmap -- +# +# Replace codes =2C by , and =3D by = in authzid and username +# (section 5.1, a and n attributes) +# +# Arguments: +# string authzid or username extracted from a challenge +# +# Result: +# Mapped argument +# +# Side effects: +# None +# +# Comment: +# Since comma, equal sign, 2, C, 3, D are all in ASCII, +# [encoding convertfrom utf-8 [Unmap]] gives the same result as +# [Unmap [encoding convertfrom utf-8]], and the former is used here +# despite the latter is correct formally + +proc ::SASL::SCRAM::Unmap {string} { + string map {=2C , =3D =} $string +} + +# ::SASL::SCRAM::GS2Header -- +# +# Return GS2 header for SCRAM (section 7, gs2-header) +# +# Arguments: +# authzid authorization identity (empty if it's the same as username +# to authenticate) +# +# Result: +# GS2 header for inclusion into a client messages +# +# Side effects: +# None + +proc ::SASL::SCRAM::GS2Header {authzid} { + # n means that client doesn't support channel binding + if {[string equal $authzid ""]} { + return "n,," + } else { + return "n,a=[Map $authzid]," + } +} + +# ::SASL::SCRAM::ClientFirstMessageBare -- +# +# Return the first client message without the GS2 header (section 7, +# client-first-message-bare, without extensions) +# +# Arguments: +# username Username to authenticate +# nonce Random string of printable chars +# +# Result: +# SCRAM client first message without GS2 header +# +# Side effects: +# None + +proc ::SASL::SCRAM::ClientFirstMessageBare {username nonce} { + return "n=[Map $username],r=$nonce" +} + +# ::SASL::SCRAM::ClientFirstMessage -- +# +# Return the first client message to be sent to a server (section 7, +# client-first-message, without extensions) +# +# Arguments: +# authzid authorization identity (empty if it's the same as username +# to authenticate) +# username Username to authenticate +# nonce Random string of printable chars +# +# Result: +# SCRAM client first message without GS2 header +# +# Side effects: +# None + +proc ::SASL::SCRAM::ClientFirstMessage {authzid username nonce} { + return "[GS2Header $authzid][ClientFirstMessageBare $username $nonce]" +} + +# ::SASL::SCRAM::ClientFinalMessageWithoutProof -- +# +# Return the final client message not including the client proof +# (section 7, client-final-message-without-proof, without extensions). +# Note that we don't support channel binding, so the GS2 header used +# here is the same as in the first message. This message is used twice: +# 1) as part of auth-message which hash authenticates user, 2) as part +# of the final message client sends to the server +# +# Arguments: +# authzid authorization identity (empty if it's the same as username +# to authenticate), must be the same as in the first message +# nonce Random string of printable chars, must be the one received +# from the server on step 1 +# +# Result: +# The final client message without proof +# +# Side effects: +# None + +proc ::SASL::SCRAM::ClientFinalMessageWithoutProof {authzid nonce} { + # We still don't support channel binding, so just use [GS2Header] + return "c=[base64::encode [GS2Header $authzid]],r=$nonce" +} + +# ::SASL::SCRAM::ServerFirstMessage -- +# +# Return the server first message (section 7, server-first-message) +# +# Arguments: +# nonce Random string of printable chars, it must start with the +# random string received from the client at step 0 +# salt Random binary string +# iter Number of iterations for salting password (required to be +# not less then 4096) +# +# Result: +# The first server message +# +# Side effects: +# None + +proc ::SASL::SCRAM::ServerFirstMessage {nonce salt iter} { + return "r=$nonce,s=[base64::encode $salt],i=$iter" +} + +# ::SASL::SCRAM::ParseChallenge -- +# +# Parse client or server output string and return a list of attr-value, +# suitable for [array set]. Channel binding part of GS2 header returns +# as "cbind n", "cbind y" or "cbind p p <value>", other attributes +# return simply as "<attr> <value>" +# +# Arguments: +# challenge Input string to parse +# +# Result: +# List with even number of members +# +# Side effects: +# None + +proc ::SASL::SCRAM::ParseChallenge {challenge} { + set attrval [split $challenge ,] + set params {} + set n 0 + foreach av $attrval { + incr n + if {$av == ""} continue + + if {[regexp {^([a-z])(?:=(.+))?$} $av -> attr val]} { + if {$n == 1 && ($attr == "n" || $attr == "y")} { + # Header (channel binding) + lappend params cbind $attr + } elseif {$n == 1 && $attr == "p"} { + # Header (channel binding) + lappend params cbind $attr $attr $val + } else { + lappend params $attr $val + } + } else { + return -code error "invalid challenge" + } + } + return $params +} + +# ::SASL::SCRAM::Xor -- +# +# Return bitwize XOR between two strings of equal length +# +# Arguments: +# str1 String to XOR +# str2 String to XOR +# +# Result: +# Bitwise XOR of the supplied strings or error if their lengths differ +# +# Side effects: +# None + +proc ::SASL::SCRAM::Xor {str1 str2} { + set result "" + foreach s1 [split $str1 ""] s2 [split $str2 ""] { + append result [binary format c [expr {[scan $s1 %c] ^ [scan $s2 %c]}]] + } + return $result +} + +# ::SASL::SCRAM::Hi -- +# +# Salt the given password using algorithm from section 2.2 +# +# Arguments: +# hmac Function which calculates a Hashed Message Authentication +# digest (HMAC) described in RFC 2104 in binary form +# password Password to salt +# salt Random string used as a salt +# i Number of iterations (assumed i>=1) +# +# Result: +# Salted password +# +# Side effects: +# None + +proc ::SASL::SCRAM::Hi {hmac password salt i} { + set res [set ui [$hmac $password "$salt\x0\x0\x0\x1"]] + for {set n 1} {$n < $i} {incr n} { + set ui [$hmac $password $ui] + set res [Xor $res $ui] + } + return $res +} + +# ::SASL::SCRAM::Algo -- +# +# Return client proof and server signature according to SCRAM +# algorithm from section 3. +# +# Arguments: +# hash Function which returns a cryptographic dugest in binary form +# hmac Function which calculates a Hashed Message Authentication +# digest (HMAC) described in RFC 2104 in binary form +# password User password +# salt Random string used as a salt +# i Number of iterations for password salting (assumed i>=1) +# auth_message Message which is to be hashed to get client and server +# signatures +# +# Result: +# List of two binaries with client proof and server signature +# +# Side effects: +# None + +proc ::SASL::SCRAM::Algo {hash hmac password salt i auth_message} { + set salted_password [Hi $hmac $password $salt $i] + set client_key [$hmac $salted_password "Client Key"] + set stored_key [$hash $client_key] + set client_signature [$hmac $stored_key $auth_message] + set client_proof [Xor $client_key $client_signature] + set server_key [$hmac $salted_password "Server Key"] + set server_signature [$hmac $server_key $auth_message] + return [list $client_proof $server_signature] +} + +# ::SASL::SCRAM::client -- +# +# Perform authentication step of the client part of SCRAM SASL +# procedure. It's an auxiliary procedure called from the callback +# registered with the SASL package +# +# Arguments: +# hash Function which returns a cryptographic dugest in binary form +# hmac Function which calculates a Hashed Message Authentication +# digest (HMAC) described in RFC 2104 in binary form +# context Array name which contains authentication state (in particular +# step and response values) +# challenge Input from the server +# args Ignored rest of the arguments +# +# Result: +# 1 if authentication is to be continued, 0 if it is finished with +# success, error if it is failed for some reason. ${context}(response) +# contains data to be sent to the server +# +# Side effects: +# The authzid, username, password are obtained using SASL callback. +# Step 1 uses data from step 0, and step 2 uses data from step 1 +# (stored in the context array) +# +# Known bugs and limitations: +# 1) The authzid, username and password aren't saslprepped +# 2) There's no check for 'm' attribute (authentication must fail if it's +# present) +# 3) There's no check if the server's nonce has the client's nonce as +# a prefix + +proc ::SASL::SCRAM::client {hash hmac context challenge args} { + upvar #0 $context ctx + + switch -exact -- $ctx(step) { + 0 { + # Initial message with username and random string + + # authzid and username will be used also at step 1, so store them + set ctx(authzid) [encoding convertto utf-8 [eval $ctx(callback) [list $context login]]] + set ctx(username) [encoding convertto utf-8 [eval $ctx(callback) [list $context username]]] + set ctx(nonce) [::SASL::CreateNonce] + set ctx(response) [ClientFirstMessage $ctx(authzid) $ctx(username) $ctx(nonce)] + incr ctx(step) + return 1 + } + 1 { + # Final message with client proof calculated using the user's password + + array set params [ParseChallenge $challenge] + set password [encoding convertto utf-8 [eval $ctx(callback) [list $context password]]] + set final_message [ClientFinalMessageWithoutProof $ctx(authzid) $params(r)] + set auth_message "[ClientFirstMessageBare $ctx(username) $ctx(nonce)],$challenge,$final_message" + foreach {proof signature} [Algo $hash $hmac $password [base64::decode $params(s)] $params(i) $auth_message] break + set ctx(signature) $signature + set ctx(response) "$final_message,p=[base64::encode $proof]" + incr ctx(step) + return 1 + } + 2 { + # Check of the server's signature + + array set params [ParseChallenge $challenge] + if {[info exists params(e)]} { + return -code error $params(e) + } + if {![string equal $ctx(signature) [base64::decode $params(v)]]} { + return -code error "invalid server signature" + } + incr ctx(step) + return 0 + + } + default { + return -code error "invalid state" + } + } +} + +# ::SASL::SCRAM::server -- +# +# Perform authentication step of the server part of SCRAM SASL +# procedure. It's an auxiliary procedure called from the callback +# registered with the SASL package +# +# Arguments: +# hash Function which returns a cryptographic dugest in binary form +# hmac Function which calculates a Hashed Message Authentication +# digest (HMAC) described in RFC 2104 in binary form +# context Array name which contains authentication state (in particular +# step and response values) +# clientrsp Input from the client +# args Ignored rest of the arguments +# +# Result: +# 1 if authentication is to be continued, 0 if it is finished with +# success, error if it is failed for some reason. ${context}(response) +# contains data to be sent to the server +# +# Side effects: +# The authentication realm and password are obtained using SASL callback. +# Step 1 uses data from step 0 (stored in the context array) +# +# Known bugs and limitations: +# 1) The server part needs to know the user's password (which violates the +# idea that server cannot impersonate client) +# 2) The username and password aren't saslprepped +# 3) There's no check for 'm' attribute (authentication must fail if it's +# present) +# 4) There's no check if the encoded username contains unprotected = +# 5) The authzid support is not implemented +# 6) The channel binding option at step 1 is ignored + +proc ::SASL::SCRAM::server {hash hmac context clientrsp args} { + upvar #0 $context ctx + + switch -exact -- $ctx(step) { + 0 { + if {[string length $clientrsp] == 0} { + # Do not increase the step counter here and send an empty + # challenge because SCRAM is a client-first mechanism (section + # 5 of RFC-4422) + set ctx(response) "" + return 1 + } + + # Initial response with random string, salt and number of iterations + + array set params [ParseChallenge $clientrsp] + if {![info exists params(cbind)]} { + return -code error "invalid header" + } + if {$params(cbind) == "p"} { + return -code error "channel binding is not supported" + } + + set ctx(username) [encoding convertfrom utf-8 [Unmap $params(n)]] + set ctx(salt) [::SASL::CreateNonce] + set ctx(nonce) $params(r)[::SASL::CreateNonce] + set ctx(iter) 4096 + + # Store the bare client message for AuthMessage at step 1 + regexp {^[^,]*,[^,]*,(.*)} $clientrsp -> ctx(message) + + set ctx(response) [ServerFirstMessage $ctx(nonce) $ctx(salt) $ctx(iter)] + incr ctx(step) + return 1 + } + 1 { + # Verification of the client's proof and response with the + # server's signature + + array set params [ParseChallenge $clientrsp] + set realm [eval $ctx(callback) [list $context realm]] + set password [encoding convertto utf-8 [eval $ctx(callback) [list $context password $ctx(username) $realm]]] + + # Remove proof to create AuthMessage + regexp {(.*),p=[^,]*$} $clientrsp -> final_message + set auth_message "$ctx(message),[ServerFirstMessage $ctx(nonce) $ctx(salt) $ctx(iter)],$final_message" + foreach {proof signature} [Algo $hash $hmac $password $ctx(salt) $ctx(iter) $auth_message] break + if {![string equal $proof [base64::decode $params(p)]]} { + return -code error "authentication failed" + } + set ctx(response) "v=[base64::encode $signature]" + incr ctx(step) + return 0 + } + default { + return -code error "invalid state" + } + } +} + +# ------------------------------------------------------------------------- +# Provide the mandatory SCRAM-SHA-1 mechanism + +proc ::SASL::SCRAM::SHA-1:hash {str} { + sha1::sha1 -bin $str +} + +proc ::SASL::SCRAM::SHA-1:hmac {key str} { + sha1::hmac -bin -key $key $str +} + +proc ::SASL::SCRAM::SHA-1:client {context challenge args} { + client ::SASL::SCRAM::SHA-1:hash ::SASL::SCRAM::SHA-1:hmac $context $challenge +} + +proc ::SASL::SCRAM::SHA-1:server {context clientrsp args} { + server ::SASL::SCRAM::SHA-1:hash ::SASL::SCRAM::SHA-1:hmac $context $clientrsp +} + +# Register the SCRAM-SHA-1 SASL mechanism with the Tcllib SASL package + +::SASL::register SCRAM-SHA-1 50 ::SASL::SCRAM::SHA-1:client ::SASL::SCRAM::SHA-1:server + +# ------------------------------------------------------------------------- + +package provide SASL::SCRAM 0.1 + +# ------------------------------------------------------------------------- +# +# Local variables: +# indent-tabs-mode: nil +# End: +# vim:ts=8:sw=4:sts=4:et diff --git a/tcllib/modules/sasl/scram.test b/tcllib/modules/sasl/scram.test new file mode 100644 index 0000000..75364d7 --- /dev/null +++ b/tcllib/modules/sasl/scram.test @@ -0,0 +1,99 @@ +# scram.test - Copyright (c) 2013 Sergei Golovan <sgolovan@nes.ru> +# +# Tests for the Tcllib SASL::SCRAM package +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +#package require tcltest +#source [file join devtools testutilities.tcl] + +testsNeedTcl 8.4 +testsNeedTcltest 2 + +support { + useLocal sasl.tcl SASL +} +testing { + useLocal scram.tcl SASL::SCRAM +} + +# ------------------------------------------------------------------------- +# Tests +# ------------------------------------------------------------------------- + +proc SASLCallback {clientblob context command args} { + upvar #0 $context ctx + switch -exact -- $command { + login { return "" } + username { return "tester" } + password { return "secret" } + realm { return "tcllib.sourceforge.net" } + hostname { return [info host] } + default { + return -code error "oops: client needs to write $command" + } + } +} + +# ------------------------------------------------------------------------- + +test SASL-SCRAM-6.0 {Check basic SCRAM-SHA-1 operation} -setup { + set result {} +} -body { + set stx [SASL::new -type server -service xmpp -mechanism SCRAM-SHA-1 -callback {SASLCallback 0}] + set ctx [SASL::new -type client -service xmpp -mechanism SCRAM-SHA-1 -callback {SASLCallback 0}] + + set sv "" + while {1} { + set res [SASL::step $ctx $sv] + lappend result $res + if {!$res} break + set cl [SASL::response $ctx] + set res [SASL::step $stx $cl] + lappend result $res + set sv [SASL::response $stx] + } + + SASL::cleanup $ctx + SASL::cleanup $stx + set result +} -cleanup { + unset result sv res stx ctx cl +} -result {1 1 1 0 0} + +test SASL-SCRAM-6.1 {Check main SCRAM-SHA-1 algorithm} -setup { +} -body { + # Data is taken from http://www.ietf.org/mail-archive/web/xmpp/current/msg00887.html + + foreach {p v} [SASL::SCRAM::Algo SASL::SCRAM::SHA-1:hash SASL::SCRAM::SHA-1:hmac \ + r0m30myr0m30 [base64::decode NjhkYTM0MDgtNGY0Zi00NjdmLTkxMmUtNDlmNTNmNDNkMDMz] 4096 \ + [join {n=juliet + r=oMsTAAwAAAAMAAAANP0TAAAAAABPU0AA + r=oMsTAAwAAAAMAAAANP0TAAAAAABPU0AAe124695b-69a9-4de6-9c30-b51b3808c59e + s=NjhkYTM0MDgtNGY0Zi00NjdmLTkxMmUtNDlmNTNmNDNkMDMz + i=4096 + c=biws + r=oMsTAAwAAAAMAAAANP0TAAAAAABPU0AAe124695b-69a9-4de6-9c30-b51b3808c59e} ,]] break + + list [base64::encode $p] [base64::encode $v] +} -cleanup { + unset p + unset v +} -result {UA57tM/SvpATBkH2FXs0WDXvJYw= pNNDFVEQxuXxCoSEiW8GEZ+1RSo=} + +# ------------------------------------------------------------------------- + +testsuiteCleanup + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: +# vim:ts=8:sw=4:sts=4:et |