source: project/release/4/smtp/trunk/tests/mta.scm @ 15891

Last change on this file since 15891 was 15891, checked in by Ivan Raikov, 10 years ago

an elaboration of the smtp test case

File size: 3.9 KB
Line 
1
2;; An example MTA implementation
3
4(use datatype smtp)
5
6(define domain    "example.net")
7(define host      "chicken-mta")
8(define mailfrom  (make-parameter #f))
9(define rcpto     (make-parameter '()))
10(define data      (make-parameter #f))
11
12(define (handle-event ev)
13  (cases event ev
14         (SayHelo (s)
15          (Reply (Code (Success) (MailSystem) 0)
16                 (list host " " "Hello " s)))
17         
18         (SayHeloAgain (s)
19          (Reply (Code (Success) (MailSystem) 0)
20                 (list host " " "Hello " s)))
21
22         (SayEhlo (s)
23          (Reply (Code (Success) (MailSystem) 0)
24                 (list host " " "Hello " s)))
25         
26         (SayEhloAgain (s)
27          (Reply (Code (Success) (MailSystem) 0)
28                 (list host " " "Hello " s)))
29         
30         (SetMailFrom (m)
31           (mailfrom m)
32           (Reply (Code (Success) (MailSystem) 0) 
33                  (list "OK")))
34
35         (AddRcptTo (m)
36            (if (not (mailfrom))
37               (Reply (Code (PermanentFailure) (Syntax) 3)
38                      (list "command out of sequence"))
39               (begin
40                 (rcpto (cons m (rcpto)))
41                 (Reply (Code (Success) (MailSystem) 0) 
42                        (list "Accepted")))))
43
44         (StartData ()
45            (if (not (rcpto))
46               (Reply (Code (PermanentFailure) (MailSystem) 4)
47                      (list "no valid recipients"))
48               (begin
49                 (data (list))
50                 (Reply (Code (IntermediateSuccess) (MailSystem) 4)
51                        (list "Ready")))))
52
53         (NeedHeloFirst ()
54           (Reply (Code (PermanentFailure) (Syntax) 3)
55                      (list "command out of sequence: "
56                            "need HELO first")
57                      ))
58
59         (NeedMailFromFirst ()
60           (Reply (Code (PermanentFailure) (Syntax) 3)
61                      (list "command out of sequence: "
62                            "need MAIL first")
63                      ))
64
65         (NeedMailRcptToFirst ()
66           (Reply (Code (PermanentFailure) (Syntax) 3)
67                      (list "command out of sequence: "
68                            "need RCPT first")
69                      ))
70
71         (NotImplemented ()
72           (Reply (Code (PermanentFailure) (Syntax) 2)
73                  (list "command not implemented")))
74
75
76         (ResetState ()
77             (mailfrom #f)
78             (rcpto    #f)
79             (data     #f)
80             (Reply (Code (Success) (MailSystem) 0) 
81                    (list "Reset OK")))
82
83         (SayOK ()
84             (Reply (Code (Success) (MailSystem) 0) 
85                    (list "OK")))
86
87         (SeeksHelp (s)
88             (Reply (Code (Success) (Information) 4) 
89                    (list "Commands supported:"
90                          "HELO EHLO MAIL RCPT DATA QUIT RSET NOOP HELP")))
91
92         (Shutdown ()
93            (Reply (Code (Success) (MailSystem) 1)
94                   (list host " closing connection")))
95
96         (SyntaxErrorIn (s)
97            (Reply (Code (PermanentFailure) (Syntax) 1)
98                   (list "syntax error in " s)))
99
100         (Unrecognized (s)
101            (Reply (Code (PermanentFailure) (Syntax) 0)
102                   (list "Unrecognized " s)))
103         ))
104
105;; from SSAX lib
106(define (peek-next-char port)
107  (read-char port) 
108  (peek-char port))
109
110(define (read-smtp-line port)
111  (let loop ((cs (list)))
112    (let ((c (peek-char port)))
113    (if (eof-object? c) (reverse cs)
114        (let ((n (peek-next-char port)))
115          (cond ((and (eq? n #\newline) (eq? c #\return))
116                 (begin
117                   (read-char port)
118                   (reverse (cons* n c cs)))
119                 )
120                (else (loop (cons c cs)))))))))
121
122(define data-end (list #\. #\return #\newline))
123     
124(define (handle-data in out cont)
125  (let loop ((tempdata (list)))
126    (let ((line (read-smtp-line in)))
127      (if (equal? line data-end)
128          (begin (data (reverse tempdata))
129                 (fprintf out "~A" 
130                          (Reply (Code (Success) (MailSystem) 0) (list "OK")))
131                 (cont)) 
132          (loop (cons (list->string line) tempdata))))))
133
134(define (main in out) 
135  (let loop ((fsm (start-session)))
136    (let ((line     (read-smtp-line in)))
137      (if (null? line) (loop fsm)
138          (let ((instream (list `(() ,line))))
139            (let-values
140             (((reply ev fsm)
141               (cases session-fsm (fsm instream)
142                      (Event (ev)
143                             (let ((reply (handle-event ev)))
144                               (values reply ev fsm)))
145                      (Trans (ev fsm)
146                             (let ((reply (handle-event ev)))
147                               (values reply ev fsm))))))
148             (fprintf out "~A" reply)
149             (cases event ev
150                    (StartData ()
151                               (handle-data in out (lambda () (loop fsm))))
152                    (Shutdown ()
153                              (begin))
154                    (else (loop fsm)))))))))
155                     
Note: See TracBrowser for help on using the repository browser.