Start work on versioned mailman.
This commit is contained in:
parent
8545c2512e
commit
697b2cb1a8
3 changed files with 219 additions and 171 deletions
13
src/Makefile
13
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)
|
||||
|
|
|
|||
171
src/mailman.scm
171
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-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)))))))
|
||||
(case (*mailman-version*)
|
||||
((2) (list-mailman2-lists))))
|
||||
|
||||
)
|
||||
|
|
|
|||
206
src/mailman2.scm
Normal file
206
src/mailman2.scm
Normal file
|
|
@ -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)))))))
|
||||
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue