;;;
;;; 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.maildir
  (use srfi-1)
  (use file.util)
  (use scmail.mail)
  (use scmail.mailbox)
  )

(select-module scmail.maildir)

;;
;; mailbox object
;;
(define-class <maildir-mailbox> (<mailbox>) ())

(define-method scmail-mailbox-mail-list ((mailbox <maildir-mailbox>) folder)
  (let1 directory (scmail-mailbox-folder->path mailbox folder)
        (if (file-is-directory? directory)
            (apply append
                   (map 
                    (lambda (subdir)
                      (let ((directory (build-path directory subdir)))
                        (sort (filter (lambda (x) (and (file-is-regular? x)
                                                       (file-is-readable? x)))
                                      (directory-list directory
                                                      :add-path? #t
                                                      :children? #t
                                                      :filter #/^[0-9]+/)))))
                    (list "cur" "new")))
            '())))

(scmail-mailbox-add-type! 'maildir <maildir-mailbox>)

;;
;; mail object
;;
(define-class <maildir-mail> (<mail>)
  ((mailbox :init-value #f
            :init-keyword :mailbox)))

(define-method maildir-get-subdir ((mail <maildir-mail>))
  (if (or (scmail-mail-from-stdin? mail)
          (string=? "new" (sys-basename (sys-dirname 
                                         (scmail-mail-query mail 'file)))))
      "new"
      "cur"))

(define-method scmail-mail-prepare ((mail <maildir-mail>) folder)
  (let* ((mailbox (ref mail 'mailbox))
         (dest-directory (scmail-mailbox-make-folder mailbox folder))
	 (new-id (if (or (eq? mail #f) (scmail-mail-from-stdin? mail))
                     (maildir-generate-new-id)
                     (sys-basename (scmail-mail-query mail 'file))))
         (subdir (if mail (maildir-get-subdir mail) "new"))
	 (new-file (string-append 
                    (maildir-file new-id dest-directory subdir))))
    (maildir-make-sub-directories dest-directory)
    (if (file-exists? new-file)
        (errorf "scmail-mail-prepare: ~a already exists" new-file))
    new-file))

(define-method scmail-mail-copy ((mail <maildir-mail>) folder)
  (let1 new-file (scmail-mail-prepare mail folder)
    (if (equal? folder "") ;; the top of ~/Maildir
        (maildir-safe-write-mail new-file
                                 (lambda (file) (scmail-mail-write mail file)))
        (begin (scmail-mail-write mail new-file)
               new-file))))

(define (maildir-safe-write-mail new-file write-proc)
  (let* ((timer 30)
         (id (sys-basename new-file))
         (tmp-file 
          (build-path (sys-dirname (sys-dirname new-file))
                      "tmp" id)))
    (while (file-exists? tmp-file)
           (if (<= timer 0)
               (errorf "maildir-safe-write-mail timeout!"))
           (sys-sleep 2)
           (set! timer (- timer 2)))
    (write-proc tmp-file)
    (sys-link tmp-file new-file)
    (sys-unlink tmp-file)
    new-file))

(define (maildir-make-sub-directories directory)
  (create-directory* (build-path directory "tmp"))
  (create-directory* (build-path directory "cur"))
  (create-directory* (build-path directory "new")))

(define maildir-generate-new-id
  (let1 maildir-seq 0
        (lambda ()
          (inc! maildir-seq)
          (format "~a.~a_~a.~a"
                  (sys-time)
                  (sys-getpid)
                  maildir-seq
                  (sys-gethostname)))))

(define (maildir-file id directory subdir)
  (build-path directory subdir id))

(scmail-mail-add-type! 'maildir <maildir-mail>)

(provide "scmail/maildir")

