Compare commits

..

5 commits

14 changed files with 73 additions and 63 deletions

View file

@ -1,6 +1,14 @@
ChangeLog ChangeLog
========= =========
1.19 - released 2025-04-16
--------------------------
* manpage updated
* added -n option for dry-runs
* removed mailman 2.x support
* added "councilml" start/stop support for member files
1.18 - released 2025-01-06 1.18 - released 2025-01-06
-------------------------- --------------------------

View file

@ -1,22 +0,0 @@
set terminal pngcairo size 1000,600
set title "Members stats"
set output 'members-base-stats-2023-11.png'
src='members-base-stats-2023-11.data'
set timefmt "%Y-%m"
set xdata time
set format x "%Y-%m"
set xlabel "Month"
set ylabel "Members"
set grid
set key out right
plot[1420066800:][0:] \
src u 1:3 w l lw 2 t 'active', \
src u 1:4 w l t 'suspended', \
src u 1:5 w l t 'students', \
src u 1:6 w l t 'destroyed'

View file

@ -187,8 +187,8 @@ PROGRESS-SOURCES=progress.scm util-time.import.scm
progress.o: progress.import.scm progress.o: progress.import.scm
progress.import.scm: $(PROGRESS-SOURCES) progress.import.scm: $(PROGRESS-SOURCES)
EXPORT-CARDS-SOURCES=export-cards.scm util-bst-ldict.import.scm \ EXPORT-CARDS-SOURCES=export-cards.scm util-bst-ldict.import.scm \
mbase.import.scm brmember.import.scm mbase.import.scm brmember.import.scm configuration.import.scm
export-cards.o: export-cards.import.scm export-cards.o: export-cards.import.scm
export-cards.import.scm: $(EXPORT-CARDS-SOURCES) export-cards.import.scm: $(EXPORT-CARDS-SOURCES)

View file

@ -61,7 +61,8 @@
grantstart grantstop grantstart grantstop
joined destroyed joined destroyed
feestart feestop feestart feestop
phone)) phone
councilmlstart councilmlstop))
(define ignored-keys '(mail2)) (define ignored-keys '(mail2))
(define known-keys (append mandatory-keys optional-keys)) (define known-keys (append mandatory-keys optional-keys))
@ -88,6 +89,9 @@
(feestart fee start) (feestart fee start)
(feestop fee stop) (feestop fee stop)
(councilmlstart councilml start)
(councilmlstop councilml stop)
)) ))
(define start-stop-markers (map car start-stop-markers-lookup)) (define start-stop-markers (map car start-stop-markers-lookup))
@ -114,7 +118,7 @@
(info (info
,(lambda (mr output key value) ,(lambda (mr output key value)
(case key (case key
((student suspend member revision chair council grant fee) ((student suspend member revision chair council grant fee councilml)
(let* ((res (period-markers->cal-periods value)) (let* ((res (period-markers->cal-periods value))
(ok? (car res)) (ok? (car res))
(periods0 (cadr res)) (periods0 (cadr res))

View file

@ -65,6 +65,7 @@
brmember-chair? brmember-chair?
brmember-council? brmember-council?
brmember-councilml?
brmember-revision? brmember-revision?
brmember-grant? brmember-grant?
@ -394,6 +395,7 @@
;; Predicates for all organizational bodies recognized ;; Predicates for all organizational bodies recognized
(define brmember-chair? (brmember-body? 'chair)) (define brmember-chair? (brmember-body? 'chair))
(define brmember-council? (brmember-body? 'council)) (define brmember-council? (brmember-body? 'council))
(define brmember-councilml? (brmember-body? 'councilml))
(define brmember-revision? (brmember-body? 'revision)) (define brmember-revision? (brmember-body? 'revision))
(define brmember-grant? (brmember-body? 'grant)) (define brmember-grant? (brmember-body? 'grant))

View file

@ -43,6 +43,7 @@
*mailman3-sql* *mailman3-sql*
*mailman3-sql-path* *mailman3-sql-path*
*notifications-cc* *notifications-cc*
*dummy-run*
load-configuration! load-configuration!
) )
@ -100,7 +101,7 @@
;; Which version of mailman to use ;; Which version of mailman to use
(define *mailman-version* (make-parameter #f)) (define *mailman-version* (make-parameter #f))
(define =mailman-version= 2) (define =mailman-version= 3)
;; What is the mailman 3 command ;; What is the mailman 3 command
(define *mailman3-bin* (make-parameter #f)) (define *mailman3-bin* (make-parameter #f))
@ -111,7 +112,7 @@
;; A string is the default, gets converted to boolean at the end of ;; A string is the default, gets converted to boolean at the end of
;; loading configuration ;; loading configuration
(define *mailman3-sql* (make-parameter #f)) (define *mailman3-sql* (make-parameter #f))
(define =mailman3-sql= "0") (define =mailman3-sql= "1")
;; The path to SQLite3 DB file ;; The path to SQLite3 DB file
(define *mailman3-sql-path* (make-parameter #f)) (define *mailman3-sql-path* (make-parameter #f))
@ -121,6 +122,9 @@
(define *notifications-cc* (make-parameter #f)) (define *notifications-cc* (make-parameter #f))
(define =notifications-cc= "rada@brmlab.cz") (define =notifications-cc= "rada@brmlab.cz")
;; If #t, do not do anything
(define *dummy-run* (make-parameter #f))
(define (load-single-configuration! fname) (define (load-single-configuration! fname)
(when (file-exists? fname) (when (file-exists? fname)
(let loop ((lines (read-lines (open-input-file fname)))) (let loop ((lines (read-lines (open-input-file fname))))

View file

@ -38,7 +38,8 @@
(chicken irregex) (chicken irregex)
util-bst-ldict util-bst-ldict
mbase mbase
brmember) brmember
configuration)
;; Prints single card type records. ;; Prints single card type records.
(define (cards-print/type mb type) (define (cards-print/type mb type)
@ -84,7 +85,8 @@
;; Exports cards and desfires to the files specified. ;; Exports cards and desfires to the files specified.
(define (cards-export mb cardsfn desfirefn) (define (cards-export mb cardsfn desfirefn)
(cards-export/type mb 'card cardsfn) (when (not (*dummy-run*))
(cards-export/type mb 'desfire desfirefn)) (cards-export/type mb 'card cardsfn)
(cards-export/type mb 'desfire desfirefn)))
) )

View file

@ -191,10 +191,11 @@
;; Generates all members in given directory ;; Generates all members in given directory
(define (gen-html-members mb dir) (define (gen-html-members mb dir)
(ensure-directory dir) (when (not (*dummy-run*))
(with-mbase-progress% (ensure-directory dir)
mb dir mr (with-mbase-progress%
(gen-html-member mr dir)) mb dir mr
(clean-members-files mb dir)) (gen-html-member mr dir))
(clean-members-files mb dir)))
) )

View file

@ -116,6 +116,8 @@
(-mailman3-sql-path (path) "Set mailman3 direct SQL access path" (-mailman3-sql-path (path) "Set mailman3 direct SQL access path"
(*mailman3-sql* "1") (*mailman3-sql* "1")
(*mailman3-sql-path* path)) (*mailman3-sql-path* path))
(-n () "Do not do anything"
(*dummy-run* #t))
"" ""
"Email options:" "Email options:"
(-from (email) "Sender email address" (-from (email) "Sender email address"

View file

@ -73,6 +73,7 @@
(define (rada-ml-pred? mr) (define (rada-ml-pred? mr)
(or (brmember-council? mr) (or (brmember-council? mr)
(brmember-chair? mr) (brmember-chair? mr)
(brmember-revision? mr))) (brmember-revision? mr)
(brmember-councilml? mr)))
) )

View file

@ -37,7 +37,8 @@
(chicken base) (chicken base)
(chicken format) (chicken format)
sqlite3 sqlite3
configuration) configuration
(chicken condition))
;; Thread-local parameter to re-use SQLite3 DB handle for subsequent queries ;; Thread-local parameter to re-use SQLite3 DB handle for subsequent queries
(define *cached-mailman3-db* (make-parameter #f)) (define *cached-mailman3-db* (make-parameter #f))
@ -55,10 +56,15 @@
;; Returns the list of mailman3 mailinglists by querying te ;; Returns the list of mailman3 mailinglists by querying te
;; underlying SQLite3 DB directly ;; underlying SQLite3 DB directly
(define (list-mailman3-sql-lists) (define (list-mailman3-sql-lists)
(let-values (((stmt _) (handle-exceptions
(prepare (mailman3-db) ex
"SELECT list_name FROM mailinglist"))) '()
(map-row identity stmt))) (let ((result
(let-values (((stmt _)
(prepare (mailman3-db)
"SELECT list_name FROM mailinglist")))
(map-row identity stmt))))
result)))
;; Returns a list of email addresses subscribed to given mailinglist ;; Returns a list of email addresses subscribed to given mailinglist
(define (list-mailman3-sql-list-members lst) (define (list-mailman3-sql-list-members lst)

View file

@ -94,27 +94,29 @@
;; Adds given email ;; Adds given email
(define (add-email-to-mailman3-list lst email) (define (add-email-to-mailman3-list lst email)
(print "Add " email " to " lst ".") (print "Add " email " to " lst "." (if (*dummy-run*) " [no-op]" ""))
(let ((result (when (not (*dummy-run*))
(mailman3-send/recv (let ((result
(list "addmembers" "-" (format "~A@brmlab.cz" lst)) (mailman3-send/recv
email))) (list "addmembers" "-" (format "~A@brmlab.cz" lst))
(let loop ((lines result)) email)))
(when (not (null? lines)) (let loop ((lines result))
(print " | " (car lines)) (when (not (null? lines))
(loop (cdr lines)))))) (print " | " (car lines))
(loop (cdr lines)))))))
;; Removes given email from given listname ;; Removes given email from given listname
(define (remove-email-from-mailman3-list lst email) (define (remove-email-from-mailman3-list lst email)
(print "Remove " email " from " lst ".") (print "Remove " email " from " lst "." (if (*dummy-run*) " [no-op]" ""))
(let ((result (when (not (*dummy-run*))
(get-mailman3-output-lines (let ((result
"delmembers" (get-mailman3-output-lines
"-l" (format "~A@brmlab.cz" lst) "delmembers"
"-m" email))) "-l" (format "~A@brmlab.cz" lst)
(let loop ((lines result)) "-m" email)))
(when (not (null? lines)) (let loop ((lines result))
(print " | " (car lines)) (when (not (null? lines))
(loop (cdr lines)))))) (print " | " (car lines))
(loop (cdr lines)))))))
) )

View file

@ -114,7 +114,7 @@
(caddr c))) (caddr c)))
(brmember-credit mr)) (brmember-credit mr))
#:border '(((#:right light) ... none) ...)))) #:border '(((#:right light) ... none) ...))))
((suspend student member council chair revision grant) ((suspend student member council chair revision grant councilml)
(let* ((pdata (cons (list "Since" "Until") (let* ((pdata (cons (list "Since" "Until")
(map (map
(lambda (p) (lambda (p)

View file

@ -39,7 +39,7 @@
(chicken format)) (chicken format))
;; Short banner ;; Short banner
(define banner-line "HackerBase 1.19-dev (c) 2023-2025 Brmlab, z.s.") (define banner-line "HackerBase 1.19 (c) 2023-2025 Brmlab, z.s.")
;; Banner source with numbers for ANSI CSI SGR ;; Banner source with numbers for ANSI CSI SGR
(define banner-source " (define banner-source "