;; Mike Burns 2004-08-21 mike@mike-burns.com
;; Copyright 2004 Mike Burns

;; Test parsing of email.
#lang scheme 
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 10))
         "../mail-parse.ss"
         )

(provide test-mail-parse)

(define test-mail-parse
  (test-suite
   "Parse emails"
   
   ;; parse-emails
   (test-case
    "Parse an input stream, provided"
    (assert-emails-equal?
     (parse-emails (emails-input))
     the-parsed-emails))
   
   (test-case
    "Parse an implicit input stream"
    (assert-emails-equal?
     (parameterize ((current-input-port (emails-input)))
       (parse-emails))
     the-parsed-emails))
   
   ;; parse-email
   (test-case
    "Parse an input-string"
    (assert-email-equal?
     (parse-email (email-input))
     the-parsed-email))
   
   ;;; TODO:
   ;;; Exceptions
   ;;; Attachments
   
   ))

(define email1
  (format "~a~n~n~a"
          ;; Headers
          (format
           (string-append
            "From netgeek@frigames.org Sun Aug 22 00:06:49 2004~n"
            "Return-path: <netgeek@frigames.org>~n"
            "Envelope-to: netgeek@lube.frigames.org~n"
            "Delivery-date: Sun, 22 Aug 2004 00:06:49 -0400~n"
            ;"Received: from netgeek by frigames.org with local (Exim 3.36 #1)~n"
            ;"  id 1Byjd3-00047J-00~n"
            ;"  for netgeek@lube.frigames.org; Sun, 22 Aug 2004 00:06:49 -0400~n"
            "Date: Sun, 22 Aug 2004 00:06:49 -0400~n"
            "From: Mike Burns <netgeek@speakeasy.net>~n"
            "To: Mike Burns <netgeek@lube.frigames.org>~n"
            "Subject: Test~n"
            "Message-ID: <20040822040649.GA17722@lube.frigames.org>~n"
            "Mime-Version: 1.0~n"
            "Content-Type: text/plain; charset=us-ascii~n"
            "Content-Disposition: inline~n"
            "User-Agent: Mutt/1.4.1i~n"
            "Sender: \"Mike Burns,,,617-739-1575\" <netgeek@frigames.org>~n"))
          ;; Body
          (format
           (string-append
            "This is a test!~n~n-- ~n"
            "Mike Burns netgeek@speakeasy.net http://mike-burns.com~n"))))

(define email2
  (format "~a~n~n~a"
          (format
           (string-append
            "From netgeek@frigames.org Sun Aug 22 00:11:22 2004~n"
            "Return-path: <netgeek@frigames.org>~n"
            "Envelope-to: netgeek@lube.frigames.org~n"
            "Delivery-date: Sun, 22 Aug 2004 00:11:22 -0400~n"
            ;"Received: from netgeek by frigames.org with local (Exim 3.36 #1)~n"
            ;"  id 1ByjhS-0000Uo-00~n"
            ;"    for netgeek@lube.frigames.org; Sun, 22 Aug 2004 00:11:22 -0400~n"
            "Date: Sun, 22 Aug 2004 00:11:22 -0400~n"
            "From: Mike Burns <netgeek@speakeasy.net>~n"
            "To: Mike Burns <netgeek@lube.frigames.org>~n"
            "Subject: Another test~n"
            "Message-ID: <20040822041122.GA18901@lube.frigames.org>~n"
            "Mime-Version: 1.0~n"
            "Content-Type: text/plain; charset=us-ascii~n"
            "Content-Disposition: inline~n"
            "User-Agent: Mutt/1.4.1i~n"
            "Sender: \"Mike Burns,,,617-739-1575\" <netgeek@frigames.org>~n"))
          (format
           (string-append
            "This is another test!~n~n-- ~n"
            "Mike Burns netgeek@speakeasy.net http://mike-burns.com~n"))))

(define parsed-email1
  (make-email
   `((Sender . "\"Mike Burns,,,617-739-1575\" <netgeek@frigames.org>")
     (User-Agent . "Mutt/1.4.1i")
     ;(Content-Disposition . "inline")
     ;(Content-tye . "text/plain; charset=us-ascii")
     ;(Mime-version . "1.0")
     (Message-ID . "<20040822040649.GA17722@lube.frigames.org>")
     (Subject . "Test")
     (To . "Mike Burns <netgeek@lube.frigames.org>")
     (From . "Mike Burns <netgeek@speakeasy.net>")
     (Date . "Sun, 22 Aug 2004 00:06:49 -0400")
     #;(Received .
                 ,(format
                   "~a\r\n~a\r\n~a"
                   "from netgeek by frigames.org with local (Exim 3.36 #1)"
                   "id 1Byjd3-00047J-00"
                   "for netgeek@lube.frigames.org; Sun, 22 Aug 2004 00:06:49 -0400"))
     (Delivery-date . "Sun, 22 Aug 2004 00:06:49 -0400")
     (Envelope-to . "netgeek@lube.frigames.org")
     (Return-path . "<netgeek@frigames.org>"))
   (list
    (list
     "This is a test!"
     ""
     "-- "
     "Mike Burns netgeek@speakeasy.net http://mike-burns.com"))))

(define parsed-email2
  (make-email
   `((Return-path . "<netgeek@frigames.org>")
     (Envelope-to . "netgeek@lube.frigames.org")
     (Delivery-date . "Sun, 22 Aug 2004 00:11:22 -0400")
     #;(received .
                 ,(format
                   "~a~n~n~a~n~n~a"
                   "from netgeek by frigames.org with local (Exim 3.36 #1)"
                   "id 1ByjhS-0000Uo-00"
                   "for netgeek@lube.frigames.org; Sun, 22 Aug 2004 00:11:22 -0400"))
     (Date . "Sun, 22 Aug 2004 00:11:22 -0400")
     (From . "Mike Burns <netgeek@speakeasy.net>")
     (To . "Mike Burns <netgeek@lube.frigames.org>")
     (Subject . "Another test")
     (Message-ID . "<20040822041122.GA18901@lube.frigames.org>")
     (Mime-Version . "1.0")
     (Content-Type . "text/plain; charset=us-ascii")
     (Content-Disposition . "inline")
     (User-Agent . "Mutt/1.4.1i")
     (Sender . "\"Mike Burns,,,617-739-1575\" <netgeek@frigames.org>"))
   (list
    (list
     "This is another test!"
     ""
     "-- "
     "Mike Burns netgeek@speakeasy.net http://mike-burns.com"))))

;; Thunkified to get a new port each time I need one.
(define (emails-input)
  (open-input-string (format "~a~n~a~n" email1 email2)))

(define the-parsed-emails (list parsed-email1 parsed-email2))

(define (email-input) (open-input-string email1))

(define the-parsed-email parsed-email1)

(define-simple-assertion (assert-emails-equal? mails1 mails2)
  (andmap email-equal?  mails1 mails2))

(define-simple-assertion (assert-email-equal? mail1 mail2)
  (email-equal? mail1 mail2))

(define (email-equal? mail1 mail2)
  (and (email? mail1)
       (email? mail2)
       (equal? (email-messages mail1)
               (email-messages mail2))
       (assoc-equal? (email-headers mail1)
                     (email-headers mail2))))

(define (assoc-equal? assoc1 assoc2)
  (let loop ((a1 assoc1)
             (seen-keys '()))
    (or (null? a1)
        (let ((k-v (car a1)))
          (if (member (car k-v) seen-keys)
              (loop (cdr a1) seen-keys)
              (and
               (equal? (assoc (car k-v) assoc2)
                       k-v)
               (loop (cdr a1) (cons (car k-v) seen-keys))))))))



; end