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

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

fixes in smtp

File size: 21.8 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 
70  (abnf:collect-chars
71   (compose string->symbol list->string trim-ws-char-list)))
72
73;; collects all consumed objects of type obj?
74(define (consumed-objects obj?)
75  (lambda (cs) 
76    (and (pair? cs)
77         (let loop ((cs cs) (ax (list)))
78           (cond ((null? cs)   (list ax ))
79                 ((obj? (car cs))
80                  (loop (cdr cs) (cons (car cs) ax)))
81                 (else (cons ax cs)))))))
82
83;; construct lists from consumed objects
84(define (lcollect obj?)
85  (let ((get-consumed (consumed-objects obj?)))
86    (lambda rest
87      (let-optionals rest ((kons identity))
88        (let ((make (if (procedure? kons) kons (lambda (x) `(,kons . ,x)))))
89          (lambda (x)
90            (let ((x1 (get-consumed x)))
91              (and x1 (pair? (car x1)) (cons (make (car x1)) (cdr x1))))))))))
92
93
94;; shortcut for (abnf:bind scollect (abnf:longest ... ))
95(define-syntax consumed->string
96  (syntax-rules () 
97    ((_ p)    (abnf:bind scollect (abnf:longest p)))
98    ))
99
100;; shortcut for (abnf:bind sscollect (abnf:longest ... ))
101(define-syntax consumed->symbol
102  (syntax-rules () 
103    ((_ p)    (abnf:bind sscollect (abnf:longest p)))
104    ))
105
106(define-syntax define-enumerated-type
107  (lambda (x r c)
108    (match-let (((_ typename pred vector inject project . rest) x))
109    (let ((%define  (r 'define))
110          (%begin   (r 'begin))
111          (%if      (r 'if)))
112      `(,%begin
113        (,%define (,pred x)    (##sys#structure? x ',typename))
114        (,%define (,project x) (##sys#slot x 2))
115        (,%define (,inject i) 
116                  (and (integer? i) (positive? i) (< i (vector-length ,vector)) 
117                       (vector-ref ,vector i)))
118        ,(let loop ((variants rest) (i 0) (defs (list)))
119           (if (null? variants) 
120               `(,%begin ,@defs)
121               (let* ((variant  (car variants))
122                      (def  `(,%define ,variant   
123                                       (##sys#make-structure ',typename ',(car variant) ,i))))
124                 (loop (cdr variants) (+ i 1) (cons def defs)))))
125        ,(let loop ((variants rest) (defs (list)))
126           (if (null? variants) 
127               `(,%define ,vector (vector ,@(reverse defs)))
128               (let* ((variant  (car variants))
129                      (def  `(,(car variant))))
130                 (loop (cdr variants) (cons def defs)))))
131        )))))
132
133(define-datatype mailbox mailbox?
134  (Mailbox (local-part string?) (domain string?)))
135
136(define-record-printer (mailbox x out)
137  (match x 
138         (($ mailbox 'Mailbox "" "" )  (fprintf out "<>"))
139         (($ mailbox 'Mailbox "postmaster" "" )  (fprintf out "<postmaster>"))
140         (($ mailbox 'Mailbox l d ) 
141          (let ((mbox  (sprintf "~S@~S" l d)))
142            (fprintf out "<~S>" mbox)))))
143
144(define (null-path) (Mailbox "" ""))
145
146(define (postmaster) (Mailbox "postmaster" ""))
147
148
149;; An SMTP reply is a three-digit return code plus some waste of
150;; bandwidth called "comments". This is what the list of strings is
151;; for; one string per line in the reply.  the record printer will
152;; append an CRLF end-of-line marker to each entry in that list, so
153;; that the resulting string is ready to be sent back to the peer.
154;;
155;; Here is an example:
156;;
157;; > (print (Reply (Code (Success) (MailSystem) 0)
158;;                     (list "worked" "like" "a charm")))
159;; 250-worked
160;; 250-like
161;; 250 a charm
162
163(define-datatype reply reply?
164  (Reply (code code?) (msg list?)))
165
166(define-enumerated-type 
167  success-code success-code? success-vector 
168  success-code-inject success-code-project 
169  (Unused)
170  (PreliminarySuccess)
171  (Success)
172  (IntermediateSuccess)
173  (TransientFailure)
174  (PermanentFailure))
175
176(define-enumerated-type 
177  category category? category-vector
178  category-inject category-project
179  (Syntax)
180  (Information)
181  (Connection)
182  (Unspecified3)
183  (Unspecified4)
184  (MailSystem))
185
186(define-datatype code code?
187  (Code (suc success-code?) (cat category?) (num integer?)))
188
189(define-record-printer (reply x out)
190  (match x 
191         (($ reply 'Reply (and c ($ code 'Code suc cat _)) ())
192          (let ((msg (sprintf "~A in category ~A" suc cat)))
193            (fprintf out "~A" (Reply c (list msg)))))
194
195         (($ reply 'Reply code msg) 
196          (let ((prefix-con (sprintf "~A-" code))
197                (prefix-end (sprintf "~A " code))
198                (fmt        (lambda (p) (lambda (l) (sprintf "~A~A\r\n" p l)))))
199            (match-let (((x . xs) (reverse msg)))
200                       (let* ((msg-con (map (fmt prefix-con) xs))
201                              (msg-end ((fmt prefix-end) x))
202                              (msg1    (reverse (cons msg-end msg-con))))
203                         (fprintf out "~A" (string-concatenate msg1))))))
204         ))
205
206(define-record-printer (code x out)
207  (cases code x
208         (Code (suc cat n) 
209               (fprintf out "~A~A~A" (success-code-project suc) 
210                        (category-project cat) n))))
211         
212;; Constructs a Reply.
213
214(define (in-range-incl? lo hi)
215  (if (< hi lo) (in-range-incl? hi lo)
216      (lambda (x) (and (<= lo x) (<= x hi)))))
217
218(define check-suc  (in-range-incl? 0 5))
219(define check-cat  (in-range-incl? 0 5))
220(define check-code (in-range-incl? 0 9))
221
222(define (make-reply suc cat n msg)
223  (or (and (check-suc suc) (check-cat cat) (check-code n)
224           (Reply (Code (success-code-inject suc) (category-inject cat) n) msg))
225      (error 'make-reply "arguments out of range: " suc cat n)))
226
227;; A reply constitutes success if the status code is any of
228;; PreliminarySuccess, Success, or IntermediateSuccess.
229
230(define (reply-success? r)
231  (match r (($ reply 'Reply 
232               ($ code 'Code 
233                  ($ success-code (or 'PreliminarySuccess 
234                                      'IntermediateSuccess 'Success _) _ _) _))
235            #t)
236         (else #f)))
237
238;; A reply constitutes failure if the status code is either
239;; PermanentFailure or TransientFailure.
240
241(define (reply-failure? r)
242  (match r (($ reply 'Reply 
243               ($ code 'Code 
244                  ($ success-code (or 'PermanentFailure 
245                                      'TransientFailure _) _ _) _))
246            #t)
247         (else #f)))
248
249;; The replies 221 and 421 signify Shutdown.
250
251(define (reply-shutdown? r)
252  (match r (($ reply 'Reply 
253               ($ code 'Code ($ success-code (or 'Success 
254                                                 'TransientFailure) _) 
255                  ($ category 'Connection _) 1) _)
256            #t)
257         (else #f)))
258
259
260;; Argument Parsers
261
262;; Match any US-ASCII character except for control characters,
263;; specials, or space. atom and dot-atom are made up of this.
264
265(define atext (abnf:alternatives
266               abnf:alpha
267               abnf:decimal
268               (abnf:set-from-string "!#$%&'*+-/=?^_`{|}~")))
269
270(define Atom         (consumed->string (abnf:repetition1 atext)))
271
272(define Dot-string   (consumed->string 
273                      (abnf:concatenation
274                       (abnf:repetition1 atext) 
275                       (abnf:repetition
276                        (abnf:concatenation
277                         (abnf:char #\.) 
278                         (abnf:repetition1 atext))))))
279
280;; backslash followed by any ASCII graphic (including itself) or space
281(define quoted-pairSMTP  (abnf:concatenation
282                          (abnf:char #\\) 
283                          (abnf:set char-set:printing)))
284
285;; within a quoted string, any ASCII graphic or space is permitted
286;; without blackslash-quoting except double-quote and the backslash
287;; itself.
288(define qtextSMTP        (abnf:set
289                          (char-set-difference 
290                           char-set:printing
291                           (char-set #\" #\\))))
292
293(define QcontentSMTP     (abnf:alternatives qtextSMTP quoted-pairSMTP))
294
295(define Quoted-string    (consumed->string 
296                          (abnf:concatenation
297                           (abnf:drop-consumed abnf:dquote) 
298                           (abnf:repetition QcontentSMTP) 
299                           (abnf:drop-consumed abnf:dquote))))
300
301(define String           (abnf:alternatives Atom Quoted-string))
302
303(define Let-dig          (abnf:alternatives abnf:alpha abnf:decimal))
304
305(define esmtp-keyword   (consumed->symbol
306                         (abnf:concatenation
307                          (abnf:alternatives abnf:alpha abnf:decimal) 
308                          (abnf:repetition
309                           (abnf:alternatives 
310                            abnf:alpha
311                            abnf:decimal
312                            (abnf:char #\-))))))
313
314(define esmtp-value    (consumed->string
315                        (abnf:repetition1 
316                         (abnf:set (char-set-difference
317                                    char-set:graphic (char-set #\= #\space))))))
318;; any CHAR excluding "=", SP, and control
319;; characters.  If this string is an email address,
320;; i.e., a Mailbox, then the "xtext" syntax [32]
321;; SHOULD be used.
322
323(define esmtp-param     (consumed-strings->list
324                         (abnf:concatenation
325                          esmtp-keyword 
326                          (abnf:optional-sequence
327                           (abnf:concatenation 
328                            (abnf:drop-consumed (abnf:char #\=)) 
329                            esmtp-value)))))
330
331
332
333(define Mail-parameters  (consumed-pairs->list
334                          (abnf:concatenation
335                           esmtp-param
336                           (abnf:repetition 
337                            (abnf:concatenation 
338                             (abnf:drop-consumed abnf:sp) esmtp-param)))))
339
340(define Rcpt-parameters  Mail-parameters)
341
342
343(define Ldh-str         (abnf:concatenation
344                          (abnf:repetition
345                           (abnf:alternatives
346                            abnf:alpha abnf:decimal (abnf:char #\-)))
347                          Let-dig))
348
349(define Keyword        Ldh-str)
350(define Argument       Atom)
351
352(define sub-domain     (consumed->string
353                        (abnf:concatenation 
354                         Let-dig 
355                         (abnf:optional-sequence Ldh-str))))
356
357(define Domain         (consumed-strings->list
358                        (abnf:concatenation 
359                         sub-domain
360                         (abnf:repetition
361                          (abnf:concatenation 
362                           (abnf:drop-consumed (abnf:char #\.)) 
363                          sub-domain)))))
364
365(define At-domain    (abnf:concatenation 
366                      (abnf:drop-consumed (abnf:char #\@)) 
367                      Domain))
368
369(define A-d-l        (abnf:concatenation
370                      At-domain
371                      (abnf:repetition
372                       (abnf:concatenation
373                        (abnf:drop-consumed (abnf:char #\,)) 
374                        At-domain))))
375
376(define Local-part   (abnf:alternatives
377                      Dot-string
378                      Quoted-string))
379
380(define IPv6-hex     (consumed->string 
381                      (abnf:variable-repetition 1 4 abnf:hexadecimal)))
382
383(define cIPv6-hex    (abnf:concatenation
384                      (abnf:drop-consumed (abnf:char #\:)) 
385                      IPv6-hex))
386
387(define IPv6-full    (consumed-strings->list 
388                      (abnf:concatenation 
389                       IPv6-hex
390                       (abnf:repetition-n 7 cIPv6-hex))))
391
392(define IPv6-comp    (consumed-strings->list
393                      (abnf:concatenation
394                       (abnf:optional-sequence
395                        (abnf:concatenation 
396                         IPv6-hex
397                         (abnf:variable-repetition 0 5 cIPv6-hex)))
398                       (consumed->string (abnf:lit "::"))
399                       (abnf:optional-sequence
400                        (abnf:concatenation 
401                         IPv6-hex
402                         (abnf:variable-repetition 0 5 cIPv6-hex))))))
403;; The "::" represents at least 2 16-bit groups of zeros.  No more
404;; than 6 groups in addition to the "::" may be present.
405
406(define Snum        (consumed->string (abnf:variable-repetition 1 3 abnf:decimal)))
407
408(define IPv4-address-literal  (abnf:concatenation 
409                               Snum 
410                               (abnf:repetition-n 
411                                3 (abnf:concatenation 
412                                   (abnf:drop-consumed (abnf:char #\.)) 
413                                   Snum))))
414
415(define IPv6v4-full   (consumed-strings->list
416                       (abnf:concatenation 
417                        IPv6-hex (abnf:repetition-n 5 cIPv6-hex) 
418                        (abnf:drop-consumed (abnf:char #\:))
419                        IPv4-address-literal)))
420
421(define IPv6v4-comp   (consumed-strings->list
422                       (abnf:concatenation 
423                        (abnf:optional-sequence
424                         (abnf:concatenation
425                          IPv6-hex
426                          (abnf:variable-repetition 0 3 cIPv6-hex)))
427                        (consumed->string (abnf:lit "::"))
428                        (abnf:optional-sequence
429                         (abnf:concatenation
430                          IPv6-hex
431                          (abnf:variable-repetition 0 3 cIPv6-hex) 
432                         (abnf:drop-consumed (abnf:char #\:))))
433                        IPv4-address-literal)))
434;; The "::" represents at least 2 16-bit groups of zeros.  No more
435;; than 4 groups in addition to the "::" and IPv4-address-literal may
436;; be present.
437
438(define IPv6-addr   (abnf:alternatives IPv6-full IPv6-comp 
439                                       IPv6v4-full IPv6v4-comp))
440
441(define IPv6-address-literal  (abnf:concatenation
442                               (consumed->string (abnf:lit "IPv6:")) IPv6-addr))
443
444(define dcontent  (abnf:set (char-set-difference
445                             char-set:printing 
446                             (char-set #\[ #\] #\\))))
447
448(define Standardized-tag  (consumed->symbol Ldh-str))
449;; Standardized-tag MUST be specified in a Standards-Track RFC and
450;; registered with IANA
451
452(define General-address-literal  (abnf:concatenation
453                                  Standardized-tag (abnf:drop-consumed (abnf:char #\:))
454                                  (abnf:repetition1 dcontent)))
455
456(define address-literal  (abnf:concatenation
457                          (abnf:char #\[) 
458                          (abnf:alternatives
459                           IPv4-address-literal 
460                           IPv6-address-literal 
461                           General-address-literal)
462                          (abnf:char #\])))
463;; See Section 4.1.3
464
465(define Mailbox        (abnf:concatenation Local-part (abnf:char #\@) (abnf:alternatives Domain address-literal)))
466
467(define Path           (abnf:concatenation (abnf:char #\<) 
468                                           (abnf:optional-sequence (abnf:concatenation A-d-l (abnf:char #\:))) 
469                                           Mailbox (abnf:char #\>)))
470(define Forward-path   Path)
471
472(define Reverse-path 
473  (abnf:alternatives 
474   Path (abnf:concatenation (abnf:char #\<) (abnf:char #\>))))
475
476
477(define from-path
478  (abnf:concatenation
479   (abnf:lit "FROM:")
480   Reverse-path
481   (abnf:optional-sequence (abnf:concatenation abnf:sp Rcpt-parameters))))
482   
483(define to-path 
484  (abnf:concatenation
485   (abnf:lit "TO:")
486   (abnf:alternatives 
487    (abnf:concatenation (abnf:char #\<) (abnf:lit "Postmaster@") Domain (abnf:char #\>))
488    (abnf:concatenation (abnf:char #\<) (abnf:lit "Postmaster") (abnf:char #\>))
489    Forward-path
490    (abnf:optional-sequence (abnf:concatenation abnf:sp Rcpt-parameters)))))
491
492;; ESMTP sessions, events, commands
493
494(define-datatype session-state session-state?
495  (Unknown)
496  (HaveHelo)
497  (HaveMailFrom)
498  (HaveRcptTo)
499  (HaveData)
500  (HaveQuit))
501
502(define-datatype event event?
503  (Greeting)                   
504  (SayHelo       (s string?))
505  (SayHeloAgain  (s string?))
506  (SayEhlo       (s string?))
507  (SayEhloAgain  (s string?))
508  (SetMailFrom   (m mailbox?))
509  (AddRcptTo     (m mailbox?))
510  (StartData)
511  (Deliver)
512  (NeedHeloFirst)
513  (NeedMailFromFirst)
514  (NeedRcptToFirst)
515  (NotImplemented) ;; Turn, Send, Soml, Saml, Vrfy, Expn.
516  (ResetState)
517  (SayOK)
518  ;; Triggered in case of Noop or when Rset is used before
519  ;; we even have a state.
520  (SeeksHelp    (s string?))
521  (Shutdown)
522  (SyntaxErrorIn (s string?))
523  (Unrecognized  (s string?)))
524 
525(define-datatype cmd cmd?
526  (Helo (s string?))
527  (Ehlo (s string?))
528  (MailFrom (m mailbox?))
529  (RcptTo   (m mailbox?))
530  (Data)
531  (Rset)
532  (Send  (m mailbox?))
533  (Soml  (m mailbox?))
534  (Saml  (m mailbox?))
535  (Vrfy  (s string?))
536  (Expn  (s string?))
537  (Help  (s string?))
538  (Noop)
539  (Quit)
540  (Turn)
541;; When a valid command has been recognized, but the
542;; argument parser fails, then this type will be
543;; returned.
544  (WrongArg (cmd string?)  (message string?)))
545
546(define-record-printer (cmd x out)
547  (cases cmd x 
548         (Helo (s)      (fprintf out "HELO ~S" s))
549         (Ehlo (s)      (fprintf out "EHLO ~S" s))
550         (MailFrom (m)  (fprintf out "MAIL FROM: ~S" m))
551         (RcptTo (m)    (fprintf out "RCPT TO: ~S" m))
552         (Data ()       (fprintf out "DATA"))
553         (Rset ()       (fprintf out "RSET"))
554         (Send (m)      (fprintf out "SEND ~S" m))
555         (Soml (m)      (fprintf out "SOML ~S" m))
556         (Saml (m)      (fprintf out "SAML ~S" m))
557         (Vrfy (s)      (fprintf out "VRFY ~S" s))
558         (Expn (s)      (fprintf out "EXPN ~S" s))
559         (Noop ()       (fprintf out "NOOP"))
560         (Quit ()       (fprintf out "QUIT"))
561         (Turn ()       (fprintf out "TURN"))
562         (Help (s)      (fprintf out "HELP ~S" s))
563         (WrongArg (s)  (fprintf out "Syntax error in argument of ~S." s))))
564
565;; Command Parsers
566
567;; Constructs a parser for a command without arguments.
568
569(define (mkcmdp0 s kons) 
570  (define (ignore x) (kons))
571  (let ((ss (->string s)))
572    (abnf:bind ((lcollect ignore))
573     (abnf:concatenation
574      (consumed->symbol (abnf:lit ss))
575      (abnf:drop-consumed (abnf:repetition abnf:sp))
576      (abnf:drop-consumed abnf:crlf)
577      ))))
578
579;; Constructs a WrongArg command
580(define (wrong-arg cmd)
581  (abnf:bind (lambda (x) (WrongArg cmd ""))
582             abnf:pass))
583
584;; Constructs a parser for a command with an argument, which the given
585;; parser will handle. The result of the argument parser will be
586;; applied to the given constructor procedure before returning.
587
588(define (mkcmdp1 s p kons) 
589  (let ((ss (->string s)))
590    (abnf:concatenation
591     (consumed->symbol (abnf:lit ss))
592     (abnf:drop-consumed (abnf:repetition abnf:sp))
593     (abnf:alternatives (abnf:bind ((lcollect kons)) p) 
594                        (wrong-arg ss) )
595     (abnf:drop-consumed abnf:crlf)
596     )))
597
598
599;; The SMTP parsers defined here correspond to the commands specified
600;; in the RFC.
601
602(define data (mkcmdp0 "DATA" Data))
603(define rset (mkcmdp0 "RSET" Rset))
604(define quit (mkcmdp0 "QUIT" Quit))
605(define turn (mkcmdp0 "TURN" Turn))
606(define helo (mkcmdp1 "HELO" Helo     Domain))
607(define ehlo (mkcmdp1 "EHLO" Ehlo     Domain))
608(define mail (mkcmdp1 "MAIL" MailFrom from-path))
609(define rcpt (mkcmdp1 "RCPT" RcptTo   to-path))
610(define send (mkcmdp1 "SEND" Send     from-path))
611(define soml (mkcmdp1 "SOML" Soml     from-path))
612(define saml (mkcmdp1 "SAML" Saml     from-path))
613(define vrfy (mkcmdp1 "VRFY" Vrfy     (abnf:concatenation abnf:sp String)))
614(define expn (mkcmdp1 "EXPN" Expn     (abnf:concatenation abnf:sp String)))
615
616(define help (mkcmdp1 "HELP" (lambda (x) (if (null? x) (Help) (Help (car x))))
617                      (abnf:optional-sequence (abnf:concatenation abnf:sp String))))
618
619(define noop0 (mkcmdp1 "NOOP" (lambda (x) (Noop))
620                       (abnf:optional-sequence (abnf:concatenation abnf:sp String))))
621                       
622
623(define smtp-cmd 
624  (abnf:longest
625   (abnf:alternatives
626    data rset noop0 quit turn helo mail rcpt 
627    send soml saml vrfy expn help ehlo
628    )))
629
630(define (parse cont p)
631  (let ((cont1 (lambda (s) (cont (map caar s)))))
632    (lambda (s) (p cont1 s))))
633
634
635;; ESMTP State Machine
636
637(define-datatype session-fsm session-fsm?
638  (Event (ev event?))
639  (Trans (ev event?) (fsm procedure?)))
640
641;; Parses an SMTP protocol line and runs handle-cmd to determine
642;; the event. In case of syntax errors, SyntaxErrorIn or Unrecognized
643;; will be returned.  Inputs must be terminated with CRLF.
644
645(define (fsm st) (parse (handle-cmd st) smtp-cmd))
646
647(define (event ev)  (Event ev))
648
649(define (trans st ev) (Trans ev (fsm st)))
650 
651(define (session-start s) (fsm (Unknown)))
652
653(define (handle-cmd st) 
654  (lambda (cmd)
655    (match (list st cmd )
656         ((_ ())                           (event (Unrecognized "")))
657         ((($ session-state 'HaveQuit) _)  (event (Shutdown)))
658         ((($ session-state 'HaveData) _)  (trans (HaveData) (StartData)))
659         ((_       ($ cmd 'WrongArg c _))  (event (SyntaxErrorIn c)))
660         ((_       ($ cmd 'Quit))          (trans (HaveQuit) (Shutdown)))
661         ((_       ($ cmd 'Noop))          (event (SayOK) ))
662
663         ((_       ($ cmd 'Turn))          (event (NotImplemented) ))
664         ((_       ($ cmd 'Send _))        (event (NotImplemented) ))
665         ((_       ($ cmd 'Soml _))        (event (NotImplemented) ))
666         ((_       ($ cmd 'Saml _))        (event (NotImplemented) ))
667         ((_       ($ cmd 'Vrfy _))        (event (NotImplemented) ))
668         ((_       ($ cmd 'Expn _))        (event (NotImplemented) ))
669
670         ((_       ($ cmd 'Help x))        (event (SeeksHelp x) ))
671
672         ((($ session-state 'Unknown)   ($ cmd 'Rset))          (event (SayOK) ))
673         ((($ session-state 'HaveHelo)  ($ cmd 'Rset))          (event (SayOK) ))
674         ((_                            ($ cmd 'Rset))          (trans (HaveHelo) (ResetState )))
675
676         ((($ session-state 'Unknown)   ($ cmd 'Helo x))        (trans (HaveHelo) (SayHelo x)))
677         ((_                            ($ cmd 'Helo x))        (trans (HaveHelo) (SayHeloAgain x)))
678         ((($ session-state 'Unknown)   ($ cmd 'Ehlo x))        (trans (HaveHelo) (SayEhlo x)))
679         ((_                            ($ cmd 'Ehlo x))        (trans (HaveHelo) (SayEhloAgain x)))
680
681         ((($ session-state 'Unknown)   ($ cmd 'MailFrom x))    (event (NeedHeloFirst)))
682         ((_                            ($ cmd 'MailFrom x))    (trans (HaveMailFrom) (SetMailFrom x)))
683
684         ((($ session-state 'Unknown)   ($ cmd 'RcptTo x))      (event (NeedHeloFirst)))
685         ((($ session-state 'HaveHelo)  ($ cmd 'RcptTo x))      (event (NeedMailFromFirst)))
686         ((_                            ($ cmd 'RcptTo x))      (trans (HaveRcptTo) (AddRcptTo x)))
687
688         ((($ session-state 'Unknown)      ($ cmd 'Data x))     (event (NeedHeloFirst)))
689         ((($ session-state 'HaveHelo)     ($ cmd 'Data x))     (event (NeedMailFromFirst)))
690         ((($ session-state 'HaveMailFrom) ($ cmd 'Data x))     (event (NeedRcptToFirst)))
691         ((($ session-state 'HaveRcptTo)   ($ cmd 'Data x))     (trans (HaveData) (StartData)))
692         ))
693  )
694
695)
Note: See TracBrowser for help on using the repository browser.