#!/usr/local/bin/klone

(setq args (getopts "USAGE: %0 [options] 
Checks if there is new mail at the IMAP or POP mail boxes.
Mail boxes are specified in the file ~/.checkmbox as lines:

    mbox-nick server-type host user passwd

Empty lines and lines beginning by # are ignored
Server-type is either POP or IMAP
Passwd are simply encrypted
Do not embed spaces into fields"
    ("-mail" addr mailto "if new mail, mail to address")
    ("-f" file mfile "config file (default ~/.checkmbox)")
    ("-v" () verbose "verbose operation")
;; --- Hidden Options ---
    ("-debug" () enter-debugger-on-error "enter klone debugger on error"
    :hidden t)
    ("-stackdump" () stackdump-on-error "verbose stack dump on error"
    :hidden t)
    ("-e" () encrypt-only "only encrypts args")
))

;; Syntax of ~/.checkmbox-state: lines of
;; nick number

(if enter-debugger-on-error (kdb t))
(if stackdump-on-error (stack-dump-on-error t))

(defstruct MBox
  nick					; user-intelligible name of the account
  type					; "IMAP" or "POP"
  host					; IP name of server
  user					; account login
  pass					; account passwd
  (mails 0)				; number of waiting emails (or ())
  (oldmails 0)				; previous number
)

(if mfile (progn
    (setq mboxes-file (expand-filename mfile))
    (setq check-file (expand-filename (+ mfile "-state")))
  )
  (progn
    (defvar mboxes-file (expand-filename "~/.checkmbox"))
    (defvar check-file (expand-filename "~/.checkmbox-state"))
))

(defvar mboxes (list))			;list of mboxes to check

(defun main (&aux news? mails? in)
  (if encrypt-only (show-encrypted-args args))
  ;; read config
  (read-mboxes-file mboxes mboxes-file check-file)
  ;; ask servers for num,ber of pending mails
  (dolist (mbox mboxes)
    (verbose? "Checking %3: %0 mbox on %1, user %2" mbox.type mbox.host
      mbox.user mbox.nick
    )
    mbox.mails = (if (= mbox.type "IMAP")
      (checkmail-IMAP mbox) (checkmail-POP mbox)
    )
    (if (not mbox.mails) mbox.mails = 0)
    (if (and mbox.mails (/= 0 mbox.mails))
      (verbose? "  *** %0 mails!" mbox.mails)
       (verbose? "  no mail.")
    )
    (if (> mbox.mails 0) mails? = t)
    (if (> mbox.mails mbox.oldmails) news? = t)
  )
  ;; write checkpoint
  (write-checkpoint mboxes check-file)
  ;; detect new mails
  (if mailto 
    ;; If we mail, mail only if there are news
    (when news?
      (system (list (if (file-stats "/usr/ucb/mail") "/usr/ucb/mail" "mail")
	  "-s" "[checkmbox] new mail" mailto
	) :input 'in
      )
      (dolist (mbox mboxes)
	(if (> mbox.mails 0)
	  (PF in "%5%0: %1 mail%2! (server %3, user %4)\n" 
	    mbox.nick mbox.mails (if (> mbox.mails 1) "s" "")
	    mbox.host mbox.user
	    (if (> mbox.mails mbox.oldmails) "*** " "    ")
      )))
      (flush in)
      (close in)
    )
    ;;else, X message
    (when mails?
      (with (message (copy ""))
	(dolist (mbox mboxes)
	  (if (> mbox.mails 0)
	    (nconc message (PF String "%0: %1 mail%2! (server %3, user %4)\n"
		mbox.nick mbox.mails (if (> mbox.mails 1) "s" "")
		mbox.host mbox.user
	))))
	(write message)
	(wait (system (list "xm" message)))
    ))
  )
)

;;=============================================================================
;;                    Read config
;;=============================================================================
(defun read-mboxes-file (mboxes mboxes-file check-file &aux 
    (fd (open mboxes-file :error ()))
  )
  (when fd
    (domatch (re fd)
      "^[ \t]*#" ()			;comments
      "^[ \t]*$" ()			;empty lines
      "^[ \t]*([^ \t]+)[ \t]+(IMAP|POP)[ \t]+([^ \t]+)[ \t]+([^ \t]+)[ \t]+([^ \t]+)" ; meaningful line
      (lappend mboxes (make-MBox 
	  :nick (re 1)
	  :type (re 2)
	  :host (re 3)
	  :user (re 4)
	  :pass (decrypt (re 5))
      ))
      ".*" 
      (fatal-error 1 "Syntax error in %0:\n    %1" mboxes-file (re 0))
  ))
  (when fd = (open check-file :error ())
    (domatch (re fd)
      "^[ \t]*([^ \t]+)[ \t]+([0-9]+)" 
      (catch :ok
	(dolist (mbox mboxes)
	  (when (= (re 1) mbox.nick) mbox.oldmails = (Int (re 2)) (throw :ok))
  ))))  
)      

(defun write-checkpoint (mboxes check-file &aux must-check? fd)
  (dolist (mbox mboxes)
    (if (/= mbox.mails mbox.oldmails) must-check? = t)
  )
  (when must-check?
    fd = (open check-file :direction :output :if-exists :supersede)
    (dolist (mbox mboxes)
      (PF fd "%0 %1\n" mbox.nick mbox.mails)
    )
    (close fd)
  )
)
  
;;=============================================================================
;;                    POP
;;=============================================================================
(defun checkmail-POP (mbox &aux fd rep ismail
    (re {regcomp "^[+]OK +([0-9]+)"})
  )
  (catch 'EOF				;ignore connection cut
    (if (not fd = (open (+ mbox.host ":110")
	  :type :tcp :direction :io :error ()))
      (throw 'EOF 
	(verbose? "Could not connect to %0 server %1" mbox.type mbox.host)
    ))
    rep = (read-line fd)
    (bad-rep? (throw 'EOF 
	(verbose? "Connection error to %0 server %1" mbox.type mbox.host)
    ))
    (cmd fd (+ "user " mbox.user))
    (bad-rep? (throw 'EOF))
    (cmd fd (+ "pass " mbox.pass))
    (bad-rep? (throw 'EOF))
    (cmd fd "list")
    (bad-rep? (throw 'EOF))
    (if (and (re rep) (> (Int (re 1)) 0))
      ismail = (Int (re 1))
    )
    (cmd fd "quit")
  )
  ismail
)

(defun cmd (fd s)
  (PF fd "%0\r\n" s) (flush fd)
  (if (/= s "quit")  rep = (pop-read-line fd))
)

(defun pop-read-line (fd &aux res)
  (if res =  (read-line fd ())
    (if (= 13 (getn res -1)) (subseq res 0 (- (length res) 1)) res) ;trim \r
    ()
))  
      
(defunq bad-rep? (&rest bad-rep-forms)
  (if (or (not rep) ({regcomp "^-ERR"} rep))
    (apply progn bad-rep-forms)
  )
)


;;=============================================================================
;;                    IMAP
;;=============================================================================
;; Returns () or the number of unseen mails

(defun checkmail-IMAP (mbox &aux fd rep rep1 re ismail)
  (catch 'EOF				;traps silently all connection cut
    (if (not fd = (open (+ mbox.host ":143") 
	  :type :tcp :direction :io :error ()))
      (throw 'EOF 
	(verbose? "Could not connect to %0 server %1" mbox.type mbox.host)
    ))
    rep = (read-line fd)
    (if (match "^[*] OK " rep) (progn
	(PF fd "A000 LOGIN %0 %1\n" mbox.user mbox.pass)
	(flush fd)
	rep = (read-line fd)
	(if  (match "^A000 OK LOGIN " rep) (progn
	    (PF fd "A001 STATUS INBOX (UNSEEN)\n")
	    (flush fd)
	    rep1 = (read-line fd)
	    (if (match ".*\nA001 OK STATUS " rep1) (progn
		(PF fd "A002 LOGOUT\n")
		(flush fd)
	      )
	      (if (not (match "^[*] STATUS INBOX [(]UNSEEN +([^)]*)[)]" rep1))
		(verbose? "IMAP status Error: %r0" rep1)
	      )
	    )
	  )
	  (verbose? "IMAP login Error: %r0" rep)
	)
      )
      (verbose? "IMAP connect Error: %r0" rep)
    )
    (close fd)
  )
  (when rep1
    re = (re-nocase "^[*] STATUS INBOX [(]UNSEEN +([^)]*)[)]")
    (if (re rep1)
      (with (num (Int (re 1)))
      (if (> num 0) ismail = num)
  )))
  ismail
)

;;=============================================================================
;;                    Encrypting
;;=============================================================================
;; Crypt / Uncrypt strings. clean quoted values, to get the sortest possible
;; string, but yet cut/pastable in shell if surrounded by '' (no ' or \ inside)
(defun encrypt (s &key quote)
  (if quote () (setq s (html:unquote-values s)))
  (map String minus1 (quote-names s quote-names:re+1))
)

(defun decrypt (s)
  (quote-names (html:unquote-values (map String add1 s)))
)
(defun add1 (c) (+ c 1))
(defun minus1 (c) (- c 1))
(defun same (s) s)

;; Returns string with non-printing chars quoted HTML style
;; We quote also ' and \ for ease of handling under shell, and %
;; And we quote spaces at start and end

(setq quote-names:re (regcomp "^[\x01-\x1f\x25\x27\x5c\x7f-\xff]"))
(setq quote-names:re+1 (regcomp "^[]\x01-\x20\x26\x28\x80-\xff]"))
(setq quote-names:space (regcomp "^ "))
(setq quote-names:endspace (regcomp " *$"))
(setq hexdigits "0123456789ABCDEF")

(defun quote-names (s &optional (re quote-names:re) &aux
    (res (copy ""))
    (pos 0)
    endpos
  )
  (quote-names:endspace s)
  endpos = quote-names:endspace.0.0			;end of non-space chars
  (while (and (< pos endpos) (quote-names:space s pos))
    (nconc res "%20") (incf pos)
  )
  (while (< pos endpos)
    (if (re s pos) (progn
	(put res -1 #\%)
	(put res -1 ((/ (pos s) 16) hexdigits))
	(put res -1 ((mod (pos s) 16) hexdigits))
      )
      (put res -1 (pos s))
    )
    (incf pos)
  )
  (dotimes (i (- (length s) endpos))
    (nconc res "%20")
  )
  res
)

(defun show-encrypted-args (args)
  (dolist (arg args)
    (PF "  %0 = %1\n" arg (encrypt arg))
  )
  (exit 0)
)

(main)

;;; EMACS MODES
;;; Local Variables: ***
;;; mode:lisp ***
;;; End: ***

