Compare commits

...

70 commits

Author SHA1 Message Date
5f4724874e Bump version to 1.19-dev. 2025-01-30 21:43:04 +01:00
9f5877d3f0 Remove mailman2 support. 2025-01-30 21:42:28 +01:00
ac83dd9c72 Remove nonexistent option from manpage. 2025-01-30 21:39:51 +01:00
b324516514 Fix amount formatting for QR code for integer amounts. 2025-01-07 11:42:21 +01:00
1d523a0495 Prepare release 1.18. 2025-01-04 17:45:16 +01:00
17ce5cc126 Finish QR code integration. 2025-01-03 17:08:16 +01:00
4d73afe3c5 Preliminary QR code embedding. 2025-01-03 16:56:59 +01:00
bbbc6527a0 Ensure proper amount format and prepare for generating QR code. 2025-01-03 11:34:18 +01:00
306b9cb20e Initial import of QR payment implementation. 2025-01-03 11:00:44 +01:00
826a5f1070 Update copyright years. 2025-01-02 20:50:50 +01:00
5052a8d46f Start work on changelog and banner for 1.18 version. 2025-01-02 20:45:33 +01:00
fa8466cfff Fix typo prolems. 2025-01-02 20:42:29 +01:00
cebe6a6cf7 Finish almost final version of attendance sheet. 2025-01-02 19:34:13 +01:00
df1a30eead Typography improvements. 2025-01-02 18:09:03 +01:00
c8c71f8465 Preliminary longtable version of attendance sheet. 2025-01-02 17:42:13 +01:00
6cfdf705c8 Finish new stats. 2025-01-02 16:58:41 +01:00
227787597d Finish stats for debts. 2025-01-02 16:22:37 +01:00
7dbdd3ea6e Balance summaries for all members over time. 2025-01-02 16:10:00 +01:00
0e9cfd546b Add data for graph of expected income. 2025-01-02 15:18:53 +01:00
b25fbd407d Split out mbase-stats into separate query module. 2025-01-02 15:06:32 +01:00
e02853edc7 Preliminary version of attendance sheet. 2024-12-26 22:20:17 +01:00
53be61d345 Generate date and GM number. 2024-12-26 21:21:31 +01:00
51a108ce64 Generate file based on command-line argument. 2024-12-26 21:08:28 +01:00
fe42315cd9 Number of active months. 2024-12-26 20:58:14 +01:00
9eb835fa72 Names cleanup, alignment and amount formatting. 2024-12-26 20:26:41 +01:00
eff186cb4c Start work on attendance sheet. 2024-12-26 20:11:01 +01:00
a86063e722 Release 1.17. 2024-10-01 20:36:28 +02:00
9562d0fa61 Fix handling members without any fees or payments. 2024-10-01 20:34:44 +02:00
09b971ad93 Fix soon expires list append. 2024-09-10 20:20:33 +02:00
f95f7a0543 Revert "When creating cal-period, ensure months for periods."
This reverts commit 488499cf23.
2024-09-10 18:54:55 +02:00
488499cf23 When creating cal-period, ensure months for periods. 2024-09-10 18:49:19 +02:00
065d406e9c Coerce suspend start to month when calculating suspended months. 2024-09-10 18:42:19 +02:00
dbc52833f0 Update relevant copyright years. 2024-07-02 21:40:38 +02:00
661d754083 Missing format import. 2024-07-02 20:58:11 +02:00
6a82821626 Start writing down 1.17 changes. 2024-07-02 20:52:27 +02:00
7d1101657f Add support for full email addresses. 2024-07-02 20:50:43 +02:00
8c436f6910 Update historical changelog. 2024-07-02 20:31:49 +02:00
1840f5675b Fix erroneous newline when sending notifications. 2024-07-02 20:21:33 +02:00
bc5db8db99 Current totals. 2024-06-11 21:33:12 +02:00
079551e41a Proper lookup. 2024-06-11 21:29:06 +02:00
90930391d0 Wrong list ref. 2024-06-11 21:25:25 +02:00
0906f9d27c List spec fee. 2024-06-11 21:23:15 +02:00
8a3c812797 One more column. 2024-06-11 20:21:05 +02:00
ce74a8962d Add current fee column. 2024-06-11 20:12:16 +02:00
85af3fcff3 Release 1.16.2 with -mlsync fix. 2024-05-07 20:27:07 +02:00
8b6e1955ef Export rada-ml-pred? for backwards compatibility. 2024-05-07 20:24:00 +02:00
2a7fb0d735 Release 1.16.1 2024-04-02 19:45:57 +02:00
e1bb1885b2 Add EUR account. 2024-04-02 19:43:27 +02:00
0a762ccb1d Improve changelog for 1.16. 2024-02-09 15:18:24 +01:00
6915cc0e21 Fix spacing and bump version. 2024-02-09 15:14:46 +01:00
6947dd37b3 Report ML check status in summary emails. 2024-02-09 15:13:09 +01:00
d24b7c4136 Move more to the new mailinglist module. 2024-02-09 15:05:49 +01:00
fabb387ba1 Split out mailinglist check base. 2024-02-09 15:01:21 +01:00
708268d91d Update the changelog. 2024-02-09 14:53:34 +01:00
a9f5fc74e4 Add members expiring soon to the summary email. 2024-02-09 14:51:26 +01:00
c458dc3900 Use the same algorithm for expected income in summary emails. 2024-02-09 14:44:24 +01:00
dcf6d8937f Update changelog. 2024-02-09 14:30:06 +01:00
15888b7e3e Fix computing expected income based on actual fees and discounts. 2024-02-09 14:28:17 +01:00
dc3044026c Fix utf-8 3-byte handling. 2024-02-08 21:05:08 +01:00
ed55660c80 Add finished issues to changelog for next version. 2024-01-16 22:26:18 +01:00
d0771e130a Remove debug output, bump version to -dev. 2024-01-16 22:16:51 +01:00
6282a934c6 Always handle lines starting with # as comment. 2024-01-16 22:14:41 +01:00
707bb1d61e More debugging. 2024-01-16 22:13:17 +01:00
ba2c753109 Allow parsing config lines without comments. 2024-01-16 22:10:56 +01:00
2674f08674 Print line-by-line for debugging. 2024-01-16 22:03:32 +01:00
3629844743 Convert condition to list. 2024-01-16 22:01:27 +01:00
65c7155ba3 Log exception details. 2024-01-16 21:58:30 +01:00
939af54e87 Sync mlcheck with mlsync. 2024-01-16 21:54:10 +01:00
a64ab232c6 Fix tests. 2024-01-16 21:50:13 +01:00
2baffe570b Update changelog for 1.15.1 2024-01-02 13:12:50 +01:00
28 changed files with 1339 additions and 787 deletions

View file

@ -1,28 +1,72 @@
ChangeLog
=========
1.15
----
1.18 - released 2025-01-06
--------------------------
* fix typo in members-print
* create LaTeX source of general meeting attendance sheet
* add expected income, cash flow and average age to stats
* add QR code payment in CZK on members' payments pages'
1.17 - released 2024-10-01
--------------------------
* add "Current Fee" column to -fees to see special discounts
* add EUR account to members page
* fix erroneous newlines in cronjobs
* add support for full RFC email addresses in *email-from* configuration
* handling of members without any fees or payments
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 2023-12-24
--------------------------
* increase membership fees starting 2024-01 (specification.rkt)
* add support for explicit fee amounts for specified period
1.14
----
1.14 - released 2023-12-06
--------------------------
* add support for dynamic terminal size
* use table cell formatting instead of paragraph formatting everywhere
* fix sqlite3 database locking issue
* allow limiting -fees output to -active only
1.13
----
1.13 - released 2023-12-05
--------------------------
* add dokuwiki problems to summary emails
* handle more SEPA payments
1.12
----
1.12 - released 2023-11-16
--------------------------
* switch to eggs: srfi-1, sqlite3
* semi-automatic export for brmdoor
@ -30,83 +74,100 @@ ChangeLog
* redirect dokuwiki plugin to login page if not logged in
* sync council and revision mailing lists
1.11
----
1.11 - released 2023-09-23
--------------------------
* add support for CC in emails
* update manual page
* setup new cron jobs
1.10
----
1.10 - released 2023-09-17
--------------------------
* direct access of mailman 3 database
1.9
---
1.9 - released 2023-09-16
-------------------------
* implement support for mailman 3
* add total debt to long-term debtors listings
1.8
---
1.8 - released 2023-07-29
------------------------
* remove old compatibility static web pages generator
* update documentation
* update Fio fetcher to handle new limits imposed by the bank
* output plain list of active members (used by BrmBar project)
1.7
---
1.7 - released 2023-07-04
-------------------------
* include current month in stats
* right-alignment in table cells
* functionality improvements of dokuwiki plugin
* checking council group between dokuwiki and members database
1.6
---
1.6.2 - released 2023-06-29
---------------------------
* fix passing members to remove_members mailman binary
1.6.1 - released 2023-06-27
---------------------------
* fix ML removal
* fix sync re-read
1.6 - released 2023-06-27
-------------------------
* dokuwiki plugin
* delete generated files for destroyed members
* verify dokuwiki users information
1.5
---
1.5 - released 2023-06-19
-------------------------
* improved table renderer
* show membership fees and payments balances history
* improved generator of static web pages
1.4
---
1.4 - released 2023-05-26
-------------------------
* vim and joe syntax highlighting support
* improved Fio bank statement fetcher and merger
1.3
---
1.3 - released 2023-05-22
-------------------------
* organizational bodies membership
1.2
---
1.2.1 - released 2023-05-19
---------------------------
* fix email string argument passing
* use bi-directional mailman communication
1.2 - released 2023-05-19
-------------------------
* split configuration and action command-line options
* support for git annotate
* show suspended members that are about to expire
* optimized utf-8 support
1.1
---
1.1 - released 2023-05-14
-------------------------
* support for suppressing output (used in cron jobs)
* sorted members in notifications
* report missing keys in member files
* internal ML membership synchronization
1.0
---
1.0 - released 2023-04-23
-------------------------
This was the first oficially released version which contains all the
functionality required to take over the original solution.

View file

@ -9,7 +9,7 @@ License
ISC License
Copyright 2023 Brmlab, z.s.
Copyright 2023-2024 Brmlab, z.s.
Dominik Pantůček <dominik.pantucek@trustica.cz>
Permission to use, copy, modify, and/or distribute this software

View file

@ -273,10 +273,6 @@ Specify member by nickname.
.B \-destroyed
Show destroyed members in \fB-fees\fR action as well.
.TP
.B \-ml-all
Load all mailman list memberships to show them in members info.
.SH "FILES"
All the information about members is stored in in members file in the

View file

@ -42,7 +42,9 @@ 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
dokuwiki.import.scm mailinglist.import.scm \
export-sheet.import.scm mbase-query.import.scm \
qr-payment.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 \
@ -58,8 +60,9 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \
table-style.o sgr-state.o util-utf8.o sgr-cell.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
util-bst-bdict.o util-bst-ldict.o util-bst-lset.o \
mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o \
mailinglist.o export-sheet.o mbase-query.o qr-payment.o
GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \
util-time.import.scm util-csv.import.scm util-git.import.scm \
@ -257,13 +260,6 @@ ENVIRONMENT-SOURCES=environment.scm ansi.import.scm
environment.o: environment.import.scm
environment.import.scm: $(ENVIRONMENT-SOURCES)
MAILMAN2-SOURCES=mailman2.scm util-bst-lset.import.scm \
util-io.import.scm mailman-common.import.scm \
configuration.import.scm
mailman2.o: mailman2.import.scm
mailman2.import.scm: $(MAILMAN2-SOURCES)
UTIL-TIME-SOURCES=util-time.scm duck.import.scm
util-time.o: util-time.import.scm
@ -291,7 +287,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
duck.import.scm racket-kwargs.import.scm
util-parser.o: util-parser.import.scm
util-parser.import.scm: $(UTIL-PARSER-SOURCES)
@ -332,7 +328,8 @@ 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
bank-account.import.scm logging.import.scm \
mailinglist.import.scm
notifications.o: notifications.import.scm
notifications.import.scm: $(NOTIFICATIONS-SOURCES)
@ -471,7 +468,8 @@ box-drawing.import.scm: $(BOX-DRAWING-SOURCES)
EXPORT-WEB-STATIC-SOURCES=export-web-static.scm brmember.import.scm \
util-dir.import.scm mbase.import.scm \
members-payments.import.scm cal-day.import.scm \
util-git.import.scm configuration.import.scm texts.import.scm
util-git.import.scm configuration.import.scm texts.import.scm \
members-fees.import.scm qr-payment.import.scm
export-web-static.o: export-web-static.import.scm
export-web-static.import.scm: $(EXPORT-WEB-STATIC-SOURCES)
@ -522,10 +520,9 @@ UTIL-BST-LSET-SOURCES=util-bst-lset.scm util-bst.import.scm \
util-bst-lset.o: util-bst-lset.import.scm
util-bst-lset.import.scm: $(UTIL-BST-LSET-SOURCES)
MAILMAN-SOURCES=mailman.scm mailman2.import.scm \
mailman-common.import.scm util-bst-lset.import.scm \
configuration.import.scm mailman3.import.scm \
progress.import.scm
MAILMAN-SOURCES=mailman.scm mailman-common.import.scm \
util-bst-lset.import.scm configuration.import.scm \
mailman3.import.scm progress.import.scm
mailman.o: mailman.import.scm
mailman.import.scm: $(MAILMAN-SOURCES)
@ -550,3 +547,32 @@ 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)
EXPORT-SHEET-SOURCES=export-sheet.scm mbase.import.scm \
brmember.import.scm brmember-format.import.scm \
util-bst-ldict.import.scm members-payments.import.scm \
util-format.import.scm members-fees.import.scm \
cal-period.import.scm
export-sheet.o: export-sheet.import.scm
export-sheet.import.scm: $(EXPORT-SHEET-SOURCES)
MBASE-QUERY-SOURCES=mbase-query.scm mbase.import.scm \
brmember.import.scm util-bst-ldict.scm primes.import.scm \
cal-period.import.scm cal-month.import.scm \
members-fees.import.scm members-payments.import.scm
mbase-query.o: mbase-query.import.scm
mbase-query.import.scm: $(MBASE-QUERY-SOURCES)
QR-PAYMENT-SOURCES=qr-payment.scm util-io.import.scm
qr-payment.o: qr-payment.import.scm
qr-payment.import.scm: $(QR-PAYMENT-SOURCES)

View file

@ -87,6 +87,8 @@
brmember-spec-fee
brmember-age
brmember-tests!
)
@ -423,7 +425,8 @@
(if (brmember-suspended? mr)
(let ((period (cal-periods-match (brmember-info mr 'suspend))))
(if period
(cal-month-diff (cal-period-since period) (*current-month*))
(cal-month-diff (cal-ensure-month (cal-period-since period))
(*current-month*))
0))
0))
@ -491,6 +494,18 @@
#f))
#f)))
(define (brmember-age mr)
(let ((born (brmember-info mr 'born #f)))
(if born
(let ((lst (string-split born "-")))
(if (null? lst)
#f
(let ((y (string->number (car lst))))
(if y
(- (current-year) y)
#f))))
#f)))
;; Self-tests
(define (brmember-tests!)
(run-tests
@ -499,8 +514,8 @@
(ldict-equal?
(make-brmember '|1234| "members/1234" '(|member|))
(make-ldict
`((file-name . |1234|)
(TAG . ,TAG-BRMEMBER)
`((TAG . ,TAG-BRMEMBER)
(file-name . |1234|)
(file-path . "members/1234")
(symlinks |member|)
(id . 1234)))))

View file

@ -26,460 +26,464 @@
(declare (unit cal-period))
(module
cal-period
(
*current-month*
*current-day*
set-current-month!
set-current-day!
with-current-month
with-current-day
make-cal-period
cal-period-since
cal-period-before
cal-period-scomment
cal-period-bcomment
set-cal-period-scomment
period-markers->cal-periods
cal-periods-duration
cal-month-in-period?
cal-month-in-periods?
cal-month-find-period
cal-day-in-period?
cal-day-in-periods?
cal-periods->string
cal-periods-match
make-cal-period-lookup-table
lookup-by-cal-period
cal-ensure-month
cal-ensure-day
cal-period-tests!
)
(import scheme
(chicken base)
(chicken sort)
(chicken time)
(chicken time posix)
(chicken format)
(chicken string)
cal-month
testing
util-tag
cal-day)
;; Type tag
(define TAG-CAL-PERIOD (make-tag CAL-PERIOD))
;; Current month - if changed, we get the actual state for given month.
(define *current-month*
(make-parameter
(let ((d (seconds->local-time (current-seconds))))
(make-cal-month (+ 1900 (vector-ref d 5))
(+ (vector-ref d 4) 1)))))
;; Current month - if changed, we get the actual state for given month.
(define *current-day*
(make-parameter
(let ((d (seconds->local-time (current-seconds))))
(make-cal-day (+ 1900 (vector-ref d 5))
(+ (vector-ref d 4) 1)
(vector-ref d 3)))))
;; Changes both current-month and current-day based on given month
(define (set-current-month! m)
(*current-month* m)
(*current-day* (cal-ensure-day m)))
;; Changes both current-day and current-month based on given day
(define (set-current-day! d)
(*current-day* d)
(*current-month* (cal-ensure-month d)))
;; Parameterizes both current-month and current-day based on given
;; month
(define-syntax with-current-month
(syntax-rules ()
((_ ms body ...)
(let ((m ms))
(parameterize ((*current-month* m)
(*current-day* (cal-ensure-day m)))
body ...)))))
;; Parameterizes both current-day and current-month based on given
;; day
(define-syntax with-current-day
(syntax-rules ()
((_ ds body ...)
(let ((d ds))
(parameterize ((*current-day* d)
(*current-month* (cal-ensure-month d)))
body ...)))))
;; Creates a new period value with optional since and before
;; comments.
(define (make-cal-period since before . args)
(let ((scomment (if (not (null? args)) (car args) #f))
(bcomment (if (and (not (null? args))
(not (null? (cdr args))))
(cadr args)
#f)))
(list TAG-CAL-PERIOD since before scomment bcomment)))
;; Simple accessors
(define cal-period-since cadr)
(define cal-period-before caddr)
(define cal-period-scomment cadddr)
(define cal-period-bcomment (compose cadddr cdr))
;; Direct updater
(define (set-cal-period-scomment p c)
(list TAG-CAL-PERIOD
(cal-period-since p)
(cal-period-before p)
c
(cal-period-bcomment p)))
;; Type predicate
(define (cal-period? p)
(and (pair? p)
(eq? (car p)
TAG-CAL-PERIOD)))
;; Month subtype predicate
(define (cal-period-month? p)
(and (cal-period? p)
(cal-month? (cal-period-since p))
(cal-month? (cal-period-before p))))
;; Day subtype predicate
(define (cal-period-day? p)
(and (cal-period? p)
(cal-day? (cal-period-since p))
(cal-day? (cal-period-before p))))
;; Validation
(define (cal-period-valid? p)
(and (pair? p)
(eq? (car p)
TAG-CAL-PERIOD)
(let ((since (cal-period-since p))
(before (cal-period-before p)))
(or (and (cal-month? since)
(cal-month? before)
(cal-month<=? since before))
(and (cal-day? since)
(cal-day? before)
(cal-day<=? since before))))))
;; Sorts period markers (be it start or end) chronologically and
;; returns the sorted list.
(define (sort-period-markers l)
(sort l
(lambda (a b)
(cal-day/month<? (cadr a) (cadr b)))))
;; Converts list of start/stop markers to list of pairs of months -
;; periods. The markers are lists in the form (start/stop cal-month).
(define (period-markers->cal-periods l)
(let loop ((l (sort-period-markers l))
(ps '())
(cb #f))
(if (null? l)
(list #t
(if cb
(reverse (cons (make-cal-period (car cb) #f (cadr cb)) ps))
(reverse ps))
""
-1)
(let* ((marker (car l))
(rmt (if cb 'stop 'start))
(mtype (car marker))
(month (cadr marker))
(line-number (if (null? (cddr marker))
#f
(caddr marker)))
(comment (if (and line-number
(not (null? (cdddr marker))))
(cadddr marker)
#f)))
(if (eq? mtype rmt)
(if cb
(loop (cdr l)
(cons (make-cal-period (car cb) month (cadr cb) comment) ps)
#f)
(loop (cdr l)
ps
(list month comment)))
(list #f
(reverse ps)
(sprintf "Invalid start/stop sequence marker ~A" marker)
line-number))))))
;; Returns duration of period in months. Start is included, end is
;; not. The period contains the month just before the specified end.
(define (cal-period->duration p)
(let* ((b (cal-period-since p))
(e (cal-period-before p))
(e- (if e e (*current-month*))))
(cal-month-diff b e-)))
;; Returns sum of periods lengths.
(define (cal-periods-duration l)
(apply + (map cal-period->duration l)))
;; True if month belongs to given month period - start inclusive, end
;; exclusive.
(define (cal-month-in-period? p . ml)
(let ((m (if (null? ml)
(*current-month*)
(cal-ensure-month (car ml))))
(before (cal-ensure-month (cal-period-before p) #t))
(since (cal-ensure-month (cal-period-since p))))
(and (or (not before)
(cal-month<? m before))
(not (cal-month<? m since)))))
;; Returns true if given month is in at least one of the periods
;; given. Defaults to current month.
(define (cal-month-in-periods? ps . ml)
(let ((m (if (null? ml)
(*current-month*)
(car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
#t
(loop (cdr ps)))))))
;; Returns true if given month is in at least one of the periods
;; given. Defaults to current month.
(define (cal-month-find-period ps . ml)
(let ((m (if (null? ml)
(*current-month*)
(car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
(car ps)
(loop (cdr ps)))))))
;; Checks whether given day belongs to day or month period
(define (cal-day-in-period? p . dl)
(let ((d (if (null? dl)
(*current-day*)
(cal-ensure-day (car dl))))
(before (cal-ensure-day (cal-period-before p)))
(since (cal-ensure-day (cal-period-since p))))
(and (or (not before)
(cal-day<? d before))
(not (cal-day<? d since)))))
;; Returns true if the day belongs to at least one period
(define (cal-day-in-periods? ps . dl)
(let ((d (if (null? dl)
(*current-day*)
(cal-ensure-day (car dl)))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-day-in-period? (car ps) d)
#t
(loop (cdr ps)))))))
;; Returns string representing a month period with possibly open end.
(define (cal-period->string p)
(sprintf "~A..~A"
(cal-day/month->string (cal-period-since p))
(cal-day/month->string (cal-period-before p))))
;; Returns a string representing a list of periods.
(define (cal-periods->string ps)
(string-intersperse
(map cal-period->string ps)
", "))
;; Finds a period the month matches and returns it. If no period
;; matches, it returns #f.
(define (cal-periods-match ps . ml)
(let ((m (if (null? ml) (*current-month*) (car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
(car ps)
(loop (cdr ps)))))))
;; Creates lookup table from definition source
(define (make-cal-period-lookup-table source)
(let loop ((lst source)
(res '())
(prev #f))
(if (null? lst)
(reverse
(cons (cons (make-cal-period (apply make-cal-month (car prev)) #f)
(cdr prev))
res))
(loop (cdr lst)
(if prev
(cons (cons (make-cal-period (apply make-cal-month (car prev))
(apply make-cal-month (caar lst)))
(cdr prev))
res)
res)
(car lst)))))
;; Looks up current month and returns associated definitions
(define (lookup-by-cal-period table)
(let loop ((lst table))
(if (null? lst)
#f
(if (cal-month-in-period? (caar lst))
(cdar lst)
(loop (cdr lst))))))
;; Wrapper that accepts either day or month and returns testable month
(define (cal-ensure-month v . stop?s)
(if v
(if (cal-month? v)
v
(if (cal-day? v)
(apply cal-day->month v stop?s)
#f))
#f))
;; Ensures day for checking the periods
(define (cal-ensure-day v)
(if v
(if (cal-day? v)
v
(if (cal-month? v)
(make-cal-day (cal-month-year v)
(cal-month-month v)
1)
#f))
#f))
;; Performs self-tests of the period module.
(define (cal-period-tests!)
(run-tests
cal-period
(test-equal? sort-period-markers
(sort-period-markers
`((start ,(make-cal-month 2023 1))
(stop ,(make-cal-month 2022 10))
(start ,(make-cal-month 2022 3))))
`((start ,(make-cal-month 2022 3))
(stop ,(make-cal-month 2022 10))
(start ,(make-cal-month 2023 1))))
(test-equal? period-markers->cal-periods
(period-markers->cal-periods
(
current-year
*current-month*
*current-day*
set-current-month!
set-current-day!
with-current-month
with-current-day
make-cal-period
cal-period-since
cal-period-before
cal-period-scomment
cal-period-bcomment
set-cal-period-scomment
period-markers->cal-periods
cal-periods-duration
cal-month-in-period?
cal-month-in-periods?
cal-month-find-period
cal-day-in-period?
cal-day-in-periods?
cal-periods->string
cal-periods-match
make-cal-period-lookup-table
lookup-by-cal-period
cal-ensure-month
cal-ensure-day
cal-period-tests!
)
(import scheme
(chicken base)
(chicken sort)
(chicken time)
(chicken time posix)
(chicken format)
(chicken string)
cal-month
testing
util-tag
cal-day)
;; Type tag
(define TAG-CAL-PERIOD (make-tag CAL-PERIOD))
(define (current-year)
(cal-month-year (*current-month*)))
;; Current month - if changed, we get the actual state for given month.
(define *current-month*
(make-parameter
(let ((d (seconds->local-time (current-seconds))))
(make-cal-month (+ 1900 (vector-ref d 5))
(+ (vector-ref d 4) 1)))))
;; Current month - if changed, we get the actual state for given month.
(define *current-day*
(make-parameter
(let ((d (seconds->local-time (current-seconds))))
(make-cal-day (+ 1900 (vector-ref d 5))
(+ (vector-ref d 4) 1)
(vector-ref d 3)))))
;; Changes both current-month and current-day based on given month
(define (set-current-month! m)
(*current-month* m)
(*current-day* (cal-ensure-day m)))
;; Changes both current-day and current-month based on given day
(define (set-current-day! d)
(*current-day* d)
(*current-month* (cal-ensure-month d)))
;; Parameterizes both current-month and current-day based on given
;; month
(define-syntax with-current-month
(syntax-rules ()
((_ ms body ...)
(let ((m ms))
(parameterize ((*current-month* m)
(*current-day* (cal-ensure-day m)))
body ...)))))
;; Parameterizes both current-day and current-month based on given
;; day
(define-syntax with-current-day
(syntax-rules ()
((_ ds body ...)
(let ((d ds))
(parameterize ((*current-day* d)
(*current-month* (cal-ensure-month d)))
body ...)))))
;; Creates a new period value with optional since and before
;; comments.
(define (make-cal-period since before . args)
(let ((scomment (if (not (null? args)) (car args) #f))
(bcomment (if (and (not (null? args))
(not (null? (cdr args))))
(cadr args)
#f)))
(list TAG-CAL-PERIOD since before scomment bcomment)))
;; Simple accessors
(define cal-period-since cadr)
(define cal-period-before caddr)
(define cal-period-scomment cadddr)
(define cal-period-bcomment (compose cadddr cdr))
;; Direct updater
(define (set-cal-period-scomment p c)
(list TAG-CAL-PERIOD
(cal-period-since p)
(cal-period-before p)
c
(cal-period-bcomment p)))
;; Type predicate
(define (cal-period? p)
(and (pair? p)
(eq? (car p)
TAG-CAL-PERIOD)))
;; Month subtype predicate
(define (cal-period-month? p)
(and (cal-period? p)
(cal-month? (cal-period-since p))
(cal-month? (cal-period-before p))))
;; Day subtype predicate
(define (cal-period-day? p)
(and (cal-period? p)
(cal-day? (cal-period-since p))
(cal-day? (cal-period-before p))))
;; Validation
(define (cal-period-valid? p)
(and (pair? p)
(eq? (car p)
TAG-CAL-PERIOD)
(let ((since (cal-period-since p))
(before (cal-period-before p)))
(or (and (cal-month? since)
(cal-month? before)
(cal-month<=? since before))
(and (cal-day? since)
(cal-day? before)
(cal-day<=? since before))))))
;; Sorts period markers (be it start or end) chronologically and
;; returns the sorted list.
(define (sort-period-markers l)
(sort l
(lambda (a b)
(cal-day/month<? (cadr a) (cadr b)))))
;; Converts list of start/stop markers to list of pairs of months -
;; periods. The markers are lists in the form (start/stop cal-month).
(define (period-markers->cal-periods l)
(let loop ((l (sort-period-markers l))
(ps '())
(cb #f))
(if (null? l)
(list #t
(if cb
(reverse (cons (make-cal-period (car cb) #f (cadr cb)) ps))
(reverse ps))
""
-1)
(let* ((marker (car l))
(rmt (if cb 'stop 'start))
(mtype (car marker))
(month (cadr marker))
(line-number (if (null? (cddr marker))
#f
(caddr marker)))
(comment (if (and line-number
(not (null? (cdddr marker))))
(cadddr marker)
#f)))
(if (eq? mtype rmt)
(if cb
(loop (cdr l)
(cons (make-cal-period (car cb) month (cadr cb) comment) ps)
#f)
(loop (cdr l)
ps
(list month comment)))
(list #f
(reverse ps)
(sprintf "Invalid start/stop sequence marker ~A" marker)
line-number))))))
;; Returns duration of period in months. Start is included, end is
;; not. The period contains the month just before the specified end.
(define (cal-period->duration p)
(let* ((b (cal-period-since p))
(e (cal-period-before p))
(e- (if e e (*current-month*))))
(cal-month-diff b e-)))
;; Returns sum of periods lengths.
(define (cal-periods-duration l)
(apply + (map cal-period->duration l)))
;; True if month belongs to given month period - start inclusive, end
;; exclusive.
(define (cal-month-in-period? p . ml)
(let ((m (if (null? ml)
(*current-month*)
(cal-ensure-month (car ml))))
(before (cal-ensure-month (cal-period-before p) #t))
(since (cal-ensure-month (cal-period-since p))))
(and (or (not before)
(cal-month<? m before))
(not (cal-month<? m since)))))
;; Returns true if given month is in at least one of the periods
;; given. Defaults to current month.
(define (cal-month-in-periods? ps . ml)
(let ((m (if (null? ml)
(*current-month*)
(car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
#t
(loop (cdr ps)))))))
;; Returns true if given month is in at least one of the periods
;; given. Defaults to current month.
(define (cal-month-find-period ps . ml)
(let ((m (if (null? ml)
(*current-month*)
(car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
(car ps)
(loop (cdr ps)))))))
;; Checks whether given day belongs to day or month period
(define (cal-day-in-period? p . dl)
(let ((d (if (null? dl)
(*current-day*)
(cal-ensure-day (car dl))))
(before (cal-ensure-day (cal-period-before p)))
(since (cal-ensure-day (cal-period-since p))))
(and (or (not before)
(cal-day<? d before))
(not (cal-day<? d since)))))
;; Returns true if the day belongs to at least one period
(define (cal-day-in-periods? ps . dl)
(let ((d (if (null? dl)
(*current-day*)
(cal-ensure-day (car dl)))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-day-in-period? (car ps) d)
#t
(loop (cdr ps)))))))
;; Returns string representing a month period with possibly open end.
(define (cal-period->string p)
(sprintf "~A..~A"
(cal-day/month->string (cal-period-since p))
(cal-day/month->string (cal-period-before p))))
;; Returns a string representing a list of periods.
(define (cal-periods->string ps)
(string-intersperse
(map cal-period->string ps)
", "))
;; Finds a period the month matches and returns it. If no period
;; matches, it returns #f.
(define (cal-periods-match ps . ml)
(let ((m (if (null? ml) (*current-month*) (car ml))))
(let loop ((ps ps))
(if (null? ps)
#f
(if (cal-month-in-period? (car ps) m)
(car ps)
(loop (cdr ps)))))))
;; Creates lookup table from definition source
(define (make-cal-period-lookup-table source)
(let loop ((lst source)
(res '())
(prev #f))
(if (null? lst)
(reverse
(cons (cons (make-cal-period (apply make-cal-month (car prev)) #f)
(cdr prev))
res))
(loop (cdr lst)
(if prev
(cons (cons (make-cal-period (apply make-cal-month (car prev))
(apply make-cal-month (caar lst)))
(cdr prev))
res)
res)
(car lst)))))
;; Looks up current month and returns associated definitions
(define (lookup-by-cal-period table)
(let loop ((lst table))
(if (null? lst)
#f
(if (cal-month-in-period? (caar lst))
(cdar lst)
(loop (cdr lst))))))
;; Wrapper that accepts either day or month and returns testable month
(define (cal-ensure-month v . stop?s)
(if v
(if (cal-month? v)
v
(if (cal-day? v)
(apply cal-day->month v stop?s)
#f))
#f))
;; Ensures day for checking the periods
(define (cal-ensure-day v)
(if v
(if (cal-day? v)
v
(if (cal-month? v)
(make-cal-day (cal-month-year v)
(cal-month-month v)
1)
#f))
#f))
;; Performs self-tests of the period module.
(define (cal-period-tests!)
(run-tests
cal-period
(test-equal? sort-period-markers
(sort-period-markers
`((start ,(make-cal-month 2023 1))
(stop ,(make-cal-month 2022 10))
(start ,(make-cal-month 2022 3))))
`((start ,(make-cal-month 2022 3))
(stop ,(make-cal-month 2022 10))
(start ,(make-cal-month 2023 1))
(stop ,(make-cal-month 2023 4))))
`(#t
(,(make-cal-period (make-cal-month 2022 3)
(make-cal-month 2022 10) #f #f)
,(make-cal-period (make-cal-month 2023 1)
(make-cal-month 2023 4) #f #f))
""
-1))
(test-equal? period-markers->cal-periods-open
(period-markers->cal-periods
`((start ,(make-cal-month 2022 3))
(stop ,(make-cal-month 2022 10))
(start ,(make-cal-month 2023 1))
(stop ,(make-cal-month 2023 4))
(start ,(make-cal-month 2023 5))))
`(#t
(,(make-cal-period (make-cal-month 2022 3)
(make-cal-month 2022 10) #f #f)
,(make-cal-period (make-cal-month 2023 1)
(make-cal-month 2023 4) #f #f)
,(make-cal-period (make-cal-month 2023 5) #f #f #f))
""
-1))
(test-eq? cal-period->duration
(cal-period->duration (make-cal-period (make-cal-month 2023 1)
(make-cal-month 2023 4) #f #f))
3)
(parameterize ((*current-month* (make-cal-month 2023 4)))
(test-eq? cal-period->duration
(cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f))
3))
(test-eq? cal-periods-duration
(cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3)
(make-cal-month 2022 10) #f #f)
,(make-cal-period (make-cal-month 2023 1)
(make-cal-month 2023 4) #f #f)))
10)
(test-true cal-month-in-period?
(cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
(make-cal-month 2022 3)))
(test-false cal-month-in-period?
(start ,(make-cal-month 2023 1))))
(test-equal? period-markers->cal-periods
(period-markers->cal-periods
`((start ,(make-cal-month 2022 3))
(stop ,(make-cal-month 2022 10))
(start ,(make-cal-month 2023 1))
(stop ,(make-cal-month 2023 4))))
`(#t
(,(make-cal-period (make-cal-month 2022 3)
(make-cal-month 2022 10) #f #f)
,(make-cal-period (make-cal-month 2023 1)
(make-cal-month 2023 4) #f #f))
""
-1))
(test-equal? period-markers->cal-periods-open
(period-markers->cal-periods
`((start ,(make-cal-month 2022 3))
(stop ,(make-cal-month 2022 10))
(start ,(make-cal-month 2023 1))
(stop ,(make-cal-month 2023 4))
(start ,(make-cal-month 2023 5))))
`(#t
(,(make-cal-period (make-cal-month 2022 3)
(make-cal-month 2022 10) #f #f)
,(make-cal-period (make-cal-month 2023 1)
(make-cal-month 2023 4) #f #f)
,(make-cal-period (make-cal-month 2023 5) #f #f #f))
""
-1))
(test-eq? cal-period->duration
(cal-period->duration (make-cal-period (make-cal-month 2023 1)
(make-cal-month 2023 4) #f #f))
3)
(parameterize ((*current-month* (make-cal-month 2023 4)))
(test-eq? cal-period->duration
(cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f))
3))
(test-eq? cal-periods-duration
(cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3)
(make-cal-month 2022 10) #f #f)
,(make-cal-period (make-cal-month 2023 1)
(make-cal-month 2023 4) #f #f)))
10)
(test-true cal-month-in-period?
(cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
(make-cal-month 2022 5)))
(test-true cal-month-in-periods?
(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2023 5)
(make-cal-month 2023 10) #f #f))
(make-cal-month 2022 3)))
(test-true cal-month-in-periods?
(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2023 5)
(make-cal-month 2023 10) #f #f))
(make-cal-month 2023 7)))
(test-false cal-month-in-periods?
(test-false cal-month-in-period?
(cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
(make-cal-month 2022 5)))
(test-true cal-month-in-periods?
(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2023 5)
(make-cal-month 2023 10) #f #f))
(make-cal-month 2022 10)))
(test-equal? cal-period->string
(cal-period->string (make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f))
"2022-01..2022-04")
(test-equal? cal-periods->string
(cal-periods->string `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2022 12)
(make-cal-month 2023 2) #f #f)))
"2022-01..2022-04, 2022-12..2023-02")
(test-false cal-periods-match
(cal-periods-match `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2022 12)
(make-cal-month 2023 2) #f #f))
(make-cal-month 2022 5)))
(test-equal? cal-periods-match
(make-cal-month 2022 3)))
(test-true cal-month-in-periods?
(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2023 5)
(make-cal-month 2023 10) #f #f))
(make-cal-month 2023 7)))
(test-false cal-month-in-periods?
(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2023 5)
(make-cal-month 2023 10) #f #f))
(make-cal-month 2022 10)))
(test-equal? cal-period->string
(cal-period->string (make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f))
"2022-01..2022-04")
(test-equal? cal-periods->string
(cal-periods->string `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2022 12)
(make-cal-month 2023 2) #f #f)))
"2022-01..2022-04, 2022-12..2023-02")
(test-false cal-periods-match
(cal-periods-match `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2022 12)
(make-cal-month 2023 2) #f #f))
(make-cal-month 2022 2))
(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f))
))
(make-cal-month 2022 5)))
(test-equal? cal-periods-match
(cal-periods-match `(,(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f)
,(make-cal-period (make-cal-month 2022 12)
(make-cal-month 2023 2) #f #f))
(make-cal-month 2022 2))
(make-cal-period (make-cal-month 2022 1)
(make-cal-month 2022 4) #f #f))
))
)
)

View file

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

View file

@ -135,18 +135,12 @@
res))))))
(define (print-duck-signature sig)
;;(print sig)
(let* ((curry-depth (get-curry-depth sig))
(name (get-signature-name sig))
(nameline (format " ~A~A" (make-string curry-depth #\() name))
(spaceline (make-string (add1 (string-length nameline)) #\space))
(args (gather-signature-arguments sig))
(eargs (expand-signature-arguments args)))
;;(print " curry depth = " curry-depth)
;;(print " name = " name)
;;(print " args = " args)
;;(printf " eargs = ~S" eargs)
;;(newline)
(if (null? eargs)
(print nameline ")")
(let loop ((args eargs)

226
src/export-sheet.scm Normal file
View file

@ -0,0 +1,226 @@
;;
;; export-sheet.scm
;;
;; Export attendance sheet as MarkDown document.
;;
;; ISC License
;;
;; Copyright 2024 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 export-sheet))
(module
export-sheet
(
print-attendance-sheet
)
(import scheme
(chicken base)
(chicken string)
(chicken format)
(chicken sort)
srfi-1
mbase
brmember
brmember-format
util-bst-ldict
members-payments
util-format
members-fees
cal-period
cal-day)
(define (print-attendance-sheet MB number)
(print "\\documentclass{article}")
(print "\\usepackage{fancyhdr}")
(print "\\usepackage{longtable}")
(print "\\usepackage{lastpage}")
(print "\\usepackage[top=3cm,left=1cm,right=2cm,bottom=3cm]{geometry}")
(print "\\lhead{}")
(print
(format
"\\chead{Prezenční listina ~A. Valné Hromady brmlab z.s. konané ~A. ~A. ~A v sídle spolku}"
number
(cal-day-day (*current-day*))
(cal-day-month (*current-day*))
(cal-day-year (*current-day*))
))
(print "\\rhead{}")
(print "\\renewcommand{\\headrulewidth}{0pt}")
(print "\\lfoot{}")
(print "\\cfoot{Strana \\thepage{} ze \\pageref*{LastPage}}")
(print "\\rfoot{}")
(print "\\pagestyle{fancy}")
(print "\\begin{document}")
(print "\\begin{center}")
(newline)
(print "\\vskip1em")
(newline)
(define colnames
'((id) Nick "Jméno" "Příjmení" (Fee) (Bilance)
("\\raisebox{2pt}{\\begin{minipage}{15mm}\\begin{center}Aktivní\\\\Měsíce\\end{center}\\end{minipage}}")
((Hlas?)) Podpis))
(print "\\renewcommand\\arraystretch{2.1}")
(print
(format
"\\begin{longtable}{|~A|}"
(string-intersperse
(map
(lambda (x)
(if (list? x)
(if (list? (car x))
"c"
"r")
"l"))
colnames)
"|")))
(print "\\hline")
(print
(string-intersperse
(map
(lambda (x)
(format
"\\textbf{~A}"
(if (symbol? x)
(symbol->string x)
(if (string? x)
x
(if (string? (car x))
(car x)
(if (list? (car x))
(symbol->string (caar x))
(symbol->string (car x))))))))
colnames)
"&")
"\\\\")
(print "\\hline")
(print "\\endhead")
(define valid-voters 0)
(define ok-balances 0)
(define ok-actives 0)
(let loop ((mrs (sort
(find-members-by-predicate
MB (lambda (mr)
(brmember-active? mr)))
(lambda (a b)
(string<? (brmember-nick a)
(brmember-nick b))))))
(when (not (null? mrs))
(let* ((mr (car mrs))
(info (ldict-ref mr 'info))
(name (ldict-ref info 'name "ERROR"))
(name* (string-translate*
name
'(("_" . " "))))
(namel (string-split name*))
(sname (car (reverse namel)))
(fname
(string-intersperse
(reverse
(cdr
(reverse namel)))
" "))
(cal (member-calendar mr))
(rcal (reverse cal))
(rcal12
(if (> (length rcal) 12)
(take rcal 12)
rcal))
(acal12 (map cadr rcal12))
(acal12* (map (lambda (f) (if (memq 'active f) 1 0)) acal12))
(numactive (foldl + 0 acal12*))
(spec-fee (brmember-spec-fee mr))
(current-fee (if spec-fee
spec-fee
(member-calendar-entry->fee
(list (*current-month*)
(brmember-flags mr)
spec-fee))))
(balance-ok? (>= (member-total-balance mr)
(- current-fee)))
(active-ok? (>= numactive 9))
(vote-ok? (and balance-ok? active-ok?))
)
(when balance-ok?
(set! ok-balances (+ ok-balances 1)))
(when active-ok?
(set! ok-actives (+ ok-actives 1)))
(when vote-ok?
(set! valid-voters (+ valid-voters 1)))
(print
(brmember-id mr)
" & "
(string-translate*
(brmember-nick mr)
'(("_" . "\\_")))
" & \\small "
fname
" & \\small "
sname
" & "
current-fee
" & "
"\\raisebox{2pt}{\\begin{minipage}{15mm}\\begin{flushright}"
(format-amount-tex
(member-total-balance mr))
"\\\\"
(if balance-ok?
"Bez~dluhu"
"---~~~~~~")
"\\end{flushright}\\end{minipage}}"
" & "
;(if balance-ok?
; "Y"
; "--")
;" & "
"\\raisebox{2pt}{\\begin{minipage}{12mm}\\begin{center}"
numactive "/" 12
"\\\\"
(if active-ok?
"Splněno"
"\\phantom{Sp}---\\phantom{Sp}")
"\\end{center}\\end{minipage}}"
" & "
;(if active-ok?
; "Y"
; "--")
;" & "
(if vote-ok?
"Ano"
"--")
" & "
"~\\hskip28mm~"
" \\\\")
(print "\\hline")
(loop (cdr mrs)))))
(print "\\end{longtable}")
(print "\\end{center}")
(print "\\end{document}")
(print "% valid-voters = " valid-voters)
(print "% valid-balances = " ok-balances)
(print "% valid-actives = " ok-actives)
)
(define (format-amount-tex amt)
(string-translate*
(format-amount amt)
'(("--" . "--{}--"))))
)

View file

@ -44,7 +44,10 @@
cal-day
util-git
configuration
texts)
texts
logging
qr-payment
members-fees)
;; HTML entities
(define (sanitize-html str)
@ -87,6 +90,8 @@
(print "dd+dt,dd+dt+dd{border-top:1px solid #8cacbb}")
(print "dd{grid-column:2/3;font-weight:bold;margin:0px;padding-left:16px}")
(print "footer{background:#dee7ec;border-top:1px solid #8cacbb;padding:16px}")
(print ".qr svg{width:100%;height:auto;max-width:10cm}")
(print ".qr{text-align: center}")
(print "</style>")
(print "</head>")
(print "<body>")
@ -100,10 +105,21 @@
(brmember-nick mr) "</dd>")
(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>2500079551/2010</dd>")
(print "<dt>Balance in CZK<br>(Zůstatek v Kč)</dt><dd>"
(if (null? bhs)
"0"
(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 "</dl>")
(print "</div>")
(print "<div class=\"bi qr\">")
(let ((fee (member-calendar-entry->fee
(make-member-calendar-entry mr))))
(print "<h2>Payment of membership fee " fee " CZK<br/>(Platba členského příspěvku)</h2>")
(print (make-brmlab-qrp-svg-string
fee "CZK" (brmember-id mr))))
(print "</div>")
(print "<div class=\"bi\">")
(print "<h2>Payments History</h2>")
(print "<table>")

View file

@ -50,7 +50,10 @@
export-web-static
dokuwiki
racket-kwargs
util-string)
util-string
mailinglist
export-sheet
mbase-query)
;; Command-line options and configurable parameters
(define -needs-bank- (make-parameter #f))
@ -65,6 +68,7 @@
(define -show-only-active- (make-parameter #f))
(define -notify-months- (make-parameter 1))
(define -send-emails- (make-parameter #f))
(define -number- (make-parameter #f))
;; Arguments parsing
(command-line
@ -180,7 +184,14 @@
(-action- 'genweb))
(-stats (file:gnuplot-data) "Get stats for all months"
(-action- 'print-stats)
(-needs-bank- #t)
(-fname- file:gnuplot-data))
(-sheet (filename gmnum) "Generate attendance sheet for given GM number"
(-needs-bank- #t)
(-fname- filename)
(-number- gmnum)
(-action- 'gen-sheet))
""
"Mailman Actions:"
(-mlsync () "Synchronize internal ML"
@ -286,32 +297,6 @@
(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)
@ -323,10 +308,7 @@
(let ()
(print-members-base-table MB)
(newline)
(check-mailing-list MLS "internal")
(check-mailing-list MLS "rada"
#:pred? rada-ml-pred?)
(check-mailing-list MLS "rk" #:pred? brmember-revision?)
(print-mailing-list-checks MB MLS)
(print-git-status)))
(newline))
((print-stats)
@ -382,6 +364,10 @@
((genweb)
(log-info "Generating static web files")
(gen-html-members MB (-web-dir-)))
((gen-sheet)
(log-info "Generating attendance sheet")
(parameterize ((current-output-port (open-output-file (-fname-))))
(print-attendance-sheet MB (-number-))))
((edit)
(if mr
(let ()
@ -406,7 +392,7 @@
(print "Mailman synchronization disabled with manually specified current month."))))
((notify)
(let ((nmembers (members-to-notify MB (-notify-months-))))
(newline)
(stdout-newline)
(if (null? nmembers)
(print "Everyone paid on time.")
(let ()
@ -424,8 +410,8 @@
(print-git-status))
((summary)
(if (-send-emails-)
(make+send-summary-email MB)
(make+print-summary-email MB)))
(make+send-summary-email MB MLS)
(make+print-summary-email MB MLS)))
((list)
(for-each (lambda (mr)
(print (brmember-nick mr)))

78
src/mailinglist.scm Normal file
View file

@ -0,0 +1,78 @@
;;
;; 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

@ -49,7 +49,6 @@
(import scheme
(chicken base)
(chicken module)
mailman2
mailman-common
util-bst-lset
configuration
@ -59,24 +58,17 @@
;; Syntax for simplifying export of case-version procedures
(define-syntax define-mailman-proc
(syntax-rules ()
((_ name proc2)
((_ name proc3)
(begin
(export name)
(define (name . args)
(case (*mailman-version*)
((2) (apply proc2 args))))))
((_ name proc2 proc3)
(begin
(export name)
(define (name . args)
(case (*mailman-version*)
((2) (apply proc2 args))
((3) (apply proc3 args))))))))
(define-mailman-proc list-mailman-lists
list-mailman2-lists list-mailman3-lists)
list-mailman3-lists)
(define-mailman-proc list-mailman-list-members
list-mailman2-list-members list-mailman3-list-members)
list-mailman3-list-members)
;; Loads a single mailman list as mailman structure, if
;; unsuccessfull, returns only a list with ML name and no member
@ -112,9 +104,9 @@
(assoc name lsts))
(define-mailman-proc add-email-to-mailman-list
add-email-to-mailman2-list add-email-to-mailman3-list)
add-email-to-mailman3-list)
(define-mailman-proc remove-email-from-mailman-list
remove-email-from-mailman2-list remove-email-from-mailman3-list)
remove-email-from-mailman3-list)
;; Ensures given email is in given ML
(define (mailman-ensure-member ml email)

View file

@ -1,104 +0,0 @@
;;
;; mailman2.scm
;;
;; Mailman management interface - Mailman version 2.x support
;;
;; 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 mailman2))
(module
mailman2
(
list-mailman2-lists
list-mailman2-list-members
add-email-to-mailman2-list
remove-email-from-mailman2-list
)
(import scheme
(chicken base)
(chicken pathname)
(chicken string)
(chicken sort)
(chicken format)
srfi-1
util-bst-lset
util-io
mailman-common
configuration)
;; Returns full path to given mailman binary
(define (mailman-bin bin)
(make-pathname (*mailman2-bin*) bin))
;; Mailman-specific process output lines capture
(define (get-mailman-output-lines bin . args)
(apply
get-process-output-lines
(mailman-bin bin)
args))
;; Sends all lines to the process
(define (mailman-send/recv bin args . lines)
(apply
process-send/recv
(mailman-bin bin)
args
lines))
;; Returns the list of available lists
(define (list-mailman2-lists)
(get-mailman-output-lines "list_lists" "-b"))
;; Returns the list of members of given list
(define (list-mailman2-list-members lst)
(sort
(get-mailman-output-lines "list_members" lst)
string-ci<?))
;; Adds given email to given listname
(define (add-email-to-mailman2-list listname email)
(print "Add " email " to " listname ".")
(let ((result
(mailman-send/recv
"add_members"
(list "-r" "-" listname)
email)))
(let loop ((lines result))
(when (not (null? lines))
(print " | " (car lines))
(loop (cdr lines))))))
;; Removes given email from given listname
(define (remove-email-from-mailman2-list listname email)
(print "Remove " email " from " listname ".")
(let ((result
(get-mailman-output-lines
"remove_members" listname
(sprintf "~A" email))))
(let loop ((lines result))
(when (not (null? lines))
(print " | " (car lines))
(loop (cdr lines))))))
)

123
src/mbase-query.scm Normal file
View file

@ -0,0 +1,123 @@
;;
;; mbase-query.scm
;;
;; Queries of various mbase derived attributes.
;;
;; ISC License
;;
;; Copyright 2023-2025 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 mbase-query))
(module
mbase-query
(
mbase-info
mbase-stats
)
(import scheme
(chicken base)
srfi-1
mbase
brmember
util-bst-ldict
primes
cal-period
cal-month
members-fees
members-payments)
(define (members-base-oldest-month mb)
(make-cal-month 2015 1))
(define (members-average-age mrs)
(let* ((ages (map brmember-age mrs))
(valid (filter (lambda (x) x) ages))
(num (length valid))
(sum (foldl + 0 valid)))
(exact->inexact (/ sum num))))
;; Returns dictionary with statistics about the members base.
(define (mbase-info mb-arg)
(let* ((members (find-members-by-predicate mb-arg brmember-usable?))
(di0 (make-ldict))
(di1 (ldict-set di0 'invalid
(filter (compose not is-4digit-prime? brmember-id) members)))
(active-members (filter brmember-active? members))
(di2 (ldict-set di1 'active
active-members))
(di3 (ldict-set di2 'suspended
(filter brmember-suspended? members)))
(di4 (ldict-set di3 'students
(filter brmember-student? members)))
(di5 (ldict-set di4 'destroyed
(filter brmember-destroyed? members)))
(di6 (ldict-set di5 'month (*current-month*)))
(di7 (ldict-set di6 'total members))
(di8 (ldict-set di7 'problems
(find-members-by-predicate mb-arg brmember-has-problems?)))
(di9 (ldict-set di8 'expected
(get-expected-income mb-arg)))
(mbals (map member-total-balance active-members))
(di10 (ldict-set di9 'balance
(foldl + 0 mbals)))
(di11 (ldict-set di10 'advance
(foldl + 0
(map (lambda (v)
(max 0 v))
mbals))))
(di12 (ldict-set di11 'debt
(foldl + 0
(map (lambda (v)
(min 0 v))
mbals))))
(di13 (ldict-set di12 'age
(members-average-age active-members)))
)
di13))
;; Returns a list two lists: keys, data.
;; Each data record contains values for all keys.
(define (mbase-stats mb)
(let ((keys
'(month
total active suspended students destroyed invalid
expected balance advance debt
age
)))
(let mloop ((data '())
(month (members-base-oldest-month mb)))
(if (cal-month<=? month (*current-month*))
(let ((bi (with-current-month month
(mbase-info mb))))
(let kloop ((row (list (ldict-ref bi 'month)))
(keys (cdr keys)))
(if (null? keys)
(mloop (cons (reverse row) data)
(cal-month-add month 1))
(kloop (cons (let ((val (ldict-ref bi (car keys))))
(if (list? val)
(length val)
val))
row)
(cdr keys)))))
(list keys (reverse data))))))
)

View file

@ -50,8 +50,6 @@
mbase-update-by-id
mbase-update
mbase-stats
mbase-add-unpaired
mbase-unpaired
@ -207,47 +205,6 @@
(proc mr)
mr)))))
;; Returns dictionary with statistics about the members base.
(define (mbase-info mb-arg)
(let* ((members (find-members-by-predicate mb-arg brmember-usable?))
(di0 (make-ldict))
(di1 (ldict-set di0 'invalid
(filter (compose not is-4digit-prime? brmember-id) members)))
(di2 (ldict-set di1 'active
(filter brmember-active? members)))
(di3 (ldict-set di2 'suspended
(filter brmember-suspended? members)))
(di4 (ldict-set di3 'students
(filter brmember-student? members)))
(di5 (ldict-set di4 'destroyed
(filter brmember-destroyed? members)))
(di6 (ldict-set di5 'month (*current-month*)))
(di7 (ldict-set di6 'total members))
(di8 (ldict-set di7 'problems
(find-members-by-predicate mb-arg brmember-has-problems?))))
di8))
(define (members-base-oldest-month mb)
(make-cal-month 2015 1))
;; Returns a list two lists: keys, data.
;; Each data record contains values for all keys.
(define (mbase-stats mb)
(let ((keys '(month total active suspended students destroyed invalid)))
(let mloop ((data '())
(month (members-base-oldest-month mb)))
(if (cal-month<=? month (*current-month*))
(let ((bi (with-current-month month
(mbase-info mb))))
(let kloop ((row (list (ldict-ref bi 'month)))
(keys (cdr keys)))
(if (null? keys)
(mloop (cons (reverse row) data)
(cal-month-add month 1))
(kloop (cons (length (ldict-ref bi (car keys))) row)
(cdr keys)))))
(list keys (reverse data))))))
;; Adds unpaired transaction to given members-base
(define (mbase-add-unpaired mb tr)
(ldict-set mb 'unpaired

View file

@ -30,6 +30,7 @@
(
lookup-member-fee
member-calendar
make-member-calendar-entry
member-calendar-first-month
member-calendar-last-month
member-calendar-query
@ -40,12 +41,15 @@
member-calendar->table
members-summary
member-calendar-entry->fee
get-expected-income
get-expected-income-string
)
(import scheme
(chicken base)
(chicken format)
(chicken sort)
(chicken string)
srfi-1
configuration
brmember
@ -82,15 +86,17 @@
(if (cal-month>? cm last-month)
(reverse cal)
(loop (cal-month-add cm)
(cons (list cm
(with-current-month
cm
(brmember-flags mr))
(with-current-month
cm
(brmember-spec-fee mr)))
(cons (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)))
;; Returns the first month of the calendar
(define (member-calendar-first-month mc)
(caar mc))
@ -202,5 +208,39 @@
(+ (cdr acc) (if (brmember-student? mr) 0 1))))
(cons 0 0)
members)))
(define (get-expected-income 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)))
(foldl + 0 (map (lambda (p) (* (car p) (cdr p))) sums))))
(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

@ -129,8 +129,6 @@
(ptbl (table->string
pdata
#:border '(((#:right light) ... none) ...))))
;;(print pdata)
;;(write ptbl)(newline)
(list k ptbl)))
((fee)
(let* ((pdata
@ -150,8 +148,6 @@
(ptbl (table->string
pdata
#:border '(((#:right light) ... none) ...))))
;;(print pdata)
;;(write ptbl)(newline)
(list k ptbl)))
(else
(if v
@ -182,7 +178,6 @@
(list (list (ansi-string #:red "DokuWiki")
(ansi-string #:red "---")))))
(result (filter identity (append head body mailman dokuwiki))))
;;(write result)(newline)
(table->string result
#:border '(((#:bottom #:right light) ... (#:bottom light))
...
@ -385,7 +380,7 @@
(members-table-row (ansi #:magenta #:bold) "Expire Soon:"
soon-expire-mrs "~N (~S)"))
(members-pred-table-row mb
(ansi-string #:red #:bold "Prolems:")
(ansi-string #:red #:bold "Problems:")
brmember-has-problems?
"~N~E ~A")
(if (null? debtor-mrs)
@ -500,7 +495,17 @@
(null? (cdr dsa)))
#f
(cadr dsa))))
(let* ((members ;; Pass 1
(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
(map
(lambda (mr)
(let* ((balance (member-balance mr))
@ -521,16 +526,15 @@
payment
total
balance
(let ((spec-fee (brmember-spec-fee mr)))
(if spec-fee
spec-fee
(member-calendar-entry->fee
(list (*current-month*)
(brmember-flags mr)
spec-fee))))
)))
(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<?)))
raw-members))
(balances (map (lambda (m)
(list-ref m 6))
members)))
@ -539,6 +543,7 @@
(cons
(list (ansi-string #:bgblue #:brightyellow #:bold "Member")
(ansi-string #:bgblue #:brightyellow #:bold "Status")
(ansi-string #:bgblue #:brightyellow #:bold "Current")
(ansi-string #:bgblue #:brightyellow #:bold "Fees")
(ansi-string #:bgblue #:brightyellow #:bold "Credit")
(ansi-string #:bgblue #:brightyellow #:bold "Payments")
@ -549,6 +554,7 @@
(let ((total (list-ref member 5)))
(list (list-ref member 0)
(list-ref member 1)
(sprintf "\t~A" (list-ref member 7))
(sprintf "\t~A" (list-ref member 2))
(sprintf "\t~A" (list-ref member 3))
(sprintf "\t~A" (list-ref member 4))
@ -565,9 +571,11 @@
(let* ((fees (foldl + 0 (map (lambda (b) (ldict-ref b 'fees)) balances)))
(credit (foldl + 0 (map (lambda (b) (ldict-ref b 'credit)) balances)))
(payment (foldl + 0 (map (lambda (b) (ldict-ref b 'payment)) balances)))
(total (- (+ credit payment) fees)))
(total (- (+ credit payment) fees))
(current-total (foldl + 0 (map (lambda (m) (list-ref m 7)) members))))
(list (list (ansi-string #:bold "Total")
""
(ansi-string "\t" #:bold (sprintf "~A" current-total))
(ansi-string "\t" #:bold (sprintf "~A" fees))
(ansi-string "\t" #:bold (sprintf "~A" credit))
(ansi-string "\t" #:bold (sprintf "~A" payment))
@ -598,19 +606,7 @@
(map (lambda (member)
(min 0 (list-ref member 5)))
members)))
(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)"))
)
))
(print (get-expected-income-string MB)))))
(define (unpaired-table mb . args)
(apply

View file

@ -40,6 +40,7 @@
(chicken format)
(chicken string)
(chicken sort)
(chicken port)
brmember
util-mail
util-bst-ldict
@ -54,7 +55,8 @@
table
bank-account
logging
srfi-1)
srfi-1
mailinglist)
;; Prints email to the console
(define (print-notification-email em)
@ -142,16 +144,14 @@
(send-notification-email em)))
;; Summary email of membership fees payments
(define (summary-email-body mb)
(define (summary-email-body mb mls)
(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 (format "Expected income: ~A CZK" income)
(format " ~A full members" full)
(format " ~A students" students)))
(list (get-expected-income-string mb)))
(unpaired (mbase-unpaired mb))
(unpaired-lst
(if (null? unpaired)
@ -160,6 +160,30 @@
(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)
'()
(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<?))
@ -256,6 +280,8 @@
", "))))))
(append income-lst
unpaired-lst
soonexps-lst
mlcheck-lst
debtors-lst
boring-lst
dw-lst
@ -266,21 +292,21 @@
))))
;; Creates the summary email structure
(define (make-summary-email mb)
(define (make-summary-email mb mls)
(make-ldict
`((to . ,(*summary-mailto*))
(subject . ,(format "Členské příspěvky ~A"
(today/iso)))
(body . ,(summary-email-body mb)))))
(body . ,(summary-email-body mb mls)))))
;; Just print to standard output
(define (make+print-summary-email mb)
(let ((em (make-summary-email mb)))
(define (make+print-summary-email mb mls)
(let ((em (make-summary-email mb mls)))
(print-notification-email em)))
;; Actually send emails
(define (make+send-summary-email mr)
(let ((em (make-summary-email mr)))
(define (make+send-summary-email mr mls)
(let ((em (make-summary-email mr mls)))
(send-notification-email em)))
)

104
src/qr-payment.scm Normal file
View file

@ -0,0 +1,104 @@
;;
;; qr-payment.scm
;;
;; QR payment generator.
;;
;; ISC License
;;
;; Copyright 2023-2025 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 qr-payment))
(module
qr-payment
(
make-qrp
make-brmlab-qrp
make-brmlab-qrp-svg-string
)
(import scheme
(chicken format)
(chicken string)
(chicken base)
util-io)
(define (make-empty-qrp . vs)
(let ((v (if (null? vs) "1.0" (car vs))))
(list v "SPD")))
(define (add-field-to-qrp qrp key value)
(cons (format "~A:~A" key value)
qrp))
(define (serialize-qrp qrp)
(string-intersperse (reverse qrp) "*"))
(define (ensure-amount-format amt)
(let* ((n (if (string? amt)
(string->number amt)
amt))
(s (number->string n))
(f (string-split s "."))
(i? (null? (cdr f))))
(format "~A.~A"
(car f)
(if i?
"00"
(substring
(string-append (cadr f) "0")
0 2)))))
(define (make-qrp iban amt cc vs msg)
(let loop ((keys '(ACC AM CC MSG X-VS))
(vals (list iban (ensure-amount-format amt) cc msg vs))
(qrp (make-empty-qrp)))
(if (null? keys)
(serialize-qrp qrp)
(loop (cdr keys)
(cdr vals)
(add-field-to-qrp qrp (car keys) (car vals))))))
(define (make-brmlab-qrp amt cc vs)
(let ((iban (if (equal? cc "CZK")
"CZ0520100000002500079551"
(if (equal? cc "EUR")
"CZ9320100000002100079552"
(error "Invalid currency!")))))
(make-qrp iban amt cc vs "Brmlab")))
(define (qrp-create-svg-string qrps)
(let-values
(((ec ol)
(get-process-exit+output-lines
"qrencode"
"-t" "svg"
"--inline"
"-o" "-"
"-l" "M"
qrps)))
(if (eq? ec 0)
(string-intersperse ol "\n")
#f)))
(define (make-brmlab-qrp-svg-string amt cc vs)
(qrp-create-svg-string
(make-brmlab-qrp amt cc vs)))
)

View file

@ -366,7 +366,6 @@
slw))
state)))
(let ((sln (sgr-list-neutralize sl)))
;;(write sln)(newline)
(values (list sln) initial-state))))
;; Renders all the lines and appends the resulting blocks

View file

@ -204,8 +204,6 @@
(tbl1 (render-cells-widths ptbl col-widths))
;;(_ (print tbl1))
(tbl2 (map expand-row-height tbl1)))
;;(write tbl1)(newline)
;;(write tbl2)(newline)
;; Just return the result - both the table and cached column widths
(values tbl2
col-widths))))

View file

@ -88,7 +88,6 @@
(borders (expand-table-style border-spec num-columns num-rows))
(col-separators (table-col-separators? borders))
(rows (merge-rows ptbl borders col-separators unicode?)))
;;(write rows)(newline)
(let loop ((rows rows)
(borders borders)
(res '())

View file

@ -5,7 +5,7 @@
;;
;; ISC License
;;
;; Copyright 2023 Brmlab, z.s.
;; Copyright 2023-2025 Brmlab, z.s.
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
;;
;; Permission to use, copy, modify, and/or distribute this software
@ -39,7 +39,7 @@
(chicken format))
;; Short banner
(define banner-line "HackerBase 1.15.1 (c) 2023 Brmlab, z.s.")
(define banner-line "HackerBase 1.19-dev (c) 2023-2025 Brmlab, z.s.")
;; Banner source with numbers for ANSI CSI SGR
(define banner-source "

View file

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

View file

@ -5,7 +5,7 @@
;;
;; ISC License
;;
;; Copyright 2023 Brmlab, z.s.
;; Copyright 2023-2024 Brmlab, z.s.
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
;;
;; Permission to use, copy, modify, and/or distribute this software
@ -39,6 +39,8 @@
(chicken base)
(chicken keyword)
(chicken string)
(chicken irregex)
(chicken format)
util-io
util-utf8
util-string
@ -61,6 +63,14 @@ sent to the address stored within.")
"?=")
subj))
;; Extracts only usernam@domain from given full RFC email address
(define (extract-email-email str)
(let* ((irr (irregex "(?:\"?([^\"]*)\"?\\s)?(?:<?(.+@[^>]+)>?)"))
(em (irregex-match irr str))
(name (irregex-match-substring em 1))
(email (irregex-match-substring em 2)))
email))
;; Sends an email using the UNIX mail(1) utility.
(define*/doc (send-mail body-lines
#:from (from #f)
@ -83,17 +93,22 @@ Sends email using mail(1) command. The arguments ```#:to``` and
tos))
(header-args
(flatten
(map
(lambda (h) (list "-a" h))
headers))))
(apply process-send/recv
"mail"
(append (if from
(list "-r" from)
'())
(list "-s" (encode-subject subject))
real-tos
header-args)
body-lines)))
(append
(if from (list (sprintf "From: ~A" from)) '())
(map
(lambda (h) (list "-a" h))
headers)))))
(let ((from-email (if from
(extract-email-email from)
#f)))
(apply process-send/recv
"mail"
(append (if from
(list "-r" from-email)
'())
(list "-s" (encode-subject subject))
real-tos
header-args)
body-lines))))
)

View file

@ -39,11 +39,12 @@ 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)
(define*/doc (parser-preprocess-line line #:strip-comments? (strip-comments? #t))
("* ```line``` - a string with contents of one source line
If the input ```line``` contains the ```#``` character, the rest of
@ -62,7 +63,9 @@ Returns a string representing the preprocessed line.")
(ploop (add1 pidx)))))
(hpos (let hloop ((hidx ppos))
(if (or (= hidx llen)
(eq? (string-ref line hidx) #\#))
(and (or strip-comments?
(= hidx 0))
(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 '())
(rpending chars)
(pending 0)
(expected #f)
(res '()))
(if (null? bytes)
(values (reverse res)
(reverse rpending))
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)
(cons byte rpending)
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 #b11000000) #b11000000)
(cond ((= (bitwise-and byte #b11100000) #b11000000)
(values (bitwise-and byte #b11111)
2))
((= (bitwise-and byte #b11100000) #b11100000)
((= (bitwise-and byte #b11110000) #b11100000)
(values (bitwise-and byte #b1111)
3))
((= (bitwise-and byte #b11110000) #b11110000)
((= (bitwise-and byte #b11111000) #b11110000)
(values (bitwise-and byte #b111)
4))
(else
;; Should not happen
(values 0 0)))))
(loop (cdr bytes)
(list byte)
bytes
(arithmetic-shift first-byte 6)
(sub1 char-bytes)
res))))))))))