diff options
Diffstat (limited to 'tcllib/examples/sasl/saslclient.tcl')
| -rw-r--r-- | tcllib/examples/sasl/saslclient.tcl | 214 |
1 files changed, 214 insertions, 0 deletions
diff --git a/tcllib/examples/sasl/saslclient.tcl b/tcllib/examples/sasl/saslclient.tcl new file mode 100644 index 0000000..e9a52ac --- /dev/null +++ b/tcllib/examples/sasl/saslclient.tcl @@ -0,0 +1,214 @@ +#!/usr/bin/env tclsh +## -*- tcl -*- +# saslclient.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sf.net> +# +# This is a SMTP SASL test client. It connects to a SMTP server and uses +# the STARTTLS feature if available to switch to a secure link before +# negotiating authentication using SASL. +# +# $Id: saslclient.tcl,v 1.5 2009/01/30 04:18:14 andreas_kupries Exp $ + +package require SASL +package require base64 +catch {package require SASL::NTLM} + +variable user +array set user {username "" password ""} +if {[info exists env(http_proxy_user)]} { + set user(username) $env(http_proxy_user) +} else { + if {[info exists env(USERNAME)]} { + set user(username) $env(USERNAME) + } +} +if {[info exists env(http_proxy_pass)]} { + set user(password) $env(http_proxy_pass) +} + + +# SASLCallback -- +# +# This procedure is called from the SASL library when it needs to get +# information from the client application. The callback can be specified +# with additional data elements and when called the SASL library will +# append the SASL context, the command and possibly additional arguments. +# The command specified the type of information needed. +# So far we have: +# login users authorization identity (can be same as username). +# username users authentication identity +# password users authentication token +# realm the authentication realm (domain for NTLM) +# hostname the client's idea of its hostname (for NTLM) +# +proc SASLCallback {clientblob chan context command args} { + global env + variable user + upvar #0 $context ctx + switch -exact -- $command { + login { + return "";# means use the authentication id + } + username { + return $user(username) + } + password { + return $user(password) + } + realm { + if {$ctx(mech) eq "NTLM"} { + return "$env(USERDOMAIN)" + } else { + return [lindex [fconfigure $chan -peername] 1] + } + } + hostname { + return [info host] + } + default { + return -code error "oops: client needs to write $command" + } + } +} + +# SMTPClient -- +# +# This implements a minimal SMTP client state engine. It will +# do enough of the SMTP protocol to initiate a SSL/TLS link and +# negotiate SASL parameters. Then it terminates. +# +proc Callback {chan eof line} { + variable mechs + variable tls + variable ctx + if {![info exists mechs]} {set mechs {}} + if {$eof} { set ::forever 1; return } + puts "> $line" + switch -glob -- $line { + "220 *" { + if {$tls} { + set tls 0 + puts "| switching to SSL" + fileevent $chan readable {} + tls::import $chan + catch {tls::handshake $chan} msg + set mechs {} + fileevent $chan readable [list Read $chan ::Callback] + } + Write $chan "EHLO [info host]" + } + "250 *" { + if {$tls} { + Write $chan STARTTLS + } else { + set supported [SASL::mechanisms] + puts "SASL mechanisms: $mechs\ncan do $supported" + foreach mech $mechs { + if {[lsearch -exact $supported $mech] != -1} { + + set ctx [SASL::new \ + -mechanism $mech \ + -callback [list [namespace origin SASLCallback] "client blob" $chan]] + Write $chan "AUTH $mech" + return + } + } + puts "! No matching SASL mechanism found" + } + } + "250-AUTH*" { + set line [string trim [string range $line 9 end]] + set mechs [concat $mechs [split $line]] + } + "250-STARTTLS*" { + if {![catch {package require tls}]} { + set tls 1 + } + } + "235 *" { + SASL::cleanup $ctx + Write $chan "QUIT" + } + "334 *" { + set challenge [string range $line 4 end] + set e [string range $challenge end-5 end] + puts "? '$e' [binary scan $e H* r; set r]" + if {![catch {set dec [base64::decode $challenge]}]} { + set challenge $dec + } + + set mech [set [subst $ctx](mech)] + #puts "> $challenge" + if {$mech eq "NTLM"} {puts ">CHA [SASL::NTLM::Debug $challenge]"} + set code [catch {SASL::step $ctx $challenge} err] + if {! $code} { + set rsp [SASL::response $ctx] + # puts "< $rsp" + if {$mech eq "NTLM"} {puts "<RSP [SASL::NTLM::Debug $rsp]"} + Write $chan [join [base64::encode $rsp] {}] + } else { + puts stderr "sasl error: $err" + Write $chan "QUIT" + } + } + "535*" { + Write $chan QUIT + } + default { + } + } +} + +# Write -- +# +# Write data to the socket channel with logging. +# +proc Write {chan what} { + puts "< $what" + puts $chan $what + return +} + +# Read -- +# +# fileevent handler reads data when available from the network socket +# and calls the specified callback when it has recieved a complete line. +# +proc Read {chan callback} { + if {[eof $chan]} { + fileevent $chan readable {} + puts stderr "eof" + eval $callback [list $chan 1 {}] + return + } + if {[gets $chan line] != -1} { + eval $callback [list $chan 0 $line] + } + return +} + +# connect -- +# +# Open an SMTP session to test out the SASL implementation. +# +proc connect { server port {username {}} {passwd {}}} { + variable mechs ; set mechs {} + variable tls ; set tls 0 + + variable user + if {$username ne {}} {set user(username) $username} + if {$passwd ne {}} {set user(password) $passwd} + + puts "Connect to $server:$port" + set sock [socket $server $port] + fconfigure $sock -buffering line -blocking 1 -translation {auto crlf} + fileevent $sock readable [list Read $sock ::Callback] + after 6000 {puts timeout ; set ::forever 1} + vwait ::forever + catch {close $sock} + return +} + +if {!$tcl_interactive} { + catch {eval ::connect $argv} res + puts $res +} |