;;
;; mailman.scm
;;
;; Mailman management interface
;;
;; ISC License
;;
;; Copyright 2023 Brmlab, z.s.
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
;;
;; Permission to use, copy, modify, and/or distribute this software
;; for any purpose with or without fee is hereby granted, provided
;; that the above copyright notice and this permission notice appear
;; in all copies.
;; 
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 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.
;;

(declare (unit mailman))

(module
 mailman
 (
  *mailman-bin*

  list-mailman-lists
  list-mailman-list-members
  load-mailman-list
  load-mailman-lists
  
  find-mailman-list
  
  mailman-list-name
  mailman-list-members
  
  email-in-mailman-list?
  
  add-email-to-mailman-list
  remove-email-from-mailman-list
  
  mailman-ensure-member
  mailman-ensure-not-member
  
  mailman-compare-members
  
  mailman-sync-members
  )

 (import scheme
	 (chicken base)
	 (chicken pathname)
	 (chicken string)
	 (chicken sort)
	 (chicken format)
	 util-list
	 progress
	 util-set-list
	 util-io)

 ;; Where does the mailman binaries reside
 (define *mailman-bin* (make-parameter "/usr/lib/mailman/bin"))

 ;; Returns full path to given mailman binary
 (define (mailman-bin bin)
   (make-pathname (*mailman-bin*) bin))

 ;; Mailman-specific process output lines capture
 (define (get-mailman-output-lines bin . args)
   (apply
    get-process-output-lines
    (mailman-bin bin)
    args))

 ;; Sends all lines to the process
 (define (mailman-send/recv bin args . lines)
   (apply
    process-send/recv
    (mailman-bin bin)
    args
    lines))
    
 ;; Returns the list of available lists
 (define (list-mailman-lists)
   (get-mailman-output-lines "list_lists" "-b"))

 ;; Returns the list of members of given list
 (define (list-mailman-list-members lst)
   (sort
    (get-mailman-output-lines "list_members" lst)
    string-ci<?))

 ;; Creates a representation of basic mailman list information
 (define (make-mailman-list name members)
   (cons name
	 members))

 ;; Simple accessors
 (define mailman-list-name car)
 (define mailman-list-members cdr)

 ;; Loads a single mailman list as mailman structure, if
 ;; unsuccessfull, returns only a list with ML name and no member
 ;; emails.
 (define (load-mailman-list name)
   (make-mailman-list name
		      (list-mailman-list-members name)))

 ;; Loads all lists and members
 (define (load-mailman-lists)
   (with-progress%
    #t "Mailman"
    (progress%-advance 0)
    (let* ((lists (list-mailman-lists))
	   (total (length lists)))
      (let loop ((lsts lists)
		 (res '())
		 (idx 0))
	(if (null? lsts)
	    (let ()
	      (progress%-advance 1)
	      ;; Will be prepended, therefore reversing result is a
	      ;; bad idea!
	      res)
	    (let ((mln (car lsts)))
	      (progress%-advance (/ idx total))
	      (loop (cdr lsts)
		    (cons (load-mailman-list mln) res)
		    (add1 idx))))))))

 ;; List of lists, returns the whole list record (including name)
 (define (find-mailman-list lsts name)
   (assoc name lsts))

 ;; Returns #t if the email is in given ml
 (define (email-in-mailman-list? ml email)
   (if (lset-member? (list->lset (mailman-list-members ml) string-ci=?)
		     email)
       #t
       #f))

 ;; Adds given email to given listname
 (define (add-email-to-mailman-list listname email)
   (print "Add " email " to " listname ".")
   (let ((result
	  (mailman-send/recv
	   "add_members"
	   (list "-r" "-" listname)
	   email)))
     (let loop ((lines result))
       (when (not (null? lines))
	 (print " | " (car lines))
	 (loop (cdr lines))))))

 ;; Removes given email from given listname
 (define (remove-email-from-mailman-list listname email)
   (print "Remove " email " from " listname ".")
   (let ((result
	  (get-mailman-output-lines
	   "remove_members" (car listname)
	   (sprintf "\"~A\"" email))))
     (let loop ((lines result))
       (when (not (null? lines))
	 (print " | " (car lines))
	 (loop (cdr lines))))))

 ;; Ensures given email is in given ML
 (define (mailman-ensure-member ml email)
   (when (not (email-in-mailman-list? ml email))
     (add-email-to-mailman-list (mailman-list-name ml) email)))

 ;; Makes sure given member is removed
 (define (mailman-ensure-not-member ml email)
   (when (email-in-mailman-list? ml email)
     (remove-email-from-mailman-list (mailman-list-name ml) email)))

 ;; Returns two values - missing members and surplus list members
 (define (mailman-compare-members ml emails)
   (let* ((mlemails (list->lset (mailman-list-members ml)))
	  (emails (list->lset emails))
	  (surplus (lset-subtract mlemails emails))
	  (missing (lset-subtract emails mlemails)))
     (values (lset->list missing)
	     (lset->list surplus))))

 ;; Ensures given ML subscribers are exactly what is in emails list
 (define (mailman-sync-members ml emails)
   (let-values (((missing surplus)
		 (mailman-compare-members ml emails)))
     (let ((listname (mailman-list-name ml)))
       (let loop ((emails missing))
	 (when (not (null? emails))
	   (add-email-to-mailman-list listname (car emails))
	   (loop (cdr emails))))
       (let loop ((emails surplus))
	 (when (not (null? emails))
	   (remove-email-from-mailman-list listname (car emails))
	   (loop (cdr loop)))))))

 )