;; Last edited: Fri Aug 20 14:49:23 1999
;; gnus customisation
(setq mm-inline-large-images t)		;prevent crash in mm-image-fit-p ???
(setq gnus-novice-user nil)
(setq gnus-message-archive-group
      '((concat "general." (format-time-string
			   "%Y-%m" (current-time)))))

(setq 	gnus-summary-ignore-duplicates t
	gnus-auto-select-next 'quietly
	gnus-summary-display-arrow nil
	gnus-your-organization "HCRC, University of Edinburgh"
	gnus-ignored-headers
	      "^Errors-To:\\|^Precedence:\\|^UNIX-From:"
        mm-discouraged-alternatives '("text/html")
	nnmail-expiry-wait 28
	nnmail-spool-file
	'((file)(file :path "/home/ht/mbox")))

(setq bbdb/news-auto-create-p t)

(defconst hash-file "/home/ht/.whitelist")

(defvar white-hash (make-hash-table :test (function equal)))

(with-current-buffer (get-buffer-create " *Whitelist")
  (insert-file-contents hash-file)
  (goto-char (point-min))
  (while (not (eobp))
    (puthash (buffer-substring (point) (progn
					 (end-of-line)
					 (point)))
	     t
	     white-hash)
    (forward-line)))

(defun get-from-addr ()
  (gnus-extract-address-components
   (gnus-fetch-field "From")))

(defun get-current-from-addr ()
  (with-current-buffer gnus-article-buffer
    (get-from-addr)))

(defun white-list (list)
  (if (or (gethash (cadr (get-from-addr))
		   white-hash)
	  (let ((subj (gnus-fetch-field "Subject")))
	    (and subj
		 (string-match "\\[\\([^]]*\\)\\]" subj)
		 (member (match-string 1 subj) white-lists))))			     
      list))

(defun add-white ()
  (interactive)
  (gnus-summary-goto-article (gnus-summary-article-number))
  (do-add-white (cadr (get-current-from-addr))))

(defun do-add-white (addr)    
  (puthash addr t white-hash)
  (with-current-buffer (get-buffer " *Whitelist")
    (let ((max (point-max)))
      (goto-char max)
      (insert addr)
      (insert "\n")
      (write-region max (point) hash-file t))))

(defun bogoNote (group) 
  (shell-command-on-region (point-min) (point-max) 
                           "/home/ht/bin/makeBogo") 
  'delete)


(defun whiten-recip ()
  ;;; a hook for outgoing mail
  (let ((recips (message-options-get 'message-recipients)))
    (mapcar (function new-white)
                      (split-string recips ",[ \f\t\n\r\v]+" t))))

(add-hook 'message-sent-hook (function whiten-recip))

(defun new-white (addr)
  (if (gethash addr white-hash)
      nil
    (do-add-white addr)))

(setq wsp-cache nil)

(defun split-on-whole-field (field pat list)
  (goto-char (point-max))
  (let ((hit (assq pat wsp-cache))
        rpat)
    (if hit
        (setq rpat (cdr hit))
      (setq rpat
         (concat "^"
                 field
                 ":\\s-*"
                 (if (stringp pat)
                     pat
                   (cdr (assq pat
                              nnmail-split-abbrev-alist)))
                 "$"))
      (setq wsp-cache (cons (cons pat rpat) wsp-cache)))
    (if (re-search-backward rpat nil t)
        list)))

(setq nnmail-crosspost nil)
(setq nnmail-split-methods 'nnmail-split-fancy)

(setq ht-lists
      '(("Subject" "Cron <mt> /home/mt/bin/heartbeat" "heartbeat")
	("Subject" "Cron <mt[@]markup> /home/mt/bin/heartbeat" "heartbeat")
	(to "xml-dev" "xml")
	(to "markup@markup[a-zA-Z]*" "markup")
	(to "general@developer.marklogic.com" "marklogic")
	(to "betterform-users@lists.sourceforge.net" "betterform")
	(to "betterform-developer@lists.sourceforge.net" "betterform")
	(to "mrbs-[a-zA-Z]*@lists.sourceforge.net" "mrbs")
	(to "selenium-users" "selenium")
	(to "sqlobject-discuss" "sqlobject")
	(to "exist-open@lists.sourceforge.net" "exist")
	(to "exim-users@exim.org" "exim")
	(to "exist-development@lists.sourceforge.net" "exist")
	(to "xsltforms-support@lists.sourceforge.net" "xsltforms")
	(to "mtt" "mtt")
	(to "ding" "gnus")))

(setq white-lists '("selenium-users" "Betterform-users" "Exist-development" "Exist-open"))

(defvar ht-compiled-split nil)

(defun set-ht-compiled-split ()
  "update the mail splitting rules"
  (interactive)
  (setq ht-compiled-split
      (let* ((month
              (format-time-string "%Y-%m" (current-time)))
             (now-group (concat "group-" month))
             (now-pers (concat "pers-" month)))
        `(|
          (: split-on-whole-field "Subject" "testing" 'junk)
          ,@ht-lists
          (to "ht\\|henry\\|\\(h\\.?\\)?thompson?" ,now-pers)
	  (to "xml-dev" "xml")
	  ,now-group
          ))))

(set-ht-compiled-split)

(setq nnmail-split-fancy
      '(!
        (lambda (sres)
          (if (or (equal (car sres) "notSPAM")
                  (equal (car sres) "waSPAM"))
              ;; documentation is wrong, no recursion,
              ;; so we do it ourselves :-(
              (nnmail-split-it ht-compiled-split)
            sres))
        (| (to "ht@hppllc.org" "llc")
	   ("X-Bogosity" "\\(Yes\\|Unsure\\).*"
            (| (: white-list "waSPAM")
               ("X-Spam-Score" "0" "boSPAM")
	       ("X-Bogosity" "Unsure.*" "mSPAM")
               "bfSPAM"))
           (: split-on-whole-field "X-Spam-Level" "\\*\\*\\*\\*.*"
              '(| (: white-list "waSPAM")
                  "saSPAM"))
           ("X-Spam-Status" "Yes.*"
            (| (: white-list "waSPAM")
               "saSPAM"))
           "notSPAM")))

(defun ht-gnus-summary-delete-forward ()
  "REAL delete for nnmail gnus"  
  (interactive)
  (gnus-summary-delete-article)
  (gnus-summary-next-unread-article))

(require 'my-news)
(setq gnus-show-mime t) ; stale

;; try to ignore list name in subject for sorting
(setq message-subject-re-regexp "^[ 	]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ 	]*\\)*\\(\\[[^]]*\\]\\)?[ 	]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ 	]*\\)*")

(custom-set-variables
 '(gnus-treat-display-picons nil))
(custom-set-faces)

(require 'mm-decode)
(setq mm-automatic-display (remove "text/html" mm-automatic-display))

(add-hook 'gnus-group-mode-hook 'gnus-topic-mode)

(add-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1)
 
;; run the first time we make a summary window
(defun gnus-summary-mode-fun1 ()
  "install ht's mods"
  (define-key gnus-summary-mode-map "D" 'ht-gnus-summary-delete-forward)
  (define-key gnus-summary-mode-map "\M-d" 'gnus-edit-and-move-to-diary)
  (define-key gnus-summary-mode-map "\M-e" 'gnus-extract-attachment)
  (define-key gnus-summary-mode-map "\M-w" 'add-white)
  (define-key gnus-summary-mode-map "\M-h" 'showMPAhtml)
  (define-key gnus-summary-mode-map "~" 'mark-and-mark)
  (remove-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1))

(defun ht-gnus-pers-refresh (n)
  (interactive "p")
  (let ((gn (concat "nnml+ht:pers-"
				 (format-time-string "%Y-%m" (current-time)))))
    (gnus-group-goto-group gn)
    (gnus-group-get-new-news-this-group n)
    (gnus-group-goto-group gn)
    (gnus-group-read-group))
  )

(add-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1)
 
;; run the first time we make a group window
(defun gnus-group-mode-fun1 ()
  "install ht's mods"
  (define-key gnus-group-mode-map "\M-\C-g" 'ht-gnus-pers-refresh)
  (remove-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1))

(defun gnus-user-format-function-t (header)
  "display the to field (for archive messages)"
  (let ((n (mail-header-number header)))
    (with-current-buffer nntp-server-buffer
      (save-excursion
	(save-restriction
	  (let ((inhibit-point-motion-hooks t))
	    (goto-char (point-min))
	    (let ((beg (search-forward (format " %d Article retrieved." n)))
		  (end (search-forward "\n.\n")))
	      (narrow-to-region beg end)
	      (goto-char beg)
	      (message-fetch-field "To"))))))))

(defun showMPAhtml ()
  "Show the text/html parts of an multipart/alternative message using lynx"
  (interactive)
  (gnus-summary-select-article)
  (with-current-buffer gnus-original-article-buffer
    (shell-command-on-region (point-min) (point-max) "/home/ht/bin/showMPA.sh")
    )
  )

(defun gnus-extract-attachment ()
  "extract attachments from a multi-part mime message"
  (interactive)
  (let ((sm gnus-show-mime))
    (if sm
	(progn (setq gnus-show-mime nil)
	       (gnus-summary-select-article t 'force))
        )
    (gnus-article-show-all-headers)
    (with-current-buffer gnus-article-buffer
      (save-excursion
	(save-restriction
	  (mime/viewer-mode)
	  (delete-other-windows)
	  (let ((pt 0))
	    (while (progn
		     (mime-viewer/next-content)
		     (and
		      (equal "*Preview-*Article**" (buffer-name (current-buffer)))
		      (not (= pt (point)))))
	      (setq pt (point))
	      (if (looking-at "^\\[[0-9]* \\([^ ]+ \\)+<")
		  (mime-viewer/extract-content)))))))
    (kill-buffer "*Preview-*Article**")
    (setq gnus-show-mime sm)
    ))

(make-variable-buffer-local 'gnus-extra-headers)
(make-variable-buffer-local 'nnmail-extra-headers)
(add-hook 'gnus-parse-headers-hook
	  '(lambda ()
	     (gnus-summary-set-local-parameters gnus-newsgroup-name)))

(defun del-dups () 
  (interactive) 
  (gnus-summary-sort-by-subject) 
  (gnus-summary-clear-mark-forward 1) 
  (goto-char (point-min)) 
  (let ((pos)) 
    (while (setq pos (search-forward "] " nil t)) 
      (end-of-line) 
      (let ((subj (buffer-substring pos (point)))) 
        (unless (equal subj "") 
          (let ((target (if (< (length subj) 26) 
                            (concat "] " subj "\n") 
                          (concat "] " (substring subj 0 25)))) 
                (done 0) 
                (case-fold-search nil)) 
          (while (and (= done 0) 
                      (search-forward target nil t)) 
            (forward-char -3) 
            (setq done (gnus-summary-mark-as-read-forward 1)))))))) 
  (gnus-summary-limit-to-unread) 
  (gnus-summary-sort-by-original)) 

(add-hook 'gnus-get-new-news-hook (lambda () (setq ht-gnus-just-read nil)))

(add-hook 'gnus-after-getting-new-news-hook
          (lambda () (message "%s" ht-gnus-just-read)))

(defvar ht-gnus-just-read nil)

(defun ht-gnus-note-save-to-group ()
  (let ((g (caar group-art)))
    (if (not (member g ht-gnus-just-read))
	(setq ht-gnus-just-read (cons g ht-gnus-just-read)))))

(add-hook 'nnml-prepare-save-mail-hook (function ht-gnus-note-save-to-group))