Changeset 15867 in project


Ignore:
Timestamp:
09/14/09 15:18:32 (10 years ago)
Author:
Ivan Raikov
Message:

smtp fixes

File:
1 edited

Legend:

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

    r15814 r15867  
    4141
    4242        (
    43          smtp-cmd help helo domain Ldh-str
    44 
    4543         mailbox? Mailbox
    4644
     
    124122(define-datatype mailbox mailbox?
    125123  (Mailbox (local-part string?)
    126            (domain string?)
    127            (parameters list?)))
     124           (domain string?)))
     125
    128126
    129127(define-record-printer (mailbox x out)
     
    132130         (($ mailbox 'Mailbox "postmaster" "" )  (fprintf out "<postmaster>"))
    133131         (($ mailbox 'Mailbox l d ) 
    134           (let ((mbox  (sprintf "~S@~S" l d)))
    135             (fprintf out "<~S>" mbox)))))
    136 
    137 (define (null-path) (Mailbox "" "" '()))
    138 
    139 (define (postmaster) (Mailbox "postmaster" "" '()))
     132          (let ((mbox  (sprintf "~A@~A" l d)))
     133            (fprintf out "<~A>" mbox)))))
     134
     135(define (null-mailbox) (Mailbox "" ""))
     136
     137(define (postmaster . rest)
     138  (let-optionals rest ((domain ""))
     139   (Mailbox "postmaster" domain )))
    140140
    141141
     
    331331                             esmtp-param)))))
    332332
    333 (define Rcpt-parameters  Mail-parameters)
    334 
    335 (define Argument       Atom)
    336 
    337333(define Ldh-str        (bind-consumed->domain-string
    338334                        (abnf:concatenation
     
    358354                      domain))
    359355
    360 (define A-d-l        (abnf:concatenation
    361                       At-domain
    362                       (abnf:repetition
    363                        (abnf:concatenation
    364                         (abnf:drop-consumed (abnf:char #\,))
    365                         At-domain))))
     356(define A-d-l        (abnf:bind-consumed-strings->list
     357                      (abnf:concatenation
     358                       At-domain
     359                       (abnf:repetition
     360                        (abnf:concatenation
     361                         (abnf:drop-consumed (abnf:char #\,))
     362                         At-domain)))))
    366363
    367364(define Local-part   (abnf:alternatives
     
    465462    (abnf:alternatives domain address-literal))))
    466463
    467 (define Path
    468   (abnf:concatenation
    469    (abnf:drop-consumed (abnf:char #\<) )
    470    (abnf:optional-sequence
    471     (abnf:concatenation A-d-l (abnf:char #\:)))
    472    Mailbox-p
    473    (abnf:drop-consumed (abnf:char #\>))))
    474 
    475 (define Forward-path   Path)
     464(define Path-p
     465  (abnf:bind
     466   (consumed-objects-lift-any first)
     467   (abnf:concatenation
     468    (abnf:drop-consumed (abnf:char #\<) )
     469    (abnf:optional-sequence
     470     (abnf:drop-consumed
     471      (abnf:concatenation
     472       A-d-l
     473       (abnf:char #\:))))
     474    Mailbox-p
     475    (abnf:drop-consumed (abnf:char #\>)))))
     476
     477(define Forward-path   Path-p)
    476478
    477479(define Reverse-path
    478480  (abnf:alternatives
    479    Path
    480    (abnf:concatenation
    481     (abnf:char #\<) (abnf:char #\>))))
    482 
     481   (abnf:bind
     482    (consumed-objects-lift-any
     483     (lambda x (null-mailbox)))
     484    (abnf:concatenation
     485     (abnf:char #\<) (abnf:char #\>)))
     486   Path-p))
    483487
    484488(define from-path
    485489  (abnf:concatenation
    486490   (abnf:drop-consumed (abnf:lit "FROM:"))
    487    Reverse-path
    488    (abnf:optional-sequence
    489     (abnf:concatenation
    490      (abnf:drop-consumed abnf:sp )
    491      Rcpt-parameters))))
    492    
     491   Reverse-path))
     492
    493493(define to-path
    494494  (abnf:concatenation
    495    (abnf:lit "TO:")
     495   (abnf:drop-consumed (abnf:lit "TO:"))
    496496   (abnf:alternatives
    497     (abnf:concatenation (abnf:char #\<) (abnf:lit "Postmaster@") domain (abnf:char #\>))
    498     (abnf:concatenation (abnf:char #\<) (abnf:lit "Postmaster") (abnf:char #\>))
    499     Forward-path
    500     (abnf:optional-sequence (abnf:concatenation abnf:sp Rcpt-parameters)))))
     497
     498    (abnf:bind
     499     (consumed-objects-lift-any
     500      (lambda (x) (postmaster)))
     501     (abnf:concatenation
     502      (abnf:char #\<)
     503      (abnf:lit "Postmaster")
     504      (abnf:char #\>)))
     505
     506    (abnf:bind
     507     (consumed-objects-lift-any
     508      (lambda (x) (postmaster (first x))))
     509     (abnf:concatenation
     510      (abnf:drop-consumed (abnf:char #\<) )
     511      (abnf:drop-consumed (abnf:lit "Postmaster@") )
     512      domain
     513      (abnf:drop-consumed (abnf:char #\>))))
     514
     515    Forward-path)))
     516
    501517
    502518;; ESMTP sessions, events, commands
     
    510526  (HaveQuit))
    511527
     528(define-record-printer (session-state x out)
     529  (fprintf out "<#session-state ~A>"
     530           (cases session-state x
     531                  (Unknown ()      "Unknown")
     532                  (HaveHelo ()     "HaveHelo")
     533                  (HaveMailFrom () "HaveMailFrom")
     534                  (HaveRcptTo   () "HaveRcptTo")
     535                  (HaveData     () "HaveData")
     536                  (HaveQuit     () "HaveQuit"))))
     537
    512538(define-datatype event event?
    513539  (SayHelo       (s string?))
     
    515541  (SayEhlo       (s string?))
    516542  (SayEhloAgain  (s string?))
    517   (SetMailFrom   (m mailbox?))
    518   (AddRcptTo     (m mailbox?))
     543  (SetMailFrom   (m mailbox?) (parameters? list))
     544  (AddRcptTo     (m mailbox?) (parameters? list))
    519545  (StartData)
    520546  (NeedHeloFirst)
     
    534560  (Helo (s string?))
    535561  (Ehlo (s string?))
    536   (MailFrom (m mailbox?))
    537   (RcptTo   (m mailbox?))
     562  (MailFrom (m mailbox?) (parameters list?))
     563  (RcptTo   (m mailbox?) (parameters list?))
    538564  (Data)
    539565  (Rset)
     
    554580(define-record-printer (cmd x out)
    555581  (cases cmd x
    556          (Helo (s)      (fprintf out "HELO ~S" s))
    557          (Ehlo (s)      (fprintf out "EHLO ~S" s))
    558          (MailFrom (m)  (fprintf out "MAIL FROM: ~S" m))
    559          (RcptTo (m)    (fprintf out "RCPT TO: ~S" m))
    560          (Data ()       (fprintf out "DATA"))
    561          (Rset ()       (fprintf out "RSET"))
    562          (Send (m)      (fprintf out "SEND ~S" m))
    563          (Soml (m)      (fprintf out "SOML ~S" m))
    564          (Saml (m)      (fprintf out "SAML ~S" m))
    565          (Vrfy (s)      (fprintf out "VRFY ~S" s))
    566          (Expn (s)      (fprintf out "EXPN ~S" s))
    567          (Noop ()       (fprintf out "NOOP"))
    568          (Quit ()       (fprintf out "QUIT"))
    569          (Turn ()       (fprintf out "TURN"))
    570          (Help (s)      (fprintf out "HELP ~S" s))
    571          (WrongArg (s)  (fprintf out "Syntax error in argument of ~S." s))))
     582         (Helo (s)        (fprintf out "HELO ~A" s))
     583         (Ehlo (s)        (fprintf out "EHLO ~A" s))
     584         (MailFrom (m p)  (fprintf out "MAIL FROM:~A" m))
     585         (RcptTo (m p)    (fprintf out "RCPT TO: ~A" m))
     586         (Data ()         (fprintf out "DATA"))
     587         (Rset ()         (fprintf out "RSET"))
     588         (Send (m)        (fprintf out "SEND ~A" m))
     589         (Soml (m)        (fprintf out "SOML ~A" m))
     590         (Saml (m)        (fprintf out "SAML ~A" m))
     591         (Vrfy (s)        (fprintf out "VRFY ~A" s))
     592         (Expn (s)        (fprintf out "EXPN ~A" s))
     593         (Noop ()         (fprintf out "NOOP"))
     594         (Quit ()         (fprintf out "QUIT"))
     595         (Turn ()         (fprintf out "TURN"))
     596         (Help (s)        (fprintf out "HELP ~A" s))
     597         (WrongArg (s)    (fprintf out "Syntax error in argument of ~A." s))))
    572598
    573599;; Command Parsers
     
    594620;; applied to the given constructor procedure before returning.
    595621
    596 (define (mkcmdp1 s kons p) 
    597   (let ((ss (->string s)))
    598     (lambda (cont s)
    599       (print "mkcmdp1: ss = " ss)
    600       (print "mkcmdp1: s = " s)
    601       ((abnf:concatenation
    602         (abnf:drop-consumed
    603          (lambda (cont s)
    604            (print "mkcmdp1: header s = " s)
    605            ((abnf:lit ss)
    606             (lambda (x) (print "mkcmdp1: header = " x) (cont x))
    607             s)))
     622(define (mkcmdp1 s kons p . r) 
     623  (let ((ss (->string s))
     624        (make (if (null? r)
     625                  (lambda (x) (kons (first x)))
     626                  (lambda (x)
     627                    (match x ((x r) (kons x r))
     628                           ((x) (kons x (list)))
     629                           )))))
     630
     631    (abnf:bind (consumed-objects-lift-any make)
     632
     633       (abnf:concatenation
     634       
     635        (abnf:drop-consumed (abnf:lit ss))
    608636        (abnf:drop-consumed (abnf:repetition abnf:sp))
    609         (abnf:alternatives
    610          (abnf:bind (consumed-objects-lift-any
    611                      (lambda (x) (kons (first x)))) p)
    612          (wrong-arg ss) )
    613         (abnf:drop-consumed abnf:crlf))
    614        (lambda (x) (print "mkcmdp1: x = " x) (cont x)) s)
    615       )))
     637       
     638        (abnf:alternatives p (wrong-arg ss) )
     639
     640        (if (null? r)
     641            (abnf:drop-consumed abnf:crlf)
     642            (abnf:concatenation
     643             (abnf:optional-sequence
     644              (abnf:concatenation
     645               (abnf:drop-consumed (abnf:repetition abnf:sp))
     646               (car r)))
     647             (abnf:drop-consumed abnf:crlf)))
     648
     649        ))
     650    ))
     651
    616652
    617653
     
    625661(define helo (mkcmdp1 "HELO" Helo     domain))
    626662(define ehlo (mkcmdp1 "EHLO" Ehlo     domain))
    627 (define mail (mkcmdp1 "MAIL" MailFrom from-path))
    628 (define rcpt (mkcmdp1 "RCPT" RcptTo   to-path))
     663(define vrfy (mkcmdp1 "VRFY" Vrfy     (abnf:concatenation
     664                                        (abnf:drop-consumed abnf:sp) String)))
     665(define expn (mkcmdp1 "EXPN" Expn     (abnf:concatenation
     666                                       (abnf:drop-consumed abnf:sp) String)))
     667
     668(define rcpt (mkcmdp1 "RCPT" RcptTo   to-path Mail-parameters))
     669(define mail (mkcmdp1 "MAIL" MailFrom from-path Mail-parameters))
    629670(define send (mkcmdp1 "SEND" Send     from-path))
    630671(define soml (mkcmdp1 "SOML" Soml     from-path))
    631672(define saml (mkcmdp1 "SAML" Saml     from-path))
    632 (define vrfy (mkcmdp1 "VRFY" Vrfy     (abnf:concatenation abnf:sp String)))
    633 (define expn (mkcmdp1 "EXPN" Expn     (abnf:concatenation abnf:sp String)))
    634673
    635674(define help (mkcmdp1 "HELP" (lambda (x) (if (null? x) (Help) (Help (car x))))
    636                       (abnf:optional-sequence (abnf:concatenation abnf:sp String))))
     675                      (abnf:optional-sequence
     676                       (abnf:concatenation (abnf:drop-consumed abnf:sp)
     677                                           String))))
    637678
    638679(define noop0 (mkcmdp1 "NOOP" (lambda (x) (Noop))
    639                        (abnf:optional-sequence (abnf:concatenation abnf:sp String))))
     680                       (abnf:optional-sequence
     681                        (abnf:concatenation (abnf:drop-consumed abnf:sp)
     682                                            String))))
    640683                       
    641684
     
    664707
    665708(define (fsm st)
    666   (parse-cmd (handle-cmd st)))
     709  (lambda (s)
     710    (print "fsm: s = " s)
     711    ((parse-cmd (handle-cmd st)) s)))
    667712
    668713(define (event ev)  (Event ev))
     
    674719(define (handle-cmd st)
    675720    (lambda (cmd)
    676       (match (list st cmd )
    677          ((_ ())                           (event (Unrecognized "")))
     721      (print "handle-cmd: st = " st)
     722      (print "handle-cmd: cmd = " cmd)
     723      (match (cons st cmd )
     724         ((_ )                             (event (Unrecognized "")))
    678725         ((($ session-state 'HaveQuit) _)  (event (Shutdown)))
    679726
     
    695742         ((_                            ($ cmd 'Rset))          (trans (HaveHelo) (ResetState )))
    696743
    697          ((($ session-state 'Unknown)   ($ cmd 'Helo x))        (trans (HaveHelo) (SayHelo x)))
     744         ((($ session-state 'Unknown)   ($ cmd 'Helo x))        (begin
     745                                                                  (print "(trans (HaveHelo) (SayHelo x))")
     746                                                                  (trans (HaveHelo) (SayHelo x))))
    698747         ((_                            ($ cmd 'Helo x))        (trans (HaveHelo) (SayHeloAgain x)))
    699748         ((($ session-state 'Unknown)   ($ cmd 'Ehlo x))        (trans (HaveHelo) (SayEhlo x)))
    700749         ((_                            ($ cmd 'Ehlo x))        (trans (HaveHelo) (SayEhloAgain x)))
    701750
    702          ((($ session-state 'Unknown)   ($ cmd 'MailFrom x))    (event (NeedHeloFirst)))
    703          ((_                            ($ cmd 'MailFrom x))    (trans (HaveMailFrom) (SetMailFrom x)))
    704 
    705          ((($ session-state 'Unknown)   ($ cmd 'RcptTo x))      (event (NeedHeloFirst)))
    706          ((($ session-state 'HaveHelo)  ($ cmd 'RcptTo x))      (event (NeedMailFromFirst)))
    707          ((_                            ($ cmd 'RcptTo x))      (trans (HaveRcptTo) (AddRcptTo x)))
     751         ((($ session-state 'Unknown)   ($ cmd 'MailFrom . _))  (event (NeedHeloFirst)))
     752         ((_                            ($ cmd 'MailFrom x p))  (trans (HaveMailFrom) (SetMailFrom x p)))
     753
     754         ((($ session-state 'Unknown)   ($ cmd 'RcptTo . _))    (event (NeedHeloFirst)))
     755         ((($ session-state 'HaveHelo)  ($ cmd 'RcptTo . _))    (event (NeedMailFromFirst)))
     756         ((_                            ($ cmd 'RcptTo x p))    (trans (HaveRcptTo) (AddRcptTo x p)))
    708757
    709758         ((($ session-state 'Unknown)      ($ cmd 'Data x))     (event (NeedHeloFirst)))
Note: See TracChangeset for help on using the changeset viewer.