brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Finish splitting mailman 2.x driver.

Browse source
This commit is contained in:
Dominik Pantůček 2023-09-15 09:03:48 +02:00
parent bee78b9411
commit c2be1d518f
2 changed files with 50 additions and 45 deletions
Download patch file Download diff file Expand all files Collapse all files

47
src/mailman.scm
View file

@ -34,13 +34,21 @@
find-mailman-list
email-in-mailman-list?
mailman-ensure-member
mailman-ensure-not-member
mailman-compare-members
mailman-sync-members
)
(import scheme
(chicken base)
(chicken module)
mailman2
mailman-common)
mailman-common
util-bst-lset)
(define *mailman-version* (make-parameter 2))
@ -69,4 +77,41 @@
(define (find-mailman-list lsts name)
(assoc name lsts))
(define-mailman-proc add-email-to-mailman-list add-email-to-mailman2-list)
(define-mailman-proc remove-email-from-mailman-list remove-email-from-mailman2-list)
;; 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)))))))
)

48
src/mailman2.scm
View file

@ -35,15 +35,8 @@
load-mailman2-list
load-mailman2-lists
add-email-to-mailman-list
remove-email-from-mailman-list
mailman-ensure-member
mailman-ensure-not-member
mailman-compare-members
mailman-sync-members
add-email-to-mailman2-list
remove-email-from-mailman2-list
)
(import scheme
@ -125,7 +118,7 @@
(add1 idx))))))))
;; Adds given email to given listname
(define (add-email-to-mailman-list listname email)
(define (add-email-to-mailman2-list listname email)
(print "Add " email " to " listname ".")
(let ((result
(mailman-send/recv
@ -138,7 +131,7 @@
(loop (cdr lines))))))
;; Removes given email from given listname
(define (remove-email-from-mailman-list listname email)
(define (remove-email-from-mailman2-list listname email)
(print "Remove " email " from " listname ".")
(let ((result
(get-mailman-output-lines
@ -149,37 +142,4 @@
(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)))))))
)