;;; imap mail archiver.

;;; usage example:
;;;; (imap-archiver:archive-messages "lisp.phemlock")
;;; will move all messages in mail.old.lisp.phemlock to
;;; archive.YEAR.lisp.phemlock, where YEAR is the year each message
;;; was sent in (according to the Date: header.)

(cl:eval-when (:load-toplevel :compile-toplevel :execute)
  (cl:require :mel-base))

(cl:defpackage :imap-archiver
  (:use :cl :mel)
  (:export #:archive-messages))

(in-package :imap-archiver)


(defvar *me* nil)
(defvar *my-pass* nil)
(defvar *my-host* nil)

(load (merge-pathnames "passwords.lisp" *load-pathname*))

(defparameter *folders* (make-hash-table :test 'equal))

(defun intern-folder (name)
  (or (gethash name *folders*)
      (setf (gethash name *folders*)
            (make-imap-folder :host *my-host* :username *me* :password *my-pass*
                              :mailbox name))))

(defun ensure-ends-with-period (str)
  (format nil "~A~:[.~;~]" str (eql (char str (1- (length str))) #\.)))

(defun ensure-folder-exists (folder folder-name)
  (handler-case (mel.folders.imap::examine-mailbox folder)
    (error ()
      (mel.folders.imap::create-mailbox folder folder-name)))
  folder)

(defun archive-messages (folder-name &key (archive-prefix "archive") (folder-prefix "mail.old"))
  "Move messages from <folder-prefix>.<folder-name> to
<archive-prefix>.<year>.<folder-name>, where year is the year in
the Date: header of the message."
  (let* ((folder-name* (format nil "~A~A" (ensure-ends-with-period folder-prefix) folder-name))
         (folder (intern-folder folder-name*)))
    (unwind-protect
        (dolist (message (messages folder))
          (format *debug-io* "~&move ~A" (message-id message))
          (multiple-value-bind (second minute hour date month year day daylight-p zone)
              (decode-universal-time (date message))
            (declare (ignorable second minute hour date month year day daylight-p zone))
      
            (let* ((t-folder-name (format nil "~A~A.~A" (ensure-ends-with-period archive-prefix) year folder-name))
                   (t-folder (intern-folder t-folder-name)))
              (format *debug-io* " from ~A~A to: ~A" (ensure-ends-with-period folder-prefix) folder-name
                      t-folder-name)
              (move-message message (ensure-folder-exists t-folder t-folder-name)))))
      (mel.folders.imap::expunge-mailbox folder))))