;;; Guile bindings for Mutt
;;; Copyright (C) 2003  Ludovic Courtès

;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;; 
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */

(mutt-module (mutt sorting)
	     #:use-module (mutt helpers misc)
	     #:documentation
"This module automates mailing-list messages sorting. The @var{sorted-lists}
Scheme variable, an alist of pattern/mailbox-name pairs, should be defined
by the user in order for the module to know which messages (i.e. messages
matching which pattern) should go where (i.e. in which mailbox).
Pattern/mailbox-name pairs may also be added to @var{sorted-lists}
using the @var{sort-list} command.

The @code{move} may be executed in order for messages to be sorted according
to @var{sorted-lists}.  Alternatively, sorting may be performed automatically
every @var{auto-sort-frequency} minutes for messages that are read and older
than @var{auto-sort-days}.")

; Mailing-list messages that are to be sorted (e.g. by the `move' command,
; see below): a list of pattern-mailbox pairs.  Here is an example:
; (set! sorted-lists
;   `((,(compile-pattern "~L hurd")        . "=hurd")
;     (,(compile-pattern "~L fsfe-france") . "=fsf")
;     (,(compile-pattern "~L mutt")        . "=mutt")
;     (,(compile-pattern "~L guile")       . "=guile")))
(define-public sorted-lists '())

(define-command (sort-list argstring)
  "Sort messages matching the pattern given as the first argument to the
mailbox whose path was passed as the second argument."
  (let ((args (split-argument-string argstring)))
    (if (= 2 (length args))
	(let ((pattern (compile-pattern (car args))))
	  (if pattern
	      (set! sorted-lists (acons pattern (cdr args) sorted-lists))
	      (ui-message (format #f "~a: Invalid pattern" (car args)))))
	(ui-message "Usage: sort-list <pattern> <mailbox-path>"))))

; Tag messages from MESSAGE-LIST.
(define (retag-messages message-list)
  (if (null? message-list)
      #t
      (and (message-tag! (car message-list))
           (retag-messages (cdr message-list)))))

; Tag all messages matching PATTERN and return the number of
; messages tagged.
(define (tag-matching-messages pattern tag?)
  (if (not (pattern? pattern))
      0
      (length
	(mailbox-select-messages
	  (lambda (message)
	    (if (and (not (message-deleted? message))
		     (execute-pattern pattern message))
		(message-tag! message tag?)
		#f))))))

; Move messages matching PATTERN to MAILBOX by tagging them, assuming
; that no other message is already tagged.
(define (move-messages pattern mailbox)
  (if (or (not (pattern? pattern))
          (not (string? mailbox)))
    #f
    (if (= 0 (mailbox-tagged-messages))
      (let ((messages (tag-matching-messages pattern #t)))
	  (and
	    ; Save and delete tagged messages, but don't decode/decrypt
	    (save-message #f (expand-path mailbox) #t #f #f)
	    (ui-message
	      (format #f "~a messages moved to ~a" messages mailbox))
	    (sleep 1)
	    (tag-matching-messages pattern #f)))
      (ui-message "There are already tagged messages!"))))

; Move mailing-list messages to the appropriate mailbox.  First of
; all, remember currently tagged messages; then tag mailing-list
; messages and save all tagged messages to their mailbox (this was
; originally supposed to be more efficient than saving messages one by
; one, although I'm not sure it really is).  Finally, re-tag
; previously tagged messages.
(define-command (move . unused-argument-string)
  "Move mailing-list messages to the appropriate mailbox."
  (if (inbox? (current-mailbox))
      (begin
	(ui-message "Moving mailing-list messages...")
	(let ((tagged-messages
	       (mailbox-select-messages
		(lambda (h)
		  (if (message-tagged? h)
		      (and (message-tag! h #f) #t)
		      #f)))))
	  (map (lambda (list-pair)
		 (move-messages (car list-pair) (cdr list-pair)))
	       sorted-lists)
	  (retag-messages tagged-messages)))
      (ui-message "Current mailbox is not $spoolfile, no message moved.")))


;;; Auto-sorting

; Number of days after which a message can get sorted out.
(define-public auto-sort-days 2)

(register-integer-option!
 "auto-sort-days"
 "Number of days after which a message can get sorted out.")

(define-command (auto-list-sort . blurps)
  "Autosorting of mailing lists messages older than @var{auto-sort-days} days."
  (if (inbox? (current-mailbox))
      (let* ((now      (current-time))
	     (days-ago (- now (* auto-sort-days 24 60 60)))
	     (stats    '())
	     (stats++  (lambda (box)
			 (let ((cur (assoc box stats)))
			   (+ 1 (if cur (cdr cur) 0))))))

	;; Traverse the list of messages and move the old ones
	(ui-message "Sorting messages...")
	(mailbox-select-messages
	 (lambda (message)
	   (if (and (message-read? message)
		    (not (message-deleted? message))
		    (< (message-date-received message) days-ago))
	       (loop-until-true
		(lambda (list-pair)
		  (if (execute-pattern (car list-pair) message)
		      (let ((box (cdr list-pair)))
			;; Save and delete message, but don't decode/decrypt
			(save-message message (expand-path box) #t #f #f)
			(set! stats
			      (assoc-set! stats box (stats++ box)))
			#t)
		      #f))
		sorted-lists))))

	;; Display the number of messages moved around
	(map (lambda (stat-pair)
	       (let ((number (cdr stat-pair)))
		 (if (> number 0)
		     (begin
		       (ui-message (format #f "~a messages moved to ~a"
					   number (car stat-pair)))
		       (sleep 1)))))
	     stats)

	(ui-message (format #f "sorted: ~a" stats))
	(sleep 1))
      (ui-message "Current mailbox is not $spoolfile, no message moved.")))


;; How often should auto-sorting be made, in minutes.
(define-public auto-sort-frequency 20)

; For safety reasons, disable it by default.
(define-public auto-sort-enabled?  #f)

(register-integer-option!
 "auto-sort-frequency"
 "Tells how often (minutes) messages auto-sorting should be performed.
Note that the actual frequency depends on the value of the
@var{timeout} option.")

(register-boolean-option!
 "auto-sort-enabled?"
 "If \"yes\", mailing-list auto-sorting is enabled.")

; When dis this file get loaded?
(define load-time (current-time))

; FIXME: If auto-sorting starts while the mailbox is being loaded, then
; Mutt may segfault!  We should add a `loaded' field to mailboxes so that
; `mailbox-select-messages' doesn't do anything until this flag is set.
; XXX: No this is wrong since Mutt is not multi-threaded.  I need to try
; to reproduce this segfault.  The only thing I know is that this happens
; in the auto-sort `mailbox-select-messages'.
(define-public auto-sort-initial-delay 5)

(register-integer-option!
 "auto-sort-initial-delay"
 "Tells how long (minutes) auto-sorting should wait before being
executed for the first time.")

; When was the last auto-sorting performed (Epoch)?
(define last-auto-sort-time 0)

(define (run-auto-sort)
  "Run auto-list-sort only at most every @var{auto-sort-frequency} minutes."
  (if auto-sort-enabled?
      (let* ((now (current-time))
	     (time-since-loaded (- now load-time))
	     (minutes-ago (- now (* auto-sort-frequency 60))))
	(if (and (>= time-since-loaded (* auto-sort-initial-delay 60))
		 (< last-auto-sort-time minutes-ago))
	    (begin
	      (auto-list-sort)
	      (set! last-auto-sort-time now))
	    #f))))

; Make sure the hook is not already there and register it.
(if (not (member run-auto-sort (hook->list idle-hook)))
    (add-hook! idle-hook run-auto-sort))
