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

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

simple test case for smtp

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 #f))
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 m)
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\n\r" 
130                          (Reply (Code (Success) (MailSystem) 0) (list "OK")))
131                 (cont)) 
132          ;; TODO: check response after the end of data
133          (loop (cons line tempdata))))))
134
135(define (main in out) 
136  (let loop ((fsm (start-session)))
137    (let ((line     (read-smtp-line in)))
138      (if (null? line) (loop fsm)
139          (let ((instream (list `(() ,line))))
140            (let-values
141             (((reply ev fsm)
142               (cases session-fsm (fsm instream)
143                      (Event (ev)
144                             (let ((reply (handle-event ev)))
145                               (values reply ev fsm)))
146                      (Trans (ev fsm)
147                             (let ((reply (handle-event ev)))
148                               (values reply ev fsm))))))
149             (fprintf out "~A\n\r" reply)
150             (cases event ev
151                    (StartData ()
152                               (handle-data in out (lambda () (loop fsm))))
153                    (Shutdown ()
154                              (exit 0))
155                    (else (loop fsm)))))))))
156                     
157(main (current-input-port) (current-output-port))
Note: See TracBrowser for help on using the repository browser.