Compare commits

..

No commits in common. "12e957fedda5e17fb7c00878a8124bcf35991c43" and "6facd2a2cca0b23365a72a9f7b7487fb1a119799" have entirely different histories.

16 changed files with 122 additions and 382 deletions

View file

@ -46,7 +46,6 @@ 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
------------
@ -60,7 +59,6 @@ Build requirements:
* make (tested with GNU make)
* Chicken eggs (chicken-install)
* sqlite3
* srfi-1
Runtime requirements:
@ -72,10 +70,6 @@ Runtime requirements:
Building
--------
All the eggs used are installed in the source tree using:
sh install-eggs.sh
Building static binary:
make static

View file

@ -388,16 +388,6 @@ 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)

View file

@ -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 tiocgwinsz.o
mailman-common.o mailman3.o mailman3-sql.o
GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \
util-time.import.scm util-csv.import.scm util-git.import.scm \
@ -68,15 +68,14 @@ 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-mail.import.scm \
util-bst-lset.import.scm
util-dir.import.scm util-utf8.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-bst-lset.o util-mail.o
util-dir.o util-utf8.o
.PHONY: imports
imports: $(HACKERBASE-DEPS)
@ -206,8 +205,7 @@ 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 \
tiocgwinsz.import.scm
util-git.import.scm racket-kwargs.import.scm
members-print.o: members-print.import.scm
members-print.import.scm: $(MEMBERS-PRINT-SOURCES)
@ -545,8 +543,3 @@ 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)

View file

@ -1,5 +1,5 @@
;;
;; configuration.scm
;; configuraiton.scm
;;
;; Configuration parameters used by various modules.
;;

View file

@ -1,27 +1,3 @@
;;
;; gendoc.scm
;;
;; Generate documentation for all documented modules dynamically.
;;
;; 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.
;;
(import duck-extract)

View file

@ -62,7 +62,6 @@
(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))
@ -138,8 +137,6 @@
"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"
@ -375,7 +372,7 @@
(newline)
(if mr
(print-member-balances-table mr)
(print-members-fees-table MB (-show-destroyed-) (-show-only-active-))))
(print-members-fees-table MB (-show-destroyed-))))
((repl)
(repl))
((genweb)
@ -409,7 +406,7 @@
(if (null? nmembers)
(print "Everyone paid on time.")
(let ()
(stdout-print "Notify" (-notify-months-))
(print "Notify" (-notify-months-))
(let loop ((lst nmembers))
(when (and (not (null? lst))
(or (not mr)

View file

@ -45,11 +45,7 @@
;; Returns (possibly cached) SQLite3 DB handle
(define (mailman3-db)
(when (not (*cached-mailman3-db*))
(*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* (open-database (*mailman3-sql-path*))))
(*cached-mailman3-db*))
;; Returns the list of mailman3 mailinglists by querying te

View file

@ -77,25 +77,13 @@
(string->number
(bank-transaction-varsym transaction)))
(varsym-id
(if (and varsym-id0
(> varsym-id0 1000))
varsym-id0
(or varsym-id0
(let* ((msg (bank-transaction-message transaction))
(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))))))
(ci (substring-index "," msg))
(vs (if ci
(substring msg 0 ci)
msg)))
(string->number vs)))))
varsym-id)))
;; Special comparator (originally with JendaSAP hack)

View file

@ -67,8 +67,7 @@
cal-format
util-git
cal-day
racket-kwargs
tiocgwinsz)
racket-kwargs)
(define *show-payments-count* (make-parameter 36))
@ -268,9 +267,11 @@
(define (members-table-row a:? label mrs fmt)
(list (string-append "\t" a:? label)
(length mrs)
(member-records->string
(sort mrs brmember<?)
fmt)))
(ansi-paragraph-format
(member-records->string
(sort mrs brmember<?)
fmt)
60)))
;; Generic table of members attributes
(define (members-attrs-table mrs fmt hdr row)
@ -300,103 +301,102 @@
;; Prints nicely aligned members base info
(define (print-members-base-table mb)
(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)
brmember<?))
(soon-expire-mrs (sort
(find-members-by-predicate
mb
(brmember-suspended-for 21 24))
brmember<?)))
(print "Known members: " total-count)
(newline)
(print
(table->string
(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)
(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)
brmember<?))
(soon-expire-mrs (sort
(find-members-by-predicate
mb
(brmember-suspended-for 21 24))
brmember<?)))
(print "Known members: " total-count)
(newline)
(print
(table->string
(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 #: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))))
(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)))
(let ((pmrs (find-members-by-predicate mb brmember-file-has-problems?)))
(when (not (null? pmrs))
(newline)
@ -471,14 +471,10 @@
")"))))
;; Prints summary table of all fees and credits for all members
(define (print-members-fees-table MB . dsa)
(let ((destroyed? (if (null? dsa)
(define (print-members-fees-table MB . ds)
(let ((destroyed? (if (null? ds)
#f
(car dsa)))
(only-active? (if (or (null? dsa)
(null? (cdr dsa)))
#f
(cadr dsa))))
(car ds))))
(let* ((members ;; Pass 1
(map
(lambda (mr)
@ -504,11 +500,8 @@
(sort
(if destroyed?
(find-members-by-predicate MB (lambda x #t))
(if only-active?
(find-members-by-predicate MB (lambda (mr)
(brmember-active? mr)))
(find-members-by-predicate MB (lambda (mr)
(not (brmember-destroyed? mr))))))
(find-members-by-predicate MB (lambda (mr)
(not (brmember-destroyed? mr)))))
brmember<?)))
(balances (map (lambda (m)
(list-ref m 6))

View file

@ -227,39 +227,11 @@
#:border '(((#:bottom #:right light) ... (#:bottom light))
((#:right light) ... none)
...)
))))
(dwpu (filter (lambda (dwu)
(or (member "member" (list-ref dwu 3))
(member "council" (list-ref dwu 3))
(member "admin" (list-ref dwu 3))))
(ldict-ref mb 'dokuwiki)))
(dw-lst
(if (null? dwpu)
'()
(list ""
"DokuWiki users (non-members) in wrong group(s):"
(string-append
" "
(string-intersperse
(map car dwpu)
", ")))))
(dwmu (find-members-by-predicate mb (compose not brmember-dokuwiki-groups-ok?)))
(dw2-lst
(if (null? dwmu)
'()
(list ""
"Members in wrong dokuwiki group(s):"
(string-append
" "
(string-intersperse
(map brmember-nick dwmu)
", "))))))
)))))
(append income-lst
unpaired-lst
debtors-lst
boring-lst
dw-lst
dw2-lst
(list ""
"--"
"Brmlab Hackerspace Members Database"

View file

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

View file

@ -1,63 +0,0 @@
;;
;; tiocgwinsz.scm
;;
;; Get size of current terminal.
;;
;; 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 tiocgwinsz))
(import duck)
(foreign-declare "#include <sys/ioctl.h>")
(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))))
)

View file

@ -1,27 +1,3 @@
;;
;; util-bst-bdict.scm
;;
;; BST-based number dictionary.
;;
;; 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 util-bst-bdict))

View file

@ -1,27 +1,3 @@
;;
;; util-bst-ldict.scm
;;
;; BST-based symbol dictionary.
;;
;; 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 util-bst-ldict))

View file

@ -1,27 +1,3 @@
;;
;; util-bst-lset.scm
;;
;; BST-based set implementation.
;;
;; 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 util-bst-lset))

View file

@ -1,27 +1,3 @@
;;
;; util-bst.scm
;;
;; Underlying BST implementation for sets and dictionaries.
;;
;; 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 util-bst))