#lang scheme
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; NET.plt
;;
;; abstraction of common network behaviors and services
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; email-address.ss - parser for email-address formats defined in rfc2822
;; yc 2/13/2010 - first versions
(require "depend.ss"
         "phrase.ss"
         )

;; okay - let's figure out what we need to make this work...
(define-struct email-address (name domain angle? display route) #:prefab)

(define-struct mail-list (display addresses) #:prefab) 

;; READERs...
#|
atext           =       ALPHA / DIGIT / ; Any character except controls,
                        "!" / "#" /     ;  SP, and specials.
                        "$" / "%" /     ;  Used for atoms
                        "&" / "'" /
                        "*" / "+" /
                        "-" / "/" /
                        "=" / "?" /
                        "^" / "_" /
                        "`" / "{" /
                        "|" / "}" /
                        "~"
;;|#
(define p:atext (choice alphanumeric 
                        (char-in '(#\! #\#
                                       #\$ #\%
                                       #\& #\'
                                       #\* #\+ 
                                       #\- #\/
                                       #\- #\?
                                       #\^ #\_ 
                                       #\` #\{
                                       #\| #\}
                                       #\~))))

#|
atom            =       [CFWS] 1*atext [CFWS]
;;|#
(define p:atom (seq v <- (one-many p:atext) (return (list->string v))))
#|
dot-atom        =       [CFWS] dot-atom-text [CFWS]
dot-atom-text   =       1*atext *("." 1*atext)
;;|#
(define p:dot-atom (seq a <- p:atom 
                        rest <- (zero-many (seq #\. a <- p:atom 
                                                (return (list "." a))))
                        (return (apply string-append (flatten (cons a rest))))))

#|
dtext           =       NO-WS-CTL /     ; Non white space controls

                        %d33-90 /       ; The rest of the US-ASCII
                        %d94-126        ;  characters not including "[",
                                        ;  "]", or "\"

;;|#
(define p:WSP (char-in '(#\space #\tab #\vtab)))

(define p:NO-WS-CTL (choice (char-between (integer->char 1) (integer->char 8))
                            (char-in (list (integer->char 11)
                                           (integer->char 12)
                                           (integer->char 127)))
                            (char-between (integer->char 14) (integer->char 31))))

(define p:dtext (choice p:NO-WS-CTL
                        (char-between (integer->char 33) (integer->char 90))
                        (char-between (integer->char 94) (integer->char 126))))
#|
dcontent        =       dtext / quoted-pair
;;|#
(define p:quoted-pair (char-when (lambda (c)
                                   (and (char-ascii? c)
                                        (not (char=? c #\return))
                                        (not (char=? c #\newline))))))

(define p:dcontent (choice p:quoted-pair p:dtext))

#|
domain-literal  =       [CFWS] "[" *([FWS] dcontent) [FWS] "]" [CFWS]
;;|#
(define p:domain-literal (seq #\[ v <- (one-many p:dcontent) #\]
                              (return (list->string v))))

#|
domain          =       dot-atom / domain-literal / obs-domain
;;|#
(define p:domain (choice p:dot-atom p:domain-literal)) 

#|
local-part      =       dot-atom / quoted-string / obs-local-part
;;|#
(define p:local-part (choice p:dot-atom quoted-string)) 



#|
addr-spec       =       local-part "@" domain
;;|#
(define p:addr-spec (seq login <- p:local-part 
                         #\@ 
                         host <- p:domain 
                         (return (make-email-address login host #f #f #f))))
#|
address         =       mailbox / group

mailbox         =       name-addr / addr-spec

name-addr       =       [display-name] angle-addr

angle-addr      =       [CFWS] "<" addr-spec ">" [CFWS] / obs-angle-addr

group           =       display-name ":" [mailbox-list / CFWS] ";"
                        [CFWS]

display-name    =       phrase

mailbox-list    =       (mailbox *("," mailbox)) / obs-mbox-list

address-list    =       (address *("," address)) / obs-addr-list

obs-angle-addr  =       [CFWS] "<" [obs-route] addr-spec ">" [CFWS]

obs-route       =       [CFWS] obs-domain-list ":" [CFWS]

obs-domain-list =       "@" domain *(*(CFWS / "," ) [CFWS] "@" domain)


;;|#

(define p:name-addr (tokens v <- (zero-one p:phrase #f) 
                            addr <- p:angle-addr 
                            (return (make-email-address (email-address-name addr)
                                                        (email-address-domain addr)
                                                        (email-address-angle? addr)
                                                        v
                                                        (email-address-route addr)
                                                      ))))

(define p:route (seq #\@ d <- p:domain (return d))) 

(define p:route-list (tokens v <- (delimited p:route #\,)
                             #\:
                             (return v)))
  

(define p:angle-addr (tokens #\< 
                             route <-  (zero-one p:route-list #f)
                             addr <- p:addr-spec 
                             #\> 
                             (return (make-email-address (email-address-name addr)
                                                         (email-address-domain addr)
                                                         #t 
                                                         (email-address-display addr)
                                                         route))))

(define p:mailbox (choice p:name-addr p:addr-spec))

(define p:mailbox-list (delimited p:mailbox (choice #\,)))

(define p:mailbox-group (tokens p <- p:phrase 
                                #\: 
                                boxes <- p:mailbox-list 
                                #\; 
                                (return (make-mail-list p boxes))))

(define p:address (choice p:mailbox-group p:mailbox)) 

(define p:address-list (delimited p:address (char-in '(#\,))))

(define read-email-address-list (make-reader p:address-list)) 

(define read-email-address (make-reader p:address))

(define read-angle-address (make-reader p:angle-addr))

;; now we need to *generate* the results.
;; how do I make sure that it is meant for writing it out to the header?
;; hmm... basically, there are two separate modes... one mode will write it
;; out to encoded
;; hmm...
;; let's make sure we do not use it in the headers...
(define (email-address->string e (display? #t)) 
  (cond ((and display? (email-address-display e))
         (format "~a <~a@~a>" (encode-phrase (email-address-display e))
                 (email-address-name e)
                 (email-address-domain e)))
        ((email-address-angle? e)
         (format "<~a@~a>" (email-address-name e)
                 (email-address-domain e)))
        (else 
         (format "~a@~a" (email-address-name e)
                 (email-address-domain e)))))

(define (mail-list->string ml) 
  (format"~a:~a;" (encode-phrase (mail-list-display ml))
         (email-address-list->string (mail-list-addresses ml))
         ))

(define (email-address-list->string addresses)
  (if (mail-list? addresses)
      (mail-list->string addresses)
      (string-join (map email-address->string addresses) ", ")))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EXPORT
(provide/contract 
 (read-email-address Reader/c)
 (read-email-address-list Reader/c)
 (read-angle-address Reader/c)
 (p:atom Parser/c)
 (email-address-list->string (-> (or/c mail-list? (listof email-address?)) string?))
 (mail-list->string (-> mail-list? string?))
 (email-address->string (->* (email-address?)
                             (boolean?)
                             string?))
 (struct email-address ((name string?)
                        (domain string?)
                        (angle? boolean?)
                        (display (or/c false/c string?))
                        (route (or/c false/c (listof string?)))))
 (struct mail-list ((display (or/c false/c string?))
                    (addresses (listof email-address?))))
 )