;;
;;  Parser and state machine for the grammar defined in RFC 5321,
;;  "Simple Mail Transfer Protocol".
;;
;;  Based on the Haskell Rfc2821 module by Peter Simons.
;;
;;  Copyright 2009 Ivan Raikov and the Okinawa Institute of Science and Technology.
;;
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.

(module smtp 

	(
	 mailbox? Mailbox 

	 reply? Reply make-reply 
	 reply-success? reply-failure? reply-shutdown?

	 success-code? success-code-inject success-code-project 
	 Unused PreliminarySuccess Success IntermediateSuccess
	 TransientFailure PermanentFailure

	 category? category-inject category-project
	 Syntax Information Connection Unspecified3 Unspecified4
	 MailSystem

	 code? Code

	 event?
  
	 cmd? Helo Ehlo MailFrom RcptTo Data Rset Send Soml Saml
	 Vrfy Expn Help Noop Quit Turn WrongArg wrong-arg

	 parse-cmd start-session session-fsm?
        )

	(import scheme chicken data-structures )

	(require-library extras abnf abnf-consumers)
	(import (prefix abnf abnf:) 
		(prefix abnf-consumers abnf:) 
		(only extras sprintf fprintf ))

	(require-extension srfi-1 srfi-13 srfi-14 datatype matchable )
	(import-for-syntax matchable)

(define consumed-objects-lift-any
  (abnf:consumed-objects-lift
   (abnf:consumed-objects identity)))

(define (list->domain-string lst)
  (if (and (pair? lst) (char=? (last lst) #\-))
      (error "domain string ends with - " 
	     (list->string lst))
      (list->string lst)))

(define-syntax bind-consumed->domain-string
  (syntax-rules () 
    ((_ p)    (abnf:bind 
	       (abnf:consumed-chars->list list->domain-string)
	       (abnf:longest p)))
    ))


(define-syntax define-enumerated-type
  (lambda (x r c)
    (match-let (((_ typename pred vector inject project . rest) x))
    (let ((%define  (r 'define))
	  (%begin   (r 'begin))
	  (%if      (r 'if)))
      `(,%begin
	(,%define (,pred x)    (##sys#structure? x ',typename))
	(,%define (,project x) (##sys#slot x 2))
	(,%define (,inject i)  
		  (and (integer? i) (positive? i) (< i (vector-length ,vector)) 
		       (vector-ref ,vector i)))
	,(let loop ((variants rest) (i 0) (defs (list)))
	   (if (null? variants) 
	       `(,%begin ,@defs)
	       (let* ((variant  (car variants))
		      (def  `(,%define ,variant   
				       (##sys#make-structure ',typename ',(car variant) ,i))))
		 (loop (cdr variants) (+ i 1) (cons def defs)))))
	,(let loop ((variants rest) (defs (list)))
	   (if (null? variants) 
	       `(,%define ,vector (vector ,@(reverse defs)))
	       (let* ((variant  (car variants))
		      (def  `(,(car variant))))
		 (loop (cdr variants) (cons def defs)))))
	)))))

(define-datatype mailbox mailbox?
  (Mailbox (local-part string?) 
	   (domain string?)))


(define-record-printer (mailbox x out)
  (match x 
	 (($ mailbox 'Mailbox "" "" )  (fprintf out "<>"))
	 (($ mailbox 'Mailbox "postmaster" "" )  (fprintf out "<postmaster>"))
	 (($ mailbox 'Mailbox l d )  
	  (let ((mbox  (sprintf "~A@~A" l d)))
	    (fprintf out "<~A>" mbox)))))

(define (null-mailbox) (Mailbox "" ""))

(define (postmaster . rest) 
  (let-optionals rest ((domain ""))
   (Mailbox "postmaster" domain )))


;; An SMTP reply is a three-digit return code plus some waste of
;; bandwidth called "comments". This is what the list of strings is
;; for; one string per line in the reply.  the record printer will
;; append an CRLF end-of-line marker to each entry in that list, so
;; that the resulting string is ready to be sent back to the peer.
;;
;; Here is an example:
;;
;; > (print (Reply (Code (Success) (MailSystem) 0)
;;                     (list "worked" "like" "a charm")))
;; 250-worked
;; 250-like
;; 250 a charm

(define-datatype reply reply?
  (Reply (code code?) (msg list?)))

(define-enumerated-type 
  success-code success-code? success-vector 
  success-code-inject success-code-project 
  (Unused)
  (PreliminarySuccess)
  (Success)
  (IntermediateSuccess)
  (TransientFailure)
  (PermanentFailure))

(define-enumerated-type 
  category category? category-vector
  category-inject category-project
  (Syntax)
  (Information)
  (Connection)
  (Unspecified3)
  (Unspecified4)
  (MailSystem))

(define-datatype code code?
  (Code (suc success-code?) (cat category?) (num integer?)))

(define-record-printer (reply x out)
  (match x 
	 (($ reply 'Reply (and c ($ code 'Code suc cat _)) ())
	  (let ((msg (sprintf "~A in category ~A" suc cat)))
	    (fprintf out "~A" (Reply c (list msg)))))

	 (($ reply 'Reply code msg) 
	  (let ((prefix-con (sprintf "~A-" code))
		(prefix-end (sprintf "~A " code))
		(fmt        (lambda (p) (lambda (l) (sprintf "~A~A\r\n" p l)))))
	    (match-let (((x . xs) (reverse msg)))
		       (let* ((msg-con (map (fmt prefix-con) xs))
			      (msg-end ((fmt prefix-end) x))
			      (msg1    (reverse (cons msg-end msg-con))))
			 (fprintf out "~A" (string-concatenate msg1))))))
	 ))

(define-record-printer (code x out)
  (cases code x
	 (Code (suc cat n)  
	       (fprintf out "~A~A~A" (success-code-project suc) 
			(category-project cat) n))))
	  
;; Constructs a Reply. 

(define (in-range-incl? lo hi)
  (if (< hi lo) (in-range-incl? hi lo)
      (lambda (x) (and (<= lo x) (<= x hi)))))

(define check-suc  (in-range-incl? 0 5))
(define check-cat  (in-range-incl? 0 5))
(define check-code (in-range-incl? 0 9))

(define (make-reply suc cat n msg)
  (or (and (check-suc suc) (check-cat cat) (check-code n)
	   (Reply (Code (success-code-inject suc) (category-inject cat) n) msg))
      (error 'make-reply "arguments out of range: " suc cat n)))


;; A reply constitutes success if the status code is any of
;; PreliminarySuccess, Success, or IntermediateSuccess.

(define (reply-success? r)
  (match r (($ reply 'Reply 
	       ($ code 'Code 
		  ($ success-code (or 'PreliminarySuccess 
				      'IntermediateSuccess 'Success _) _ _) _))
	    #t)
	 (else #f)))

;; A reply constitutes failure if the status code is either
;; PermanentFailure or TransientFailure.

(define (reply-failure? r)
  (match r (($ reply 'Reply 
	       ($ code 'Code 
		  ($ success-code (or 'PermanentFailure 
				      'TransientFailure _) _ _) _))
	    #t)
	 (else #f)))

;; The replies 221 and 421 signify Shutdown.

(define (reply-shutdown? r)
  (match r (($ reply 'Reply 
	       ($ code 'Code ($ success-code (or 'Success 
						 'TransientFailure) _) 
		  ($ category 'Connection _) 1) _)
	    #t)
	 (else #f)))


;; Argument Parsers

;; Match any US-ASCII character except for control characters,
;; specials, or space. atom and dot-atom are made up of this.

(define atext (abnf:alternatives
	       abnf:alpha
	       abnf:decimal
	       (abnf:set-from-string "!#$%&'*+-/=?^_`{|}~")))

(define Atom         (abnf:bind-consumed->string (abnf:repetition1 atext)))

(define Dot-string   (abnf:bind-consumed->string 
		      (abnf:concatenation
		       (abnf:repetition1 atext) 
		       (abnf:repetition
			(abnf:concatenation
			 (abnf:char #\.) 
			 (abnf:repetition1 atext))))))

;; backslash followed by any ASCII graphic (including itself) or space
(define quoted-pairSMTP  (abnf:concatenation
			  (abnf:char #\\) 
			  (abnf:set char-set:printing)))

;; within a quoted string, any ASCII graphic or space is permitted
;; without blackslash-quoting except double-quote and the backslash
;; itself.
(define qtextSMTP        (abnf:set
			  (char-set-difference 
			   char-set:printing
			   (char-set #\" #\\))))

(define QcontentSMTP     (abnf:alternatives qtextSMTP quoted-pairSMTP))

(define Quoted-string    (abnf:bind-consumed->string 
			  (abnf:concatenation
			   (abnf:drop-consumed abnf:dquote) 
			   (abnf:repetition QcontentSMTP) 
			   (abnf:drop-consumed abnf:dquote))))

(define String           (abnf:alternatives Atom Quoted-string))

(define esmtp-keyword   (abnf:bind-consumed->symbol
			 (abnf:concatenation
			  (abnf:alternatives abnf:alpha abnf:decimal) 
			  (abnf:repetition
			   (abnf:alternatives 
			    abnf:alpha
			    abnf:decimal
			    (abnf:char #\-))))))

(define esmtp-value    (abnf:bind-consumed->string
			(abnf:repetition1 
			 (abnf:set (char-set-difference
				    char-set:graphic (char-set #\= #\space))))))
;; any CHAR excluding "=", SP, and control
;; characters.  If this string is an email address,
;; i.e., a Mailbox, then the "xtext" syntax [32]
;; SHOULD be used.

(define esmtp-param     (abnf:bind-consumed-strings->list
			 (abnf:concatenation
			  esmtp-keyword 
			  (abnf:optional-sequence
			   (abnf:concatenation 
			    (abnf:drop-consumed (abnf:char #\=)) 
			    esmtp-value)))))



(define Mail-parameters  (abnf:bind-consumed-pairs->list
			  (abnf:concatenation
			   esmtp-param
			   (abnf:repetition 
			    (abnf:concatenation 
			     (abnf:drop-consumed abnf:sp) 
			     esmtp-param)))))

(define Ldh-str        (bind-consumed->domain-string
			(abnf:concatenation 
			 abnf:alpha 
			 (abnf:repetition
			  (abnf:alternatives
			   abnf:alpha abnf:decimal (abnf:char #\-))))))

(define sub-domain     Ldh-str)

(define domain         (abnf:bind-consumed-strings->list
			(lambda (l) 
			  (string-concatenate (intersperse l ".")))
			(abnf:concatenation 
			 sub-domain
			 (abnf:repetition
			  (abnf:concatenation 
			   (abnf:drop-consumed (abnf:char #\.)) 
			  sub-domain)))))

(define At-domain    (abnf:concatenation 
		      (abnf:drop-consumed (abnf:char #\@)) 
		      domain))

(define A-d-l        (abnf:bind-consumed-strings->list 
		      (abnf:concatenation
		       At-domain
		       (abnf:repetition
			(abnf:concatenation
			 (abnf:drop-consumed (abnf:char #\,)) 
			 At-domain)))))

(define Local-part   (abnf:alternatives
		      Dot-string
		      Quoted-string))

(define IPv6-hex     (abnf:bind-consumed->string 
		      (abnf:variable-repetition 1 4 abnf:hexadecimal)))

(define cIPv6-hex    (abnf:concatenation
		      (abnf:drop-consumed (abnf:char #\:)) 
		      IPv6-hex))

(define IPv6-full    (abnf:bind-consumed-strings->list 
		      (abnf:concatenation 
		       IPv6-hex
		       (abnf:repetition-n 7 cIPv6-hex))))

(define IPv6-comp    (abnf:bind-consumed-strings->list
		      (abnf:concatenation
		       (abnf:optional-sequence
			(abnf:concatenation 
			 IPv6-hex
			 (abnf:variable-repetition 0 5 cIPv6-hex)))
		       (abnf:bind-consumed->string (abnf:lit "::"))
		       (abnf:optional-sequence
			(abnf:concatenation 
			 IPv6-hex
			 (abnf:variable-repetition 0 5 cIPv6-hex))))))
;; The "::" represents at least 2 16-bit groups of zeros.  No more
;; than 6 groups in addition to the "::" may be present.

(define Snum        
  (abnf:bind-consumed->string
   (abnf:variable-repetition 1 3 abnf:decimal)))

(define IPv4-address-literal  (abnf:concatenation 
			       Snum 
			       (abnf:repetition-n 
				3 (abnf:concatenation 
				   (abnf:drop-consumed (abnf:char #\.))  
				   Snum))))

(define IPv6v4-full   (abnf:bind-consumed-strings->list
		       (abnf:concatenation 
			IPv6-hex (abnf:repetition-n 5 cIPv6-hex) 
			(abnf:drop-consumed (abnf:char #\:))
			IPv4-address-literal)))

(define IPv6v4-comp   (abnf:bind-consumed-strings->list
		       (abnf:concatenation 
			(abnf:optional-sequence
			 (abnf:concatenation
			  IPv6-hex
			  (abnf:variable-repetition 0 3 cIPv6-hex)))
			(abnf:bind-consumed->string (abnf:lit "::"))
			(abnf:optional-sequence
			 (abnf:concatenation
			  IPv6-hex
			  (abnf:variable-repetition 0 3 cIPv6-hex) 
			 (abnf:drop-consumed (abnf:char #\:))))
			IPv4-address-literal)))
;; The "::" represents at least 2 16-bit groups of zeros.  No more
;; than 4 groups in addition to the "::" and IPv4-address-literal may
;; be present.

(define IPv6-addr   (abnf:alternatives IPv6-full IPv6-comp 
				       IPv6v4-full IPv6v4-comp))

(define IPv6-address-literal  (abnf:concatenation
			       (abnf:bind-consumed->string (abnf:lit "IPv6:")) IPv6-addr))

(define dcontent  (abnf:set (char-set-difference
			     char-set:printing 
			     (char-set #\[ #\] #\\))))

(define Standardized-tag  (abnf:bind-consumed->symbol Ldh-str))
;; Standardized-tag MUST be specified in a Standards-Track RFC and
;; registered with IANA

(define General-address-literal  (abnf:concatenation
				  Standardized-tag (abnf:drop-consumed (abnf:char #\:))
				  (abnf:repetition1 dcontent)))

(define address-literal  (abnf:concatenation
			  (abnf:char #\[) 
			  (abnf:alternatives
			   IPv4-address-literal 
			   IPv6-address-literal 
			   General-address-literal)
			  (abnf:char #\])))
;; See Section 4.1.3

(define Mailbox-p 
  (abnf:bind
   (consumed-objects-lift-any 
    (lambda (x) (Mailbox (first x) (second x))))
   (abnf:concatenation 
    Local-part
    (abnf:drop-consumed (abnf:char #\@) )
    (abnf:alternatives domain address-literal))))

(define Path-p
  (abnf:bind 
   (consumed-objects-lift-any first)
   (abnf:concatenation
    (abnf:drop-consumed (abnf:char #\<) )
    (abnf:optional-sequence 
     (abnf:drop-consumed
      (abnf:concatenation 
       A-d-l 
       (abnf:char #\:))))
    Mailbox-p
    (abnf:drop-consumed (abnf:char #\>)))))

(define Forward-path   Path-p)

(define Reverse-path 
  (abnf:alternatives 
   (abnf:bind
    (consumed-objects-lift-any 
     (lambda x (null-mailbox)))
    (abnf:concatenation
     (abnf:char #\<) (abnf:char #\>)))
   Path-p))

(define from-path
  (abnf:concatenation
   (abnf:drop-consumed (abnf:lit "FROM:"))
   Reverse-path))

(define to-path 
  (abnf:concatenation
   (abnf:drop-consumed (abnf:lit "TO:"))
   (abnf:alternatives 

    (abnf:bind
     (consumed-objects-lift-any 
      (lambda (x) (postmaster)))
     (abnf:concatenation
      (abnf:char #\<) 
      (abnf:lit "Postmaster") 
      (abnf:char #\>)))

    (abnf:bind
     (consumed-objects-lift-any 
      (lambda (x) (postmaster (first x))))
     (abnf:concatenation
      (abnf:drop-consumed (abnf:char #\<) )
      (abnf:drop-consumed (abnf:lit "Postmaster@") )
      domain 
      (abnf:drop-consumed (abnf:char #\>))))

    Forward-path)))


;; ESMTP sessions, events, commands

(define-datatype session-state session-state?
  (Unknown)
  (HaveHelo)
  (HaveMailFrom)
  (HaveRcptTo)
  (HaveData)
  (HaveQuit))

(define-record-printer (session-state x out)
  (fprintf out "<#session-state ~A>" 
	   (cases session-state x
		  (Unknown ()      "Unknown")
		  (HaveHelo ()     "HaveHelo")
		  (HaveMailFrom () "HaveMailFrom")
		  (HaveRcptTo   () "HaveRcptTo")
		  (HaveData     () "HaveData")
		  (HaveQuit     () "HaveQuit"))))

(define-datatype event event?
  (SayHelo       (s string?))
  (SayHeloAgain  (s string?))
  (SayEhlo       (s string?))
  (SayEhloAgain  (s string?))
  (SetMailFrom   (m mailbox?) (parameters? list))
  (AddRcptTo     (m mailbox?) (parameters? list))
  (StartData)
  (NeedHeloFirst)
  (NeedMailFromFirst)
  (NeedRcptToFirst)
  (NotImplemented) ;; Turn, Send, Soml, Saml, Vrfy, Expn.
  (ResetState)
  (SayOK)
  ;; Triggered in case of Noop or when Rset is used before
  ;; we even have a state.
  (SeeksHelp    (s string?))
  (Shutdown)
  (SyntaxErrorIn (s string?))
  (Unrecognized  (s string?)))
  
(define-datatype cmd cmd?
  (Helo (s string?))
  (Ehlo (s string?))
  (MailFrom (m mailbox?) (parameters list?))
  (RcptTo   (m mailbox?) (parameters list?))
  (Data)
  (Rset)
  (Send  (m mailbox?))
  (Soml  (m mailbox?))
  (Saml  (m mailbox?))
  (Vrfy  (s string?))
  (Expn  (s string?))
  (Help  (s string?))
  (Noop)
  (Quit)
  (Turn)
;; When a valid command has been recognized, but the
;; argument parser fails, then this type will be
;; returned. 
  (WrongArg (cmd string?)  (message string?)))

(define-record-printer (cmd x out)
  (cases cmd x 
	 (Helo (s)        (fprintf out "HELO ~A" s))
	 (Ehlo (s)        (fprintf out "EHLO ~A" s))
	 (MailFrom (m p)  (fprintf out "MAIL FROM:~A" m))
	 (RcptTo (m p)    (fprintf out "RCPT TO: ~A" m))
	 (Data ()         (fprintf out "DATA"))
	 (Rset ()         (fprintf out "RSET"))
	 (Send (m)        (fprintf out "SEND ~A" m))
	 (Soml (m)        (fprintf out "SOML ~A" m))
	 (Saml (m)        (fprintf out "SAML ~A" m))
	 (Vrfy (s)        (fprintf out "VRFY ~A" s))
	 (Expn (s)        (fprintf out "EXPN ~A" s))
	 (Noop ()         (fprintf out "NOOP"))
	 (Quit ()         (fprintf out "QUIT"))
	 (Turn ()         (fprintf out "TURN"))
	 (Help (s)        (fprintf out "HELP ~A" s))
	 (WrongArg (s)    (fprintf out "Syntax error in argument of ~A." s))))

;; Command Parsers

;; Constructs a parser for a command without arguments.

(define (mkcmdp0 s kons)  
  (define (ignore x) (kons))
  (let ((ss (->string s)))
    (abnf:bind (consumed-objects-lift-any ignore)
     (abnf:concatenation
      (abnf:bind-consumed->symbol (abnf:lit ss))
      (abnf:drop-consumed (abnf:repetition abnf:sp))
      (abnf:drop-consumed abnf:crlf)
      ))))

;; Constructs a WrongArg command
(define (wrong-arg cmd)
  (abnf:bind (lambda (x) (list (WrongArg cmd "")))
	     abnf:pass))

;; Constructs a parser for a command with an argument, which the given
;; parser will handle. The result of the argument parser will be
;; applied to the given constructor procedure before returning.

(define (mkcmdp1 s kons p . r)  
  (let ((ss (->string s))
	(make (if (null? r)
		  (lambda (x) (kons (first x)))
		  (lambda (x)
		    (match x ((x r) (kons x r))
			   ((x) (kons x (list)))
			   )))))

    (abnf:bind (consumed-objects-lift-any make) 

       (abnf:concatenation
	
	(abnf:drop-consumed (abnf:lit ss))
	(abnf:drop-consumed (abnf:repetition abnf:sp))
	
	(abnf:alternatives p (wrong-arg ss) )

	(if (null? r)
	    (abnf:drop-consumed abnf:crlf)
	    (abnf:concatenation
	     (abnf:optional-sequence 
	      (abnf:concatenation
	       (abnf:drop-consumed (abnf:repetition abnf:sp))
	       (car r)))
	     (abnf:drop-consumed abnf:crlf)))

	))
    ))



;; The SMTP parsers defined here correspond to the commands specified
;; in the RFC.

(define data (mkcmdp0 "DATA" Data))
(define rset (mkcmdp0 "RSET" Rset))
(define quit (mkcmdp0 "QUIT" Quit))
(define turn (mkcmdp0 "TURN" Turn))
(define helo (mkcmdp1 "HELO" Helo     domain))
(define ehlo (mkcmdp1 "EHLO" Ehlo     domain))
(define vrfy (mkcmdp1 "VRFY" Vrfy     (abnf:concatenation 
					(abnf:drop-consumed abnf:sp) String)))
(define expn (mkcmdp1 "EXPN" Expn     (abnf:concatenation 
				       (abnf:drop-consumed abnf:sp) String)))

(define rcpt (mkcmdp1 "RCPT" RcptTo   to-path Mail-parameters))
(define mail (mkcmdp1 "MAIL" MailFrom from-path Mail-parameters))
(define send (mkcmdp1 "SEND" Send     from-path))
(define soml (mkcmdp1 "SOML" Soml     from-path))
(define saml (mkcmdp1 "SAML" Saml     from-path))

(define help (mkcmdp1 "HELP" (lambda (x) (if (null? x) (Help) (Help (car x))))
		      (abnf:optional-sequence
		       (abnf:concatenation (abnf:drop-consumed abnf:sp)
					   String))))

(define noop0 (mkcmdp1 "NOOP" (lambda (x) (Noop))
		       (abnf:optional-sequence 
			(abnf:concatenation (abnf:drop-consumed abnf:sp)
					    String))))
		       

(define smtp-cmd 
  (abnf:longest
   (abnf:alternatives
    data rset noop0 quit turn helo mail rcpt 
    send soml saml vrfy expn help ehlo
    ))
  )

(define (parse-cmd cont)
  (let ((cont1 (lambda (s) (cont (map caar s)))))
    (lambda (s) (smtp-cmd cont1 s))))


;; ESMTP State Machine

(define-datatype session-fsm session-fsm?
  (Event (ev event?))
  (Trans (ev event?) (fsm procedure?)))

;; Parses an SMTP protocol line and runs handle-cmd to determine the
;; event. In case of syntax errors, SyntaxErrorIn or Unrecognized will
;; be returned.  Inputs must be terminated with CRLF.

(define (fsm st) 
  (lambda (s)
    ((parse-cmd (handle-cmd st)) s)))

(define (event ev)  (Event ev))

(define (trans st ev) (Trans ev (fsm st)))
  
(define (start-session) (fsm (Unknown)))

(define (handle-cmd st) 
    (lambda (cmd)
      (match (cons st cmd )
	 ((_ )                             (event (Unrecognized "")))
	 ((($ session-state 'HaveQuit) _)  (event (Shutdown)))

	 ((_       ($ cmd 'WrongArg c _))  (event (SyntaxErrorIn c)))
	 ((_       ($ cmd 'Quit))          (trans (HaveQuit) (Shutdown)))
	 ((_       ($ cmd 'Noop))          (event (SayOK) ))

	 ((_       ($ cmd 'Turn))          (event (NotImplemented) ))
	 ((_       ($ cmd 'Send _))        (event (NotImplemented) ))
	 ((_       ($ cmd 'Soml _))        (event (NotImplemented) ))
	 ((_       ($ cmd 'Saml _))        (event (NotImplemented) ))
	 ((_       ($ cmd 'Vrfy _))        (event (NotImplemented) ))
	 ((_       ($ cmd 'Expn _))        (event (NotImplemented) ))

	 ((_       ($ cmd 'Help x))        (event (SeeksHelp x) ))

	 ((($ session-state 'Unknown)   ($ cmd 'Rset))          (event (SayOK) ))
	 ((($ session-state 'HaveHelo)  ($ cmd 'Rset))          (event (SayOK) ))
	 ((_                            ($ cmd 'Rset))          (trans (HaveHelo) (ResetState )))

	 ((($ session-state 'Unknown)   ($ cmd 'Helo x))        (trans (HaveHelo) (SayHelo x)))
	 ((_                            ($ cmd 'Helo x))        (trans (HaveHelo) (SayHeloAgain x)))
	 ((($ session-state 'Unknown)   ($ cmd 'Ehlo x))        (trans (HaveHelo) (SayEhlo x)))
	 ((_                            ($ cmd 'Ehlo x))        (trans (HaveHelo) (SayEhloAgain x)))

	 ((($ session-state 'Unknown)   ($ cmd 'MailFrom . _))  (event (NeedHeloFirst)))
	 ((_                            ($ cmd 'MailFrom x p))  (trans (HaveMailFrom) (SetMailFrom x p)))

	 ((($ session-state 'Unknown)   ($ cmd 'RcptTo . _))    (event (NeedHeloFirst)))
	 ((($ session-state 'HaveHelo)  ($ cmd 'RcptTo . _))    (event (NeedMailFromFirst)))
	 ((_                            ($ cmd 'RcptTo x p))    (trans (HaveRcptTo) (AddRcptTo x p)))

	 ((($ session-state 'Unknown)      ($ cmd 'Data))     (event (NeedHeloFirst)))
	 ((($ session-state 'HaveHelo)     ($ cmd 'Data))     (event (NeedMailFromFirst)))
	 ((($ session-state 'HaveMailFrom) ($ cmd 'Data))     (event (NeedRcptToFirst)))
	 ((($ session-state 'HaveRcptTo)   ($ cmd 'Data))     (trans (HaveData) (StartData)))

	 ((($ session-state 'HaveData)   _)     (event (StartData)))

	 ))
  )


)