Compare commits

..

No commits in common. "85af3fcff333cf2ba725f7d37b951df792204ea7" and "9b165490e57727c2b9a61b9f4895942a28d4e45c" have entirely different histories.

14 changed files with 104 additions and 237 deletions

View file

@ -1,41 +1,14 @@
ChangeLog
=========
1.16.2 - released 2024-05-07
----------------------------
* fix rada-ml-pred? in -mlsync
1.16.1 - released 2024-04-02
----------------------------
* add EUR account for paying membership fees to member's page
1.16 - released 2024-02-09
--------------------------
* handle # character at weird positions in DokuWiki users.auth.php
* unify -mlsync and -mlcheck handling of member predicates
* handle unicode characters with 3-byte UTF-8 representation correctly
* calculate expected income with respect to discounts granted
* report soon-expiring members in the summary emails
* report mailing lists check status in summary emails
1.15.1 - released 2024-01-02
----------------------------
* fix calculating historical membership fee (was erroneously based on
current date)
* fix showing basic information without MLs loaded
1.15 - released 2024-12-24
--------------------------
1.15
----
* increase membership fees starting 2024-01 (specification.rkt)
* add support for explicit fee amounts for specified period
1.14 - released 2024-12-06
--------------------------
1.14
----
* add support for dynamic terminal size
* use table cell formatting instead of paragraph formatting everywhere

View file

@ -42,7 +42,7 @@ HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm \
tests.import.scm notifications.import.scm logging.import.scm \
progress.import.scm cal-period.import.scm \
util-stdout.import.scm export-web-static.import.scm \
dokuwiki.import.scm mailinglist.import.scm
dokuwiki.import.scm
HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \
cal-period.o ansi.o util-bst-ldict.o command-line.o mbase.o \
@ -59,8 +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 \
mailinglist.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 \
@ -292,7 +291,7 @@ util-io.o: util-io.import.scm
util-io.import.scm: $(UTIL-IO-SOURCES)
UTIL-PARSER-SOURCES=util-parser.scm testing.import.scm \
duck.import.scm racket-kwargs.import.scm
duck.import.scm
util-parser.o: util-parser.import.scm
util-parser.import.scm: $(UTIL-PARSER-SOURCES)
@ -333,8 +332,7 @@ NOTIFICATIONS-SOURCES=notifications.scm brmember.import.scm \
brmember-format.import.scm configuration.import.scm \
util-time.import.scm members-fees.import.scm mbase.import.scm \
members-print.import.scm table.import.scm \
bank-account.import.scm logging.import.scm \
mailinglist.import.scm
bank-account.import.scm logging.import.scm
notifications.o: notifications.import.scm
notifications.import.scm: $(NOTIFICATIONS-SOURCES)
@ -552,10 +550,3 @@ TIOCGWINSZ-SOURCES=tiocgwinsz.scm duck.import.scm
tiocgwinsz.o: tiocgwinsz.import.scm
tiocgwinsz.import.scm: $(TIOCGWINSZ-SOURCES)
MAILINGLIST-SOURCES=mailinglist.scm racket-kwargs.import.scm \
mailman.import.scm mbase.import.scm util-string.import.scm \
brmember.import.scm
mailinglist.o: mailinglist.import.scm
mailinglist.import.scm: $(MAILINGLIST-SOURCES)

View file

@ -499,8 +499,8 @@
(ldict-equal?
(make-brmember '|1234| "members/1234" '(|member|))
(make-ldict
`((TAG . ,TAG-BRMEMBER)
(file-name . |1234|)
`((file-name . |1234|)
(TAG . ,TAG-BRMEMBER)
(file-path . "members/1234")
(symlinks |member|)
(id . 1234)))))

View file

@ -54,7 +54,7 @@
(users '()))
(if (null? lines)
users
(let ((line (parser-preprocess-line (car lines) #:strip-comments? #f)))
(let ((line (parser-preprocess-line (car lines))))
(if (equal? line "")
(loop (cdr lines)
users)
@ -74,8 +74,8 @@
(handle-exceptions
exn
(let ()
(log-warning "DokuWiki (~A) exception ~A" fname (condition->list exn))
(stdout-printf "DokuWiki (~A) exception ~A" fname (condition->list exn))
(log-warning "DokuWiki: cannot open ~A" fname)
(stdout-printf "DokuWiki: cannot open ~A" fname)
'())
(with-input-from-file fname
parse-dokuwiki-users-auth)))

View file

@ -101,7 +101,7 @@
(print "<dt>Member ID, Variable Symbol for Payments<br>(Členské číslo, variabilní symbol plateb)</dt><dd>"
(brmember-id mr) "</dd>")
(print "<dt>Balance in CZK<br>(Zůstatek v Kč)</dt><dd>" (caar (reverse bhs)) "</dd>")
(print "<dt>Account for Payments<br>(Účet pro platbu příspěvků)</dt><dd>CZK: 2500079551/2010<br>EUR: CZ93 2010 0000 0021 0007 9552</dd>")
(print "<dt>Account for Payments<br>(Účet pro platbu příspěvků)</dt><dd>2500079551/2010</dd>")
(print "</dl>")
(print "</div>")
(print "<div class=\"bi\">")

View file

@ -50,8 +50,7 @@
export-web-static
dokuwiki
racket-kwargs
util-string
mailinglist)
util-string)
;; Command-line options and configurable parameters
(define -needs-bank- (make-parameter #f))
@ -287,6 +286,32 @@
(print " " (car keys) ": " (length (ldict-ref status (car keys)))))
(loop (cdr keys)))))))
(define* (check-mailing-list mls name #:pred? (pred? #f))
(define ml (find-mailman-list mls name))
(when ml
(let-values (((missing surplus)
(mailman-compare-members ml
(mbase-active-emails MB
#:suspended #t
#:pred? pred?
))))
(if (null? (cdr ml))
(print "Skipping ML check - not loaded")
(if (and (null? missing)
(null? surplus))
(print (format "~a mailing list membership in sync." (string-capitalize name)))
(let ()
(print (format "~a mailing list:" (string-capitalize name)))
(when (not (null? missing))
(print " Missing: " missing))
(when (not (null? surplus))
(print " Outsiders: " surplus))))))))
(define (rada-ml-pred? mr)
(or (brmember-council? mr)
(brmember-chair? mr)
(brmember-revision? mr)))
;; Perform requested action
(case (-action-)
((print-info)
@ -298,7 +323,10 @@
(let ()
(print-members-base-table MB)
(newline)
(print-mailing-list-checks MB MLS)
(check-mailing-list MLS "internal")
(check-mailing-list MLS "rada"
#:pred? rada-ml-pred?)
(check-mailing-list MLS "rk" #:pred? brmember-revision?)
(print-git-status)))
(newline))
((print-stats)
@ -396,8 +424,8 @@
(print-git-status))
((summary)
(if (-send-emails-)
(make+send-summary-email MB MLS)
(make+print-summary-email MB MLS)))
(make+send-summary-email MB)
(make+print-summary-email MB)))
((list)
(for-each (lambda (mr)
(print (brmember-nick mr)))

View file

@ -1,78 +0,0 @@
;;
;; mailinglist.scm
;;
;; Common high-level mailinglist management procedures.
;;
;; 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 mailinglist))
(module
mailinglist
(
check-mailing-list
print-mailing-list-checks
rada-ml-pred?
)
(import scheme
(chicken base)
(chicken format)
racket-kwargs
mailman
mbase
util-string
brmember)
(define* (check-mailing-list MB mls name #:pred? (pred? #f) #:suspended (suspended #f))
(define ml (find-mailman-list mls name))
(when ml
(let-values (((missing surplus)
(mailman-compare-members ml
(mbase-active-emails MB
#:suspended suspended
#:pred? pred?
))))
(if (null? (cdr ml))
(print "Skipping ML check - not loaded")
(if (and (null? missing)
(null? surplus))
(print (format "~a mailing list membership in sync." (string-capitalize name)))
(let ()
(print (format "~a mailing list:" (string-capitalize name)))
(when (not (null? missing))
(print " Missing: " missing))
(when (not (null? surplus))
(print " Outsiders: " surplus))))))))
(define (print-mailing-list-checks MB MLS)
(check-mailing-list MB MLS "internal" #:suspended #t)
(check-mailing-list MB MLS "rada"
#:pred? rada-ml-pred?)
(check-mailing-list MB MLS "rk" #:pred? brmember-revision?))
(define (rada-ml-pred? mr)
(or (brmember-council? mr)
(brmember-chair? mr)
(brmember-revision? mr)))
)

View file

@ -30,7 +30,6 @@
(
lookup-member-fee
member-calendar
make-member-calendar-entry
member-calendar-first-month
member-calendar-last-month
member-calendar-query
@ -41,14 +40,12 @@
member-calendar->table
members-summary
member-calendar-entry->fee
get-expected-income-string
)
(import scheme
(chicken base)
(chicken format)
(chicken sort)
(chicken string)
srfi-1
configuration
brmember
@ -85,16 +82,14 @@
(if (cal-month>? cm last-month)
(reverse cal)
(loop (cal-month-add cm)
(cons (with-current-month
(cons (list cm
(with-current-month
cm
(brmember-flags mr))
(with-current-month
cm
(make-member-calendar-entry mr))
cal))))))
;; Assumes current-month is specified correctly
(define (make-member-calendar-entry mr)
(list (*current-month*)
(brmember-flags mr)
(brmember-spec-fee mr)))
cal))))))
;; Returns the first month of the calendar
(define (member-calendar-first-month mc)
@ -208,25 +203,4 @@
(cons 0 0)
members)))
(define (get-expected-income-string mb)
(let* ((flst
(map (compose member-calendar-entry->fee make-member-calendar-entry)
(find-members-by-predicate mb brmember-active?)))
(amts (sort (delete-duplicates flst) <))
(sums
(map
(lambda (amt)
(cons amt
(length (filter (lambda (v) (= v amt)) flst))))
amts)))
(string-append
"Expected income: "
(string-intersperse (map
(lambda (p)
(format "~A*~A" (cdr p) (car p)))
sums)
" + ")
" = "
(number->string (foldl + 0 (map (lambda (p) (* (car p) (cdr p))) sums))))))
)

View file

@ -500,17 +500,7 @@
(null? (cdr dsa)))
#f
(cadr dsa))))
(let* ((raw-members
(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))))))
brmember<?))
(members ;; Pass 1
(let* ((members ;; Pass 1
(map
(lambda (mr)
(let* ((balance (member-balance mr))
@ -532,7 +522,15 @@
total
balance
)))
raw-members))
(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))))))
brmember<?)))
(balances (map (lambda (m)
(list-ref m 6))
members)))
@ -600,7 +598,19 @@
(map (lambda (member)
(min 0 (list-ref member 5)))
members)))
(print (get-expected-income-string MB)))))
(let* ((ns (foldl (lambda (acc member)
(cons (+ (car acc) (if (eq? 'student (cadr member)) 1 0))
(+ (cdr acc) (if (eq? 'active (cadr member)) 1 0))))
(cons 0 0)
members))
(students (car ns))
(full (cdr ns)))
(print "Expected income: "
(+ (* (lookup-member-fee 'normal) full)
(* (lookup-member-fee 'student) students))
" (" full " full members + " students " students)"))
)
))
(define (unpaired-table mb . args)
(apply

View file

@ -40,7 +40,6 @@
(chicken format)
(chicken string)
(chicken sort)
(chicken port)
brmember
util-mail
util-bst-ldict
@ -55,8 +54,7 @@
table
bank-account
logging
srfi-1
mailinglist)
srfi-1)
;; Prints email to the console
(define (print-notification-email em)
@ -144,14 +142,16 @@
(send-notification-email em)))
;; Summary email of membership fees payments
(define (summary-email-body mb mls)
(define (summary-email-body mb)
(let* ((mbs (members-summary mb))
(students (car mbs))
(full (cdr mbs))
(income (+ (* (lookup-member-fee 'normal) full)
(* (lookup-member-fee 'student) students)))
(income-lst
(list (get-expected-income-string mb)))
(list (format "Expected income: ~A CZK" income)
(format " ~A full members" full)
(format " ~A students" students)))
(unpaired (mbase-unpaired mb))
(unpaired-lst
(if (null? unpaired)
@ -160,30 +160,6 @@
(list ""
"Unpaired transactions:")
(unpaired-table mb #:border-style 'ascii))))
(soonexps (sort
(find-members-by-predicate
mb
(brmember-suspended-for 21 24))
brmember<?))
(soonexps-lst
(if (null? soonexps)
#f
(list ""
(format "Expiring members (~A): ~A"
(length soonexps)
(string-intersperse
(map
(lambda (mr)
(brmember-format "~N (~S)" mr))
soonexps)
",")))))
(mlcheck-lst
(cons ""
(string-split
(with-output-to-string
(lambda ()
(print-mailing-list-checks mb mls)))
"\n")))
(debtors (sort
(members-to-notify mb 1)
brmember<?))
@ -280,8 +256,6 @@
", "))))))
(append income-lst
unpaired-lst
soonexps-lst
mlcheck-lst
debtors-lst
boring-lst
dw-lst
@ -292,21 +266,21 @@
))))
;; Creates the summary email structure
(define (make-summary-email mb mls)
(define (make-summary-email mb)
(make-ldict
`((to . ,(*summary-mailto*))
(subject . ,(format "Členské příspěvky ~A"
(today/iso)))
(body . ,(summary-email-body mb mls)))))
(body . ,(summary-email-body mb)))))
;; Just print to standard output
(define (make+print-summary-email mb mls)
(let ((em (make-summary-email mb mls)))
(define (make+print-summary-email mb)
(let ((em (make-summary-email mb)))
(print-notification-email em)))
;; Actually send emails
(define (make+send-summary-email mr mls)
(let ((em (make-summary-email mr mls)))
(define (make+send-summary-email mr)
(let ((em (make-summary-email mr)))
(send-notification-email em)))
)

View file

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

View file

@ -286,12 +286,10 @@
(call/cc
(lambda (cc)
(set! break cc)
(cond (resume
(if resume
(resume '())
(break #f))
(else
(bst-iter-kv bst yield)
(break #f))))))))
(bst-iter-kv bst yield))
#f)))))
(define/doc (bst-keys bst)
("Returns all the keys contained in given dictionary.")

View file

@ -39,12 +39,11 @@ member file parsers. All functions are UTF-8 aware.")
(import scheme
(chicken base)
racket-kwargs
testing)
;; Pass 0: Removes any comments and removes any leading and trailing
;; whitespace.
(define*/doc (parser-preprocess-line line #:strip-comments? (strip-comments? #t))
(define/doc (parser-preprocess-line line)
("* ```line``` - a string with contents of one source line
If the input ```line``` contains the ```#``` character, the rest of
@ -63,9 +62,7 @@ Returns a string representing the preprocessed line.")
(ploop (add1 pidx)))))
(hpos (let hloop ((hidx ppos))
(if (or (= hidx llen)
(and (or strip-comments?
(= hidx 0))
(eq? (string-ref line hidx) #\#)))
(eq? (string-ref line hidx) #\#))
hidx
(hloop (add1 hidx)))))
(spos (let sloop ((sidx (sub1 hpos)))

View file

@ -120,13 +120,13 @@ of the string and a list of remaining bytes (as integers).")
(define/doc (utf8-bytes->lists chars)
("The same as above but accepts a list of bytes (as integers).")
(let loop ((bytes chars)
(rpending chars)
(rpending '())
(pending 0)
(expected #f)
(res '()))
(if (null? bytes)
(values (reverse res)
rpending)
(reverse rpending))
(let ((byte (car bytes)))
(cond (expected
;; Decode UTF-8 sequence
@ -135,14 +135,14 @@ of the string and a list of remaining bytes (as integers).")
(let ((char (integer->char (bitwise-ior pending
(bitwise-and byte #b111111)))))
(loop (cdr bytes)
(cdr bytes)
'()
0
#f
(cons char res))))
(else
;; Intermediate bytes
(loop (cdr bytes)
rpending
(cons byte rpending)
(arithmetic-shift (bitwise-ior pending
(bitwise-and byte #b111111)) 6)
(sub1 expected)
@ -152,7 +152,7 @@ of the string and a list of remaining bytes (as integers).")
(cond ((= (bitwise-and byte #b10000000) 0)
;; ASCII
(loop (cdr bytes)
(cdr bytes)
'()
0
#f
(cons (integer->char byte) res)))
@ -160,20 +160,20 @@ of the string and a list of remaining bytes (as integers).")
;; First byte of UTF-8 sequence
(let-values
(((first-byte char-bytes)
(cond ((= (bitwise-and byte #b11100000) #b11000000)
(cond ((= (bitwise-and byte #b11000000) #b11000000)
(values (bitwise-and byte #b11111)
2))
((= (bitwise-and byte #b11110000) #b11100000)
((= (bitwise-and byte #b11100000) #b11100000)
(values (bitwise-and byte #b1111)
3))
((= (bitwise-and byte #b11111000) #b11110000)
((= (bitwise-and byte #b11110000) #b11110000)
(values (bitwise-and byte #b111)
4))
(else
;; Should not happen
(values 0 0)))))
(loop (cdr bytes)
bytes
(list byte)
(arithmetic-shift first-byte 6)
(sub1 char-bytes)
res))))))))))