1#! /bin/sh 2# the next line restarts with tclsh \ 3exec tclsh "$0" ${1+"$@"} 4 5# saslclient.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sf.net> 6# 7# This is a SMTP SASL test client. It connects to a SMTP server and uses 8# the STARTTLS feature if available to switch to a secure link before 9# negotiating authentication using SASL. 10# 11# $Id: saslclient.tcl,v 1.5 2009/01/30 04:18:14 andreas_kupries Exp $ 12 13package require SASL 14package require base64 15catch {package require SASL::NTLM} 16 17variable user 18array set user {username "" password ""} 19if {[info exists env(http_proxy_user)]} { 20 set user(username) $env(http_proxy_user) 21} else { 22 if {[info exists env(USERNAME)]} { 23 set user(username) $env(USERNAME) 24 } 25} 26if {[info exists env(http_proxy_pass)]} { 27 set user(password) $env(http_proxy_pass) 28} 29 30 31# SASLCallback -- 32# 33# This procedure is called from the SASL library when it needs to get 34# information from the client application. The callback can be specified 35# with additional data elements and when called the SASL library will 36# append the SASL context, the command and possibly additional arguments. 37# The command specified the type of information needed. 38# So far we have: 39# login users authorization identity (can be same as username). 40# username users authentication identity 41# password users authentication token 42# realm the authentication realm (domain for NTLM) 43# hostname the client's idea of its hostname (for NTLM) 44# 45proc SASLCallback {clientblob chan context command args} { 46 global env 47 variable user 48 upvar #0 $context ctx 49 switch -exact -- $command { 50 login { 51 return "";# means use the authentication id 52 } 53 username { 54 return $user(username) 55 } 56 password { 57 return $user(password) 58 } 59 realm { 60 if {$ctx(mech) eq "NTLM"} { 61 return "$env(USERDOMAIN)" 62 } else { 63 return [lindex [fconfigure $chan -peername] 1] 64 } 65 } 66 hostname { 67 return [info host] 68 } 69 default { 70 return -code error "oops: client needs to write $command" 71 } 72 } 73} 74 75# SMTPClient -- 76# 77# This implements a minimal SMTP client state engine. It will 78# do enough of the SMTP protocol to initiate a SSL/TLS link and 79# negotiate SASL parameters. Then it terminates. 80# 81proc Callback {chan eof line} { 82 variable mechs 83 variable tls 84 variable ctx 85 if {![info exists mechs]} {set mechs {}} 86 if {$eof} { set ::forever 1; return } 87 puts "> $line" 88 switch -glob -- $line { 89 "220 *" { 90 if {$tls} { 91 set tls 0 92 puts "| switching to SSL" 93 fileevent $chan readable {} 94 tls::import $chan 95 catch {tls::handshake $chan} msg 96 set mechs {} 97 fileevent $chan readable [list Read $chan ::Callback] 98 } 99 Write $chan "EHLO [info host]" 100 } 101 "250 *" { 102 if {$tls} { 103 Write $chan STARTTLS 104 } else { 105 set supported [SASL::mechanisms] 106 puts "SASL mechanisms: $mechs\ncan do $supported" 107 foreach mech $mechs { 108 if {[lsearch -exact $supported $mech] != -1} { 109 110 set ctx [SASL::new \ 111 -mechanism $mech \ 112 -callback [list [namespace origin SASLCallback] "client blob" $chan]] 113 Write $chan "AUTH $mech" 114 return 115 } 116 } 117 puts "! No matching SASL mechanism found" 118 } 119 } 120 "250-AUTH*" { 121 set line [string trim [string range $line 9 end]] 122 set mechs [concat $mechs [split $line]] 123 } 124 "250-STARTTLS*" { 125 if {![catch {package require tls}]} { 126 set tls 1 127 } 128 } 129 "235 *" { 130 SASL::cleanup $ctx 131 Write $chan "QUIT" 132 } 133 "334 *" { 134 set challenge [string range $line 4 end] 135 set e [string range $challenge end-5 end] 136 puts "? '$e' [binary scan $e H* r; set r]" 137 if {![catch {set dec [base64::decode $challenge]}]} { 138 set challenge $dec 139 } 140 141 set mech [set [subst $ctx](mech)] 142 #puts "> $challenge" 143 if {$mech eq "NTLM"} {puts ">CHA [SASL::NTLM::Debug $challenge]"} 144 set code [catch {SASL::step $ctx $challenge} err] 145 if {! $code} { 146 set rsp [SASL::response $ctx] 147 # puts "< $rsp" 148 if {$mech eq "NTLM"} {puts "<RSP [SASL::NTLM::Debug $rsp]"} 149 Write $chan [join [base64::encode $rsp] {}] 150 } else { 151 puts stderr "sasl error: $err" 152 Write $chan "QUIT" 153 } 154 } 155 "535*" { 156 Write $chan QUIT 157 } 158 default { 159 } 160 } 161} 162 163# Write -- 164# 165# Write data to the socket channel with logging. 166# 167proc Write {chan what} { 168 puts "< $what" 169 puts $chan $what 170 return 171} 172 173# Read -- 174# 175# fileevent handler reads data when available from the network socket 176# and calls the specified callback when it has recieved a complete line. 177# 178proc Read {chan callback} { 179 if {[eof $chan]} { 180 fileevent $chan readable {} 181 puts stderr "eof" 182 eval $callback [list $chan 1 {}] 183 return 184 } 185 if {[gets $chan line] != -1} { 186 eval $callback [list $chan 0 $line] 187 } 188 return 189} 190 191# connect -- 192# 193# Open an SMTP session to test out the SASL implementation. 194# 195proc connect { server port {username {}} {passwd {}}} { 196 variable mechs ; set mechs {} 197 variable tls ; set tls 0 198 199 variable user 200 if {$username ne {}} {set user(username) $username} 201 if {$passwd ne {}} {set user(password) $passwd} 202 203 puts "Connect to $server:$port" 204 set sock [socket $server $port] 205 fconfigure $sock -buffering line -blocking 1 -translation {auto crlf} 206 fileevent $sock readable [list Read $sock ::Callback] 207 after 6000 {puts timeout ; set ::forever 1} 208 vwait ::forever 209 catch {close $sock} 210 return 211} 212 213if {!$tcl_interactive} { 214 catch {eval ::connect $argv} res 215 puts $res 216} 217