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