diff --git a/CHANGELOG.md b/CHANGELOG.md
index 03cbc12..6c593ff 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/src/Makefile b/src/Makefile
index 010c646..c71d1ff 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -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)
diff --git a/src/brmember.scm b/src/brmember.scm
index e83c9dd..fb9e07e 100644
--- a/src/brmember.scm
+++ b/src/brmember.scm
@@ -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)))))
diff --git a/src/dokuwiki.scm b/src/dokuwiki.scm
index 40c2585..db944ce 100644
--- a/src/dokuwiki.scm
+++ b/src/dokuwiki.scm
@@ -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)))
diff --git a/src/export-web-static.scm b/src/export-web-static.scm
index 8ed8abc..fb2bed2 100644
--- a/src/export-web-static.scm
+++ b/src/export-web-static.scm
@@ -101,7 +101,7 @@
(print "
Member ID, Variable Symbol for Payments
(Členské číslo, variabilní symbol plateb)"
(brmember-id mr) "")
(print "Balance in CZK
(Zůstatek v Kč)" (caar (reverse bhs)) "")
- (print "Account for Payments
(Účet pro platbu příspěvků)CZK: 2500079551/2010
EUR: CZ93 2010 0000 0021 0007 9552")
+ (print "Account for Payments
(Účet pro platbu příspěvků)2500079551/2010")
(print "")
(print "")
(print "")
diff --git a/src/hackerbase.scm b/src/hackerbase.scm
index 6579723..fcaa90a 100644
--- a/src/hackerbase.scm
+++ b/src/hackerbase.scm
@@ -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)))
diff --git a/src/mailinglist.scm b/src/mailinglist.scm
deleted file mode 100644
index 73f3e5b..0000000
--- a/src/mailinglist.scm
+++ /dev/null
@@ -1,78 +0,0 @@
-;;
-;; mailinglist.scm
-;;
-;; Common high-level mailinglist management procedures.
-;;
-;; 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 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)))
-
- )
diff --git a/src/members-fees.scm b/src/members-fees.scm
index 5a3b0c3..7fe3dc8 100644
--- a/src/members-fees.scm
+++ b/src/members-fees.scm
@@ -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,17 +82,15 @@
(if (cal-month>? cm last-month)
(reverse cal)
(loop (cal-month-add cm)
- (cons (with-current-month
- cm
- (make-member-calendar-entry mr))
+ (cons (list cm
+ (with-current-month
+ cm
+ (brmember-flags mr))
+ (with-current-month
+ cm
+ (brmember-spec-fee mr)))
cal))))))
- ;; Assumes current-month is specified correctly
- (define (make-member-calendar-entry mr)
- (list (*current-month*)
- (brmember-flags mr)
- (brmember-spec-fee mr)))
-
;; Returns the first month of the calendar
(define (member-calendar-first-month mc)
(caar mc))
@@ -207,26 +202,5 @@
(+ (cdr acc) (if (brmember-student? mr) 0 1))))
(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))))))
)
diff --git a/src/members-print.scm b/src/members-print.scm
index 2591238..fad53e6 100644
--- a/src/members-print.scm
+++ b/src/members-print.scm
@@ -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
diff --git a/src/notifications.scm b/src/notifications.scm
index 86c888a..afe2835 100644
--- a/src/notifications.scm
+++ b/src/notifications.scm
@@ -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)))
)
diff --git a/src/texts.scm b/src/texts.scm
index 2bd8193..fbcb67e 100644
--- a/src/texts.scm
+++ b/src/texts.scm
@@ -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 "
diff --git a/src/util-bst.scm b/src/util-bst.scm
index 236fdd3..c27d518 100644
--- a/src/util-bst.scm
+++ b/src/util-bst.scm
@@ -286,12 +286,10 @@
(call/cc
(lambda (cc)
(set! break cc)
- (cond (resume
- (resume '())
- (break #f))
- (else
- (bst-iter-kv bst yield)
- (break #f))))))))
+ (if resume
+ (resume '())
+ (bst-iter-kv bst yield))
+ #f)))))
(define/doc (bst-keys bst)
("Returns all the keys contained in given dictionary.")
diff --git a/src/util-parser.scm b/src/util-parser.scm
index 24e05ed..789827f 100644
--- a/src/util-parser.scm
+++ b/src/util-parser.scm
@@ -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)))
diff --git a/src/util-utf8.scm b/src/util-utf8.scm
index 0deef64..14a4c6b 100644
--- a/src/util-utf8.scm
+++ b/src/util-utf8.scm
@@ -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))))))))))