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

;; Test parsing of email.

(module test-mail-parse mzscheme
  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1 0))
           "../mail-parse.ss"
           )

  (provide test-mail-parse)

  (define test-mail-parse
    (make-test-suite
      "Parse emails"

      ;; parse-emails
      (make-test-case
        "Parse an input stream, provided"
        (assert-emails-equal?
          (parse-emails (emails-input))
          the-parsed-emails))

      (make-test-case
        "Parse an implicit input stream"
        (assert-emails-equal?
          (parameterize ((current-input-port (emails-input)))
            (parse-emails))
          the-parsed-emails))

      ;; parse-email
      (make-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))))))))



  )