Changeset 15717 in project


Ignore:
Timestamp:
09/03/09 02:01:23 (10 years ago)
Author:
Ivan Raikov
Message:

save

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/smtp/trunk/smtp.scm

    r15280 r15717  
    3838;;
    3939
    40 (module smtp *
     40(module smtp
     41
     42        (
     43         mailbox? Mailbox
     44
     45         reply? Reply make-reply
     46         reply-success? reply-failure? reply-shutdown?
     47
     48         success-code? success-code-inject success-code-project
     49         Unused PreliminarySuccess Success IntermediateSuccess
     50         TransientFailure PermanentFailure
     51
     52         category? category-inject category-project
     53         Syntax Information Connection Unspecified3 Unspecified4
     54         MailSystem
     55
     56         code? Code
     57
     58         session-state? event?
     59
     60 
     61         cmd? Helo Ehlo MailFrom RcptTo Data Rset Send Soml Saml
     62         Vrfy Expn Help Noop Quit Turn WrongArg wrong-arg
     63
     64         parse-cmd start-session session-fsm?
     65        )
    4166
    4267        (import scheme chicken data-structures srfi-1 srfi-13 srfi-14)
     
    91116              (and x1 (pair? (car x1)) (cons (make (car x1)) (cdr x1))))))))))
    92117
     118
     119;; shortcut for (abnf:bind (abnf:collect-chars) (abnf:longest ... ))
     120(define-syntax consumed->list
     121  (syntax-rules ()
     122    ((_ p)      (abnf:bind (abnf:collect-chars) (abnf:longest p)))
     123    ((_ l p)    (abnf:bind (abnf:collect-chars l) (abnf:longest p)))
     124    ))
    93125
    94126;; shortcut for (abnf:bind scollect (abnf:longest ... ))
     
    225257      (error 'make-reply "arguments out of range: " suc cat n)))
    226258
     259
    227260;; A reply constitutes success if the status code is any of
    228261;; PreliminarySuccess, Success, or IntermediateSuccess.
     
    501534
    502535(define-datatype event event?
    503   (Greeting)                   
    504536  (SayHelo       (s string?))
    505537  (SayHeloAgain  (s string?))
     
    509541  (AddRcptTo     (m mailbox?))
    510542  (StartData)
    511   (Deliver)
    512543  (NeedHeloFirst)
    513544  (NeedMailFromFirst)
     
    621652                       
    622653
    623 (define smtp-cmd
     654(define p-smtp-cmd
    624655  (abnf:longest
    625656   (abnf:alternatives
     
    628659    )))
    629660
    630 (define (parse cont p)
     661(define (parse-cmd cont)
    631662  (let ((cont1 (lambda (s) (cont (map caar s)))))
    632     (lambda (s) (p cont1 s))))
     663    (lambda (s) (p-smtp-cmd cont1 s))))
    633664
    634665
     
    639670  (Trans (ev event?) (fsm procedure?)))
    640671
    641 ;; Parses an SMTP protocol line and runs handle-cmd to determine
    642 ;; the event. In case of syntax errors, SyntaxErrorIn or Unrecognized
    643 ;; will be returned.  Inputs must be terminated with CRLF.
    644 
    645 (define (fsm st) (parse (handle-cmd st) smtp-cmd))
     672;; Parses an SMTP protocol line and runs handle-cmd to determine the
     673;; event. In case of syntax errors, SyntaxErrorIn or Unrecognized will
     674;; be returned.  Inputs must be terminated with CRLF.
     675
     676(define (fsm st)
     677  (parse-cmd (handle-cmd st)))
    646678
    647679(define (event ev)  (Event ev))
     
    649681(define (trans st ev) (Trans ev (fsm st)))
    650682 
    651 (define (session-start s) (fsm (Unknown)))
     683(define (start-session) (fsm (Unknown)))
    652684
    653685(define (handle-cmd st)
    654   (lambda (cmd)
    655     (match (list st cmd )
     686    (lambda (cmd)
     687      (match (list st cmd )
    656688         ((_ ())                           (event (Unrecognized "")))
    657689         ((($ session-state 'HaveQuit) _)  (event (Shutdown)))
    658          ((($ session-state 'HaveData) _)  (trans (HaveData) (StartData)))
     690
    659691         ((_       ($ cmd 'WrongArg c _))  (event (SyntaxErrorIn c)))
    660692         ((_       ($ cmd 'Quit))          (trans (HaveQuit) (Shutdown)))
     
    690722         ((($ session-state 'HaveMailFrom) ($ cmd 'Data x))     (event (NeedRcptToFirst)))
    691723         ((($ session-state 'HaveRcptTo)   ($ cmd 'Data x))     (trans (HaveData) (StartData)))
     724
     725         ((($ session-state 'HaveData)   _)     (event (StartData)))
     726
    692727         ))
    693728  )
    694729
     730
    695731)
Note: See TracChangeset for help on using the changeset viewer.