diff --git a/src/Makefile b/src/Makefile index f8447e7..34ee08a 100644 --- a/src/Makefile +++ b/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 -mailman.import.scm: $(MAILMAN-SOURCES) +mailman2.o: mailman2.import.scm +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) diff --git a/src/mailman.scm b/src/mailman.scm index 62acc3a..9d8a753 100644 --- a/src/mailman.scm +++ b/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) - (chicken pathname) - (chicken string) - (chicken sort) - (chicken format) - util-list - progress - util-bst-lset - util-io) + mailman2) - ;; Where does the mailman binaries reside - (define *mailman-bin* (make-parameter "/usr/lib/mailman/bin")) + (define *mailman-version* (make-parameter 2)) - ;; 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-cilset (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))))))) + (case (*mailman-version*) + ((2) (list-mailman2-lists)))) ) diff --git a/src/mailman2.scm b/src/mailman2.scm new file mode 100644 index 0000000..5857695 --- /dev/null +++ b/src/mailman2.scm @@ -0,0 +1,206 @@ +;; +;; mailman2.scm +;; +;; Mailman management interface +;; +;; ISC License +;; +;; Copyright 2023 Brmlab, z.s. +;; Dominik Pantůček +;; +;; 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-cilset (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))))))) + + )