Start work on versioned mailman.

src/Makefile

@@ -56,7 +56,7 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o		\
 	 template-list-expander.o box-drawing.o util-list.o		\
 	 export-web-static.o util-dir.o dokuwiki.o racket-kwargs.o	\
 	 duck.o util-bst.o util-bst-bdict.o util-bst-ldict.o		\
-	 util-bst-lset.o
+	 util-bst-lset.o mailman2.o
 
 GENDOC-SOURCES=gendoc.scm duck-extract.import.scm			\
 	util-time.import.scm util-csv.import.scm util-git.import.scm	\
@@ -258,12 +258,12 @@ ENVIRONMENT-SOURCES=environment.scm ansi.import.scm
 environment.o: environment.import.scm
 environment.import.scm: $(ENVIRONMENT-SOURCES)
 
-MAILMAN-SOURCES=mailman.scm progress.import.scm		\
+MAILMAN2-SOURCES=mailman2.scm progress.import.scm		\
 	util-bst-lset.import.scm util-io.import.scm	\
 	util-list.import.scm
 
-mailman.o: mailman.import.scm
+mailman2.o: mailman2.import.scm
-mailman.import.scm: $(MAILMAN-SOURCES)
+mailman2.import.scm: $(MAILMAN2-SOURCES)
 
 UTIL-TIME-SOURCES=util-time.scm duck.import.scm
 
@@ -528,3 +528,8 @@ UTIL-BST-LSET-SOURCES=util-bst-lset.scm util-bst.import.scm	\
 
 util-bst-lset.o: util-bst-lset.import.scm
 util-bst-lset.import.scm: $(UTIL-BST-LSET-SOURCES)
+
+MAILMAN-SOURCES=mailman.scm mailman2.import.scm
+
+mailman.o: mailman.import.scm
+mailman.import.scm: $(MAILMAN-SOURCE)

src/mailman.scm

@@ -28,179 +28,16 @@
 (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)
+	 mailman2)
-	 (chicken pathname)
-	 (chicken string)
-	 (chicken sort)
-	 (chicken format)
-	 util-list
-	 progress
-	 util-bst-lset
-	 util-io)
 
- ;; Where does the mailman binaries reside
+ (define *mailman-version* (make-parameter 2))
- (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"))
+   (case (*mailman-version*)
-
+     ((2) (list-mailman2-lists))))
- ;; 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" 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 emails)))))))
 
  )

src/mailman2.scm

@@ -0,0 +1,206 @@
+;;
+;; mailman2.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 mailman2))
+
+(module
+ mailman2
+ (
+  *mailman2-bin*
+
+  list-mailman2-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-bst-lset
+	 util-io)
+
+ ;; Where does the mailman binaries reside
+ (define *mailman2-bin* (make-parameter "/usr/lib/mailman/bin"))
+
+ ;; Returns full path to given mailman binary
+ (define (mailman-bin bin)
+   (make-pathname (*mailman2-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-mailman2-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-mailman2-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" 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 emails)))))))
+
+ )