;;;  This is my personal configuration file.  It implements several funny
;;;  functions:
;;;
;;;    -  including a clever `display-message' function;
;;;    -  a message scoring method that allows for negative scores;
;;;    -  a wonderful auto-reply feature written as an additionnal
;;;       `score-message' aspect;
;;;    -  a customized signature that uses fortune(1);
;;;    -  `smart' forwarded mail intro;
;;;    -  `count', a command that displays the number of messages
;;;        matching a pattern.
;;;
;;;  ... and many others!  :-)
;;;
;;;
;;;  Feel free to use these things.
;;;
;;;  Ludovic Courtès <ludovic.courtes@laas.fr>.


(use-modules (ice-9 regex)
	     (ice-9 popen)
	     (ice-9 rdelim))

;(set! debug? #t)
;(set! debug-time 0)
;(set! debug-port (open-file "muttlog" "w+"))

; Discard the built-in scoring method.
(define score-message noop)


(use-modules ((mutt aliases)     #:renamer (symbol-prefix-proc 'al:))
	     ((mutt reminders)   #:renamer (symbol-prefix-proc 'rem:))
	     ((mutt notify)      #:renamer (symbol-prefix-proc 'not:))
	     ((mutt sorting)     #:renamer (symbol-prefix-proc 'sort:))
	     ((mutt mua-stats)   #:renamer (symbol-prefix-proc 'stat:))
	     ((mutt ping)        #:renamer (symbol-prefix-proc 'ping:))
	     ((mutt attribution) #:renamer (symbol-prefix-proc 'attr:))
	     ((mutt spam)        #:renamer (symbol-prefix-proc 'spam:))
	     ((mutt make-doc)    #:renamer (symbol-prefix-proc 'doc:))
	     (mutt helpers misc)
	     (mutt helpers send))


; (define x (split-argument-string "'~f \"sego\"' ~A ~t\\ ludo"))
; (format #t "length: ~a~%" (length x))
; (let ((i 0))
;   (map
;    (lambda (s)
;      (begin
;        (format #t "arg ~a: ~s~%" i s)
;        (set! i (+ i 1))))
;    x))

(define home-directory (getenv "HOME"))

(define (home-file filename)
  (string-append home-directory "/" filename))

(load (home-file ".mail_aliases.scm"))

; Load the legacy Muttrc file, just for the fun of it.
(source-rc-file (home-file ".muttrc"))

(set! (user-headers)
      '("X-PGP-Fingerprint: 821D 815D 902A 7EAB 5CEE  D120 7FBA 3D4F EB1F 5364"
	"X-PGP-Key-ID: 0xEB1F5364"
	"X-PGP-Key: http://ludo.humanoidz.org/ludovic.asc"
	"Organization: LAAS-CNRS"
	"X-OS: GNU/Linux"
	"X-URL: http://ludo.humanoidz.org/"))

(set! (subscribed-lists)
      '("help-hurd" "bug-hurd" "debian-hurd" "hurd-devel" "l4-hurd"
	"lout@ptc.spbu.ru" "guile-user@gnu.org"
	"etudiants@utbm.fr" "etudiants.gi@utbm.fr" "lolut" "club-linut"
	"toutlelaas@laas.fr" "annonce@laas.fr" "tsf" "friends-folks"
	"general@libretudes.org" "fsfe-france" "mutt-users" "mutt-dev"
	"ocattac"))

(set! (mailing-lists) (subscribed-lists))

(set-option "spoolfile" "imap://lcourtes@imap2/")

#[### Some muttrc code ###
  # Outgoing mail copies
  set copy=yes
  set record="=outbox"
  set save_name=no
  set fcc_clear

  # User and display setup
  set realname="Ludovic Courtès"
  set from="ludovic.courtes@laas.fr"
  set alternates="(lcourtes(@laas\.fr)?|ludovic\.courtes@utbm.fr)"
  set charset=iso-8859-1
  set editor=vim
  set alias_file=~/.mail_aliases
  set pager_index_lines=7
  source ~/.mail_aliases
]#

(set! spam:spam-check-enabled? #t)

(define my-address
  (create-address (query-option "from")))

(if (not (address-personal my-address))
    (set! (address-personal my-address) (query-option "realname")))
  
(define (default-from-address)
  "My default from address, based on $from and $realname."
  my-address)

(define (dumb)
  "Useful to test exception handling. ;)"
  (do-stupid-things))

(set-option "timeout" "10")


;(output-documentation "mutt-guile.texi")

; The feature no one can live without: display date and a fortune.
(add-hook!
 idle-hook
 (lambda ()
   "This function gets called every $timeout seconds without a keypress."
   (let ((timestr (strftime "%H:%M | " (localtime (current-time))))
	 (unread  (mailbox-unread-messages (current-mailbox))))
     (ui-message
      (string-append timestr
		     (if (> unread 0)
			 (format #f "~a nelegitaj mesagoj" unread)
			 (strip-non-printable-chars
			  (command-output "/usr/games/fortune -n 70 -s"))))))))


; Patterns (the trailing #f means that the pattern may apply only to a message
; header, which is faster than a pattern that also looks at the message body).
(define spam (compile-pattern "~h '^X-Spam-Status: *Yes'"))
(define contains-attach-word
  (compile-pattern "~b attach | ~b patch | ~b joint"))
(define from-hurd  (compile-pattern "~L hurd" #f))
(define from-lolut (compile-pattern "~L lolut | ~L linut | ~L libretudes" #f))
(define from-mutt  (compile-pattern "~L mutt" #f))
(define from-fsf   (compile-pattern "~L fsfe-france" #f))
(define from-utbm  (compile-pattern "~L etudiants.*@utbm.fr" #f))
(define from-guile (compile-pattern "~L guile-user@gnu.org" #f))
(define from-attac (compile-pattern "~L ocattac" #f))
(define subject-sell     (compile-pattern "~s [vV][eE][nN][dD]" #f))
(define subject-capitals (compile-pattern "~s '^[A-Z!\?: -]+$'" #f))
(define subject-loud     (compile-pattern "~s '!!+'" #f))

(define from-family
  (compile-pattern "~f anne-sophie.courtes | ~f alain.courtes" #f))
(define from-sego
  (compile-pattern "~f sego | ~f sgm | ~f metais@irit.fr" #f))
(define to-sego
  (compile-pattern "~t sego | ~t metais@irit.fr | ~t sgm" #f))

(set! not:notify-pattern from-sego)

(define (is-from-mailing-list? message)
  (or (execute-pattern from-hurd  message)
      (execute-pattern from-lolut message)
      (execute-pattern from-mutt  message)
      (execute-pattern from-fsf   message)
      (execute-pattern from-guile message)
      (execute-pattern from-utbm  message)))

;(define (is-mailing-list? address)
;  (string=? (address-mailbox address) "help-hurd@gnu.org"))
;(define is-subscribed-list? is-mailing-list?)

(define low-score "-4")
(define (get-low-score)
  (let ((lo (string->number low-score)))
    (if lo lo 0)))

; A clever display-message
; This need to appear *before* (mutt spam) gets loaded.
(define-aspect (display-message message)
  (let ((ret #f))
    (set! ret
      ; Check whether this message should be directly displayed
      (let* ((score (message-score message)))
	(if
	  (or #f
; 	    (if (execute-pattern spam message)
; 		(begin
; 		  (message-delete! message)
; 		  (ui-yes-or-no? "This seems to be spam, view anyway?"))
; 		#f)
	    (if (< score (get-low-score))
	      (if (ui-yes-or-no?
		    (format #f "Score is too low (~a), view anyway?" score))
		#t
		(and (message-read! message) #f))
	      #t))

	  (next-aspect message)
	  #f)))
    ;(if (is-from-mailing-list? message) (message-tag! message))
    ret)) ; Always return true to force the index to be refreshed

(define-macro (change-score message value)
  `(and
    (set! (message-score ,message) (+ (message-score ,message) ,value))
    ,message))

(define-aspect (score-message message update-mailbox? mailbox)
  "Simple score-message function which allows for negative scores."
  (set! (message-score message) 0)
  (let ((to (envelope-to (message-envelope message))))
    (if (and to (address-is-user? to))
	(change-score message +10)))
  (if (execute-pattern from-family message)
      (change-score message +4))
  (if (execute-pattern from-sego message)
      (change-score message +5))
  (if (execute-pattern from-utbm message)
      (change-score message -2))
  (if (execute-pattern subject-sell message)
      (change-score message -2))
  (if (execute-pattern subject-capitals message)
      (change-score message -4))
  (if (execute-pattern subject-loud message)
      (change-score message -2))
  (next-aspect message update-mailbox? mailbox))

(define (query-exit)
  "An annoying thing."
  (if (ui-yes-or-no? "Really?")
    (builtin-query-exit)
    #f))

(define-command (reload . str)
  "Reload file $HOME/.mutt.scm."
  (catch #t
    (lambda ()
      (begin
	;(reload-defaults)
	(load (home-file ".mutt.scm"))))
    (lambda (key . args)
      (and (set-error-message! (format #f "~a exception" key)) #f))))



;(define send-message builtin-send-message)

;;; Tests

(define (my-function)
  (ui-message "This is my function"))

;(define (default-from-address)
;  (create-address "LuDo <ludovic.courtes@laas.fr>"))

(define-command (count argstring)
  "Display the number of messages matching the given pattern."
  (let* ((arglist  (split-argument-string argstring))
	 (argcount (length arglist))
	 (patternstr (if (> argcount 0) (car arglist) #f)))
    (if (not (= argcount 1))
	(and
	 (cond
	  ((< argcount 1) (ui-error-message "Too few arguments"))
	  (#t             (ui-error-message "Too many arguments"))) #t)
	(let ((pat (compile-pattern patternstr)))
	  (if (not pat)
	      (and
	       (set-error-message!
		(string-append patternstr ": Invalid pattern")) #f)
	      (let
		  ((number
		    (length
		     (mailbox-select-messages
		      (lambda (h)
			(execute-pattern pat h M_MATCH_FULL_ADDRESS))))))
		(ui-message (format #f "~a matching messages" number))))))))

(define-macro (++ number)
  `(set! ,number (+ ,number 1)))


; Mailing-list messages that are to be sorted (e.g. by the `move' command,
; see below): a list of pattern-mailbox pairs.
(set! sort:sorted-lists
  `((,from-hurd  . "=hurd")
    (,from-lolut . "=lolut")
    (,from-fsf   . "=fsf")
    (,from-mutt  . "=mutt")
    (,from-guile . "=guile")
    (,from-attac . "=attac")))

; I definitely need auto-sorting.
(set! sort:auto-sort-enabled? #t)


(define (append-signature file message)
  "Add a fortune cookie to my prefered recipient as a signature."
  (if (execute-pattern to-sego message M_MATCH_FULL_ADDRESS)
      (let ((fortune (command-output "/usr/games/fortune -s")))
	(display "\n--\n" file)
	(display fortune file))
      #t))

(define (make-forward-subject! envelope message mailbox)
  "Sets the subject of @var{envelope} which is a forward of @var{message}."
  (let ((orig-subject (envelope-subject (message-envelope message))))
	(set! (envelope-subject envelope)
	      (string-append "Fw: " orig-subject))))

(define (string-pad string length pad-char)
  "If @var{string} is shorter than @var{length}, then return a string of
size @var{length} equal to @var{string} padded with some @var{pad-char}
characters."
  (let* ((strlen (string-length string))
	 (padlen (if (< strlen length)
		     (- length strlen)
		     0))
	 (half-padlen (quotient padlen 2)))
    (string-append (make-string half-padlen pad-char)
		   string
		   (make-string half-padlen pad-char))))

(define (append-forward-intro port forwarded)
  "Append a smart forward intro."
  (let ((sender (envelope-from (message-envelope forwarded)))
	(rcpt   (envelope-to   (message-envelope forwarded))))
    (format port "~a\n\n" (string-pad
			   (if (is-mailing-list? rcpt)
			       (format #f "[ Seen on ~a ]"
				       (address-mailbox rcpt))
			       (format #f "[ Forwarded from ~a ]"
				       (pretty-address sender)))
			   72 #\-))))

(define (append-forward-trailer port forwarded)
  "Append a nice forward trailer."
  (format port "\n~a\n"
	  (string-pad "[ End of forwarded message ]" 72 #\-)))

(define attribution-show-seconds? #t)
(define attribution-split-if-needed? #t)
		   
(define-command (dummy . argstring)
  "Create and send a message containing your signature! :-)"
  (let ((msg (build-simple-message "The automagix message!"
				   (default-from-address)
				   (home-file ".signature"))))

    ; Try to attach a file (PDF) and make it base64 encoded.
    (let ((root (create-body))
	  (text (message-body msg))
	  (attach (create-body)))
      (set! (body-content-type attach) "application/pdf")
      (set! (body-parameters attach)
	    '(("encoding" . "base64")))
      (set! (body-filename attach) (home-file "attacinfo441.pdf"))
      (set! (body-next text) attach)
      (set! (body-content-type root) '("multipart" . "mixed"))
      (set! (body-parameters root)
	    (list (generate-boundary)))
      (set! (body-parts root) text)
      (set! (message-body msg) root))
    
    (if (builtin-send-message msg)
	(ui-message
	 (format #f "Succesfully sent message ~a"
		 (envelope-message-id (message-envelope msg))))
	(ui-message "Failed to send message :-("))))

(define-command (stress . argstr)
  "Stresses the garbage collection mechanism by creating many objects."
  (let ((i 0))
    (while (< i 100000)
	   (begin
	     (let ((message (create-message)))
	       (create-message)
	       (set! (message-envelope message) (create-envelope)))
	     (set! i (+ 1 i)))))
  (gc))
