# 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