source: project/release/4/smtp/tags/4.0/smtp.scm @ 27606

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

smtp: using utf8 for compatibility with abnf 6.0+

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