/tcllib-1.11.1/examples/sasl/saslclient.tcl
TCL | 212 lines | 157 code | 13 blank | 42 comment | 27 complexity | 3b25eef570259511d33d305064bbf136 MD5 | raw file
Possible License(s): AGPL-3.0
- # 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.4 2005/10/06 14:48:02 patthoyts 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
- }