;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
;;         Copyright IBM Corporation 1988,1991 - All Rights Reserved      ;;
;;        For full copyright information see:'andrew/config/COPYRITE'     ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;
;;;;;;
;;;;;; LIBRARY OF FLAMES FUNCTIONS FOR PROCESSING MAIL/BBOARDS
;;;;;;
;;;;;;  (authors: ghoti+, bobg+ nsb+) (4/27/88)
;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; $Disclaimer: 
;;Permission to use, copy, modify, and distribute this software and its 
;;documentation for any purpose is hereby granted without fee, 
;;provided that the above copyright notice appear in all copies and that 
;;both that copyright notice, this permission notice, and the following 
;;disclaimer appear in supporting documentation, and that the names of 
;;IBM, Carnegie Mellon University, and other copyright holders, not be 
;;used in advertising or publicity pertaining to distribution of the software 
;;without specific, written prior permission.
;;
;;IBM, CARNEGIE MELLON UNIVERSITY, AND THE OTHER COPYRIGHT HOLDERS 
;;DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING 
;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.  IN NO EVENT 
;;SHALL IBM, CARNEGIE MELLON UNIVERSITY, OR ANY OTHER COPYRIGHT HOLDER 
;;BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY 
;;DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, 
;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 
;;ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 
;;OF THIS SOFTWARE.
;; $

(load "elilib")

; flist is a list of strings, each of which is the name of a
; msg directory.  Adds the msg to each dir in flist, stopping
; (possibly after some appends) as soon as an error occurs.
; Returns T on success, NIL on any error.
(defun add-to-folders (msg flist)
  (cond ((null flist) T)
        ((appendmsgtodir msg (car flist))
         (add-to-folders msg (cdr flist)))
        (T NIL)))

;;;;; (>> returns T/NIL <<)
(defun create-folders (msg creats)
  ;;;;; LIST creats
  (cond
   ((NULL creats) T)
   ((createfolderfrommessage (car creats) msg)
    (create-folders msg (cdr creats)))
   (T NIL)))


;;;;; (>> returns T/NIL <<)
(defun ensure-folders-exist (msg flist)
  ;;;;; MESSAGE msg
  ;;;;; LIST flist
  (cond
   ((null flist) T)
   ((findfolder (car flist) "w")
    (ensure-folders-exist msg (cdr flist)))
   ((createfolderfrommessage (car flist) msg)
    (ensure-folders-exist msg (cdr flist)))
   (T NIL)))

(defun post-by-keyword (msg default biglist)
  (post-to-list msg
                (map-heads-keys-folders msg biglist)
                default NIL NIL NIL T NIL))

(defun map-heads-keys-folders (msg biglist)
  (cond ((null biglist) NIL)
        (T (append (let* ((ca (car biglist))
                          (cda (cdr ca)))
                     (mhkf msg
                           (car ca)
                           (car cda)
                           (car (cdr cda))
                           NIL))
                   (map-heads-keys-folders msg
                                           (cdr biglist))))))


;;;;; (>> returns LIST <<)
(defun mhkf (msg hlist klist flist ans)
  ;;;;; MESSAGE msg
  ;;;;; LIST hlist 
  ;;;;; LIST klist 
  ;;;;; LIST flist 
  ;;;;; LIST ans 
  (cond ((null hlist) ans)
        ((any-pat-in-any-str
          (map-strlist-to-lowercase klist)
          (map-strlist-to-lowercase
		(only-strings
			(apply 'append
			       (mapcar '(lambda (x)
						(getheadercontents msg x))
				       hlist)))))
         (append ans flist))
        (T ans)))

;;;;; (>> returns LIST <<)
(defun validate-folder-list (flist)
  ;;;;; LIST flist
  (validate-folder-list-aux flist NIL NIL NIL))


;;;;; (>> returns LIST <<)
(defun validate-folder-list-aux (flist adds errs creats)
  ;;;;; LIST flist
  ;;;;; LIST adds
  ;;;;; LIST errs
  ;;;;; LIST creats
  (cond
   ((null flist)
    (list (remove-duplicates adds)
          (remove-duplicates errs)
          (remove-duplicates creats)))
   (T (let*
       ((foo (findfolder (car flist) "w"))
        (bar (findfolder (car flist) "c")))
        (cond ((null bar)
               (validate-folder-list-aux (cdr flist)
                                         adds
                                         (append (list (car flist)) errs)
                                         creats))
              ((null foo)
               (validate-folder-list-aux (cdr flist)
                                         adds
                                         errs
                                         (append (list bar) creats)))
              (T (validate-folder-list-aux (cdr flist)
                                           (append (list foo) adds)
                                           errs
                                           creats)))))))

(defun multi-getheadercontents (msg hnamelist)
  (do ((hdrs hnamelist (cdr hdrs))
       (result nil (append result
                           (getheadercontents msg (car hdrs)))))
      ((null hdrs) result)))

(defun process-mapped-mailbox (msg pathroot prefix
                                   headernamelist defaultfolder
                                   rejto rejcc rejstr)
  (process-mapped-restricted-mailbox msg pathroot prefix
                                     headernamelist defaultfolder
                                     rejto rejcc rejstr NIL))

(defun process-mapped-restricted-mailbox (msg pathroot
                                              prefix headernamelist
                                              defaultfolder rejto
                                              rejcc rejstr restrictions)
  (post-to-list msg 
                (mapcar '(lambda (x) (strcat pathroot x))
                        (extract-liberally prefix
                                           (multi-getheadercontents
                                            msg
                                            headernamelist)))
                defaultfolder
                rejto
                rejcc
                rejstr
                T
                restrictions))


(defun standard-mapping (msg treeroot defaultfolder rejto rejcc rejstr)
  (process-mapped-restricted-mailbox
   msg
   (strcat (findfolder treeroot "w") "/")
   (strcat (getparameter "uid") ; the first thing in this strcat used to be "\\{"
           (let ((suffix (getparameter "uidsuffix")))
             (cond ((eq suffix "+") "\\+")
                   (T suffix))))
   '("to" "cc" "resent-to" "resent-cc" "received")
   (findfolder defaultfolder "w")
   rejto
   rejcc
   rejstr
   NIL))

; This routine applies the restrictions	to the unvalidated folder list.
;   It rejects the message and returns T if the	restrictions apply.
;   If no restrictions apply, it returns NIL.
;   A restriction list is a list of lists, each	of which is a list of patterns,
;   a list of authorized users, and a rejection text.  For example,
;   ((("^official" "^university") ("nsb" "jr")
;      "You are not authorized to post on this.  Send mail to nsb for more details.")
;    (("^org") NIL "You don't post to org through this mailbox"))

(defun apply-restrictions (msg flist rejto rejcc restricts)
  (cond
   ((null restricts) NIL) ; no restrictions apply, obviously
   ((apply-single-restriction msg flist	rejto rejcc (car restricts)) T)
   (T (apply-restrictions msg flist rejto rejcc (cdr restricts)))))

(defun apply-single-restriction (msg flist rejto rejcc restriction)
  (cond
   ((and (any-pat-in-any-str (car restriction) flist)
         (not (a-pat-in-any-str (getauthsender msg) ; this should be (strcat "\\{" (getauthsender msg))
                                (car (cdr restriction)))))
    (reject-from-message
     msg rejto rejcc
     (car (cdr (cdr restriction)))
     NIL))
   (T NIL)))

;;;;; (>> returns T/NIL <<)
(defun post-to-list (msg flist default rejto rejcc
                         rejstr allowcreats restricts)
  (cond ((apply-restrictions msg flist rejto rejcc restricts) T)
        (T (let* ((vlist
                   (validate-folder-list flist))
                  (def-folder
                   (findfolder default "w"))
                  (adds (car vlist))
                  (errs (car (cdr vlist)))
                  (creats (car (cdr (cdr vlist))))
                  (result ""))
             (cond ((and (null  flist)
                         (null def-folder))
                    NIL)
                   ((null flist)
                    (appendmsgtodir msg def-folder))
                   ((and errs (null rejstr))
                    NIL)
                   (errs
                    (reject-from-message msg rejto rejcc rejstr errs))
                   ((null creats)
                    (add-to-folders msg adds))
                   ((null allowcreats)
                    (reject-from-message msg rejto rejcc
                                         (strcat rejstr
                                                 " (creation not permitted) ")
                                         creats))
                   ((ensure-folders-exist msg creats)
                    (add-to-folders msg (append creats adds)))
                   (T NIL))))))

(defun reject-from-message (msg rejto rejcc rejstr flist)
  (let* ((x (replyaddr msg "sender"))
         (repaddr (cond (rejto rejto)
                        (x x)
                        (T "postman+"))))
    (rejectmessage msg repaddr
                   rejcc
                   (strcat
                    (cond (rejstr rejstr)
                          (T
                           "Message rejected with no reason specified: "))
                    NEWLINE-TAB
                    (cond (flist (list-to-str flist NEWLINE-TAB))
                          (T ""))))))

(defun extract-liberally (pattern strs)
  (remove-duplicates
   (do ((refs strs (cdr refs))
        (result nil (append result
                            (extract-liberally-onestr
                             pattern
                             (car refs)))))
       ((null refs) result))))

(defun last-list-elt (l)
  (cond ((null l) nil)
	((null (cdr l)) (car l))
	(t (last-list-elt (cdr l)))))

(defun extract-liberally-onestr (pattern str)
  (let* ((decomp (re-strdecompose+ (strcat pattern
                                           &END-OF-EXTRACT-PATTERN)
                                   str)))
    (cond (decomp (cons (last-list-elt (car (cdr decomp)))
                        (extract-liberally-onestr
                         pattern
                         (car (cdr (cdr decomp))))))
          (T NIL))))

; This pattern gets concatenated onto the end of the
; pattern passed to extract-liberally.  It matches
; one or more non-terminator characters within a subexpression
; (so we can get at the matched portion with re-strdecompose+)
(setq &END-OF-EXTRACT-PATTERN "([^]\n ,@:)}>%;!\"]+)")

(setq NEWLINE-TAB "\n\t")

(defun only-strings (lis)
  (cond ((null lis) nil)
        ((stringp (car lis))
         (cons (car lis) (only-strings (cdr lis))))
        (T (only-strings (cdr lis)))))

(defun map-strlist-to-lowercase (strlist)
  (mapcar '(lambda (x) (lcstring x))
          strlist))