#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MIME.plt
;;
;; an extensible MIME framework.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; message.ss - represents the message structure
;; yc 2/18/2010 - first version.
(require "depend.ss"
         "base.ss"
         "content-type.ss"
         "content-disposition.ss"
         "mime.ss"
         )

;; the body will always be a MIME object - if it is a plain text it will be a content
;; object with content-type text/plain.
(define-struct (message mime) (body))

(mime-body-set! message? message-body)

;; message/rfc822 is used to contain a message object - it is only used
;; when the MIME is defined as a message/*.
;; this means that for a message that directly embeds a message/* as its content-type
;; would have the following:
;; message -> message/rfc822 -> message/*
;; this is because message is defined as a container over the body, which is its
;; own mime object...
(define-struct (message/rfc822 message) ()) 

(define (read-message-with-headers in headers) 
  (make-message (filter-non-mime-headers headers)
                (read-mime in (filter-mime-headers headers))))

(define (read-message/rfc822-with-headers in headers) 
  (make-message/rfc822 (kvs/list->kvlist headers)
                       (read-message in))) 

(define message-header-readertable
  `(("Date" . ,(lambda (in) 
                 (read-rfc822 in #:eof? #f)))
    ("From" . ,read-email-address-list)
    ("To" . ,read-email-address-list)
    ("Cc" . ,read-email-address-list)
    ("Bcc" . ,read-email-address-list)
    ("Sender" . ,read-email-address-list)
    ("Message-ID" . ,read-angle-address)
    ("References" . ,read-email-address-list)
    ("In-Reply-To" . ,read-email-address-list)
    ("Subject" . ,read-phrase)
    ))

(define (read-message in)
  (parameterize ((kvs-readertable (append (mime-header-reader-list)
                                             message-header-readertable)))
    (read-message-with-headers in (read-headers in))))

(mime-reader-set! "message" read-message/rfc822-with-headers)

(define (message-from msg)
  (kvs-ref msg "From")) 

(define (message-to msg)
  (kvs-ref msg "To")) 

(define (message-subject msg) 
  (kvs-ref msg "Subject"))

(define (message-date msg)
  (kvs-ref msg "Date")) 

(define (message-id msg) 
  (kvs-ref msg "Message-ID"))

(define (message-cc msg) 
  (kvs-ref msg "Cc")) 

(define (message-bcc msg) 
  (kvs-ref msg "Bcc")) 

(define (message-sender msg) 
  (kvs-ref msg "Sender"))

(define (message-in-reply-to msg)
  (kvs-ref msg "In-Reply-To")) 

(define (message-references msg) 
  (kvs-ref msg "References")) 

(define (parse-emails field)
  (cond ((not field) #f)
        ((or (email-address? field)
             (mail-list? field)) field)
        ((string? field) (read-email-address-list field))
        ((list? field)
         (flatten (map parse-emails field)))))

(define (parse-message-id field)
  (cond ((not field) #f)
        ((email-address? field) field)
        ((string? field) (read-angle-address field))
        ((list? field)
         (flatten (map parse-message-id field)))
        (else (error 'parse-id "unknown field: ~a" field))))

(define (default-message-id (domain "localhost"))
  (format "<~a@~a>" (uuid->string (make-uuid)) domain))


(define (build-message #:from (from #f) 
                       #:to (to #f) 
                       #:cc (cc #f) 
                       #:bcc (bcc #f)
                       #:sender (sender #f) 
                       #:id (id #f) 
                       #:references (references #f) 
                       #:in-reply-to (in-reply-to #f) 
                       #:subject (subject #f) 
                       body)
  ;; for now we'll assume that we are not taking in more
  (make-message (filter cdr `(("From" . ,(parse-emails from))
                              ("To" . ,(parse-emails to))
                              ("Cc" . ,(parse-emails cc))
                              ("Bcc" . ,(parse-emails bcc))
                              ("Sender" . ,(parse-emails sender))
                              ("Message-ID" . ,(parse-message-id id))
                              ("References" . ,(parse-message-id references))
                              ("In-Reply-To" . ,(parse-message-id in-reply-to))
                              ("Subject" . ,subject)))
                body))


;; every message body should have a MIME-Version header... the only time that
;; a mime object should have such a header...
(define (message-body->input m)
  (mime->input (kvs-set! (message-body m) "MIME-Version" "1.0"))) 

(define (message-headers->input m)
  (headers->string (filter cdr (kvs/list->kvlist m)) #f)) 

(define (message->input m) 
  (mime->input-helper m message-headers->input message-body->input))

(mime-writer-set! message? message->input)

;; we also need to handle message/partial correctly...
;; a message/partial will contain a single content inside... they are kept
;; as either content or a file until they are combined, which will return a
;; separate message.

(provide/contract 
 (struct:message struct-type?)
 (message? isa/c)
 (make-message (-> kvs/list? mime? message?))
 (message-body (-> message? mime?))
 (struct:message/rfc822 struct-type?)
 (message/rfc822? isa/c)
 (make-message/rfc822 (-> kvs/list? mime? message?))
 )

(provide message
         message/rfc822
         read-message
         message-from
         message-to
         message-subject
         message-date
         message-id
         message-cc
         message-bcc
         message-sender
         message-in-reply-to
         message-references 
         build-message 
         )