source: project/release/4/smtp/trunk/smtp.scm @ 15133

Last change on this file since 15133 was 15133, checked in by Ivan Raikov, 12 years ago

smtp save

File size: 20.7 KB
Line 
1;;
2;;  Parser and state machine for the grammar defined in RFC 5321,
3;;  "Simple Mail Transfer Protocol".
4;;
5;;  Based on the Haskell Rfc2821 module by Peter Simons.
6;;
7;;  Copyright 2009 Ivan Raikov.
8;;
9;;  Redistribution and use in source and binary forms, with or without
10;;  modification, are permitted provided that the following conditions
11;;  are met:
12;;
13;;  - Redistributions of source code must retain the above copyright
14;;  notice, this list of conditions and the following disclaimer.
15;;
16;;  - Redistributions in binary form must reproduce the above
17;;  copyright notice, this list of conditions and the following
18;;  disclaimer in the documentation and/or other materials provided
19;;  with the distribution.
20;;
21;;  - Neither name of the copyright holders nor the names of its
22;;  contributors may be used to endorse or promote products derived
23;;  from this software without specific prior written permission.
24;;
25;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
26;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
27;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
28;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
29;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
30;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
31;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
32;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
33;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
34;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
35;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
36;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
37;;  POSSIBILITY OF SUCH DAMAGE.
38;;
39
40(module smtp *
41
42        (import scheme chicken data-structures srfi-1 srfi-13 srfi-14)
43
44        (require-library extras abnf)
45        (import (prefix abnf abnf:) (only extras sprintf fprintf ))
46
47        (require-extension datatype matchable)
48        (import-for-syntax matchable)
49
50;; construct strings from consumed chars
51(define scollect (abnf:collect-chars list->string))
52
53(define (trim-ws-char-list cs)
54  (let* ((cs1 (let loop ((cs cs))
55               (cond ((null? cs) (reverse cs))
56                     ((char-set-contains? char-set:whitespace (car cs))
57                      (loop (cdr cs)))
58                     (else (reverse cs)))))
59         (cs2  (let loop ((cs cs1))
60               (cond ((null? cs) (reverse cs))
61                     ((char-set-contains? char-set:whitespace (car cs))
62                      (loop (cdr cs)))
63                     (else (reverse cs))))))
64    cs2))
65   
66
67;; construct symbols from consumed chars; trailing and preceding white
68;; space is stripped
69(define sscollect (abnf:collect-chars (compose string->symbol list->string trim-ws-char-list)))
70
71;; collects all consumed objects of type obj?
72(define (consumed-objects obj?)
73  (lambda (cs) 
74    (and (pair? cs)
75         (let loop ((cs cs) (ax (list)))
76           (cond ((null? cs)   (list ax ))
77                 ((obj? (car cs))
78                  (loop (cdr cs) (cons (car cs) ax)))
79                 (else (cons ax cs)))))))
80
81;; construct lists from consumed objects
82(define (lcollect obj?)
83  (let ((get-consumed (consumed-objects obj?)))
84    (lambda rest
85      (let-optionals rest ((kons identity))
86        (let ((make (if (procedure? kons) kons (lambda (x) `(,kons . ,x)))))
87          (lambda (x)
88            (let ((x1 (get-consumed x)))
89              (and x1 (pair? (car x1)) (cons (make (car x1)) (cdr x1))))))))))
90
91
92;; shortcut for (abnf:bind scollect (abnf:longest ... ))
93(define-syntax consumed->string
94  (syntax-rules () 
95    ((_ p)    (abnf:bind scollect (abnf:longest p)))
96    ))
97
98;; shortcut for (abnf:bind sscollect (abnf:longest ... ))
99(define-syntax consumed->symbol
100  (syntax-rules () 
101    ((_ p)    (abnf:bind sscollect (abnf:longest p)))
102    ))
103
104(define-syntax define-enumerated-type
105  (lambda (x r c)
106    (match-let (((_ typename pred vector inject project . rest) x))
107    (let ((%define  (r 'define))
108          (%begin   (r 'begin))
109          (%if      (r 'if)))
110      `(,%begin
111        (,%define (,pred x)    (##sys#structure? x ',typename))
112        (,%define (,project x) (##sys#slot x 2))
113        (,%define (,inject i)  (and (integer? i) (positive? i) (< i (vector-length ,vector)) 
114                                    (vector-ref ,vector i)))
115        ,(let loop ((variants rest) (i 0) (defs (list)))
116           (if (null? variants) 
117               `(,%begin ,@defs)
118               (let* ((variant  (car variants))
119                      (def  `(,%define ,variant   (##sys#make-structure ',typename ',(car variant) ,i))))
120                 (loop (cdr variants) (+ i 1) (cons def defs)))))
121        ,(let loop ((variants rest) (defs (list)))
122           (if (null? variants) 
123               `(,%define ,vector (vector ,@(reverse defs)))
124               (let* ((variant  (car variants))
125                      (def  `(,(car variant))))
126                 (loop (cdr variants) (cons def defs)))))
127        )))))
128
129(define-datatype mailbox mailbox?
130  (Mailbox (route list?) (local-part string?) (domain string?)))
131
132(define-record-printer (mailbox x out)
133  (match x 
134         (($ mailbox 'Mailbox () "" "" )  (fprintf out "<>"))
135         (($ mailbox 'Mailbox () "postmaster" "" )  (fprintf out "<postmaster>"))
136         (($ mailbox 'Mailbox r l d ) 
137          (let ((route (string-concatenate (intersperse r ",")))
138                (mbox  (sprintf "~S@~S" l d)))
139            (if (string-null? route) (fprintf out "<~S>" mbox)
140                (fprintf out "<~S:~S>" route mbox))))))
141
142(define (null-path) (Mailbox (list) "" ""))
143
144(define (postmaster) (Mailbox (list) "postmaster" ""))
145
146
147;; An SMTP reply is a three-digit return code plus some waste of
148;; bandwidth called "comments". This is what the list of strings is
149;; for; one string per line in the reply.  the record printer will
150;; append an CRLF end-of-line marker to each entry in that list, so
151;; that the resulting string is ready to be sent back to the peer.
152;;
153;; Here is an example:
154;;
155;; > (print (Reply (Code (Success) (MailSystem) 0)
156;;                     (list "worked" "like" "a charm")))
157;; 250-worked
158;; 250-like
159;; 250 a charm
160
161(define-datatype reply reply?
162  (Reply (code code?) (msg list?)))
163
164(define-enumerated-type 
165  success-code success-code? success-vector 
166  success-code-inject success-code-project 
167  (Unused)
168  (PreliminarySuccess)
169  (Success)
170  (IntermediateSuccess)
171  (TransientFailure)
172  (PermanentFailure))
173
174(define-enumerated-type 
175  category category? category-vector
176  category-inject category-project
177  (Syntax)
178  (Information)
179  (Connection)
180  (Unspecified3)
181  (Unspecified4)
182  (MailSystem))
183
184(define-datatype code code?
185  (Code (suc success-code?) (cat category?) (num integer?)))
186
187(define-record-printer (reply x out)
188  (match x 
189         (($ reply 'Reply (and c ($ code 'Code suc cat _)) ())
190          (let ((msg (sprintf "~A in category ~A" suc cat)))
191            (fprintf out "~A" (Reply c (list msg)))))
192
193         (($ reply 'Reply code msg) 
194          (let ((prefix-con (sprintf "~A-" code))
195                (prefix-end (sprintf "~A " code))
196                (fmt        (lambda (p) (lambda (l) (sprintf "~A~A\r\n" p l)))))
197            (match-let (((x . xs) (reverse msg)))
198                       (let* ((msg-con (map (fmt prefix-con) xs))
199                              (msg-end ((fmt prefix-end) x))
200                              (msg1    (reverse (cons msg-end msg-con))))
201                         (fprintf out "~A" (string-concatenate msg1))))))
202         ))
203
204(define-record-printer (code x out)
205  (cases code x
206         (Code (suc cat n) 
207               (fprintf out "~A~A~A" (success-code-project suc) (category-project cat) n))))
208         
209;; Constructs a Reply.
210
211(define (in-range-incl? lo hi)
212  (if (< hi lo) (in-range-incl? hi lo)
213      (lambda (x) (and (<= lo x) (<= x hi)))))
214
215(define check-suc  (in-range-incl? 0 5))
216(define check-cat  (in-range-incl? 0 5))
217(define check-code (in-range-incl? 0 9))
218
219(define (make-reply suc cat n msg)
220  (or (and (check-suc suc) (check-cat cat) (check-code n)
221           (Reply (Code (success-code-inject suc) (category-inject cat) n) msg))
222      (error 'make-reply "arguments out of range: " suc cat n)))
223
224;; A reply constitutes success if the status code is any of
225;; PreliminarySuccess, Success, or IntermediateSuccess.
226
227(define (reply-success? r)
228  (match r (($ reply 'Reply 
229               ($ code 'Code 
230                  ($ success-code (or 'PreliminarySuccess 'IntermediateSuccess 'Success _) _ _) _))
231            #t)
232         (else #f)))
233
234;; A reply constitutes failure if the status code is either
235;; PermanentFailure or TransientFailure.
236
237(define (reply-failure? r)
238  (match r (($ reply 'Reply 
239               ($ code 'Code 
240                  ($ success-code (or 'PermanentFailure 'TransientFailure _) _ _) _))
241            #t)
242         (else #f)))
243
244;; The replies 221 and 421 signify Shutdown.
245
246(define (reply-shutdown? r)
247  (match r (($ reply 'Reply 
248               ($ code 'Code ($ success-code (or 'Success 'TransientFailure) _) 
249                  ($ category 'Connection _) 1) _)
250            #t)
251         (else #f)))
252
253
254;; Argument Parsers
255
256;; Match any US-ASCII character except for control characters,
257;; specials, or space. atom and dot-atom are made up of this.
258
259(define atext (abnf:alternatives
260               abnf:alpha
261               abnf:decimal
262               (abnf:set-from-string "!#$%&'*+-/=?^_`{|}~")))
263
264(define Atom        (abnf:repetition1 atext)) 
265
266(define Dot-string  (abnf:concatenation Atom (abnf:repetition (abnf:concatenation (abnf:char #\.) Atom))))
267
268;; backslash followed by any ASCII graphic (including itself) or space
269(define quoted-pairSMTP  (abnf:concatenation (abnf:char #\\) (abnf:set char-set:printing)))
270
271;; within a quoted string, any ASCII graphic or space is permitted
272;; without blackslash-quoting except double-quote and the backslash
273;; itself.
274(define qtextSMTP        (abnf:set (char-set-difference char-set:printing (char-set #\" #\\))))
275
276(define QcontentSMTP     (abnf:alternatives qtextSMTP quoted-pairSMTP))
277
278(define Quoted-string    (abnf:concatenation abnf:dquote  (abnf:repetition QcontentSMTP) abnf:dquote))
279
280(define String           (abnf:alternatives Atom Quoted-string))
281
282(define Let-dig          (abnf:alternatives abnf:alpha abnf:decimal))
283
284(define esmtp-keyword   (abnf:concatenation (abnf:alternatives abnf:alpha abnf:decimal) 
285                                            (abnf:repetition (abnf:alternatives abnf:alpha abnf:decimal 
286                                                                                (abnf:char #\-)))))
287
288(define esmtp-value    (abnf:repetition1 
289                        (abnf:set (char-set-difference
290                                   char-set:graphic (char-set #\= #\space)))))
291;; any CHAR excluding "=", SP, and control
292;; characters.  If this string is an email address,
293;; i.e., a Mailbox, then the "xtext" syntax [32]
294;; SHOULD be used.
295
296(define esmtp-param     (abnf:concatenation esmtp-keyword 
297                                            (abnf:optional-sequence (abnf:concatenation (abnf:char #\=) esmtp-value))))
298
299
300(define Mail-parameters  (abnf:concatenation esmtp-param (abnf:repetition (abnf:concatenation abnf:sp esmtp-param))))
301
302(define Rcpt-parameters  Mail-parameters)
303
304
305(define Ldh-str          (abnf:concatenation
306                          (abnf:repetition (abnf:alternatives abnf:alpha abnf:decimal (abnf:char #\-)))
307                          Let-dig))
308(define Keyword        Ldh-str)
309(define Argument       Atom)
310
311(define sub-domain     (abnf:concatenation Let-dig (abnf:optional-sequence Ldh-str)))
312
313(define Domain         (abnf:concatenation 
314                        sub-domain
315                        (abnf:repetition
316                         (abnf:concatenation 
317                          (abnf:char #\.) sub-domain))))
318
319(define At-domain    (abnf:concatenation (abnf:char #\@) Domain))
320
321(define A-d-l        (abnf:concatenation At-domain (abnf:repetition (abnf:concatenation (abnf:char #\,) At-domain))))
322
323(define Local-part   (abnf:alternatives Dot-string Quoted-string))
324
325(define IPv6-hex     (abnf:variable-repetition 1 4 abnf:hexadecimal))
326
327(define cIPv6-hex    (abnf:concatenation (abnf:char #\:) IPv6-hex))
328
329(define IPv6-full    (abnf:concatenation IPv6-hex (abnf:repetition-n 7 cIPv6-hex)))
330
331(define IPv6-comp    (abnf:concatenation
332                      (abnf:optional-sequence (abnf:concatenation IPv6-hex (abnf:variable-repetition 0 5 cIPv6-hex)))
333                      (abnf:lit "::")
334                      (abnf:optional-sequence (abnf:concatenation IPv6-hex (abnf:variable-repetition 0 5 cIPv6-hex)))))
335;; The "::" represents at least 2 16-bit groups of zeros.  No more
336;; than 6 groups in addition to the "::" may be present.
337
338(define Snum        (abnf:variable-repetition 1 3 abnf:decimal))
339
340(define IPv4-address-literal  (abnf:concatenation Snum (abnf:repetition-n 3 (abnf:concatenation (abnf:char #\.)  Snum))))
341
342(define IPv6v4-full   (abnf:concatenation IPv6-hex (abnf:repetition-n 5 cIPv6-hex) 
343                                          (abnf:char #\:) IPv4-address-literal))
344
345(define IPv6v4-comp   (abnf:concatenation (abnf:optional-sequence
346                                           (abnf:concatenation IPv6-hex (abnf:variable-repetition 0 3 cIPv6-hex)))
347                                          (abnf:lit "::")
348                                          (abnf:optional-sequence
349                                           (abnf:concatenation IPv6-hex (abnf:variable-repetition 0 3 cIPv6-hex) ":"))
350                                          IPv4-address-literal))
351;; The "::" represents at least 2 16-bit groups of zeros.  No more
352;; than 4 groups in addition to the "::" and IPv4-address-literal may
353;; be present.
354
355(define IPv6-addr   (abnf:alternatives IPv6-full IPv6-comp IPv6v4-full IPv6v4-comp))
356
357
358(define IPv6-address-literal  (abnf:concatenation (abnf:lit "IPv6:") IPv6-addr))
359
360(define dcontent  (abnf:set (char-set-difference char-set:printing (char-set #\[ #\] #\\))))
361
362(define Standardized-tag  Ldh-str)
363;; Standardized-tag MUST be specified in a Standards-Track RFC and
364;; registered with IANA
365
366(define General-address-literal  (abnf:concatenation Standardized-tag (abnf:char #\:) (abnf:repetition1 dcontent)))
367
368(define address-literal  (abnf:concatenation
369                          (abnf:char #\[) 
370                          (abnf:alternatives
371                           IPv4-address-literal 
372                           IPv6-address-literal 
373                           General-address-literal)
374                          (abnf:char #\])))
375;; See Section 4.1.3
376
377(define Mailbox        (abnf:concatenation Local-part (abnf:char #\@) (abnf:alternatives Domain address-literal)))
378
379
380
381(define Path           (abnf:concatenation (abnf:char #\<) 
382                                           (abnf:optional-sequence (abnf:concatenation A-d-l (abnf:char #\:))) 
383                                           Mailbox (abnf:char #\>)))
384(define Forward-path   Path)
385
386(define Reverse-path 
387  (abnf:alternatives 
388   Path (abnf:concatenation (abnf:char #\<) (abnf:char #\>))))
389
390
391(define from-path
392  (abnf:concatenation
393   (abnf:lit "FROM:")
394   Reverse-path
395   (abnf:optional-sequence (abnf:concatenation abnf:sp Rcpt-parameters))))
396   
397(define to-path 
398  (abnf:concatenation
399   (abnf:lit "TO:")
400   (abnf:alternatives 
401    (abnf:concatenation (abnf:char #\<) (abnf:lit "Postmaster@") Domain (abnf:char #\>))
402    (abnf:concatenation (abnf:char #\<) (abnf:lit "Postmaster") (abnf:char #\>))
403    Forward-path
404    (abnf:optional-sequence (abnf:concatenation abnf:sp Rcpt-parameters)))))
405
406;; ESMTP sessions, events, commands
407
408(define-datatype session-state session-state?
409  (Unknown)
410  (HaveHelo)
411  (HaveMailFrom)
412  (HaveRcptTo)
413  (HaveData)
414  (HaveQuit))
415
416(define-datatype event event?
417  (Greeting)                   
418  (SayHelo       (s string?))
419  (SayHeloAgain  (s string?))
420  (SayEhlo       (s string?))
421  (SayEhloAgain  (s string?))
422  (SetMailFrom   (m mailbox?))
423  (AddRcptTo     (m mailbox?))
424  (StartData)
425  (Deliver)
426  (NeedHeloFirst)
427  (NeedMailFromFirst)
428  (NeedRcptToFirst)
429  (NotImplemented) ;; Turn, Send, Soml, Saml, Vrfy, Expn.
430  (ResetState)
431  (SayOK)
432  ;; Triggered in case of Noop or when Rset is used before
433  ;; we even have a state.
434  (SeeksHelp    (s string?))
435  (Shutdown)
436  (SyntaxErrorIn (s string?))
437  (Unrecognized  (s string?)))
438 
439(define-datatype cmd cmd?
440  (Helo (s string?))
441  (Ehlo (s string?))
442  (MailFrom (m mailbox?))
443  (RcptTo   (m mailbox?))
444  (Data)
445  (Rset)
446  (Send  (m mailbox?))
447  (Soml  (m mailbox?))
448  (Saml  (m mailbox?))
449  (Vrfy  (s string?))
450  (Expn  (s string?))
451  (Help  (s string?))
452  (Noop)
453  (Quit)
454  (Turn)
455;; When a valid command has been recognized, but the
456;; argument parser fails, then this type will be
457;; returned.
458  (WrongArg (cmd string?)  (message string?)))
459
460(define-record-printer (cmd x out)
461  (cases cmd x 
462         (Helo (s)      (fprintf out "HELO ~S" s))
463         (Ehlo (s)      (fprintf out "EHLO ~S" s))
464         (MailFrom (m)  (fprintf out "MAIL FROM: ~S" m))
465         (RcptTo (m)    (fprintf out "RCPT TO: ~S" m))
466         (Data ()       (fprintf out "DATA"))
467         (Rset ()       (fprintf out "RSET"))
468         (Send (m)      (fprintf out "SEND ~S" m))
469         (Soml (m)      (fprintf out "SOML ~S" m))
470         (Saml (m)      (fprintf out "SAML ~S" m))
471         (Vrfy (s)      (fprintf out "VRFY ~S" s))
472         (Expn (s)      (fprintf out "EXPN ~S" s))
473         (Noop ()       (fprintf out "NOOP"))
474         (Quit ()       (fprintf out "QUIT"))
475         (Turn ()       (fprintf out "TURN"))
476         (Help (s)      (fprintf out "HELP ~S" s))
477         (WrongArg (s)  (fprintf out "Syntax error in argument of ~S." s))))
478
479;; Command Parsers
480
481;; Constructs a parser for a command without arguments.
482
483(define (mkcmdp0 s kons) 
484  (define (ignore x) (kons))
485  (let ((ss (->string s)))
486    (abnf:bind ((lcollect ignore))
487     (abnf:concatenation
488      (consumed->symbol (abnf:lit ss))
489      (abnf:drop-consumed (abnf:repetition abnf:sp))
490      (abnf:drop-consumed abnf:crlf)
491      ))))
492
493;; Constructs a WrongArg command
494(define (wrong-arg cmd)
495  (abnf:bind (lambda (x) (WrongArg cmd ""))
496             abnf:pass))
497
498;; Constructs a parser for a command with an argument, which the given
499;; parser will handle. The result of the argument parser will be
500;; applied to the given constructor procedure before returning.
501
502(define (mkcmdp1 s p kons) 
503  (let ((ss (->string s)))
504    (abnf:concatenation
505     (consumed->symbol (abnf:lit ss))
506     (abnf:drop-consumed (abnf:repetition abnf:sp))
507     (abnf:alternatives (abnf:bind ((lcollect kons)) p) 
508                        (wrong-arg ss) )
509     (abnf:drop-consumed abnf:crlf)
510     )))
511
512
513;; The SMTP parsers defined here correspond to the commands specified
514;; in the RFC.
515
516(define data (mkcmdp0 "DATA" Data))
517(define rset (mkcmdp0 "RSET" Rset))
518(define quit (mkcmdp0 "QUIT" Quit))
519(define turn (mkcmdp0 "TURN" Turn))
520(define helo (mkcmdp1 "HELO" Helo     Domain))
521(define ehlo (mkcmdp1 "EHLO" Ehlo     Domain))
522(define mail (mkcmdp1 "MAIL" MailFrom from-path))
523(define rcpt (mkcmdp1 "RCPT" RcptTo   to-path))
524(define send (mkcmdp1 "SEND" Send     from-path))
525(define soml (mkcmdp1 "SOML" Soml     from-path))
526(define saml (mkcmdp1 "SAML" Saml     from-path))
527(define vrfy (mkcmdp1 "VRFY" Vrfy     (abnf:concatenation abnf:sp String)))
528(define expn (mkcmdp1 "EXPN" Expn     (abnf:concatenation abnf:sp String)))
529
530(define help (mkcmdp1 "HELP" (lambda (x) (if (null? x) (Help) (Help (car x))))
531                      (abnf:optional-sequence (abnf:concatenation abnf:sp String))))
532
533(define noop0 (mkcmdp1 "NOOP" (lambda (x) (Noop))
534                       (abnf:optional-sequence (abnf:concatenation abnf:sp String))))
535                       
536
537(define smtp-cmd 
538  (abnf:longest
539   (abnf:alternatives
540    data rset noop0 quit turn helo mail rcpt 
541    send soml saml vrfy expn help ehlo
542    )))
543
544(define (parse cont p)
545  (let ((cont1 (lambda (s) (cont (map caar s)))))
546    (lambda (s) (p cont1 s))))
547
548
549;; ESMTP State Machine
550
551(define-datatype session-fsm session-fsm?
552  (Event (ev event?))
553  (Trans (ev event?) (fsm procedure?)))
554
555;; Parses an SMTP protocol line and runs handle-cmd to determine
556;; the event. In case of syntax errors, SyntaxErrorIn or Unrecognized
557;; will be returned.  Inputs must be terminated with CRLF.
558
559(define (fsm st) (parse (handle-cmd st) smtp-cmd))
560
561(define (event ev)  (Event ev))
562
563(define (trans st ev) (Trans ev (fsm st)))
564 
565(define (session-start s) (fsm (Unknown)))
566
567(define (handle-cmd st) 
568  (lambda (cmd)
569    (match (list st cmd )
570         ((_ ())                           (event (Unrecognized "")))
571         ((($ session-state 'HaveQuit) _)  (event (Shutdown)))
572         ((($ session-state 'HaveData) _)  (trans (HaveData) (StartData)))
573         ((_       ($ cmd 'WrongArg c _))  (event (SyntaxErrorIn c)))
574         ((_       ($ cmd 'Quit))          (trans (HaveQuit) (Shutdown)))
575         ((_       ($ cmd 'Noop))          (event (SayOK) ))
576
577         ((_       ($ cmd 'Turn))          (event (NotImplemented) ))
578         ((_       ($ cmd 'Send _))        (event (NotImplemented) ))
579         ((_       ($ cmd 'Soml _))        (event (NotImplemented) ))
580         ((_       ($ cmd 'Saml _))        (event (NotImplemented) ))
581         ((_       ($ cmd 'Vrfy _))        (event (NotImplemented) ))
582         ((_       ($ cmd 'Expn _))        (event (NotImplemented) ))
583
584         ((_       ($ cmd 'Help x))        (event (SeeksHelp x) ))
585
586         ((($ session-state 'Unknown)   ($ cmd 'Rset))          (event (SayOK) ))
587         ((($ session-state 'HaveHelo)  ($ cmd 'Rset))          (event (SayOK) ))
588         ((_                            ($ cmd 'Rset))          (trans (HaveHelo) (ResetState )))
589
590         ((($ session-state 'Unknown)   ($ cmd 'Helo x))        (trans (HaveHelo) (SayHelo x)))
591         ((_                            ($ cmd 'Helo x))        (trans (HaveHelo) (SayHeloAgain x)))
592         ((($ session-state 'Unknown)   ($ cmd 'Ehlo x))        (trans (HaveHelo) (SayEhlo x)))
593         ((_                            ($ cmd 'Ehlo x))        (trans (HaveHelo) (SayEhloAgain x)))
594
595         ((($ session-state 'Unknown)   ($ cmd 'MailFrom x))    (event (NeedHeloFirst)))
596         ((_                            ($ cmd 'MailFrom x))    (trans (HaveMailFrom) (SetMailFrom x)))
597
598         ((($ session-state 'Unknown)   ($ cmd 'RcptTo x))      (event (NeedHeloFirst)))
599         ((($ session-state 'HaveHelo)  ($ cmd 'RcptTo x))      (event (NeedMailFromFirst)))
600         ((_                            ($ cmd 'RcptTo x))      (trans (HaveRcptTo) (AddRcptTo x)))
601
602         ((($ session-state 'Unknown)      ($ cmd 'Data x))     (event (NeedHeloFirst)))
603         ((($ session-state 'HaveHelo)     ($ cmd 'Data x))     (event (NeedMailFromFirst)))
604         ((($ session-state 'HaveMailFrom) ($ cmd 'Data x))     (event (NeedRcptToFirst)))
605         ((($ session-state 'HaveRcptTo)   ($ cmd 'Data x))     (trans (HaveData) (StartData)))
606         ))
607  )
608
609)
Note: See TracBrowser for help on using the repository browser.