;;;
;;; scmail - a mail filter written in Scheme
;;;
;;; Copyright (C) 2002-2004 Satoru Takabayashi <satoru@namazu.org> 
;;;     All rights reserved.
;;;     This is free software with ABSOLUTELY NO WARRANTY.
;;;
;;; Permission to use, copy, modify, distribute this software and
;;; accompanying documentation for any purpose is hereby granted,
;;; provided that existing copyright notices are retained in all
;;; copies and that this notice is included verbatim in all
;;; distributions.
;;; This software is provided as is, without express or implied
;;; warranty.  In no circumstances the author(s) shall be liable
;;; for any damages arising out of the use of this software.
;;;

(define-module scmail.mail
  (use srfi-1)
  (use srfi-13)
  (use gauche.charconv)
  (use gauche.regexp)
  (use gauche.parameter)
  (use rfc.822)
  (use rfc.base64)
  (use rfc.quoted-printable)
  (use gauche.net)
  (use file.util)
  (use scmail.util)

  (export <mail>
	  make-scmail-mail
          scmail-mail-removed? scmail-mail-query 
          scmail-mail-write scmail-mail-remove 
          scmail-mail-forward scmail-mail-rename
          scmail-mail-from-stdin?
          scmail-mail-decode-field scmail-send-mail
          scmail-mail-copy scmail-mail-move 
          scmail-mail-prepare
          scmail-mail-add-type!))

(select-module scmail.mail)

(define-class <mail> ()
  ((port :init-form (current-input-port))
   (file :init-value #f
	 :init-keyword :file)
   (content  :init-value "")
   (info  :init-value '())
   (dry-run-mode :init-keyword :dry-run-mode
                 :init-value #f)
   (removed?  :init-value #f)))

(define-method initialize ((mail <mail>) initargs)
  (next-method)
  (if (ref mail 'file)
      (slot-set! mail 'port (open-input-file (ref mail 'file))))
  (scmail-mail-read mail (symbol->string (gauche-character-encoding))))

(define-method write-object ((mail <mail>) port)
  (format port "~a" (class-name (class-of mail))))

(define-method scmail-mail-read ((mail <mail>) to-code)
  (define (add-info! key value)
    (slot-set! mail 'info
     (cons (cons key value) (ref mail 'info))))

  ;; We don't know which character code the mail is written in beforehand.
  ;; For safety, we use block I/O to read the mail.
  (define (read-content iport)
    (when (eq? iport (standard-input-port))
      (set! (port-buffering iport) :none))
    (let loop ((block "")
               (blocks '()))
      (if (eof-object? block)
        (string-concatenate-reverse blocks)
        (loop (read-block 4096 iport) (cons block blocks)))))

  ;; decode the value of a field.
  (define (read-header cport)
    (map (lambda (field)
           (let ((name (first field))
                 (value (second field)))
             (list name (scmail-mail-decode-field value to-code))))
         (rfc822-header->list cport)))

  ;; First we read everything into content.
  (set! (ref mail 'content) (read-content (ref mail 'port)))
  (close-input-port (ref mail 'port))
  ;; Parse the content
  (unless (string-null? (ref mail 'content))
          (call-with-input-string 
           (ref mail 'content)
           (lambda (cport)
             (let1 headers (read-header cport)
                   (set! (ref mail 'info)
                         (map (lambda (p) (cons 
                                           (string->symbol (car p)) (cadr p)))
                              (filter (lambda (p)
                                        (and (string? (car p))
                                             (string? (cadr p))))
                                      headers)))
                   (add-info! 'body (get-remaining-input-string cport))
                   (add-info! 'length (string-size (ref mail 'content)))
                   (add-info! 'to/cc
                              (string-append (scmail-mail-query mail 'to)
                                             ", "
                                             (scmail-mail-query mail 'cc)))
                   (add-info! 'file (or (ref mail 'file) "(stdin)"))
                   ;; for backward compatibility.
                   (add-info! 'file-name (port-name (ref mail 'port)))
                   )))))

(define-method scmail-mail-query ((mail <mail>) key . options)
  (cond ((null? options)
         (let ((pair (assq key (ref mail 'info))))
           (if pair (cdr pair)	"")))
        ((eq? (car options) :multi-field)
         (map cdr (filter (lambda (pair) (eq? key (car pair))) 
                          (ref mail 'info))))))

(define-method scmail-mail-port ((mail <mail>))
  (open-input-string (ref mail 'content)))
  
(define-method scmail-mail-from-stdin? ((mail <mail>))
  (eq? (ref mail 'file) #f))

(define-method scmail-mail-removed? ((mail <mail>))
  (ref mail 'removed?))

(define-method scmail-mail-dry-run-mode? ((mail <mail>))
  (ref mail 'dry-run-mode))
  
(define-method scmail-mail-write ((mail <mail>) file)
  (unless (scmail-mail-dry-run-mode? mail)
          (call-with-output-file file
            (lambda (port)
              (copy-port (scmail-mail-port mail) 
                         port)))))

(define-method scmail-mail-remove ((mail <mail>))
  (unless (or (scmail-mail-from-stdin? mail)
              (scmail-mail-dry-run-mode? mail))
	  (sys-unlink (scmail-mail-query mail 'file)))
  (slot-set! mail 'removed? #t))

(define-method scmail-mail-rename ((mail <mail>) new-name)
  (unless (scmail-mail-dry-run-mode? mail)
          (sys-rename (scmail-mail-query mail 'file) new-name))
  (slot-set! mail 'removed? #t))

(define-method scmail-mail-forward ((mail <mail>) host address)
  (unless (scmail-mail-dry-run-mode? mail)
          (scmail-send-mail host 25 (scmail-mail-port mail) "" address)))


;; (scmail-mail-decode-field 
;;   "=?iso-2022-jp?Q?=1B=24=42=24=22=1B=28=42?=abc" "eucjp")
;;  => "あabc"
;; (scmail-mail-decode-field "=?ISO-2022-JP?B?GyRCJCIbKEJhYmM=?=" "eucjp")
;;  => "あabc"
(define (scmail-mail-decode-field str to-code)
  (with-error-handler 
   (lambda (e) str)
   (lambda ()
     (regexp-replace-all #/=\?([^?]+)\?([BQ])\?([^?]+)\?=\s*/ 
                         str
                         (lambda (m)
                           (let* ((charcode (rxmatch-substring m 1))
                                  (encoding (rxmatch-substring m 2))
                                  (message  (rxmatch-substring m 3))
                                  (decode (if (equal? encoding "B")
                                              base64-decode-string
                                              quoted-printable-decode-string)))
                             (ces-convert (decode message)
                                          charcode
                                          to-code)))))))

;; (scmail-send-mail "localhost" 25 (open-input-string "Hello!")
;;  "from@localhost" "to@localhost")
(define (scmail-send-mail host port iport mail-from recipients)
  (with-error-handler
   (lambda (e) (errorf "scmail-send-mail failed: ~a" (ref e 'message)))
   (lambda ()
     (call-with-client-socket
      (make-client-socket 'inet host port)
      (lambda (in out)
	(let ((send-command 
	       (lambda (command code)
		 (when command (format out "~a\r\n" command))
		 (let* ((line (read-line in))
			(return-code (string->number (substring line 0 3))))
		   (if (eq? return-code code)
		       line
		       (errorf "smtp-error: ~a => ~a" command line))))))
	  (send-command #f 220)
	  (send-command (format "HELO ~a" (sys-gethostname)) 250)
	  (send-command (format "MAIL FROM: <~a>" mail-from) 250)
	  (for-each (lambda (rcpt)
		      (send-command (format "RCPT TO: <~a>" rcpt) 250))
		    (if (string? recipients) (list recipients) recipients))
	  (send-command "DATA" 354)
	  (port-for-each (lambda (line)
                           (format out "~a~a\r\n"
                                   (if (string-prefix? "." line) "." "")
                                   line))
			 (lambda () (read-line iport #t)))
	  (send-command "." 250)
	  (send-command "QUIT" 221))))
     #t)))

(define supported-mail-type-table (make-parameter '()))

(define (scmail-mail-add-type! name class)
  (supported-mail-type-table  (cons (cons name class)
                                    (supported-mail-type-table))))

(define (make-scmail-mail mail-type . options)
  (let1 pair (assq mail-type (supported-mail-type-table))
        (if pair
            (apply make (cdr pair) options)
            (errorf "unsupported mail-type: ~a" mail-type))))

(define-method scmail-mail-copy ((mail <mail>) folder)
  (scmail-not-implemented-error mail 'scmail-mail-copy))

(define-method scmail-mail-prepare ((mail <mail>) folder)
  (scmail-not-implemented-error mail 'scmail-mail-prepare))

(define-method scmail-mail-move ((mail <mail>) folder)
  (let1 new-name (scmail-mail-prepare mail folder)
    (scmail-mail-rename mail new-name)
    new-name))

(provide "scmail/mail")
