'From Squeak 2.4c of May 10, 1999 on 31 May 1999 at 10:00:01 am'!
Object subclass: #SMTPServer
	instanceVariableNames: 'connection peerName buffer bufferPos mailFrom rcptTo mailMessage stateTable remoteLine remoteCommand '
	classVariableNames: 'CR CrLf LF ServerPort ServerProcess ServerStatus Users '
	poolDictionaries: ''
	category: 'SMTP'!
Object subclass: #SMTPServerSampleDeliver
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMTP'!

!SMTPServer commentStamp: 'BEO 5/31/1999 09:55' prior: 0!
This is an implimentation of an RFC822 SMTP server.  

Greatly inspired and liberly copied from the PluggableWebServer PWS.  Without that as an example I'm sure I never would have gotten this to work.

I copied the buffer code from the SimpleClientSocket Class which also saved me a lot of time.

Assuming no errors on my part, this should qualify as a Minimal RFC822 SMTP server.  It only does inbound mail.  For outbound mail please look at SMTPSocket.

An example can be found in SMTPServer example1.

It is pluggable for the actual mail deliverly.  You need to call Class addUserId:action: passing a string of a username, and, an object which responds to 

deliverMail: userid message: message

and does something sensible.
!

!SMTPServer reorganize!
('Accessing' getCommand getMultilineResponse getMultilineResponseShowing: getResponse getResponseShowing: reply: sendLine: waitForData:)
('Processing' cmdData cmdHelo cmdMail cmdNoop cmdQuit cmdRcpt cmdRset processCommand processMail)
('Initializing' clientName: initializeFrom:)
('Replies' errorClose errorNoUser errorSyntax errorUnknownCommand replyData replyDeliveredMail replyHelo replyMail replyNoop replyOpen replyQuit replyRcpt replyRset)
!


!SMTPServer methodsFor: 'Accessing' stamp: 'BEO 5/29/1999 14:56'!
getCommand
	"Get a one-line command from the remote system" 

	remoteLine := (self getResponse).
	^ remoteCommand := 
			((remoteLine findTokens: Character separators) first) asLowercase.
! !

!SMTPServer methodsFor: 'Accessing' stamp: 'BEO 5/22/1999 14:57'!
getMultilineResponse
	"Get a multiple line response to the last command, filtering out LF characters. A multiple line response ends with a line containing only a single period (.) character."

	^ self getMultilineResponseShowing: false.
! !

!SMTPServer methodsFor: 'Accessing' stamp: 'BEO 5/22/1999 14:57'!
getMultilineResponseShowing: showFlag
	"Get a multiple line response to the last command. A multiple line response ends with a line containing only a single period (.) character. Linefeed characters are filtered out. If showFlag is true, each line is shown in the upper-left corner of the Display as it is received."

	| response done chunk |
	response _ WriteStream on: ''.
	done _ false.
	[done] whileFalse: [
		showFlag
			ifTrue: [chunk _ self getResponseShowing: true]
			ifFalse: [chunk _ self getResponse].
		(chunk beginsWith: '.')
			ifTrue: [ response nextPutAll: (chunk copyFrom: 2 to: chunk size) ]
			ifFalse: [ response nextPutAll: chunk ].
		done _ (chunk = ('.', String cr)) ].

	^ response contents
! !

!SMTPServer methodsFor: 'Accessing' stamp: 'BEO 5/22/1999 14:56'!
getResponse
	"Get a one-line response from the server.  The final LF is removed from the line, but the CR is left, so that the line is in Squeak's text format"

	^ self getResponseShowing: false
! !

!SMTPServer methodsFor: 'Accessing' stamp: 'BEO 5/30/1999 15:28'!
getResponseShowing: showFlag

	| line idx |
	line _ WriteStream on: String new.

	buffer ifNil: [
		buffer _ String new.
		bufferPos _ 0 ].

	[
		"look for a LF in the buffer"
		idx _ buffer indexOf: Character lf startingAt: bufferPos+1 ifAbsent: [ 0 ].
		idx > 0 ifTrue: [
			"found it!! we have a line"
			line nextPutAll: (buffer copyFrom: bufferPos+1 to: idx-1).
			bufferPos _ idx.
			^line contents ].
		
		"didn't find it.  add the whole buffer to the line, and retrieve some more data"
		line nextPutAll: (buffer copyFrom: bufferPos+1 to: buffer size).
		bufferPos _ 0.
		buffer _ String new.
		connection waitForDataUntil: 30.
		buffer _ connection getData.

		true
	] whileTrue.! !

!SMTPServer methodsFor: 'Accessing' stamp: 'BEO 5/22/1999 14:50'!
reply: aString
	"Send back the reply."

	((connection ~~ nil) and: [connection isConnected])
		ifTrue: [self sendLine: aString].
! !

!SMTPServer methodsFor: 'Accessing' stamp: 'BEO 5/30/1999 14:59'!
sendLine: lineString
	"Send the given line followed by a <CR><LF> terminator."

	connection sendData: lineString, CrLf.
! !

!SMTPServer methodsFor: 'Accessing' stamp: 'BEO 5/22/1999 15:10'!
waitForData: seconds
	"Wait for data to arrive for seconds seconds.  If no data arrives then 		destroy the socket and raise an error."

	| gotData |
	gotData _ false.
	[gotData]
		whileFalse: [
			gotData _ connection waitForDataUntil: (Socket deadlineSecs:
				seconds).
			gotData ifFalse: [
				connection isConnected ifFalse: [
					connection destroy.
					self error: 'server closed connection'].
				connection destroy.
				self error: 'no response from server']].
! !

!SMTPServer methodsFor: 'Processing' stamp: 'BEO 5/31/1999 09:20'!
cmdData
	"Process the Data cmd"
	self replyData.
	mailMessage := self getMultilineResponse.
	"actually deliver the message"
	rcptTo do: [:receipt |
		(Users at: receipt) deliverMail: receipt message: mailMessage.].
	self replyDeliveredMail.

	"Update the state table to have the right commands"
	stateTable := Dictionary new.
	"Don't forget perform: "
	stateTable at: 'mail' put: #cmdMail.
	stateTable at: 'rset' put: #cmdRset.
	stateTable at: 'noop' put: #cmdNoop.
	stateTable at: 'quit' put: #cmdQuit.
! !

!SMTPServer methodsFor: 'Processing' stamp: 'BEO 5/29/1999 15:17'!
cmdHelo
	"Process the Helo cmd - not done"
	self replyHelo.
	"Update the state table to have the right commands"
	stateTable := Dictionary new.
	"Don't forget perform: "
	stateTable at: 'mail' put: #cmdMail.
	stateTable at: 'rset' put: #cmdRset.
	stateTable at: 'noop' put: #cmdNoop.
	stateTable at: 'quit' put: #cmdQuit.
! !

!SMTPServer methodsFor: 'Processing' stamp: 'BEO 5/29/1999 15:28'!
cmdMail
	"Process the Mail cmd"
	mailFrom :=  ((remoteLine findTokens: Character separators) second) 			asLowercase.
	mailFrom := mailFrom findTokens: '<>'.
	"Update the state table to have the right commands"
	stateTable := Dictionary new.

	mailFrom 
		ifNil: [
			self errorSyntax.
			stateTable at: 'mail' put: #cmdMail.]
		ifNotNil: [
			self replyMail.
			stateTable at: 'rcpt' put: #cmdRcpt.].
	stateTable at: 'rset' put: #cmdRset.
	stateTable at: 'noop' put: #cmdNoop.
	stateTable at: 'quit' put: #cmdQuit.


! !

!SMTPServer methodsFor: 'Processing' stamp: 'BEO 5/29/1999 15:17'!
cmdNoop
	"Process the Noop cmd"
	self replyNoop.! !

!SMTPServer methodsFor: 'Processing' stamp: 'BEO 5/31/1999 09:21'!
cmdQuit
	"Process the Quit cmd"
	self replyQuit.
	(Delay forMilliseconds: 1000) wait.
	connection destroy.! !

!SMTPServer methodsFor: 'Processing' stamp: 'BEO 5/31/1999 09:24'!
cmdRcpt
	"Process the Rcpt cmd"
	| receipt |
	receipt :=  ((remoteLine findTokens: ' :') third) asLowercase.
	receipt := (receipt findTokens: '<>') first.

	"Update the state table to have the right commands"
	stateTable := Dictionary new.

	receipt 
		ifNil: [
			self errorSyntax.
			stateTable at: 'rcpt' put: #cmdRcpt.]
		ifNotNil: [
			"does the user exist?"
			(Users includesKey: receipt) 
				ifFalse: [
					self errorNoUser.]
				ifTrue: [
					"add receipt to the collection of receiptents"
					rcptTo ifNil: [rcptTo := Bag new].
					rcptTo add: receipt.
			
					self replyRcpt.
					stateTable at: 'data' put: #cmdData.].].
	stateTable at: 'rcpt' put: #cmdRcpt.
	stateTable at: 'rset' put: #cmdRset.
	stateTable at: 'noop' put: #cmdNoop.
	stateTable at: 'quit' put: #cmdQuit.

! !

!SMTPServer methodsFor: 'Processing' stamp: 'BEO 5/29/1999 15:17'!
cmdRset
	"Process the Rset cmd"
	self replyRset.
	stateTable := Dictionary new.
	"Don't forget perform: "
	stateTable at: 'mail' put: #cmdMail.
	stateTable at: 'rset' put: #cmdRset.
	stateTable at: 'noop' put: #cmdNoop.
	stateTable at: 'quit' put: #cmdQuit.
	mailMessage := nil.
	rcptTo := nil.
	mailFrom := nil.! !

!SMTPServer methodsFor: 'Processing' stamp: 'BEO 5/29/1999 14:59'!
processCommand
	"Process a command"

	self getCommand.
	(stateTable includesKey: remoteCommand) 
		ifFalse: 	[self errorUnknownCommand]
		ifTrue: [self perform: (stateTable at: remoteCommand)].
! !

!SMTPServer methodsFor: 'Processing' stamp: 'BEO 5/29/1999 14:58'!
processMail
	"Actually process the mail message"
	[connection isConnected] whileTrue: 
		[self processCommand.].
! !

!SMTPServer methodsFor: 'Initializing' stamp: 'BEO 5/22/1999 13:53'!
clientName: addr
	"Return the host name of the client connecting via the given socket. If the host name cannot be found, return a string representing that host's numeric IP address."
	| addrString name |
	addrString _ NetNameResolver stringFromAddress: addr.
	name _ NetNameResolver nameForAddress: addr timeout: 15.
	name ifNil: [name _ addrString].  "lookup failed or timed out; use numeric address"

! !

!SMTPServer methodsFor: 'Initializing' stamp: 'BEO 5/31/1999 09:19'!
initializeFrom: aSocket
	"Initialize me from aSocket."
	connection := aSocket.
	"peerName := self clientName: connection remoteAddress.
		Transcript show: 'Got a peerName of '; show: peerName; cr."
	self replyOpen.
	stateTable := Dictionary new.
	"Don't forget perform: "
	stateTable at: 'helo' put: #cmdHelo.
	stateTable at: 'rset' put: #cmdRset.
	stateTable at: 'noop' put: #cmdNoop.
	stateTable at: 'quit' put: #cmdQuit.


! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/22/1999 15:11'!
errorClose
	[self reply: '451 Somthing wicked this way came'] 
		ifError:  [:m :r | "ignore errors"].
	connection destroy.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/31/1999 09:19'!
errorNoUser
	self reply: '550 The user has left the building'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 15:26'!
errorSyntax
	self reply: '501 Huh?  Check your syntax'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 14:45'!
errorUnknownCommand
	self reply: '502 You asked but I do not know the answer'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 15:36'!
replyData
	self reply: '354 Start talking to me, end with <CRLF>.<CRLF>'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 22:02'!
replyDeliveredMail
	self reply: '250 Delivering Mail'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 15:08'!
replyHelo
	self reply: '250 Hi Yall'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 15:20'!
replyMail
	self reply: '250 Hi Yall'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 15:11'!
replyNoop
	self reply: '250 Hi Yall'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 15:09'!
replyOpen
	self reply: '220 SMTP Service Ready. Hi Yall'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 15:07'!
replyQuit
	self reply: '221 SMTP Closing.  See Ya'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 15:31'!
replyRcpt
	self reply: '250 Hi Yall'.! !

!SMTPServer methodsFor: 'Replies' stamp: 'BEO 5/29/1999 15:11'!
replyRset
	self reply: '250 Hi Yall'.! !


!SMTPServer class methodsFor: 'Serving' stamp: 'BEO 5/30/1999 14:47'!
loopOnPort25
	"Loop forever handling SMTP requests."

	| socket |
	[true] whileTrue: [
		socket _ ServerPort getConnectionOrNil.
		socket notNil
			ifTrue: [
				Transcript show: 'got connection'.
				self receiveMail: socket]
			ifFalse: [
				(Delay forMilliseconds: 100) wait]].
! !

!SMTPServer class methodsFor: 'Serving' stamp: 'BEO 5/31/1999 09:57'!
receiveMail: aSocket
	"Respond to a request arriving on the given socket and return a string to be entered in the log file."

	| inst |
	inst _ self new.
	[inst initializeFrom: aSocket.
	 inst processMail] ifError: [:msg :rec | 
		Transcript show: 'error in receiveMail '; 
			show: msg asString; 
			show: rec asString; cr.
		inst errorClose].
	aSocket closeAndDestroy: 30.
! !

!SMTPServer class methodsFor: 'Serving' stamp: 'BEO 5/22/1999 14:54'!
serveOnPort25
	"Start up the SMTP server loop."

	CR _ Character cr.
	LF _ Character linefeed.

	"string for command line termination:"
	CrLf _ String with: CR with: LF.

	self stopServer.
	Socket initializeNetwork.
	ServerPort _ ConnectionQueue portNumber: 25 queueLength: 6.

	ServerProcess _ [self loopOnPort25] newProcess.
	ServerProcess priority: Processor lowIOPriority.
	ServerProcess resume.
! !

!SMTPServer class methodsFor: 'Serving' stamp: 'BEO 5/21/1999 15:36'!
shutDown

	self stopServer! !

!SMTPServer class methodsFor: 'Serving' stamp: 'BEO 5/21/1999 15:35'!
stopServer
	"Shut down the server."

	ServerProcess	ifNotNil: [ServerProcess terminate].
	ServerPort		ifNotNil: [ServerPort destroy].
	ServerProcess _ ServerPort _ nil.
! !

!SMTPServer class methodsFor: 'Initializing' stamp: 'BEO 5/29/1999 21:57'!
addUserId: userId action: action
	"Add a userid with an action"
	Users ifNil: [Users := Dictionary new.].
	Users at: userId put: action.! !

!SMTPServer class methodsFor: 'Initializing' stamp: 'BEO 5/30/1999 15:09'!
cleanUserIds
	"Clean up the users array"
	Users := nil.
! !

!SMTPServer class methodsFor: 'Example' stamp: 'BEO 5/31/1999 09:59'!
example1

	"A test example for SMTPServer.  Open a Transcript :-)

	SMTPServer example1.
	"
	SMTPServer addUserId: 'user1' action: SMTPServerSampleDeliver new.
	SMTPServer addUserId: 'user2' action: SMTPServerSampleDeliver new.
	SMTPServer serveOnPort25.

	SMTPSocket deliverMailFrom: 'beoneel@mindspring.com' to: #(user1 user2) 
		text:
'From: test
To: "not listed"
Subject: this is a test

Hello from Squeak!!
'	usingServer: '1.2.3.4'.

	SMTPServer shutDown.
	SMTPServer cleanUserIds.
! !


!SMTPServerSampleDeliver commentStamp: 'BEO 5/31/1999 09:50' prior: 0!
A very simple example of a SMTPServer Plugin.!

!SMTPServerSampleDeliver reorganize!
('Examples' deliverMail:message:)
!


!SMTPServerSampleDeliver methodsFor: 'Examples' stamp: 'BEO 5/30/1999 14:34'!
deliverMail: receipt message: mailMessage
	Transcript show: 'Sending mail to ';
		show: (receipt printString);
		show: 'the message ';
		show: (mailMessage printString); 
		cr.! !


SMTPServer removeSelector: #serv:!
SMTPServer removeSelector: #serve:!
SMTPServer class removeSelector: #AddUserId:Action:!
SMTPServer class removeSelector: #serve:!
Smalltalk removeClassNamed: #SMTPServerSamplDeliver!