154 lines
4.2 KiB
Scheme
154 lines
4.2 KiB
Scheme
;;
|
|
;; 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
|
|
mailman-sync-members
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken pathname)
|
|
(chicken string)
|
|
(chicken sort)
|
|
(chicken format)
|
|
utils
|
|
progress)
|
|
|
|
;; 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)
|
|
(get-process-output-lines
|
|
(string-intersperse
|
|
(cons (mailman-bin bin)
|
|
args)
|
|
" ")))
|
|
|
|
;; 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 (member email (mailman-list-members ml))
|
|
#t
|
|
#f))
|
|
|
|
;; Adds given email to given listname
|
|
(define (add-email-to-mailman-list listname email)
|
|
(let ((result
|
|
(get-mailman-output-lines
|
|
"add_members" "-r" "-" listname
|
|
(sprintf "<<<\"~A\"" email))))
|
|
(print result)))
|
|
|
|
;; Removes given email from given listname
|
|
(define (remove-email-from-mailman-list listname email)
|
|
(let ((result
|
|
(get-mailman-output-lines
|
|
"remove_members" (car listname)
|
|
(sprintf "\"~A\"" email))))
|
|
(print result)))
|
|
|
|
;; 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)))
|
|
|
|
;; Ensures given ML subscribers are exactly what is in emails list
|
|
(define (mailman-sync-members ml emails)
|
|
#f)
|
|
|
|
)
|