source: project/wiki/eggref/4/smtp @ 15893

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

added an example to smtp doc

File size: 8.1 KB
Line 
1[[tags: eggs]]
2[[toc:]]
3
4== smtp
5
6=== Description
7
8{{smtp}} is a collection of parser combinators and state machine
9primitives for the grammar defined in
10[[http://www.ietf.org/rfc/rfc5321.txt|RFC 5321]]
11(Simple Mail Transfer Protocol).
12
13=== Data Types for SMTP Commands
14
15 
16 (define-datatype cmd cmd?
17  (Helo (s string?))
18  (Ehlo (s string?))
19  (MailFrom (m mailbox?) (parameters list?))
20  (RcptTo   (m mailbox?) (parameters list?))
21  (Data)
22  (Rset)
23  (Send  (m mailbox?))
24  (Soml  (m mailbox?))
25  (Saml  (m mailbox?))
26  (Vrfy  (s string?))
27  (Expn  (s string?))
28  (Help  (s string?))
29  (Noop)
30  (Quit)
31  (Turn)
32  (WrongArg (cmd string?)  (message string?)))
33
34
35 (define-datatype mailbox mailbox?
36   (Mailbox (local-part string?)
37            (domain string?)))
38
39
40=== Data Types for SMTP Replies
41
42  (define-datatype reply reply?
43   (Reply (code code?) (msg list?)))
44
45 (define-enumerated-type
46   success-code success-code? success-vector
47   success-code-inject success-code-project
48   (Unused)
49   (PreliminarySuccess)
50   (Success)
51   (IntermediateSuccess)
52   (TransientFailure)
53   (PermanentFailure))
54
55 (define-enumerated-type
56   category category? category-vector
57   category-inject category-project
58   (Syntax)
59   (Information)
60   (Connection)
61   (Unspecified3)
62   (Unspecified4)
63   (MailSystem))
64
65 (define-datatype code code?
66   (Code (suc success-code?) (cat category?) (num integer?)))
67
68An SMTP reply is a three-digit return code plus comments. This is what
69the list of strings is for; one string per line in the reply.  the
70record printer will ppend an CRLF end-of-line marker to each entry in
71that list, so that the resulting string is ready to be sent back to
72the peer.
73
74
75For example:
76
77 > (print (Reply (Code (Success) (MailSystem) 0)
78                     (list "worked" "like" "a charm")))
79 250-worked
80 250-like
81 250 a charm
82
83
84=== Command Parsers
85
86 (define (parse-cmd cont)
87
88=== ESMTP State Machine
89
90 start-session session-fsm?
91
92 (define-datatype session-state session-state?
93   (Unknown)
94   (HaveHelo)
95   (HaveMailFrom)
96   (HaveRcptTo)
97   (HaveData)
98   (HaveQuit))
99
100 (define-datatype event event?
101   (SayHelo       (s string?))
102   (SayHeloAgain  (s string?))
103   (SayEhlo       (s string?))
104   (SayEhloAgain  (s string?))
105   (SetMailFrom   (m mailbox?) (parameters? list))
106   (AddRcptTo     (m mailbox?) (parameters? list))
107   (StartData)
108   (NeedHeloFirst)
109   (NeedMailFromFirst)
110   (NeedRcptToFirst)
111   (NotImplemented) ;; Turn, Send, Soml, Saml, Vrfy, Expn.
112   (ResetState)
113   (SayOK)
114   (SeeksHelp    (s string?))
115   (Shutdown)
116   (SyntaxErrorIn (s string?))
117   (Unrecognized  (s string?)))
118
119=== Requires
120
121* [[abnf]]
122* [[datatype]]
123* [[matchable]]
124
125=== Examples
126
127<enscript highlight="scheme">
128
129;; An example MTA implementation
130
131(use datatype smtp)
132
133(define domain    "example.net")
134(define host      "chicken-mta")
135(define mailfrom  (make-parameter #f))
136(define rcpto     (make-parameter '()))
137(define data      (make-parameter #f))
138
139(define (handle-event ev)
140  (cases event ev
141         (SayHelo (s)
142          (Reply (Code (Success) (MailSystem) 0)
143                 (list host " " "Hello " s)))
144         
145         (SayHeloAgain (s)
146          (Reply (Code (Success) (MailSystem) 0)
147                 (list host " " "Hello " s)))
148
149         (SayEhlo (s)
150          (Reply (Code (Success) (MailSystem) 0)
151                 (list host " " "Hello " s)))
152         
153         (SayEhloAgain (s)
154          (Reply (Code (Success) (MailSystem) 0)
155                 (list host " " "Hello " s)))
156         
157         (SetMailFrom (m)
158           (mailfrom m)
159           (Reply (Code (Success) (MailSystem) 0)
160                  (list "OK")))
161
162         (AddRcptTo (m)
163            (if (not (mailfrom))
164               (Reply (Code (PermanentFailure) (Syntax) 3)
165                      (list "command out of sequence"))
166               (begin
167                 (rcpto (cons m (rcpto)))
168                 (Reply (Code (Success) (MailSystem) 0)
169                        (list "Accepted")))))
170
171         (StartData ()
172            (if (not (rcpto))
173               (Reply (Code (PermanentFailure) (MailSystem) 4)
174                      (list "no valid recipients"))
175               (begin
176                 (data (list))
177                 (Reply (Code (IntermediateSuccess) (MailSystem) 4)
178                        (list "Ready")))))
179
180         (NeedHeloFirst ()
181           (Reply (Code (PermanentFailure) (Syntax) 3)
182                      (list "command out of sequence: "
183                            "need HELO first")
184                      ))
185
186         (NeedMailFromFirst ()
187           (Reply (Code (PermanentFailure) (Syntax) 3)
188                      (list "command out of sequence: "
189                            "need MAIL first")
190                      ))
191
192         (NeedMailRcptToFirst ()
193           (Reply (Code (PermanentFailure) (Syntax) 3)
194                      (list "command out of sequence: "
195                            "need RCPT first")
196                      ))
197
198         (NotImplemented ()
199           (Reply (Code (PermanentFailure) (Syntax) 2)
200                  (list "command not implemented")))
201
202
203         (ResetState ()
204             (mailfrom #f)
205             (rcpto    #f)
206             (data     #f)
207             (Reply (Code (Success) (MailSystem) 0)
208                    (list "Reset OK")))
209
210         (SayOK ()
211             (Reply (Code (Success) (MailSystem) 0)
212                    (list "OK")))
213
214         (SeeksHelp (s)
215             (Reply (Code (Success) (Information) 4)
216                    (list "Commands supported:"
217                          "HELO EHLO MAIL RCPT DATA QUIT RSET NOOP HELP")))
218
219         (Shutdown ()
220            (Reply (Code (Success) (MailSystem) 1)
221                   (list host " closing connection")))
222
223         (SyntaxErrorIn (s)
224            (Reply (Code (PermanentFailure) (Syntax) 1)
225                   (list "syntax error in " s)))
226
227         (Unrecognized (s)
228            (Reply (Code (PermanentFailure) (Syntax) 0)
229                   (list "Unrecognized " s)))
230         ))
231
232;; from SSAX lib
233(define (peek-next-char port)
234  (read-char port)
235  (peek-char port))
236
237(define (read-smtp-line port)
238  (let loop ((cs (list)))
239    (let ((c (peek-char port)))
240    (if (eof-object? c) (reverse cs)
241        (let ((n (peek-next-char port)))
242          (cond ((and (eq? n #\newline) (eq? c #\return))
243                 (begin
244                   (read-char port)
245                   (reverse (cons* n c cs)))
246                 )
247                (else (loop (cons c cs)))))))))
248
249(define data-end (list #\. #\return #\newline))
250     
251(define (handle-data in out cont)
252  (let loop ((tempdata (list)))
253    (let ((line (read-smtp-line in)))
254      (if (equal? line data-end)
255          (begin (data (reverse tempdata))
256                 (fprintf out "~A"
257                          (Reply (Code (Success) (MailSystem) 0) (list "OK")))
258                 (cont))
259          (loop (cons (list->string line) tempdata))))))
260
261(define (main in out) 
262  (let loop ((fsm (start-session)))
263    (let ((line     (read-smtp-line in)))
264      (if (null? line) (loop fsm)
265          (let ((instream (list `(() ,line))))
266            (let-values
267             (((reply ev fsm)
268               (cases session-fsm (fsm instream)
269                      (Event (ev)
270                             (let ((reply (handle-event ev)))
271                               (values reply ev fsm)))
272                      (Trans (ev fsm)
273                             (let ((reply (handle-event ev)))
274                               (values reply ev fsm))))))
275             (fprintf out "~A" reply)
276             (cases event ev
277                    (StartData ()
278                               (handle-data in out (lambda () (loop fsm))))
279                    (Shutdown ()
280                              (begin))
281                    (else (loop fsm)))))))))
282                     
283
284
285</enscript>
286
287=== Version History
288
289* 1.0 Initial release
290
291=== License
292
293Based on the Haskell Rfc2821 module by Peter Simons.
294
295  Copyright 2009 Ivan Raikov.
296  All rights reserved.
297 
298  Redistribution and use in source and binary forms, with or without
299  modification, are permitted provided that the following conditions are
300  met:
301 
302  Redistributions of source code must retain the above copyright
303  notice, this list of conditions and the following disclaimer.
304 
305  Redistributions in binary form must reproduce the above copyright
306  notice, this list of conditions and the following disclaimer in the
307  documentation and/or other materials provided with the distribution.
308 
309  Neither the name of the author nor the names of its contributors may
310  be used to endorse or promote products derived from this software
311  without specific prior written permission.
312 
313  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
314  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
315  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
316  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
317  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
318  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
319  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
320  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
321  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
322  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
323  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
324  OF THE POSSIBILITY OF SUCH DAMAGE.
Note: See TracBrowser for help on using the repository browser.