'''Email Authentication with MIME''' , by [Jeff Gosnell], provides a couple of
[proc%|%procedures] that use [Tcllib%|%Tcllib's] [Tcllib MIME] package to
authenticate a user on a [email] server that requires authentication.


''email_authentication.tcl''

[http://www.geocities.com/machtyn]

======
 # created by Jeff Gosnell for the tcl community
 # Tuesday, May 29, 2001
 #
 # a couple of simple procedures to authenticate a user
 # on a mailserver that requires authentication.
 #
 # Take care when using these procedures.  They use the 
 # global variable array user
 #
 # run the LogOn procedure to get a nice display.
 # LogOn will then run VrfyUser 
 # Make sure the pathname is correct for your installation
 # of tcllib0.9's MIME package
 #
 # There is no visible result that the login was successful
 # except that the .logOn window will disappear.
 # When sending an email (in another procedure), 
 # use $user(nameMIME) and $user(pwMIME) to authenticate.
 #

 proc LogOn {} {
        
        set w [toplevel .logOn]
        wm geometry $w 175x140+100+100
        wm title $w "Log On Information"
        
        set sw [frame $w.name]
        label $sw.lbl -text "Username: "
        entry $sw.ent -width 15 -textvariable user(name)
        pack $sw.lbl $sw.ent -side left -padx 2 -expand true
        
        set sw [frame $w.pw]
        label $sw.lbl -text "Password: "
        entry $sw.ent -width 15 -textvariable user(pw) -show *
        pack $sw.lbl $sw.ent -side left -padx 2 -expand true

        set sw [frame $w.server]
        label $sw.lbl -text "Mail Server:"
        entry $sw.ent -width 15 -textvariable user(mailserver)
        pack $sw.lbl $sw.ent -side left -padx 2 -expand true

        set sw [frame $w.buttons]
        button $sw.ok -text Ok -command {VrfyUser .logOn} -width 8
        button $sw.cancel -text Cancel -command {destroy .logOn; array unset user; return Cancelled} -width 8
        pack $sw.ok $sw.cancel -side left -padx 5 -expand true

        pack $w.name $w.pw $w.server $w.buttons -side top -pady 2 -expand true -fill both

        bind $w <Return> {.logOn.buttons.ok invoke}

 } ;# end proc LogOn


 ##########################################
 #            proc VrfyUser               #
 #                                        #
 # This procedure is designed to verify   #
 # the username and password for          #
 # authenticating the user for emailing.  #
 # It will notify the user if it fails.   #
 #                                        #
 #                                        #
 ##########################################
 proc VrfyUser {w} {

        global user

        source "/program files/tcl/tcllib0.8/mime/mime.tcl"
        source "/program files/tcl/tcllib0.8/mime/smtp.tcl"
        package provide mime 1.2
        package provide smtp 1.2

 # display a toplevel showing the system logging in.
        toplevel $w.working -width 200 -height 100 -bg #ff3d3d
        wm overrideredirect $w.working 1
        wm geometry $w.working +150+150
        pack [frame $w.working.frame -bd 2 -relief raised -width 200 -height 100] -ipadx 1 -ipady 1
        pack [label $w.working.frame.lbl -bg #ff3d3d -relief sunken \
                        -text "Logging $user(name) on the system." 
                        ] -fill both
        update

 # convert the username to mime format
        set t_name [mime::initialize -canonical text/octet-stream \
                                        -encoding base64 -string $user(name)]
        set user(nameMIME) [lindex [mime::buildmessage $t_name] end]
        mime::finalize $t_name -subordinates all

 # convert the password to mime format
   set t_pw   [mime::initialize -canonical text/octet-stream \
                                        -encoding base64 -string $user(pw)]
        set user(pwMIME) [lindex [mime::buildmessage $t_pw] end]
        mime::finalize $t_pw -subordinates all

 # log on to the server
        set sid [socket $user(mailserver) 25]
 # if the server doesn't return 220 it failed
        if {[lindex [gets $sid] 0] != 220} {
                catch {destroy $w.msg}
                pack [label $w.msg -text "Error logging in:  \nFailed to connect to server" \
                                        -font {-family Arial -size 10} -justify left
                        ] -side bottom -pady 2
                catch {destroy $w.working}
                focus $w
                return
        }

 # log on user
        #Note the 'HELO' parameter is not actually a username.
        #It is generally supposed to be the client machines Hostname or IP address.
        # Some SMTP servers are fussier than others as to what they will accept here.
        # If the server is a 'Mail Submission Agent' for end-users it will probably accept almost anything.
        puts $sid "HELO $user(name)"
        flush $sid
        if {[lindex [gets $sid] 0] != 250} {
                catch {destroy $w.msg}
                pack [label $w.msg -text "Error during HELO greeting:  \nHelo not accepted by server" \
                                        -font {-family Arial -size 10} -justify left
                        ] -side bottom -pady 2
                catch {destroy $w.working}
                focus $w
                return
        }

 # attempt authentication
        puts $sid "AUTH LOGIN"
        flush $sid
        if {[lindex [gets $sid] 0] != 334} {
                catch {destroy $w.msg}
                pack [label $w.msg -text "Error logging in:  \nFailed to initiate authorization" \
                                        -font {-family Arial -size 10} -justify left
                        ] -side bottom -pady 2
                catch {destroy $w.working}
                focus $w
                return
        }

 # Username:
        puts $sid $user(nameMIME)
        flush $sid
        if {[lindex [gets $sid] 0] != 334} {
                catch {destroy $w.msg}
                pack [label $w.msg -text "Error logging in:  \nInvalid username or password" \
                                        -font {-family Arial -size 10} -justify left
                        ] -side bottom -pady 2
                catch {destroy $w.working}
                focus $w
                return
        }

 # Password:
        puts $sid $user(pwMIME)
        flush $sid
        if {[lindex [gets $sid] 0] != 235} {
                catch {destroy $w.msg}
                pack [label $w.msg -text "Error logging in:  \nInvalid username or password" \
                                        -font {-family Arial -size 10} -justify left
                        ] -side bottom -pady 2
                catch {destroy $w.working}
                focus $w
                return
        }

        close $sid

        destroy $w

        return "Log on successful"

 } ;# end proc VrfyUser



<<categories>> email | MIME