;;; 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 reminders)
	     #:use-module (mutt helpers misc)
	     #:documentation
"This module defines the following reminders:

@itemize @bullet

@item
warns you before sending a message when there are unread
messages from the person you are writing to;

@item
warns you before sending a message if this message contains
the word `attachment' or some such.

@end itemize")


;;; Configuration options

(define my-stuff "hello")
(register-option! "my-stuff" #f #f "This option is useless.")

(define-public remind-unread? #t)
(register-boolean-option!
 "remind-unread?"
 "When true, notifies the user of pending unread messages before
sending an email.")

(define-public remind-attachment? #t)
(register-boolean-option!
 "remind-attachment?"
 "When true, notifies the user when he is about to forget an attachment.")

(define-public attachment-regexp
  ; Note: the '<word>' sequence to match whole words doesn't work.
  (make-regexp "(attach(ed|ment|é)|patch|joint)"
	       regexp/icase regexp/extended))

(define (set-attachment-regexp! name expr hint)
  "Change the attachment regexp to that of @var{expr}, a string."
  (let ((new-regexp (make-regexp expr regexp/icase regexp/extended)))
    (if (not new-regexp)
	(and (set-error-message! "Invalid attachment regexp")
	     #f)
	(and (set! attachment-regexp new-regexp)
	     #t))))

(register-option! "attachment-regexp" #f set-attachment-regexp!
		  "A regexp describing the `attachment' word.")


;;; Aspects

(define-aspect (send-message message)
  "Before sending @var{message}, notify the user if there are pending unread
messages from @var{message}'s recipient."
  (if remind-unread?
      (let* ((rcpt (address-mailbox (envelope-to (message-envelope message))))
	     (unread-messages
	      (length
	       (mailbox-select-messages
		(lambda (h)
		  (and
		   (string=?
		    (address-mailbox (envelope-from (message-envelope h)))
		    rcpt)
		   (not (message-read? h))))))))
	(ui-debug (string-append "Sending to " rcpt))
	(if (> unread-messages 0)
	    (if
	     (ui-yes-or-no?
	      (format #f "~a unread messages from ~a, continue?"
		      unread-messages rcpt) #f)
	     (next-aspect message)
	     (and (set-error-message! "Mail not sent") #f))
	    (next-aspect message)))
      
      (next-aspect message)))


(define-public (grep-file port regexp)
  "Return true if @var{port}'s contents match @var{regex}."
  (let ((line ""))
    (sleep 1)
    (while (not (or (eof-object? line)
		    (regexp-exec regexp line)))
	     (set! line (read-line port)))
    (not (eof-object? line))))

(define-public (message-deals-with-attachments? message)
  "Return true if the content of @var{message}, an outgoing message,
matches regexp @var{attachment-regexp}."
  ; Select the messages that actually contain text
  (let ((text-bodies (message-select-bodies
		      (lambda (body)
			(let* ((content-type (body-content-type body))
			       (major-type (if (null? content-type)
					       ""
					       (car content-type)))
			       (encoding (assoc-ref "encoding"
						    (body-parameters body))))
			  (and (string=? major-type "text")
			       (if encoding
				   (not (string=? encoding "base64"))
				   #t))))
		      message)))

    (not (null?
	  ; Iterate over the text bodies and look for the word `attachment'
	  (loop-until-true
	   (lambda (body)
	     (let* ((filename (body-filename body))
		    (port (if filename (open-input-file filename) #f)))
	       (if (and port (grep-file port attachment-regexp))
		   (and (ui-debug "Attachment regexp found!")
			(close-port port) #t) ; Contains the word
		   (if (not port)
		       (and
			 (ui-message (format #f "File error: ~a / ~a"
					     filename port))
			 #f)
		       #f))))
	   text-bodies)))))


(define-aspect (send-message message)
  "The forgotten attachment feature aspect!"
  ; Note: `execute-pattern' can't work on outgoing
  ; messages (see the `msg_search ()' function).
  (if remind-attachment?
      (if (if (message-deals-with-attachments? message)
	      (ui-yes-or-no?
	       "Warning: You might need to send an attachment! Continue?"
	       #t)
	      #t)
	  (next-aspect message)
	  (and (set-error-message! "Message not sent")
	       #f))
      (next-aspect message)))