smtp-client/smtp-client.tcl

#!/usr/bin/wish

tk scaling 1.2

set serverAddress "ip"
set serverPort "25"
set mailFrom "user@server.domain"
set mailRecipient "user2@server.domain"
set mailSubject "subj"



proc sendSmtpRequest { smtpRequest } {
	puts $::serverSocket $smtpRequest
	flush $::serverSocket
}


proc unexpectedDataReceiver { } {
	
	if { [eof $::serverSocket] } {
		puts "============================================================="
		disconnectFromSmtpServer
		return
	}
	
	puts [ gets $::serverSocket ]
	
	incr ::unexpectedPacketNo
	if { $::unexpectedPacketNo > 9 } {
		puts "============================================================="
		disconnectFromSmtpServer
	}
}

proc unexpectedPacketHandler { msg } {
	
	puts "Fatal protocol error. Send mail state is $::sendMailStep."
	puts "Undefined data from server:"
	puts "============================================================="
	puts "$msg"
	
	incr ::sendMailErrorFlag
	set ::unexpectedPacketNo 0
	set ::sendMailStep "error"
	fileevent $::serverSocket readable unexpectedDataReceiver
}


proc unexpectedSmtpCodeHandler { expectedCode } {
	
	incr ::sendMailErrorFlag
	puts "SMTP code is $::smtpCode, but uxpected $expectedCode"
	puts "msg $::smtpCodeDescription"
	puts "Step is $::sendMailStep"
	puts "Quiting..."
	sendSmtp_QUIT
}

proc sendSmtp_HELO { } {
	
	if { $::smtpCode != 220 } {
		unexpectedSmtpCodeHandler 220
		return
	}
	
	sendSmtpRequest "HELO $::mailFromDomain"
	set ::sendMailStep "HELO"
	set ::sendMailProgress 30
}

proc sendSmtp_MAIL_FROM { } {
	
	if { $::smtpCode != 250 } {
		unexpectedSmtpCodeHandler 250
		return
	}
	
	sendSmtpRequest "MAIL FROM: <$::mailFrom>"
	set ::sendMailStep "MAIL_FROM"
	set ::sendMailProgress 40
}

proc sendSmtp_RCPT_TO { } {
	
	if { $::smtpCode != 250 } {
		unexpectedSmtpCodeHandler 250
		return
	}
	
	sendSmtpRequest "RCPT TO: <$::mailRecipient>"
	set ::sendMailStep "RCPT_TO"
	set ::sendMailProgress 50
}

proc sendSmtp_DATA { } {
	
	if { $::smtpCode != 250 } {
		unexpectedSmtpCodeHandler 250
		return
	}
	
	sendSmtpRequest "DATA"
	set ::sendMailStep "DATA"
	set ::sendMailProgress 60
}

proc sendSmtp_mail_body { } {
	
	if { $::smtpCode != 354 } {
		unexpectedSmtpCodeHandler 354
		return
	}
	
	set currentDate [ clock format [clock seconds] -format "%a, %d %b %Y %H:%M:%S %z" ]
	
	#mail headers
	puts  $::serverSocket "From: <$::mailFrom>"
	puts  $::serverSocket "To: <$::mailRecipient>"
	puts  $::serverSocket "Subject: $::mailSubject"
	puts  $::serverSocket "Date: $currentDate"
	puts  $::serverSocket "MIME-Version: 1.0"
	puts  $::serverSocket "Content-Transfer-Encoding: 8bit"
	puts  $::serverSocket "Content-Type: text/plain; charset=\"UTF-8\""
	puts  $::serverSocket ""
	flush $::serverSocket
	
	#mail text
	puts  $::serverSocket "$::mailText"
	flush $::serverSocket
	
	#mail text terminator
	puts -nonewline $::serverSocket "\n.\n"
	flush $::serverSocket
	
	set ::sendMailStep "mail_body"
	set ::sendMailProgress 70
}

proc sendSmtp_QUIT { } {
	
	if { $::smtpCode != 250 } {
		puts "It looks like something went wrong. Code is $::smtpCode."
		puts "msg $::smtpCodeDescription"
	}
	
	sendSmtpRequest "QUIT"
	set ::sendMailStep "QUIT"
	set ::sendMailProgress 90
}

proc sendSmtp_disconnect { } {
	
	if { $::smtpCode != 221 } {
		puts "Warning: unexpected response code on QUIT command."
		puts "Code is $::smtpCode, expected 221"
		puts "msg $::smtpCodeDescription"
	}
	
	disconnectFromSmtpServer
}

proc smtpCodeParser { msg } {
	
	#normal
	set matchCount [ regexp {^([0-9]{3})([ -]{1})(.+)$} $msg fullMatch ::smtpCode ::smtpCodeMultiline ::smtpCodeDescription ]
	
	if { $matchCount == 1 } { return }
	
	#only code
	set matchCount [ regexp {^[0-9]{3}} $msg ::smtpCode ]
	
	if { $matchCount == 1 } {
		
		set ::smtpCodeDescription ""
		set ::smtpCodeMultiline " "
		puts "Warning: the received packet does not fully comply with the RFC!"
		return
	}
	
	unexpectedPacketHandler $msg
	
}

proc sendMail { } {
	
	if { [ eof $::serverSocket ] } {
		puts "Unexpected disconnection from server!"
		disconnectFromSmtpServer
		return
	}
	
	set buf [ gets $::serverSocket ]
	smtpCodeParser $buf
	
	switch $::sendMailStep {
		
		"connected" { sendSmtp_HELO       }
		"HELO"      { sendSmtp_MAIL_FROM  }
		"MAIL_FROM" { sendSmtp_RCPT_TO    }
		"RCPT_TO"   { sendSmtp_DATA       }
		"DATA"      { sendSmtp_mail_body  }
		"mail_body" { sendSmtp_QUIT       }
		"QUIT"      { sendSmtp_disconnect }
		
		default { }
	}
}


proc prepareMail { } {
	
	set matchCount [ regexp  -- "^.+@(.+)$" $::mailFrom fullMatch ::mailFromDomain ]
	
	if { $matchCount != 1 } {
		throw "error" "e-mail address invalid"
	}
	
	set ::mailText [ .tabs.writer.entry get 0.0 end ]
}

proc connect2SmtpServer { } {
	
	set ::sendMailErrorFlag 0
	set ::sendMailProgress 0
	set ::sendMailStatus ""
	
	prepareMail
	
	set ::serverSocket [ socket $::serverAddress $::serverPort ]
	puts "Connected to $::serverAddress:$::serverPort"
	fileevent $::serverSocket readable sendMail
	
	set ::sendMailStep "connected"
	set ::sendMailProgress 15
	set ::sendMailStatus "Processing..."
}

proc disconnectFromSmtpServer { } {
	
	close $::serverSocket
	puts "Disconnected from $::serverAddress:$::serverPort"
	set ::sendMailStep "disconnected"
	set ::sendMailProgress 100
	
	if { $::sendMailErrorFlag > 0 } {
		set ::sendMailStatus "Failed."
	} else {
		set ::sendMailStatus "Done."
	}
}

proc buildMainGui { } {
	
	###   TABS   ###
	ttk::notebook .tabs
	grid .tabs -padx 5 -pady 5
	
	ttk::frame .tabs.requisites
	ttk::frame .tabs.writer
	ttk::frame .tabs.attachments
	ttk::frame .tabs.send
	
	.tabs add .tabs.requisites  -text "Requisites"
	.tabs add .tabs.writer      -text "Message"
	.tabs add .tabs.attachments -text "Attachments"
	.tabs add .tabs.send        -text "Send"
	
	
	###   REQUISITES TAB   ###
	label      .tabs.requisites.fromLabel    -anchor e -text "From:" 
	label      .tabs.requisites.toLabel      -anchor e -text "To:" 
	label      .tabs.requisites.subjectLabel -anchor e -text "Subject:" 
	ttk::entry .tabs.requisites.fromEntry     -textvariable mailFrom
	ttk::entry .tabs.requisites.toEntry       -textvariable mailRecipient
	ttk::entry .tabs.requisites.subjectEntry  -textvariable mailSubject
	grid .tabs.requisites.fromLabel    -sticky we -padx 5
	grid .tabs.requisites.toLabel      -sticky we -padx 5
	grid .tabs.requisites.subjectLabel -sticky we -padx 5
	grid .tabs.requisites.fromEntry    -row 0 -column 1 -sticky we -padx 5 -pady 5
	grid .tabs.requisites.toEntry      -row 1 -column 1 -sticky we -padx 5 -pady 5
	grid .tabs.requisites.subjectEntry -row 2 -column 1 -sticky we -padx 5 -pady 5
	
	grid columnconfigure .tabs.requisites 1 -weight 1
	
	
	###   WRITER TAB   ###
	text .tabs.writer.entry -yscrollcommand ".tabs.writer.scrollV set" -xscrollcommand ".tabs.writer.scrollH set"
	ttk::scrollbar .tabs.writer.scrollV -orient vertical   -command ".tabs.writer.entry yview"
	ttk::scrollbar .tabs.writer.scrollH -orient horizontal -command ".tabs.writer.entry xview"
	
	grid .tabs.writer.entry   -row 0 -column 0
	grid .tabs.writer.scrollV -row 0 -column 1 -sticky ns
	grid .tabs.writer.scrollH -row 1 -column 0 -sticky we
	
	
	###   SEND TAB   ###
	label            .tabs.send.addressLabel -text "SMTP server:"
	ttk::entry       .tabs.send.address      -textvariable serverAddress
	ttk::entry       .tabs.send.port         -textvariable serverPort
	button           .tabs.send.button       -text "Send" -command connect2SmtpServer
	ttk::progressbar .tabs.send.progress     -variable sendMailProgress
	ttk::button      .tabs.send.cancel       -text "Cancel" -command disconnectFromSmtpServer
	label            .tabs.send.status       -textvariable sendMailStatus
	
	grid .tabs.send.addressLabel -row 0 -column 0
	grid .tabs.send.address      -row 0 -column 1
	grid .tabs.send.port         -row 0 -column 2
	grid .tabs.send.button       -row 1 -column 0
	grid .tabs.send.progress     -row 1 -column 1
	grid .tabs.send.cancel       -row 1 -column 2
	grid .tabs.send.status       -row 2 -column 1
	
	#grid rowconfigure    .tabs.send 0 -weight 1
	grid rowconfigure    .tabs.send 1 -weight 1
	grid columnconfigure .tabs.send 0 -weight 1
	grid columnconfigure .tabs.send 1 -weight 1
	
	
	###   DEBUG   ###
	ttk::button .debugButton -text "Debug" -command debugFunction
	grid        .debugButton
	
}

bind . <Control-q> { destroy . }
buildMainGui