Changeset 15893 in project


Ignore:
Timestamp:
09/15/09 05:48:43 (10 years ago)
Author:
iraikov
Message:

added an example to smtp doc

File:
1 edited

Legend:

Unmodified
Added
Removed
  • wiki/eggref/4/smtp

    r15892 r15893  
    123123* [[matchable]]
    124124
     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
    125287=== Version History
    126288
Note: See TracChangeset for help on using the changeset viewer.