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

Last change on this file since 27605 was 27605, checked in by Ivan Raikov, 8 years ago

smtp: removed required-extension-version from .setup file

File size: 25.4 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-2012 Ivan Raikov and the Okinawa Institute of Science and Technology.
8;;
9;;
10;; This program is free software: you can redistribute it and/or
11;; modify it under the terms of the GNU General Public License as
12;; published by the Free Software Foundation, either version 3 of the
13;; License, or (at your option) any later version.
14;;
15;; This program is distributed in the hope that it will be useful, but
16;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18;; General Public License for more details.
19;;
20;; A full copy of the GPL license can be found at
21;; <http://www.gnu.org/licenses/>.
22
23(module smtp 
24
25        (
26         mailbox? Mailbox 
27
28         reply? Reply make-reply 
29         reply-success? reply-failure? reply-shutdown?
30
31         success-code? success-code-inject success-code-project 
32         Unused PreliminarySuccess Success IntermediateSuccess
33         TransientFailure PermanentFailure
34
35         category? category-inject category-project
36         Syntax Information Connection Unspecified3 Unspecified4
37         MailSystem
38
39         code? Code
40
41         event?
42 
43         cmd? Helo Ehlo MailFrom RcptTo Data Rset Send Soml Saml
44         Vrfy Expn Help Noop Quit Turn WrongArg wrong-arg
45
46         session-fsm?
47         CoreABNF->SMTP <SMTP> 
48        )
49
50        (import scheme chicken data-structures )
51        (require-extension srfi-1 srfi-13 srfi-14 datatype matchable typeclass )
52        (import-for-syntax matchable)
53
54        (require-library extras abnf abnf-consumers)
55        (import (prefix abnf abnf:) 
56                (prefix abnf-consumers abnf:) 
57                (only abnf <CoreABNF> <Input> <Token> <CharLex> )
58                (only extras sprintf fprintf ))
59
60
61(define-class <SMTP> (<CoreABNF> A) 
62  parse-cmd start-session )
63
64
65(define consumed-objects-lift-any
66  (abnf:consumed-objects-lift
67   (abnf:consumed-objects identity)))
68
69(define (list->domain-string lst)
70  (if (and (pair? lst) (char=? (last lst) #\-))
71      (error "domain string ends with - " 
72             (list->string lst))
73      (list->string lst)))
74
75(define-syntax bind-consumed->domain-string
76  (syntax-rules () 
77    ((_ p)    (abnf:bind 
78               (abnf:consumed-chars->list list->domain-string)
79               p))
80    ))
81
82
83(define-syntax define-enumerated-type
84  (lambda (x r c)
85    (match-let (((_ typename pred vector inject project . rest) x))
86    (let ((%define  (r 'define))
87          (%begin   (r 'begin))
88          (%if      (r 'if)))
89      `(,%begin
90        (,%define (,pred x)    (##sys#structure? x ',typename))
91        (,%define (,project x) (##sys#slot x 2))
92        (,%define (,inject i) 
93                  (and (integer? i) (positive? i) (< i (vector-length ,vector)) 
94                       (vector-ref ,vector i)))
95        ,(let loop ((variants rest) (i 0) (defs (list)))
96           (if (null? variants) 
97               `(,%begin ,@defs)
98               (let* ((variant  (car variants))
99                      (def  `(,%define ,variant   
100                                       (##sys#make-structure ',typename ',(car variant) ,i))))
101                 (loop (cdr variants) (+ i 1) (cons def defs)))))
102        ,(let loop ((variants rest) (defs (list)))
103           (if (null? variants) 
104               `(,%define ,vector (vector ,@(reverse defs)))
105               (let* ((variant  (car variants))
106                      (def  `(,(car variant))))
107                 (loop (cdr variants) (cons def defs)))))
108        )))))
109
110(define-datatype mailbox mailbox?
111  (Mailbox (local-part string?) 
112           (domain string?)))
113
114
115(define-record-printer (mailbox x out)
116  (match x 
117         (($ mailbox 'Mailbox "" "" )  (fprintf out "<>"))
118         (($ mailbox 'Mailbox "postmaster" "" )  (fprintf out "<postmaster>"))
119         (($ mailbox 'Mailbox l d ) 
120          (let ((mbox  (sprintf "~A@~A" l d)))
121            (fprintf out "<~A>" mbox)))))
122
123(define (null-mailbox) (Mailbox "" ""))
124
125(define (postmaster . rest) 
126  (let-optionals rest ((domain ""))
127   (Mailbox "postmaster" domain )))
128
129
130;; An SMTP reply is a three-digit return code plus some waste of
131;; bandwidth called "comments". This is what the list of strings is
132;; for; one string per line in the reply.  the record printer will
133;; append an CRLF end-of-line marker to each entry in that list, so
134;; that the resulting string is ready to be sent back to the peer.
135;;
136;; Here is an example:
137;;
138;; > (print (Reply (Code (Success) (MailSystem) 0)
139;;                     (list "worked" "like" "a charm")))
140;; 250-worked
141;; 250-like
142;; 250 a charm
143
144(define-datatype reply reply?
145  (Reply (code code?) (msg list?)))
146
147(define-enumerated-type 
148  success-code success-code? success-vector 
149  success-code-inject success-code-project 
150  (Unused)
151  (PreliminarySuccess)
152  (Success)
153  (IntermediateSuccess)
154  (TransientFailure)
155  (PermanentFailure))
156
157(define-enumerated-type 
158  category category? category-vector
159  category-inject category-project
160  (Syntax)
161  (Information)
162  (Connection)
163  (Unspecified3)
164  (Unspecified4)
165  (MailSystem))
166
167(define-datatype code code?
168  (Code (suc success-code?) (cat category?) (num integer?)))
169
170(define-record-printer (reply x out)
171  (match x 
172         (($ reply 'Reply (and c ($ code 'Code suc cat _)) ())
173          (let ((msg (sprintf "~A in category ~A" suc cat)))
174            (fprintf out "~A" (Reply c (list msg)))))
175
176         (($ reply 'Reply code msg) 
177          (let ((prefix-con (sprintf "~A-" code))
178                (prefix-end (sprintf "~A " code))
179                (fmt        (lambda (p) (lambda (l) (sprintf "~A~A\r\n" p l)))))
180            (match-let (((x . xs) (reverse msg)))
181                       (let* ((msg-con (map (fmt prefix-con) xs))
182                              (msg-end ((fmt prefix-end) x))
183                              (msg1    (reverse (cons msg-end msg-con))))
184                         (fprintf out "~A" (string-concatenate msg1))))))
185         ))
186
187(define-record-printer (code x out)
188  (cases code x
189         (Code (suc cat n) 
190               (fprintf out "~A~A~A" (success-code-project suc) 
191                        (category-project cat) n))))
192         
193;; Constructs a Reply.
194
195(define (in-range-incl? lo hi)
196  (if (< hi lo) (in-range-incl? hi lo)
197      (lambda (x) (and (<= lo x) (<= x hi)))))
198
199(define check-suc  (in-range-incl? 0 5))
200(define check-cat  (in-range-incl? 0 5))
201(define check-code (in-range-incl? 0 9))
202
203(define (make-reply suc cat n msg)
204  (or (and (check-suc suc) (check-cat cat) (check-code n)
205           (Reply (Code (success-code-inject suc) (category-inject cat) n) msg))
206      (error 'make-reply "arguments out of range: " suc cat n)))
207
208
209;; A reply constitutes success if the status code is any of
210;; PreliminarySuccess, Success, or IntermediateSuccess.
211
212(define (reply-success? r)
213  (match r (($ reply 'Reply 
214               ($ code 'Code 
215                  ($ success-code (or 'PreliminarySuccess 
216                                      'IntermediateSuccess 'Success _) _ _) _))
217            #t)
218         (else #f)))
219
220;; A reply constitutes failure if the status code is either
221;; PermanentFailure or TransientFailure.
222
223(define (reply-failure? r)
224  (match r (($ reply 'Reply 
225               ($ code 'Code 
226                  ($ success-code (or 'PermanentFailure 
227                                      'TransientFailure _) _ _) _))
228            #t)
229         (else #f)))
230
231;; The replies 221 and 421 signify Shutdown.
232
233(define (reply-shutdown? r)
234  (match r (($ reply 'Reply 
235               ($ code 'Code ($ success-code (or 'Success 
236                                                 'TransientFailure) _) 
237                  ($ category 'Connection _) 1) _)
238            #t)
239         (else #f)))
240
241
242;; Argument Parsers
243
244;; Match any US-ASCII character except for control characters,
245;; specials, or space. atom and dot-atom are made up of this.
246
247(define=> (atext <CoreABNF>)
248  (abnf:alternatives
249   alpha decimal
250   (set-from-string "!#$%&'*+-/=?^_`{|}~")))
251
252(define=> (Atom <CoreABNF>)
253  (lambda (atext)
254    (abnf:bind-consumed->string (abnf:repetition1 atext))))
255
256(define=> (Dot-string <CoreABNF>)
257  (lambda (atext)
258    (abnf:bind-consumed->string 
259     (abnf:concatenation
260      (abnf:repetition1 atext) 
261      (abnf:repetition
262       (abnf:concatenation
263        (char #\.) 
264        (abnf:repetition1 atext)))))))
265
266;; backslash followed by any ASCII graphic (including itself) or space
267(define=> (quoted-pairSMTP <CoreABNF>)
268  (abnf:concatenation
269   (char #\\) 
270   (set char-set:printing)))
271
272;; within a quoted string, any ASCII graphic or space is permitted
273;; without blackslash-quoting except double-quote and the backslash
274;; itself.
275(define=> (qtextSMTP <CoreABNF>)
276  (set
277   (char-set-difference 
278    char-set:printing
279    (char-set #\" #\\))))
280
281(define (QcontentSMTP qtextSMTP quoted-pairSMTP)
282  (abnf:alternatives qtextSMTP quoted-pairSMTP))
283
284(define=> (Quoted-string <CoreABNF>)
285  (lambda (QcontentSMTP)
286    (abnf:bind-consumed->string 
287     (abnf:concatenation
288      (abnf:drop-consumed dquote) 
289      (abnf:repetition QcontentSMTP) 
290      (abnf:drop-consumed dquote)))))
291
292(define (String Atom Quoted-string)
293  (abnf:alternatives Atom Quoted-string))
294
295(define=> (esmtp-keyword <CoreABNF>)
296  (abnf:bind-consumed->symbol
297   (abnf:concatenation
298    (abnf:alternatives alpha decimal) 
299    (abnf:repetition
300     (abnf:alternatives 
301      alpha decimal (char #\-))))))
302
303
304(define=> (esmtp-value <CoreABNF>)
305  (abnf:bind-consumed->string
306   (abnf:repetition1 
307    (set (char-set-difference
308          char-set:graphic (char-set #\= #\space))))))
309
310;; any CHAR excluding "=", SP, and control
311;; characters.  If this string is an email address,
312;; i.e., a Mailbox, then the "xtext" syntax [32]
313;; SHOULD be used.
314
315(define=> (esmtp-param <CoreABNF>)
316  (lambda (esmtp-keyword esmtp-value)
317    (abnf:bind-consumed-strings->list
318     (abnf:concatenation
319      esmtp-keyword 
320      (abnf:optional-sequence
321       (abnf:concatenation 
322        (abnf:drop-consumed (char #\=)) 
323        esmtp-value))))))
324
325
326
327(define=> (Mail-parameters <CoreABNF>)
328  (lambda (esmtp-param)
329    (abnf:bind-consumed-pairs->list
330     (abnf:concatenation
331      esmtp-param
332      (abnf:repetition 
333       (abnf:concatenation 
334        (abnf:drop-consumed sp) 
335        esmtp-param))))))
336
337
338(define=> (Ldh-str <CoreABNF>)
339  (bind-consumed->domain-string
340   (abnf:concatenation 
341    alpha 
342    (abnf:repetition
343     (abnf:alternatives
344      alpha decimal (char #\-))))))
345
346;;(define sub-domain     Ldh-str)
347
348(define=> (domain <CoreABNF>)
349  (lambda (sub-domain)
350    (abnf:bind-consumed-strings->list
351     (lambda (l) 
352       (string-concatenate (intersperse l ".")))
353     (abnf:concatenation 
354      sub-domain
355      (abnf:repetition
356       (abnf:concatenation 
357        (abnf:drop-consumed (char #\.)) 
358        sub-domain))))))
359
360(define=> (At-domain <CoreABNF>)
361  (lambda (domain)
362    (abnf:concatenation 
363     (abnf:drop-consumed (char #\@)) 
364     domain)))
365
366(define=> (A-d-l <CoreABNF>)
367  (lambda (At-domain)
368    (abnf:bind-consumed-strings->list 
369     (abnf:concatenation
370      At-domain
371      (abnf:repetition
372       (abnf:concatenation
373        (abnf:drop-consumed (char #\,)) 
374        At-domain))))))
375
376(define (Local-part Dot-string Quoted-string)
377  (abnf:alternatives
378   Dot-string
379   Quoted-string))
380
381(define=> (IPv6-hex <CoreABNF>)
382  (abnf:bind-consumed->string 
383   (abnf:variable-repetition 1 4 hexadecimal)))
384
385(define=> (cIPv6-hex <CoreABNF>)
386  (abnf:concatenation
387   (abnf:drop-consumed (char #\:)) 
388   IPv6-hex))
389
390(define=> (IPv6-full <CoreABNF>)
391  (lambda (IPv6-hex cIPv6-hex)
392    (abnf:bind-consumed-strings->list 
393     (abnf:concatenation 
394      IPv6-hex
395      (abnf:repetition-n 7 cIPv6-hex)))))
396
397(define=> (IPv6-comp <CoreABNF>)
398  (lambda (IPv6-hex cIPv6-hex)
399    (abnf:bind-consumed-strings->list
400     (abnf:concatenation
401      (abnf:optional-sequence
402       (abnf:concatenation 
403        IPv6-hex
404      (abnf:variable-repetition 0 5 cIPv6-hex)))
405      (abnf:bind-consumed->string (lit "::"))
406      (abnf:optional-sequence
407       (abnf:concatenation 
408        IPv6-hex
409        (abnf:variable-repetition 0 5 cIPv6-hex)))))))
410
411;; The "::" represents at least 2 16-bit groups of zeros.  No more
412;; than 6 groups in addition to the "::" may be present.
413
414(define=> (Snum <CoreABNF>)
415  (abnf:bind-consumed->string
416   (abnf:variable-repetition 1 3 decimal)))
417
418(define=> (IPv4-address-literal <CoreABNF>)
419  (lambda (Snum)
420    (abnf:concatenation 
421     Snum 
422     (abnf:repetition-n 
423      3 (abnf:concatenation 
424         (abnf:drop-consumed (char #\.)) 
425         Snum)))))
426
427
428(define=> (IPv6v4-full <CoreABNF>)
429  (lambda (IPv6-hex cIPv6-hex IPv4-address-literal)
430    (abnf:bind-consumed-strings->list
431     (abnf:concatenation 
432      IPv6-hex (abnf:repetition-n 5 cIPv6-hex) 
433      (abnf:drop-consumed (char #\:))
434      IPv4-address-literal))))
435
436
437(define=> (IPv6v4-comp <CoreABNF>)
438  (lambda (IPv6-hex cIPv6-hex IPv4-address-literal)
439    (abnf:bind-consumed-strings->list
440     (abnf:concatenation 
441      (abnf:optional-sequence
442       (abnf:concatenation
443        IPv6-hex
444        (abnf:variable-repetition 0 3 cIPv6-hex)))
445      (abnf:bind-consumed->string (lit "::"))
446      (abnf:optional-sequence
447       (abnf:concatenation
448        IPv6-hex
449        (abnf:variable-repetition 0 3 cIPv6-hex) 
450        (abnf:drop-consumed (char #\:))))
451      IPv4-address-literal))))
452
453
454;; The "::" represents at least 2 16-bit groups of zeros.  No more
455;; than 4 groups in addition to the "::" and IPv4-address-literal may
456;; be present.
457
458(define=>  (IPv6-addr <CoreABNF>)
459  (lambda (IPv6-full IPv6-comp IPv6v4-full IPv6v4-comp)
460    (abnf:alternatives IPv6-full IPv6-comp IPv6v4-full IPv6v4-comp)))
461
462(define=> (IPv6-address-literal <CoreABNF>)
463  (lambda (IPv6-addr)
464    (abnf:concatenation
465     (abnf:bind-consumed->string (lit "IPv6:")) IPv6-addr)))
466
467(define=> (dcontent <CoreABNF>)
468  (set (char-set-difference
469        char-set:printing 
470        (char-set #\[ #\] #\\))))
471
472
473(define (Standardized-tag Ldh-str)
474  (abnf:bind-consumed->symbol Ldh-str))
475;; Standardized-tag MUST be specified in a Standards-Track RFC and
476;; registered with IANA
477
478
479(define=> (General-address-literal <CoreABNF>)
480  (lambda (Standardized-tag dcontent)
481    (abnf:concatenation
482     Standardized-tag (abnf:drop-consumed (char #\:))
483     (abnf:repetition1 dcontent))))
484
485
486(define=> (address-literal <CoreABNF>)
487  (lambda (IPv4-address-literal IPv6-address-literal General-address-literal)
488    (abnf:concatenation
489     (char #\[) 
490     (abnf:alternatives
491      IPv4-address-literal 
492      IPv6-address-literal 
493      General-address-literal)
494     (char #\]))))
495
496;; See Section 4.1.3
497
498(define=> (Mailbox-p <CoreABNF>)
499  (lambda (Local-part domain address-literal)
500    (abnf:bind
501     (consumed-objects-lift-any 
502      (lambda (x) (Mailbox (first x) (second x))))
503     (abnf:concatenation 
504      Local-part
505      (abnf:drop-consumed (char #\@) )
506      (abnf:alternatives domain address-literal)))))
507
508(define=> (Path-p <CoreABNF>)
509  (lambda (A-d-l Mailbox-p)
510    (abnf:bind 
511     (consumed-objects-lift-any first)
512     (abnf:concatenation
513      (abnf:drop-consumed (char #\<) )
514      (abnf:optional-sequence 
515       (abnf:drop-consumed
516        (abnf:concatenation 
517         A-d-l 
518         (char #\:))))
519      Mailbox-p
520      (abnf:drop-consumed (char #\>))))))
521
522;;(define Forward-path   Path-p)
523
524(define=> (Reverse-path <CoreABNF>)
525  (lambda (Path-p)
526    (abnf:alternatives 
527     (abnf:bind
528      (consumed-objects-lift-any 
529       (lambda x (null-mailbox)))
530      (abnf:concatenation
531       (char #\<) (char #\>)))
532     Path-p)))
533
534(define=> (from-path <CoreABNF>)
535  (lambda (Reverse-path)
536    (abnf:concatenation
537     (abnf:drop-consumed (lit "FROM:"))
538     Reverse-path)))
539
540(define=> (to-path  <CoreABNF>)
541  (lambda (domain Forward-path)
542
543    (abnf:concatenation
544     (abnf:drop-consumed (lit "TO:"))
545     (abnf:alternatives 
546
547      (abnf:bind
548       (consumed-objects-lift-any 
549        (lambda (x) (postmaster)))
550       (abnf:concatenation
551        (char #\<) 
552        (lit "Postmaster") 
553        (char #\>)))
554
555      (abnf:bind
556       (consumed-objects-lift-any 
557        (lambda (x) (postmaster (first x))))
558       (abnf:concatenation
559        (abnf:drop-consumed (char #\<) )
560        (abnf:drop-consumed (lit "Postmaster@") )
561        domain 
562        (abnf:drop-consumed (char #\>))))
563
564    Forward-path))))
565
566
567;; ESMTP sessions, events, commands
568
569(define-datatype session-state session-state?
570  (Unknown)
571  (HaveHelo)
572  (HaveMailFrom)
573  (HaveRcptTo)
574  (HaveData)
575  (HaveQuit))
576
577(define-record-printer (session-state x out)
578  (fprintf out "<#session-state ~A>" 
579           (cases session-state x
580                  (Unknown ()      "Unknown")
581                  (HaveHelo ()     "HaveHelo")
582                  (HaveMailFrom () "HaveMailFrom")
583                  (HaveRcptTo   () "HaveRcptTo")
584                  (HaveData     () "HaveData")
585                  (HaveQuit     () "HaveQuit"))))
586
587(define-datatype event event?
588  (SayHelo       (s string?))
589  (SayHeloAgain  (s string?))
590  (SayEhlo       (s string?))
591  (SayEhloAgain  (s string?))
592  (SetMailFrom   (m mailbox?) (parameters? list?))
593  (AddRcptTo     (m mailbox?) (parameters? list?))
594  (StartData)
595  (NeedHeloFirst)
596  (NeedMailFromFirst)
597  (NeedRcptToFirst)
598  (NotImplemented) ;; Turn, Send, Soml, Saml, Vrfy, Expn.
599  (ResetState)
600  (SayOK)
601  ;; Triggered in case of Noop or when Rset is used before
602  ;; we even have a state.
603  (SeeksHelp    (s string?))
604  (Shutdown)
605  (SyntaxErrorIn (s string?))
606  (Unrecognized  (s string?)))
607 
608(define-datatype cmd cmd?
609  (Helo (s string?))
610  (Ehlo (s string?))
611  (MailFrom (m mailbox?) (parameters list?))
612  (RcptTo   (m mailbox?) (parameters list?))
613  (Data)
614  (Rset)
615  (Send  (m mailbox?))
616  (Soml  (m mailbox?))
617  (Saml  (m mailbox?))
618  (Vrfy  (s string?))
619  (Expn  (s string?))
620  (Help  (s string?))
621  (Noop)
622  (Quit)
623  (Turn)
624;; When a valid command has been recognized, but the
625;; argument parser fails, then this type will be
626;; returned.
627  (WrongArg (cmd string?)  (message string?)))
628
629(define-record-printer (cmd x out)
630  (cases cmd x 
631         (Helo (s)        (fprintf out "HELO ~A" s))
632         (Ehlo (s)        (fprintf out "EHLO ~A" s))
633         (MailFrom (m p)  (fprintf out "MAIL FROM:~A" m))
634         (RcptTo (m p)    (fprintf out "RCPT TO: ~A" m))
635         (Data ()         (fprintf out "DATA"))
636         (Rset ()         (fprintf out "RSET"))
637         (Send (m)        (fprintf out "SEND ~A" m))
638         (Soml (m)        (fprintf out "SOML ~A" m))
639         (Saml (m)        (fprintf out "SAML ~A" m))
640         (Vrfy (s)        (fprintf out "VRFY ~A" s))
641         (Expn (s)        (fprintf out "EXPN ~A" s))
642         (Noop ()         (fprintf out "NOOP"))
643         (Quit ()         (fprintf out "QUIT"))
644         (Turn ()         (fprintf out "TURN"))
645         (Help (s)        (fprintf out "HELP ~A" s))
646         (WrongArg (s)    (fprintf out "Syntax error in argument of ~A." s))))
647
648;; Command Parsers
649
650;; Constructs a parser for a command without arguments.
651
652(define=> (mkcmdp0 <CoreABNF>)
653  (lambda (s kons) 
654    (define (ignore x) (kons))
655    (let ((ss (->string s)))
656      (abnf:bind (consumed-objects-lift-any ignore)
657                 (abnf:concatenation
658                  (abnf:bind-consumed->symbol (lit ss))
659                  (abnf:drop-consumed (abnf:repetition sp))
660                  (abnf:drop-consumed crlf)
661                  )))))
662
663;; Constructs a WrongArg command
664(define (wrong-arg cmd)
665  (abnf:bind (lambda (x) (list (WrongArg cmd "")))
666             abnf:pass))
667
668;; Constructs a parser for a command with an argument, which the given
669;; parser will handle. The result of the argument parser will be
670;; applied to the given constructor procedure before returning.
671
672(define=> (mkcmdp1 <CoreABNF>)
673  (lambda (s kons p . r) 
674    (let ((ss (->string s))
675          (make (if (null? r)
676                    (lambda (x) (kons (first x)))
677                    (lambda (x)
678                      (match x ((x r) (kons x r))
679                             ((x) (kons x (list)))
680                             )))))
681
682      (abnf:bind (consumed-objects-lift-any make) 
683                 
684                 (abnf:concatenation
685                 
686                  (abnf:drop-consumed (lit ss))
687                  (abnf:drop-consumed (abnf:repetition sp))
688       
689                  (abnf:alternatives p (wrong-arg ss) )
690                 
691                  (if (null? r)
692                      (abnf:drop-consumed crlf)
693                      (abnf:concatenation
694                       (abnf:optional-sequence 
695                        (abnf:concatenation
696                         (abnf:drop-consumed (abnf:repetition sp))
697                         (car r)))
698                       (abnf:drop-consumed crlf)))
699
700                  ))
701      )))
702
703
704;; Parsers for (optional) argument strings
705
706(define=> (Arg-string <CoreABNF>)
707  (lambda (String)
708    (abnf:concatenation 
709     (abnf:drop-consumed sp) String)))
710
711(define=> (Opt-string <CoreABNF>)
712  (lambda (String)
713    (abnf:optional-sequence
714     (abnf:concatenation 
715      (abnf:drop-consumed sp) String))))
716
717;; ESMTP State Machine
718
719(define-datatype session-fsm session-fsm?
720  (Event (ev event?))
721  (Trans (ev event?) (fsm procedure?)))
722
723
724(define (CoreABNF->SMTP A)
725
726  (let* (
727         ;; The SMTP parsers defined here correspond to the commands specified
728         ;; in the RFC.
729
730         (atext            (atext A))
731         (Atom             ((Atom A) atext))
732         (quoted-pairSMTP  (quoted-pairSMTP A))
733         (qtextSMTP        (qtextSMTP A))
734         (QcontentSMTP     (QcontentSMTP qtextSMTP quoted-pairSMTP))
735         (Quoted-string    ((Quoted-string A) QcontentSMTP))
736         (String           (String Atom Quoted-string))
737         (Arg-string       ((Arg-string A) String))
738         (Opt-string       ((Opt-string A) String))
739         (Dot-string       ((Dot-string A) atext))
740         (Ldh-str          (Ldh-str A))
741
742         (sub-domain       Ldh-str)
743         (domain           ((domain A) sub-domain))
744         (At-domain        ((At-domain A) domain))
745         (A-d-l            ((A-d-l A) At-domain))
746         (Local-part       (Local-part Dot-string Quoted-string))
747
748         (IPv6-hex             (IPv6-hex A))
749         (cIPv6-hex            (cIPv6-hex A))
750         (IPv6-comp            ((IPv6-comp A) IPv6-hex cIPv6-hex))
751         (Snum                 (Snum A))
752         (IPv4-address-literal ((IPv4-address-literal A) Snum))
753         (IPv6v4-comp          ((IPv6v4-comp A)
754                                IPv6-hex cIPv6-hex IPv4-address-literal))
755         (IPv6v4-full          ((IPv6v4-full A)
756                                IPv6-hex cIPv6-hex IPv4-address-literal))
757         (IPv6-addr            ((IPv6-addr A)
758                                IPv6-full IPv6-comp IPv6v4-full IPv6v4-comp))
759         (IPv6-address-literal ((IPv6-address-literal A)
760                                IPv6-addr))
761
762         (dcontent          (dcontent A))
763         (Standardized-tag  (Standardized-tag Ldh-str))
764         (General-address-literal  ((General-address-literal A)
765                                    Standardized-tag dcontent))
766                                   
767         (address-literal ((address-literal A) 
768                           IPv4-address-literal 
769                           IPv6-address-literal 
770                           General-address-literal))
771
772         (Mailbox-p      ((Mailbox-p A) Local-part domain address-literal))
773         (Path-p         ((Path-p A) A-d-l Mailbox-p))
774         (Reverse-path   ((Reverse-path A) Path-p))
775         (Forward-path   Path-p)
776         (from-path      ((from-path A) Reverse-path))
777         (to-path        ((to-path A) domain Forward-path))
778
779         (esmtp-value     (esmtp-value A))
780         (esmtp-keyword   (esmtp-keyword A))
781         (esmtp-param     ((esmtp-param A) esmtp-keyword esmtp-value))
782         (Mail-parameters ((Mail-parameters A) esmtp-param))
783         
784         (mkcmdp0  (mkcmdp0 A))
785         (mkcmdp1  (mkcmdp1 A))
786         
787         (data (mkcmdp0 "DATA" Data))
788         (rset (mkcmdp0 "RSET" Rset))
789         (quit (mkcmdp0 "QUIT" Quit))
790         (turn (mkcmdp0 "TURN" Turn))
791         (helo (mkcmdp1 "HELO" Helo     domain))
792         (ehlo (mkcmdp1 "EHLO" Ehlo     domain))
793         (vrfy (mkcmdp1 "VRFY" Vrfy     Arg-string))
794         (expn (mkcmdp1 "EXPN" Expn     Arg-string))
795
796         (rcpt (mkcmdp1 "RCPT" RcptTo   to-path Mail-parameters))
797         (mail (mkcmdp1 "MAIL" MailFrom from-path Mail-parameters))
798         (send (mkcmdp1 "SEND" Send     from-path))
799         (soml (mkcmdp1 "SOML" Soml     from-path))
800         (saml (mkcmdp1 "SAML" Saml     from-path))
801
802         (help (mkcmdp1 "HELP" (lambda (x) (if (null? x) (Help) (Help (car x))))
803                        Opt-string))
804
805         (noop0 (mkcmdp1 "NOOP" (lambda (x) (Noop)) Opt-string))
806
807
808         (smtp-cmd   (abnf:alternatives
809                       data rset noop0 quit turn helo mail rcpt 
810                       send soml saml vrfy expn help ehlo))
811
812         (parse-cmd  (lambda (k) (lambda (s) (smtp-cmd (compose k caar) identity s))))
813
814         )
815
816;; Parses an SMTP protocol line and runs handle-cmd to determine the
817;; event. In case of syntax errors, SyntaxErrorIn or Unrecognized will
818;; be returned.  Inputs must be terminated with CRLF.
819    (letrec ((fsm            (lambda (st) (lambda (s) ((parse-cmd (handle-cmd st)) s))))
820             (event          Event)
821             (trans          (lambda (st ev) (Trans ev (fsm st))))
822             (start-session  (lambda () (fsm (Unknown))))
823             (handle-cmd     (lambda (st) 
824                               (lambda (cmd)
825                                 (match (list st cmd )
826                                        ((($ session-state 'HaveQuit) _)  (event (Shutdown)))
827                                       
828                                        ((_       ($ cmd 'WrongArg c _))  (event (SyntaxErrorIn c)))
829                                        ((_       ($ cmd 'Quit))          (trans (HaveQuit) (Shutdown)))
830                                        ((_       ($ cmd 'Noop))          (event (SayOK) ))
831                                       
832                                        ((_       ($ cmd 'Turn))          (event (NotImplemented) ))
833                                        ((_       ($ cmd 'Send _))        (event (NotImplemented) ))
834                                        ((_       ($ cmd 'Soml _))        (event (NotImplemented) ))
835                                        ((_       ($ cmd 'Saml _))        (event (NotImplemented) ))
836                                        ((_       ($ cmd 'Vrfy _))        (event (NotImplemented) ))
837                                        ((_       ($ cmd 'Expn _))        (event (NotImplemented) ))
838                                       
839                                        ((_       ($ cmd 'Help x))        (event (SeeksHelp x) ))
840                                       
841                                       ((($ session-state 'Unknown)   ($ cmd 'Rset))         
842                                        (event (SayOK) ))
843                                       ((($ session-state 'HaveHelo)  ($ cmd 'Rset))         
844                                        (event (SayOK) ))
845                                       ((_                            ($ cmd 'Rset))         
846                                        (trans (HaveHelo) (ResetState )))
847                                       
848                                       ((($ session-state 'Unknown)   ($ cmd 'Helo x))       
849                                        (trans (HaveHelo) (SayHelo x)))
850                                       ((_                            ($ cmd 'Helo x))       
851                                        (trans (HaveHelo) (SayHeloAgain x)))
852                                       ((($ session-state 'Unknown)   ($ cmd 'Ehlo x))       
853                                        (trans (HaveHelo) (SayEhlo x)))
854                                       ((_                            ($ cmd 'Ehlo x))       
855                                        (trans (HaveHelo) (SayEhloAgain x)))
856
857                                       ((($ session-state 'Unknown)   ($ cmd 'MailFrom . _)) 
858                                        (event (NeedHeloFirst)))
859                                       ((_                            ($ cmd 'MailFrom x p)) 
860                                        (trans (HaveMailFrom) (SetMailFrom x p)))
861                                       
862                                       ((($ session-state 'Unknown)   ($ cmd 'RcptTo . _))   
863                                        (event (NeedHeloFirst)))
864                                       ((($ session-state 'HaveHelo)  ($ cmd 'RcptTo . _))   
865                                        (event (NeedMailFromFirst)))
866                                       ((_                            ($ cmd 'RcptTo x p))   
867                                        (trans (HaveRcptTo) (AddRcptTo x p)))
868                                       
869                                       ((($ session-state 'Unknown)      ($ cmd 'Data))     
870                                        (event (NeedHeloFirst)))
871                                       ((($ session-state 'HaveHelo)     ($ cmd 'Data))     
872                                        (event (NeedMailFromFirst)))
873                                       ((($ session-state 'HaveMailFrom) ($ cmd 'Data))     
874                                        (event (NeedRcptToFirst)))
875                                       ((($ session-state 'HaveRcptTo)   ($ cmd 'Data))     
876                                        (trans (HaveData) (StartData)))
877                                       
878                                       ((($ session-state 'HaveData)   _)     (event (StartData)))
879
880                                       ((_  _)                           (event (Unrecognized "")))
881                                       
882                                       ))
883                              ))
884             )
885      (make-<SMTP> A parse-cmd start-session ))))
886   
887
888)
Note: See TracBrowser for help on using the repository browser.