diff --git a/README.md b/README.md index 699ae82..9fcb37f 100644 --- a/README.md +++ b/README.md @@ -46,6 +46,7 @@ Features * computing member balance * generating static web output for member pages in dokuwiki * exporting brmdoor cards lists +* synchronization of mailinglist subscriptions with member files Requirements ------------ @@ -59,6 +60,7 @@ Build requirements: * make (tested with GNU make) * Chicken eggs (chicken-install) * sqlite3 + * srfi-1 Runtime requirements: @@ -70,6 +72,10 @@ Runtime requirements: Building -------- +All the eggs used are installed in the source tree using: + + sh install-eggs.sh + Building static binary: make static diff --git a/doc/d-utils.md b/doc/d-utils.md index fdf2ad2..08b8a43 100644 --- a/doc/d-utils.md +++ b/doc/d-utils.md @@ -388,6 +388,16 @@ quoted-printable sequences. Returns the ```str``` with all characters converted to upper case using ```char-upcase```. Does not work with UTF-8. +### string-capitalize [procedure] + + (string-capitalize str) + +* ```str``` - arbitrary string + +Returns the ```str``` with the first character converted to upper case +using ```char-upcase``` and the remainder converted to lower case +using ```char-downcase```. Does not work with UTF-8. + ## util-mail [module] (import util-mail) diff --git a/src/Makefile b/src/Makefile index 0615ce5..c71d1ff 100644 --- a/src/Makefile +++ b/src/Makefile @@ -59,7 +59,7 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \ template-list-expander.o box-drawing.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 mailman2.o \ - mailman-common.o mailman3.o mailman3-sql.o + mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \ util-time.import.scm util-csv.import.scm util-git.import.scm \ @@ -68,14 +68,15 @@ GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \ util-format.import.scm util-tag.import.scm \ util-string.import.scm util-bst.import.scm \ util-bst-bdict.import.scm util-bst-ldict.import.scm \ - util-dir.import.scm util-utf8.import.scm + util-dir.import.scm util-utf8.import.scm util-mail.import.scm \ + util-bst-lset.import.scm GENDOC-OBJS=gendoc.o duck-extract.o util-time.o util-csv.o util-io.o \ progress.o testing.o util-proc.o util-git.o util-io.o \ util-stdout.o util-parser.o util-proc.o util-format.o \ racket-kwargs.o util-bst-ldict.o util-tag.o duck.o \ util-string.o util-bst.o util-bst-bdict.o util-bst-ldict.o \ - util-dir.o util-utf8.o + util-dir.o util-utf8.o util-bst-lset.o util-mail.o .PHONY: imports imports: $(HACKERBASE-DEPS) @@ -205,7 +206,8 @@ MEMBERS-PRINT-SOURCES=members-print.scm util-bst-ldict.import.scm \ bank-account.import.scm members-fees.import.scm \ members-payments.import.scm brmember-format.import.scm \ specification.import.scm cal-format.import.scm \ - util-git.import.scm racket-kwargs.import.scm + util-git.import.scm racket-kwargs.import.scm \ + tiocgwinsz.import.scm members-print.o: members-print.import.scm members-print.import.scm: $(MEMBERS-PRINT-SOURCES) @@ -543,3 +545,8 @@ MAILMAN3-SQL-SOURCES=mailman3-sql.scm configuration.import.scm mailman3-sql.o: mailman3-sql.import.scm mailman3-sql.import.scm: $(MAILMAN3-SQL-SOURCES) + +TIOCGWINSZ-SOURCES=tiocgwinsz.scm duck.import.scm + +tiocgwinsz.o: tiocgwinsz.import.scm +tiocgwinsz.import.scm: $(TIOCGWINSZ-SOURCES) diff --git a/src/configuration.scm b/src/configuration.scm index 7b9b7af..3518efc 100644 --- a/src/configuration.scm +++ b/src/configuration.scm @@ -1,5 +1,5 @@ ;; -;; configuraiton.scm +;; configuration.scm ;; ;; Configuration parameters used by various modules. ;; diff --git a/src/gendoc.scm b/src/gendoc.scm index e5afddc..2ffd3ac 100644 --- a/src/gendoc.scm +++ b/src/gendoc.scm @@ -1,3 +1,27 @@ +;; +;; gendoc.scm +;; +;; Generate documentation for all documented modules dynamically. +;; +;; 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. +;; (import duck-extract) diff --git a/src/hackerbase.scm b/src/hackerbase.scm index f458a18..24552d1 100644 --- a/src/hackerbase.scm +++ b/src/hackerbase.scm @@ -62,6 +62,7 @@ (define -web-dir- (make-parameter #f)) (define -normal-month- (make-parameter #t)) (define -show-destroyed- (make-parameter #f)) +(define -show-only-active- (make-parameter #f)) (define -notify-months- (make-parameter 1)) (define -send-emails- (make-parameter #f)) @@ -137,6 +138,8 @@ "Misc options:" (-destroyed () "Show destroyed members in -fees" (-show-destroyed- #t)) + (-only-active () "Show only active members in -fees" + (-show-only-active- #t)) "" "Base Actions:" (-info () "Print information" @@ -372,7 +375,7 @@ (newline) (if mr (print-member-balances-table mr) - (print-members-fees-table MB (-show-destroyed-)))) + (print-members-fees-table MB (-show-destroyed-) (-show-only-active-)))) ((repl) (repl)) ((genweb) @@ -406,7 +409,7 @@ (if (null? nmembers) (print "Everyone paid on time.") (let () - (print "Notify" (-notify-months-)) + (stdout-print "Notify" (-notify-months-)) (let loop ((lst nmembers)) (when (and (not (null? lst)) (or (not mr) diff --git a/src/mailman3-sql.scm b/src/mailman3-sql.scm index a9a0fc8..741ec23 100644 --- a/src/mailman3-sql.scm +++ b/src/mailman3-sql.scm @@ -45,7 +45,11 @@ ;; Returns (possibly cached) SQLite3 DB handle (define (mailman3-db) (when (not (*cached-mailman3-db*)) - (*cached-mailman3-db* (open-database (*mailman3-sql-path*)))) + (*cached-mailman3-db* + (let ((handler (make-busy-timeout 2000))) + (let ((db (open-database (*mailman3-sql-path*)))) + (set-busy-handler! db handler) + db)))) (*cached-mailman3-db*)) ;; Returns the list of mailman3 mailinglists by querying te diff --git a/src/members-payments.scm b/src/members-payments.scm index 6f8731d..bf2c416 100644 --- a/src/members-payments.scm +++ b/src/members-payments.scm @@ -77,13 +77,25 @@ (string->number (bank-transaction-varsym transaction))) (varsym-id - (or varsym-id0 + (if (and varsym-id0 + (> varsym-id0 1000)) + varsym-id0 (let* ((msg (bank-transaction-message transaction)) - (ci (substring-index "," msg)) - (vs (if ci - (substring msg 0 ci) - msg))) - (string->number vs))))) + (ci1 (substring-index "," msg)) + (vs1 (if ci1 + (substring msg 0 ci1) + msg)) + (ci2 (substring-index " " msg)) + (vs2 (if ci2 + (substring msg 0 ci2) + msg)) + (ci3 (substring-index "NULL" msg)) + (vs3 (if ci3 + (substring msg (+ ci3 4) (+ ci3 4 4)) + msg))) + (or (string->number vs1) + (string->number vs2) + (string->number vs3)))))) varsym-id))) ;; Special comparator (originally with JendaSAP hack) diff --git a/src/members-print.scm b/src/members-print.scm index 3fdf736..86e14c1 100644 --- a/src/members-print.scm +++ b/src/members-print.scm @@ -67,7 +67,8 @@ cal-format util-git cal-day - racket-kwargs) + racket-kwargs + tiocgwinsz) (define *show-payments-count* (make-parameter 36)) @@ -267,11 +268,9 @@ (define (members-table-row a:? label mrs fmt) (list (string-append "\t" a:? label) (length mrs) - (ansi-paragraph-format - (member-records->string - (sort mrs brmemberstring + (sort mrs brmemberstring - (filter - identity - (list (list "Type" "Count" "List") - (members-pred-table-row mb - (ansi-string #:yellow "Chair:") - brmember-chair? - "~N") - (members-pred-table-row mb - (ansi-string #:yellow "Council:") - brmember-council? - "~N") - (members-pred-table-row mb - (ansi-string #:yellow "Revision:") - brmember-revision? - "~N") - (members-pred-table-row mb - (ansi-string #:yellow "Grant:") - brmember-grant? - "~N") - (members-pred-table-row mb - (string-append a:success "Active:") - brmember-active? - "~N~E") - (members-pred-table-row mb - (string-append a:highlight "Students:") - brmember-student? - "~N~E") - (members-table-row a:warning "Suspended:" suspended-mrs "~N~E (~S)") - (members-pred-table-row mb - (string-append a:warning "Destroyed:") - brmember-destroyed? - "~N~E") - (let ((suspended2 (filter - (lambda (mr) - (>= (brmember-suspended-months mr) - member-suspend-max-months)) - suspended-mrs))) - (if (null? suspended2) + (let-values (((rows columns) (term-size))) + (let* ((total-count (length + (find-members-by-predicate mb brmember-usable?))) + (invalid-mrs (find-members-by-predicate + mb + (compose not is-4digit-prime? brmember-id))) + (suspended-mrs (find-members-by-predicate mb brmember-suspended?)) + (debtor-mrs (sort + (members-to-notify mb 3) + brmemberstring + (filter + identity + (list (list "Type" "Count" "List") + (members-pred-table-row mb + (ansi-string #:yellow "Chair:") + brmember-chair? + "~N") + (members-pred-table-row mb + (ansi-string #:yellow "Council:") + brmember-council? + "~N") + (members-pred-table-row mb + (ansi-string #:yellow "Revision:") + brmember-revision? + "~N") + (members-pred-table-row mb + (ansi-string #:yellow "Grant:") + brmember-grant? + "~N") + (members-pred-table-row mb + (string-append a:success "Active:") + brmember-active? + "~N~E") + (members-pred-table-row mb + (string-append a:highlight "Students:") + brmember-student? + "~N~E") + (members-table-row a:warning "Suspended:" suspended-mrs "~N~E (~S)") + (members-pred-table-row mb + (string-append a:warning "Destroyed:") + brmember-destroyed? + "~N~E") + (let ((suspended2 (filter + (lambda (mr) + (>= (brmember-suspended-months mr) + member-suspend-max-months)) + suspended-mrs))) + (if (null? suspended2) + #f + (members-table-row (ansi #:magenta) "Suspended (long):" suspended2 "~N (~S)"))) + (if (null? soon-expire-mrs) #f - (members-table-row (ansi #:magenta) "Suspended (long):" suspended2 "~N (~S)"))) - (if (null? soon-expire-mrs) - #f - (members-table-row (ansi #:magenta #:bold) "Expire Soon:" - soon-expire-mrs "~N (~S)")) - (members-pred-table-row mb - (ansi-string #:red #:bold "Prolems:") - brmember-has-problems? - "~N~E ~A") - (if (null? debtor-mrs) - #f - (list (ansi-string "\t" #:magenta #:bold "Debtors:") - (format "~A" (length debtor-mrs)) - (table->string - (append - (members-attrs-table debtor-mrs - brmember-format - (list "Name" "Balance" "Last Payment") - (list "~N" "\t~B" "~L")) - (list - (list - "Total" - (format - "\t~A" - (foldr - (lambda (v a) - (+ (member-total-balance v) a)) - 0 - debtor-mrs))))) - #:border '(((#:bottom #:right light) ... (#:bottom light)) - ((#:right light) ... none) ... - ((#:top #:right light) ... (#:top light))) - #:ansi-reset? #t))) - )) - #:border '(((#:bottom #:right light) ... (#:bottom light)) - ... - ((#:right light) ... none)) - #:width 70 - #:ansi-reset? #t))) + (members-table-row (ansi #:magenta #:bold) "Expire Soon:" + soon-expire-mrs "~N (~S)")) + (members-pred-table-row mb + (ansi-string #:red #:bold "Prolems:") + brmember-has-problems? + "~N~E ~A") + (if (null? debtor-mrs) + #f + (list (ansi-string "\t" #:magenta #:bold "Debtors:") + (format "~A" (length debtor-mrs)) + (table->string + (append + (members-attrs-table debtor-mrs + brmember-format + (list "Name" "Balance" "Last Payment") + (list "~N" "\t~B" "~L")) + (list + (list + "Total" + (format + "\t~A" + (foldr + (lambda (v a) + (+ (member-total-balance v) a)) + 0 + debtor-mrs))))) + #:border '(((#:bottom #:right light) ... (#:bottom light)) + ((#:right light) ... none) ... + ((#:top #:right light) ... (#:top light))) + #:ansi-reset? #t))) + )) + #:border '(((#:bottom #:right light) ... (#:bottom light)) + ... + ((#:right light) ... none)) + #:width (- columns 10) + #:ansi-reset? #t)))) (let ((pmrs (find-members-by-predicate mb brmember-file-has-problems?))) (when (not (null? pmrs)) (newline) @@ -471,10 +471,14 @@ ")")))) ;; Prints summary table of all fees and credits for all members - (define (print-members-fees-table MB . ds) - (let ((destroyed? (if (null? ds) + (define (print-members-fees-table MB . dsa) + (let ((destroyed? (if (null? dsa) #f - (car ds)))) + (car dsa))) + (only-active? (if (or (null? dsa) + (null? (cdr dsa))) + #f + (cadr dsa)))) (let* ((members ;; Pass 1 (map (lambda (mr) @@ -500,8 +504,11 @@ (sort (if destroyed? (find-members-by-predicate MB (lambda x #t)) - (find-members-by-predicate MB (lambda (mr) - (not (brmember-destroyed? mr))))) + (if only-active? + (find-members-by-predicate MB (lambda (mr) + (brmember-active? mr))) + (find-members-by-predicate MB (lambda (mr) + (not (brmember-destroyed? mr)))))) brmember +;; +;; 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 tiocgwinsz)) + +(import duck) + +(foreign-declare "#include ") + +(module* + tiocgwinsz + #:doc ("TTY terminal size support.") + ( + term-size + ) + + (import scheme + (chicken foreign) + (chicken bitwise)) + + (define tiocgwinsz-ioctl + (foreign-lambda* + int () + " +struct winsize wss; +if (ioctl(0, TIOCGWINSZ, &wss) == 0) { + C_return(wss.ws_row*65536+wss.ws_col); +} else { + C_return(0); +} +" + )) + + (define/doc (term-size) + ("Returns the number of terminal rows and columns.") + (let ((res (tiocgwinsz-ioctl))) + (values + (arithmetic-shift res -16) + (bitwise-and res #xffff)))) + + ) diff --git a/src/util-bst-bdict.scm b/src/util-bst-bdict.scm index 1a2c6a7..bf198de 100644 --- a/src/util-bst-bdict.scm +++ b/src/util-bst-bdict.scm @@ -1,3 +1,27 @@ +;; +;; util-bst-bdict.scm +;; +;; BST-based number dictionary. +;; +;; 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 util-bst-bdict)) diff --git a/src/util-bst-ldict.scm b/src/util-bst-ldict.scm index 1810793..99d0393 100644 --- a/src/util-bst-ldict.scm +++ b/src/util-bst-ldict.scm @@ -1,3 +1,27 @@ +;; +;; util-bst-ldict.scm +;; +;; BST-based symbol dictionary. +;; +;; 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 util-bst-ldict)) diff --git a/src/util-bst-lset.scm b/src/util-bst-lset.scm index 48bf226..b8a035f 100644 --- a/src/util-bst-lset.scm +++ b/src/util-bst-lset.scm @@ -1,3 +1,27 @@ +;; +;; util-bst-lset.scm +;; +;; BST-based set implementation. +;; +;; 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 util-bst-lset)) diff --git a/src/util-bst.scm b/src/util-bst.scm index 93f97a7..c27d518 100644 --- a/src/util-bst.scm +++ b/src/util-bst.scm @@ -1,3 +1,27 @@ +;; +;; util-bst.scm +;; +;; Underlying BST implementation for sets and dictionaries. +;; +;; 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 util-bst))