Compare commits
No commits in common. "master" and "v1.10" have entirely different histories.
52 changed files with 1079 additions and 2201 deletions
205
CHANGELOG.md
205
CHANGELOG.md
|
|
@ -1,205 +0,0 @@
|
||||||
ChangeLog
|
|
||||||
=========
|
|
||||||
|
|
||||||
1.19 - released 2025-04-16
|
|
||||||
--------------------------
|
|
||||||
|
|
||||||
* manpage updated
|
|
||||||
* added -n option for dry-runs
|
|
||||||
* removed mailman 2.x support
|
|
||||||
* added "councilml" start/stop support for member files
|
|
||||||
|
|
||||||
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 - 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 - released 2023-12-05
|
|
||||||
--------------------------
|
|
||||||
|
|
||||||
* add dokuwiki problems to summary emails
|
|
||||||
* handle more SEPA payments
|
|
||||||
|
|
||||||
1.12 - released 2023-11-16
|
|
||||||
--------------------------
|
|
||||||
|
|
||||||
* switch to eggs: srfi-1, sqlite3
|
|
||||||
* semi-automatic export for brmdoor
|
|
||||||
* improvements of summary emails for council
|
|
||||||
* redirect dokuwiki plugin to login page if not logged in
|
|
||||||
* sync council and revision mailing lists
|
|
||||||
|
|
||||||
1.11 - released 2023-09-23
|
|
||||||
--------------------------
|
|
||||||
|
|
||||||
* add support for CC in emails
|
|
||||||
* update manual page
|
|
||||||
* setup new cron jobs
|
|
||||||
|
|
||||||
1.10 - released 2023-09-17
|
|
||||||
--------------------------
|
|
||||||
|
|
||||||
* direct access of mailman 3 database
|
|
||||||
|
|
||||||
1.9 - released 2023-09-16
|
|
||||||
-------------------------
|
|
||||||
|
|
||||||
* implement support for mailman 3
|
|
||||||
* add total debt to long-term debtors listings
|
|
||||||
|
|
||||||
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 - 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.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 - released 2023-06-19
|
|
||||||
-------------------------
|
|
||||||
|
|
||||||
* improved table renderer
|
|
||||||
* show membership fees and payments balances history
|
|
||||||
* improved generator of static web pages
|
|
||||||
|
|
||||||
1.4 - released 2023-05-26
|
|
||||||
-------------------------
|
|
||||||
|
|
||||||
* vim and joe syntax highlighting support
|
|
||||||
* improved Fio bank statement fetcher and merger
|
|
||||||
|
|
||||||
1.3 - released 2023-05-22
|
|
||||||
-------------------------
|
|
||||||
|
|
||||||
* organizational bodies membership
|
|
||||||
|
|
||||||
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 - 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 - released 2023-04-23
|
|
||||||
-------------------------
|
|
||||||
|
|
||||||
This was the first oficially released version which contains all the
|
|
||||||
functionality required to take over the original solution.
|
|
||||||
|
|
||||||
* parsing and interpreting member files with specified grammar
|
|
||||||
* basic support for start/stop periods
|
|
||||||
* command-line arguments support with integrated help display
|
|
||||||
* static builds
|
|
||||||
* cards export for BrmDoor project
|
|
||||||
* data validation and error reporting
|
|
||||||
* improved manual credit handling
|
|
||||||
* member id validation and generation
|
|
||||||
* export of gnuplot-compatible statistics
|
|
||||||
* static web data generation
|
|
||||||
* table formatting with color support
|
|
||||||
* member fees and payments accounting
|
|
||||||
* support for multiple join/destroy periods
|
|
||||||
* period-based exchange rates lookups
|
|
||||||
* unpaired transactions handling
|
|
||||||
* internal ML membership check
|
|
||||||
* notifications for both council and members with debts
|
|
||||||
* universal Fio bank account statement fetcher
|
|
||||||
* preliminary SEPA payment parsing
|
|
||||||
* programming modules documentation
|
|
||||||
* git status support
|
|
||||||
* sample configuration
|
|
||||||
* manual page
|
|
||||||
10
README.md
10
README.md
|
|
@ -9,7 +9,7 @@ License
|
||||||
|
|
||||||
ISC License
|
ISC License
|
||||||
|
|
||||||
Copyright 2023-2024 Brmlab, z.s.
|
Copyright 2023 Brmlab, z.s.
|
||||||
Dominik Pantůček <dominik.pantucek@trustica.cz>
|
Dominik Pantůček <dominik.pantucek@trustica.cz>
|
||||||
|
|
||||||
Permission to use, copy, modify, and/or distribute this software
|
Permission to use, copy, modify, and/or distribute this software
|
||||||
|
|
@ -46,7 +46,6 @@ Features
|
||||||
* computing member balance
|
* computing member balance
|
||||||
* generating static web output for member pages in dokuwiki
|
* generating static web output for member pages in dokuwiki
|
||||||
* exporting brmdoor cards lists
|
* exporting brmdoor cards lists
|
||||||
* synchronization of mailinglist subscriptions with member files
|
|
||||||
|
|
||||||
Requirements
|
Requirements
|
||||||
------------
|
------------
|
||||||
|
|
@ -58,9 +57,6 @@ Build requirements:
|
||||||
|
|
||||||
* Chicken Scheme 5
|
* Chicken Scheme 5
|
||||||
* make (tested with GNU make)
|
* make (tested with GNU make)
|
||||||
* Chicken eggs (chicken-install)
|
|
||||||
* sqlite3
|
|
||||||
* srfi-1
|
|
||||||
|
|
||||||
Runtime requirements:
|
Runtime requirements:
|
||||||
|
|
||||||
|
|
@ -72,10 +68,6 @@ Runtime requirements:
|
||||||
Building
|
Building
|
||||||
--------
|
--------
|
||||||
|
|
||||||
All the eggs used are installed in the source tree using:
|
|
||||||
|
|
||||||
sh install-eggs.sh
|
|
||||||
|
|
||||||
Building static binary:
|
Building static binary:
|
||||||
|
|
||||||
make static
|
make static
|
||||||
|
|
|
||||||
|
|
@ -257,6 +257,24 @@ pair consisting of symbol created by interning the string of
|
||||||
non-whitespace characters before the first whitespace character and
|
non-whitespace characters before the first whitespace character and
|
||||||
the string with the rest of the line.
|
the string with the rest of the line.
|
||||||
|
|
||||||
|
## util-list [module]
|
||||||
|
|
||||||
|
(import util-list)
|
||||||
|
|
||||||
|
This module implements basic list functionality which is common in
|
||||||
|
most scheme implementations.
|
||||||
|
|
||||||
|
### filter [procedure]
|
||||||
|
|
||||||
|
(filter pred?
|
||||||
|
lst)
|
||||||
|
|
||||||
|
* ```pred?``` - procedure accepting any value and returning #t or #f
|
||||||
|
* ```lst``` - list to be filtered
|
||||||
|
|
||||||
|
Returns a list containing only elements matching given ```pred?```
|
||||||
|
predicate.
|
||||||
|
|
||||||
## util-proc [module]
|
## util-proc [module]
|
||||||
|
|
||||||
(import util-proc)
|
(import util-proc)
|
||||||
|
|
@ -388,16 +406,6 @@ quoted-printable sequences.
|
||||||
Returns the ```str``` with all characters converted to upper case
|
Returns the ```str``` with all characters converted to upper case
|
||||||
using ```char-upcase```. Does not work with UTF-8.
|
using ```char-upcase```. Does not work with UTF-8.
|
||||||
|
|
||||||
### string-capitalize [procedure]
|
|
||||||
|
|
||||||
(string-capitalize str)
|
|
||||||
|
|
||||||
* ```str``` - arbitrary string
|
|
||||||
|
|
||||||
Returns the ```str``` with the first character converted to upper case
|
|
||||||
using ```char-upcase``` and the remainder converted to lower case
|
|
||||||
using ```char-downcase```. Does not work with UTF-8.
|
|
||||||
|
|
||||||
## util-mail [module]
|
## util-mail [module]
|
||||||
|
|
||||||
(import util-mail)
|
(import util-mail)
|
||||||
|
|
@ -420,14 +428,12 @@ sent to the address stored within.
|
||||||
(send-mail body-lines
|
(send-mail body-lines
|
||||||
#:from (from #f)
|
#:from (from #f)
|
||||||
#:to to
|
#:to to
|
||||||
#:subject subject
|
#:subject subject)
|
||||||
#:headers (headers (quote ())))
|
|
||||||
|
|
||||||
* ```body-lines``` - lines of the email
|
* ```body-lines``` - lines of the email
|
||||||
* ```from``` - email address from string
|
* ```from``` - email address from string
|
||||||
* ```to``` - email address to string
|
* ```to``` - email address to string
|
||||||
* ```subject``` - email subject string
|
* ```subject``` - email subject string
|
||||||
* ```headers``` - list of headers to add
|
|
||||||
|
|
||||||
Sends email using mail(1) command. The arguments ```#:to``` and
|
Sends email using mail(1) command. The arguments ```#:to``` and
|
||||||
```#:subject``` are mandatory. Argument ```#:from``` is optional.
|
```#:subject``` are mandatory. Argument ```#:from``` is optional.
|
||||||
|
|
|
||||||
|
|
@ -29,6 +29,3 @@ mailman3-sql 1
|
||||||
|
|
||||||
# The path to SQLite3 DB file
|
# The path to SQLite3 DB file
|
||||||
mailman3-sql-path /var/lib/mailman3/data/mailman.db
|
mailman3-sql-path /var/lib/mailman3/data/mailman.db
|
||||||
|
|
||||||
# Default notifications CC
|
|
||||||
notifications-cc rada@brmlab.cz
|
|
||||||
|
|
|
||||||
|
|
@ -56,6 +56,7 @@ Processed source is scanned for known keys. Known keys are:
|
||||||
* nick
|
* nick
|
||||||
* name
|
* name
|
||||||
* mail
|
* mail
|
||||||
|
* phone
|
||||||
* born
|
* born
|
||||||
|
|
||||||
Multiple instances of single key are considered an error.
|
Multiple instances of single key are considered an error.
|
||||||
|
|
@ -82,7 +83,6 @@ line numbers as the value for such key. Multikeys are:
|
||||||
* revisionstop
|
* revisionstop
|
||||||
* grantstart
|
* grantstart
|
||||||
* grantstop
|
* grantstop
|
||||||
* phone
|
|
||||||
|
|
||||||
The result is a valid dictionary of keys and multikeys.
|
The result is a valid dictionary of keys and multikeys.
|
||||||
|
|
||||||
|
|
@ -104,8 +104,7 @@ periods.
|
||||||
The joined key is converted into a month value.
|
The joined key is converted into a month value.
|
||||||
|
|
||||||
Card and desfire lists are parsed to get lists of card id and optional
|
Card and desfire lists are parsed to get lists of card id and optional
|
||||||
comment. The same processing is used for phone to support multiple
|
comment.
|
||||||
phone numbers.
|
|
||||||
|
|
||||||
Credit list is parsed to get a list of amounts and optional comments.
|
Credit list is parsed to get a list of amounts and optional comments.
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -223,18 +223,6 @@ Base directory of DokuWiki installation.
|
||||||
.B \-count \fRcount
|
.B \-count \fRcount
|
||||||
Maximum count of transactions shown in member detail view.
|
Maximum count of transactions shown in member detail view.
|
||||||
|
|
||||||
.TP
|
|
||||||
.B \-mailman \fRver
|
|
||||||
Sets the mailman version. Can be \fB2 \fRor \fB3\fR.
|
|
||||||
|
|
||||||
.TP
|
|
||||||
.B \-mailman-sql
|
|
||||||
Enable direct access to mailman 3.x SQLite3 database.
|
|
||||||
|
|
||||||
.TP
|
|
||||||
.B \-mailman3-sql-path \fRpath
|
|
||||||
Sets the full path to mailman 3.x SQLite3 database file.
|
|
||||||
|
|
||||||
.TP
|
.TP
|
||||||
.B \-from \fRemail
|
.B \-from \fRemail
|
||||||
Specify sender email address. The value read from configuration file
|
Specify sender email address. The value read from configuration file
|
||||||
|
|
@ -273,6 +261,10 @@ Specify member by nickname.
|
||||||
.B \-destroyed
|
.B \-destroyed
|
||||||
Show destroyed members in \fB-fees\fR action as well.
|
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"
|
.SH "FILES"
|
||||||
|
|
||||||
All the information about members is stored in in members file in the
|
All the information about members is stored in in members file in the
|
||||||
|
|
|
||||||
|
|
@ -33,10 +33,6 @@ class action_plugin_hackerbase extends DokuWiki_Action_Plugin
|
||||||
if ($act === 'payments') {
|
if ($act === 'payments') {
|
||||||
global $INPUT;
|
global $INPUT;
|
||||||
$user = $INPUT->server->str('REMOTE_USER');
|
$user = $INPUT->server->str('REMOTE_USER');
|
||||||
if (strlen($user) === 0) {
|
|
||||||
header("Location: /start?do=login");
|
|
||||||
die();
|
|
||||||
}
|
|
||||||
echo file_get_contents($this->getConf("htmlexports") . '/' . $user . ".html");
|
echo file_get_contents($this->getConf("htmlexports") . '/' . $user . ".html");
|
||||||
die();
|
die();
|
||||||
} else if ($act === 'brmstatus') {
|
} else if ($act === 'brmstatus') {
|
||||||
|
|
|
||||||
|
|
@ -1,60 +0,0 @@
|
||||||
#!/bin/sh
|
|
||||||
#
|
|
||||||
# install-eggs.sh
|
|
||||||
#
|
|
||||||
# Local installer of CHICKEN eggs required for building.
|
|
||||||
#
|
|
||||||
# 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.
|
|
||||||
#
|
|
||||||
|
|
||||||
# Source root directory
|
|
||||||
owd=$(pwd)
|
|
||||||
cd $(dirname "$0")
|
|
||||||
SRCDIR=$(pwd)
|
|
||||||
cd "$owd"
|
|
||||||
|
|
||||||
# Make temporary prefix directory (eggs shared throwaway files)
|
|
||||||
TMPDIR=$(mktemp -d)
|
|
||||||
|
|
||||||
# Installs given egg locally
|
|
||||||
chicken_install() {
|
|
||||||
echo "Installing $1 ..."
|
|
||||||
CHICKEN_INSTALL_PREFIX="$TMPDIR" \
|
|
||||||
CHICKEN_REPOSITORY_PATH="$SRCDIR/eggs":`chicken-install -repository` \
|
|
||||||
CHICKEN_INSTALL_REPOSITORY="$SRCDIR/eggs" \
|
|
||||||
chicken-install "$1" 2>&1 | \
|
|
||||||
sed -u 's/^/ /'
|
|
||||||
}
|
|
||||||
|
|
||||||
# Removes throwaway files
|
|
||||||
chicken_cleanup() {
|
|
||||||
echo "Cleaning up ..."
|
|
||||||
rm -fr ${TMPDIR}
|
|
||||||
}
|
|
||||||
|
|
||||||
# Always cleanup
|
|
||||||
trap chicken_cleanup INT QUIT
|
|
||||||
|
|
||||||
# Install required eggs
|
|
||||||
chicken_install sqlite3
|
|
||||||
chicken_install srfi-1
|
|
||||||
|
|
||||||
# Normal termination cleanup
|
|
||||||
chicken_cleanup
|
|
||||||
22
members-base-stats.gp
Normal file
22
members-base-stats.gp
Normal file
|
|
@ -0,0 +1,22 @@
|
||||||
|
set terminal pngcairo size 1000,600
|
||||||
|
set title "Members stats"
|
||||||
|
set output 'members-base-stats.png'
|
||||||
|
|
||||||
|
src='members-base-stats.data'
|
||||||
|
|
||||||
|
set timefmt "%Y-%m"
|
||||||
|
set xdata time
|
||||||
|
set format x "%Y-%m"
|
||||||
|
|
||||||
|
set xlabel "Month"
|
||||||
|
set ylabel "Members"
|
||||||
|
|
||||||
|
set grid
|
||||||
|
|
||||||
|
set key out right
|
||||||
|
|
||||||
|
plot[][0:] \
|
||||||
|
src u 1:3 w l t 'active', \
|
||||||
|
src u 1:4 w l t 'suspended', \
|
||||||
|
src u 1:5 w l t 'students', \
|
||||||
|
src u 1:6 w l t 'destroyed'
|
||||||
134
src/Makefile
134
src/Makefile
|
|
@ -29,10 +29,7 @@ default: imports
|
||||||
.PHONY: static
|
.PHONY: static
|
||||||
static: ../hackerbase
|
static: ../hackerbase
|
||||||
|
|
||||||
# Uses local repository first, then system. Be sure to run
|
CSC=csc
|
||||||
# install-eggs.sh in the parent directory first!
|
|
||||||
SCRP=$(shell chicken-install -repository)
|
|
||||||
CSC=CHICKEN_REPOSITORY_PATH=../eggs:$(SCRP) csc
|
|
||||||
|
|
||||||
HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm \
|
HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm \
|
||||||
command-line.import.scm mbase.import.scm brmember.import.scm \
|
command-line.import.scm mbase.import.scm brmember.import.scm \
|
||||||
|
|
@ -42,9 +39,7 @@ HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm \
|
||||||
tests.import.scm notifications.import.scm logging.import.scm \
|
tests.import.scm notifications.import.scm logging.import.scm \
|
||||||
progress.import.scm cal-period.import.scm \
|
progress.import.scm cal-period.import.scm \
|
||||||
util-stdout.import.scm export-web-static.import.scm \
|
util-stdout.import.scm export-web-static.import.scm \
|
||||||
dokuwiki.import.scm mailinglist.import.scm \
|
dokuwiki.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 \
|
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 \
|
cal-period.o ansi.o util-bst-ldict.o command-line.o mbase.o \
|
||||||
|
|
@ -58,28 +53,28 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \
|
||||||
util-git.o cal-day.o util-stdout.o cal-format.o table.o \
|
util-git.o cal-day.o util-stdout.o cal-format.o table.o \
|
||||||
sgr-list.o sgr-block.o table-processor.o table-border.o \
|
sgr-list.o sgr-block.o table-processor.o table-border.o \
|
||||||
table-style.o sgr-state.o util-utf8.o sgr-cell.o \
|
table-style.o sgr-state.o util-utf8.o sgr-cell.o \
|
||||||
template-list-expander.o box-drawing.o export-web-static.o \
|
template-list-expander.o box-drawing.o util-list.o \
|
||||||
util-dir.o dokuwiki.o racket-kwargs.o duck.o util-bst.o \
|
export-web-static.o util-dir.o dokuwiki.o racket-kwargs.o \
|
||||||
util-bst-bdict.o util-bst-ldict.o util-bst-lset.o \
|
duck.o util-bst.o util-bst-bdict.o util-bst-ldict.o \
|
||||||
mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o \
|
util-bst-lset.o mailman2.o mailman-common.o mailman3.o \
|
||||||
mailinglist.o export-sheet.o mbase-query.o qr-payment.o
|
mailman3-sql.o
|
||||||
|
|
||||||
GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \
|
GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \
|
||||||
util-time.import.scm util-csv.import.scm util-git.import.scm \
|
util-time.import.scm util-csv.import.scm util-git.import.scm \
|
||||||
util-io.import.scm util-stdout.import.scm \
|
util-io.import.scm util-stdout.import.scm \
|
||||||
util-parser.import.scm util-proc.import.scm \
|
util-parser.import.scm util-list.import.scm \
|
||||||
util-format.import.scm util-tag.import.scm \
|
util-proc.import.scm util-format.import.scm \
|
||||||
util-string.import.scm util-bst.import.scm \
|
util-tag.import.scm util-string.import.scm \
|
||||||
util-bst-bdict.import.scm util-bst-ldict.import.scm \
|
util-bst.import.scm util-bst-bdict.import.scm \
|
||||||
util-dir.import.scm util-utf8.import.scm util-mail.import.scm \
|
util-bst-ldict.import.scm util-dir.import.scm \
|
||||||
util-bst-lset.import.scm
|
util-utf8.import.scm
|
||||||
|
|
||||||
GENDOC-OBJS=gendoc.o duck-extract.o util-time.o util-csv.o util-io.o \
|
GENDOC-OBJS=gendoc.o duck-extract.o util-time.o util-csv.o util-io.o \
|
||||||
progress.o testing.o util-proc.o util-git.o util-io.o \
|
progress.o testing.o util-proc.o util-git.o util-io.o \
|
||||||
util-stdout.o util-parser.o util-proc.o util-format.o \
|
util-stdout.o util-parser.o util-list.o util-proc.o \
|
||||||
racket-kwargs.o util-bst-ldict.o util-tag.o duck.o \
|
util-format.o racket-kwargs.o util-bst-ldict.o util-tag.o \
|
||||||
util-string.o util-bst.o util-bst-bdict.o util-bst-ldict.o \
|
duck.o util-string.o util-bst.o util-bst-bdict.o \
|
||||||
util-dir.o util-utf8.o util-bst-lset.o util-mail.o
|
util-bst-ldict.o util-dir.o util-utf8.o
|
||||||
|
|
||||||
.PHONY: imports
|
.PHONY: imports
|
||||||
imports: $(HACKERBASE-DEPS)
|
imports: $(HACKERBASE-DEPS)
|
||||||
|
|
@ -143,13 +138,13 @@ LISTING-SOURCES=listing.scm testing.import.scm ansi.import.scm \
|
||||||
listing.o: listing.import.scm
|
listing.o: listing.import.scm
|
||||||
listing.import.scm: $(LISTING-SOURCES)
|
listing.import.scm: $(LISTING-SOURCES)
|
||||||
|
|
||||||
ANSI-SOURCES=ansi.scm testing.import.scm
|
ANSI-SOURCES=ansi.scm testing.import.scm util-list.import.scm
|
||||||
|
|
||||||
ansi.o: ansi.import.scm
|
ansi.o: ansi.import.scm
|
||||||
ansi.import.scm: $(ANSI-SOURCES)
|
ansi.import.scm: $(ANSI-SOURCES)
|
||||||
|
|
||||||
COMMAND-LINE-SOURCES=command-line.scm testing.import.scm \
|
COMMAND-LINE-SOURCES=command-line.scm testing.import.scm \
|
||||||
util-proc.import.scm
|
util-proc.import.scm util-list.import.scm
|
||||||
|
|
||||||
command-line.o: command-line.import.scm
|
command-line.o: command-line.import.scm
|
||||||
command-line.import.scm: $(COMMAND-LINE-SOURCES)
|
command-line.import.scm: $(COMMAND-LINE-SOURCES)
|
||||||
|
|
@ -159,12 +154,13 @@ MBASE-SOURCES=mbase.scm testing.import.scm util-bst-ldict.import.scm \
|
||||||
cal-period.import.scm cal-month.import.scm \
|
cal-period.import.scm cal-month.import.scm \
|
||||||
configuration.import.scm progress.import.scm \
|
configuration.import.scm progress.import.scm \
|
||||||
mbase-dir.import.scm util-tag.import.scm \
|
mbase-dir.import.scm util-tag.import.scm \
|
||||||
racket-kwargs.import.scm util-bst-bdict.import.scm
|
racket-kwargs.import.scm util-bst-bdict.import.scm \
|
||||||
|
util-list.import.scm
|
||||||
|
|
||||||
mbase.o: mbase.import.scm
|
mbase.o: mbase.import.scm
|
||||||
mbase.import.scm: $(MBASE-SOURCES)
|
mbase.import.scm: $(MBASE-SOURCES)
|
||||||
|
|
||||||
PRIMES-SOURCES=primes.scm testing.import.scm
|
PRIMES-SOURCES=primes.scm testing.import.scm util-list.import.scm
|
||||||
|
|
||||||
primes.o: primes.import.scm
|
primes.o: primes.import.scm
|
||||||
primes.import.scm: $(PRIMES-SOURCES)
|
primes.import.scm: $(PRIMES-SOURCES)
|
||||||
|
|
@ -172,7 +168,8 @@ primes.import.scm: $(PRIMES-SOURCES)
|
||||||
BRMEMBER-SOURCES=brmember.scm util-bst-ldict.import.scm \
|
BRMEMBER-SOURCES=brmember.scm util-bst-ldict.import.scm \
|
||||||
cal-period.import.scm testing.import.scm cal-month.import.scm \
|
cal-period.import.scm testing.import.scm cal-month.import.scm \
|
||||||
configuration.import.scm primes.import.scm \
|
configuration.import.scm primes.import.scm \
|
||||||
bank-account.import.scm util-tag.import.scm
|
bank-account.import.scm util-tag.import.scm \
|
||||||
|
util-list.import.scm
|
||||||
|
|
||||||
brmember.o: brmember.import.scm
|
brmember.o: brmember.import.scm
|
||||||
brmember.import.scm: $(BRMEMBER-SOURCES)
|
brmember.import.scm: $(BRMEMBER-SOURCES)
|
||||||
|
|
@ -188,7 +185,7 @@ progress.o: progress.import.scm
|
||||||
progress.import.scm: $(PROGRESS-SOURCES)
|
progress.import.scm: $(PROGRESS-SOURCES)
|
||||||
|
|
||||||
EXPORT-CARDS-SOURCES=export-cards.scm util-bst-ldict.import.scm \
|
EXPORT-CARDS-SOURCES=export-cards.scm util-bst-ldict.import.scm \
|
||||||
mbase.import.scm brmember.import.scm configuration.import.scm
|
mbase.import.scm brmember.import.scm
|
||||||
|
|
||||||
export-cards.o: export-cards.import.scm
|
export-cards.o: export-cards.import.scm
|
||||||
export-cards.import.scm: $(EXPORT-CARDS-SOURCES)
|
export-cards.import.scm: $(EXPORT-CARDS-SOURCES)
|
||||||
|
|
@ -197,7 +194,8 @@ BRMEMBER-PARSER-SOURCES=brmember-parser.scm brmember.import.scm \
|
||||||
testing.import.scm util-bst-ldict.import.scm \
|
testing.import.scm util-bst-ldict.import.scm \
|
||||||
cal-month.import.scm cal-period.import.scm \
|
cal-month.import.scm cal-period.import.scm \
|
||||||
configuration.import.scm util-string.import.scm \
|
configuration.import.scm util-string.import.scm \
|
||||||
util-parser.import.scm cal-day.import.scm
|
util-parser.import.scm cal-day.import.scm \
|
||||||
|
util-list.import.scm
|
||||||
|
|
||||||
brmember-parser.o: brmember-parser.import.scm
|
brmember-parser.o: brmember-parser.import.scm
|
||||||
brmember-parser.import.scm: $(BRMEMBER-PARSER-SOURCES)
|
brmember-parser.import.scm: $(BRMEMBER-PARSER-SOURCES)
|
||||||
|
|
@ -209,22 +207,23 @@ MEMBERS-PRINT-SOURCES=members-print.scm util-bst-ldict.import.scm \
|
||||||
bank-account.import.scm members-fees.import.scm \
|
bank-account.import.scm members-fees.import.scm \
|
||||||
members-payments.import.scm brmember-format.import.scm \
|
members-payments.import.scm brmember-format.import.scm \
|
||||||
specification.import.scm cal-format.import.scm \
|
specification.import.scm cal-format.import.scm \
|
||||||
util-git.import.scm racket-kwargs.import.scm \
|
util-git.import.scm util-list.import.scm \
|
||||||
tiocgwinsz.import.scm
|
racket-kwargs.import.scm
|
||||||
|
|
||||||
members-print.o: members-print.import.scm
|
members-print.o: members-print.import.scm
|
||||||
members-print.import.scm: $(MEMBERS-PRINT-SOURCES)
|
members-print.import.scm: $(MEMBERS-PRINT-SOURCES)
|
||||||
|
|
||||||
MEMBERS-FEES-SOURCES=members-fees.scm configuration.import.scm \
|
MEMBERS-FEES-SOURCES=members-fees.scm configuration.import.scm \
|
||||||
brmember.import.scm cal-month.import.scm table.import.scm \
|
brmember.import.scm cal-month.import.scm table.import.scm \
|
||||||
mbase.import.scm specification.import.scm
|
mbase.import.scm specification.import.scm \
|
||||||
|
util-list.import.scm
|
||||||
|
|
||||||
members-fees.o: members-fees.import.scm
|
members-fees.o: members-fees.import.scm
|
||||||
members-fees.import.scm: $(MEMBERS-FEES-SOURCES)
|
members-fees.import.scm: $(MEMBERS-FEES-SOURCES)
|
||||||
|
|
||||||
MBASE-DIR-SOURCES=mbase-dir.scm testing.import.scm \
|
MBASE-DIR-SOURCES=mbase-dir.scm testing.import.scm \
|
||||||
util-bst-ldict.import.scm brmember.import.scm \
|
util-bst-ldict.import.scm brmember.import.scm \
|
||||||
brmember-parser.import.scm
|
brmember-parser.import.scm util-list.import.scm
|
||||||
|
|
||||||
mbase-dir.o: mbase-dir.import.scm
|
mbase-dir.o: mbase-dir.import.scm
|
||||||
mbase-dir.import.scm: $(MBASE-DIR-SOURCES)
|
mbase-dir.import.scm: $(MBASE-DIR-SOURCES)
|
||||||
|
|
@ -250,7 +249,7 @@ MEMBERS-PAYMENTS-SOURCES=members-payments.scm bank-account.import.scm \
|
||||||
util-bst-ldict.import.scm members-fees.import.scm \
|
util-bst-ldict.import.scm members-fees.import.scm \
|
||||||
cal-period.import.scm configuration.import.scm \
|
cal-period.import.scm configuration.import.scm \
|
||||||
progress.import.scm bank-fio.import.scm \
|
progress.import.scm bank-fio.import.scm \
|
||||||
specification.import.scm
|
specification.import.scm util-list.import.scm
|
||||||
|
|
||||||
members-payments.o: members-payments.import.scm
|
members-payments.o: members-payments.import.scm
|
||||||
members-payments.import.scm: $(MEMBERS-PAYMENTS-SOURCES)
|
members-payments.import.scm: $(MEMBERS-PAYMENTS-SOURCES)
|
||||||
|
|
@ -260,6 +259,13 @@ ENVIRONMENT-SOURCES=environment.scm ansi.import.scm
|
||||||
environment.o: environment.import.scm
|
environment.o: environment.import.scm
|
||||||
environment.import.scm: $(ENVIRONMENT-SOURCES)
|
environment.import.scm: $(ENVIRONMENT-SOURCES)
|
||||||
|
|
||||||
|
MAILMAN2-SOURCES=mailman2.scm util-bst-lset.import.scm \
|
||||||
|
util-io.import.scm util-list.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-SOURCES=util-time.scm duck.import.scm
|
||||||
|
|
||||||
util-time.o: util-time.import.scm
|
util-time.o: util-time.import.scm
|
||||||
|
|
@ -287,7 +293,7 @@ util-io.o: util-io.import.scm
|
||||||
util-io.import.scm: $(UTIL-IO-SOURCES)
|
util-io.import.scm: $(UTIL-IO-SOURCES)
|
||||||
|
|
||||||
UTIL-PARSER-SOURCES=util-parser.scm testing.import.scm \
|
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.o: util-parser.import.scm
|
||||||
util-parser.import.scm: $(UTIL-PARSER-SOURCES)
|
util-parser.import.scm: $(UTIL-PARSER-SOURCES)
|
||||||
|
|
@ -328,8 +334,7 @@ NOTIFICATIONS-SOURCES=notifications.scm brmember.import.scm \
|
||||||
brmember-format.import.scm configuration.import.scm \
|
brmember-format.import.scm configuration.import.scm \
|
||||||
util-time.import.scm members-fees.import.scm mbase.import.scm \
|
util-time.import.scm members-fees.import.scm mbase.import.scm \
|
||||||
members-print.import.scm table.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.o: notifications.import.scm
|
||||||
notifications.import.scm: $(NOTIFICATIONS-SOURCES)
|
notifications.import.scm: $(NOTIFICATIONS-SOURCES)
|
||||||
|
|
@ -465,11 +470,15 @@ BOX-DRAWING-SOURCES=box-drawing.scm util-utf8.import.scm \
|
||||||
box-drawing.o: box-drawing.import.scm
|
box-drawing.o: box-drawing.import.scm
|
||||||
box-drawing.import.scm: $(BOX-DRAWING-SOURCES)
|
box-drawing.import.scm: $(BOX-DRAWING-SOURCES)
|
||||||
|
|
||||||
|
UTIL-LIST-SOURCES=util-list.scm testing.import.scm duck.import.scm
|
||||||
|
|
||||||
|
util-list.o: util-list.import.scm
|
||||||
|
util-list.import.scm: $(UTIL-LIST-SOURCES)
|
||||||
|
|
||||||
EXPORT-WEB-STATIC-SOURCES=export-web-static.scm brmember.import.scm \
|
EXPORT-WEB-STATIC-SOURCES=export-web-static.scm brmember.import.scm \
|
||||||
util-dir.import.scm mbase.import.scm \
|
util-dir.import.scm mbase.import.scm \
|
||||||
members-payments.import.scm cal-day.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.o: export-web-static.import.scm
|
||||||
export-web-static.import.scm: $(EXPORT-WEB-STATIC-SOURCES)
|
export-web-static.import.scm: $(EXPORT-WEB-STATIC-SOURCES)
|
||||||
|
|
@ -515,14 +524,16 @@ util-bst-ldict.o: util-bst-ldict.import.scm
|
||||||
util-bst-ldict.import.scm: $(UTIL-BST-LDICT-SOURCES)
|
util-bst-ldict.import.scm: $(UTIL-BST-LDICT-SOURCES)
|
||||||
|
|
||||||
UTIL-BST-LSET-SOURCES=util-bst-lset.scm util-bst.import.scm \
|
UTIL-BST-LSET-SOURCES=util-bst-lset.scm util-bst.import.scm \
|
||||||
racket-kwargs.import.scm util-bst-ldict.import.scm
|
racket-kwargs.import.scm util-bst-ldict.import.scm \
|
||||||
|
util-list.import.scm
|
||||||
|
|
||||||
util-bst-lset.o: util-bst-lset.import.scm
|
util-bst-lset.o: util-bst-lset.import.scm
|
||||||
util-bst-lset.import.scm: $(UTIL-BST-LSET-SOURCES)
|
util-bst-lset.import.scm: $(UTIL-BST-LSET-SOURCES)
|
||||||
|
|
||||||
MAILMAN-SOURCES=mailman.scm mailman-common.import.scm \
|
MAILMAN-SOURCES=mailman.scm mailman2.import.scm \
|
||||||
util-bst-lset.import.scm configuration.import.scm \
|
mailman-common.import.scm util-bst-lset.import.scm \
|
||||||
mailman3.import.scm progress.import.scm
|
configuration.import.scm mailman3.import.scm \
|
||||||
|
progress.import.scm
|
||||||
|
|
||||||
mailman.o: mailman.import.scm
|
mailman.o: mailman.import.scm
|
||||||
mailman.import.scm: $(MAILMAN-SOURCES)
|
mailman.import.scm: $(MAILMAN-SOURCES)
|
||||||
|
|
@ -533,7 +544,8 @@ mailman-common.o: mailman-common.import.scm
|
||||||
mailman-common.import.scm: $(MAILMAN-COMMON-SOURCES)
|
mailman-common.import.scm: $(MAILMAN-COMMON-SOURCES)
|
||||||
|
|
||||||
MAILMAN3-SOURCES=mailman3.scm configuration.import.scm \
|
MAILMAN3-SOURCES=mailman3.scm configuration.import.scm \
|
||||||
util-io.import.scm mailman3-sql.import.scm
|
util-io.import.scm mailman3-sql.import.scm \
|
||||||
|
util-list.import.scm
|
||||||
|
|
||||||
mailman3.o: mailman3.import.scm
|
mailman3.o: mailman3.import.scm
|
||||||
mailman3.import.scm: $(MAILMAN3-SOURCES)
|
mailman3.import.scm: $(MAILMAN3-SOURCES)
|
||||||
|
|
@ -542,37 +554,3 @@ MAILMAN3-SQL-SOURCES=mailman3-sql.scm configuration.import.scm
|
||||||
|
|
||||||
mailman3-sql.o: mailman3-sql.import.scm
|
mailman3-sql.o: mailman3-sql.import.scm
|
||||||
mailman3-sql.import.scm: $(MAILMAN3-SQL-SOURCES)
|
mailman3-sql.import.scm: $(MAILMAN3-SQL-SOURCES)
|
||||||
|
|
||||||
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)
|
|
||||||
|
|
|
||||||
|
|
@ -50,7 +50,7 @@
|
||||||
(chicken string)
|
(chicken string)
|
||||||
(chicken irregex)
|
(chicken irregex)
|
||||||
(chicken keyword)
|
(chicken keyword)
|
||||||
srfi-1
|
util-list
|
||||||
testing)
|
testing)
|
||||||
|
|
||||||
;; Only basic ANSI colors and bold attribute support.
|
;; Only basic ANSI colors and bold attribute support.
|
||||||
|
|
|
||||||
|
|
@ -36,7 +36,7 @@
|
||||||
(chicken io)
|
(chicken io)
|
||||||
(chicken irregex)
|
(chicken irregex)
|
||||||
(chicken string)
|
(chicken string)
|
||||||
srfi-1
|
util-list
|
||||||
brmember
|
brmember
|
||||||
testing
|
testing
|
||||||
util-bst-ldict
|
util-bst-ldict
|
||||||
|
|
@ -48,7 +48,7 @@
|
||||||
cal-day)
|
cal-day)
|
||||||
|
|
||||||
;; Pass 2: known keys
|
;; Pass 2: known keys
|
||||||
(define mandatory-keys '(nick name mail))
|
(define mandatory-keys '(nick name mail phone))
|
||||||
(define optional-keys '(born))
|
(define optional-keys '(born))
|
||||||
(define known-multikeys
|
(define known-multikeys
|
||||||
'(card desfire
|
'(card desfire
|
||||||
|
|
@ -59,10 +59,7 @@
|
||||||
councilstart councilstop
|
councilstart councilstop
|
||||||
revisionstart revisionstop
|
revisionstart revisionstop
|
||||||
grantstart grantstop
|
grantstart grantstop
|
||||||
joined destroyed
|
joined destroyed))
|
||||||
feestart feestop
|
|
||||||
phone
|
|
||||||
councilmlstart councilmlstop))
|
|
||||||
(define ignored-keys '(mail2))
|
(define ignored-keys '(mail2))
|
||||||
|
|
||||||
(define known-keys (append mandatory-keys optional-keys))
|
(define known-keys (append mandatory-keys optional-keys))
|
||||||
|
|
@ -86,12 +83,6 @@
|
||||||
|
|
||||||
(joined member start)
|
(joined member start)
|
||||||
(destroyed member stop)
|
(destroyed member stop)
|
||||||
|
|
||||||
(feestart fee start)
|
|
||||||
(feestop fee stop)
|
|
||||||
|
|
||||||
(councilmlstart councilml start)
|
|
||||||
(councilmlstop councilml stop)
|
|
||||||
))
|
))
|
||||||
(define start-stop-markers (map car start-stop-markers-lookup))
|
(define start-stop-markers (map car start-stop-markers-lookup))
|
||||||
|
|
||||||
|
|
@ -118,33 +109,17 @@
|
||||||
(info
|
(info
|
||||||
,(lambda (mr output key value)
|
,(lambda (mr output key value)
|
||||||
(case key
|
(case key
|
||||||
((student suspend member revision chair council grant fee councilml)
|
((student suspend member revision chair council grant)
|
||||||
(let* ((res (period-markers->cal-periods value))
|
(let* ((res (period-markers->cal-periods value))
|
||||||
(ok? (car res))
|
(ok? (car res))
|
||||||
(periods0 (cadr res))
|
(periods (cadr res))
|
||||||
(periods
|
|
||||||
(if (eq? key 'fee)
|
|
||||||
(let ((ps
|
|
||||||
(map
|
|
||||||
(lambda (p)
|
|
||||||
(let* ((sc (cal-period-scomment p))
|
|
||||||
(scp (string-first+rest sc))
|
|
||||||
(amts (car scp))
|
|
||||||
(amt (string->number amts))
|
|
||||||
(rc (cdr scp)))
|
|
||||||
(set-cal-period-scomment
|
|
||||||
p
|
|
||||||
(list amt rc))))
|
|
||||||
periods0)))
|
|
||||||
ps)
|
|
||||||
periods0))
|
|
||||||
(msg (caddr res))
|
(msg (caddr res))
|
||||||
(line-number (cadddr res))
|
(line-number (cadddr res))
|
||||||
(mr1 (brmember-sub-set mr output key periods)))
|
(mr1 (brmember-sub-set mr output key periods)))
|
||||||
(if ok?
|
(if ok?
|
||||||
mr1
|
mr1
|
||||||
(brmember-add-highlight mr1 line-number msg 3 'error))))
|
(brmember-add-highlight mr1 line-number msg 3 'error))))
|
||||||
((card desfire phone)
|
((card desfire)
|
||||||
(brmember-sub-set mr output key
|
(brmember-sub-set mr output key
|
||||||
(map
|
(map
|
||||||
(lambda (rec)
|
(lambda (rec)
|
||||||
|
|
@ -278,7 +253,7 @@
|
||||||
(caar passes)
|
(caar passes)
|
||||||
(interpreter-pass mr pass-name (ldict-ref mr prev-name) pass-proc)))))))
|
(interpreter-pass mr pass-name (ldict-ref mr prev-name) pass-proc)))))))
|
||||||
|
|
||||||
;; Loads member file source. Performs passes 0-4
|
;; Loads member file source. Performs passes 0, 1 and 2.
|
||||||
(define (load-brmember-file mr)
|
(define (load-brmember-file mr)
|
||||||
(let* ((mrif (brmember-input-file mr))
|
(let* ((mrif (brmember-input-file mr))
|
||||||
(source (read-lines mrif))
|
(source (read-lines mrif))
|
||||||
|
|
|
||||||
|
|
@ -65,7 +65,6 @@
|
||||||
|
|
||||||
brmember-chair?
|
brmember-chair?
|
||||||
brmember-council?
|
brmember-council?
|
||||||
brmember-councilml?
|
|
||||||
brmember-revision?
|
brmember-revision?
|
||||||
brmember-grant?
|
brmember-grant?
|
||||||
|
|
||||||
|
|
@ -86,10 +85,6 @@
|
||||||
brmember-mailman
|
brmember-mailman
|
||||||
brmember-add-mailman
|
brmember-add-mailman
|
||||||
|
|
||||||
brmember-spec-fee
|
|
||||||
|
|
||||||
brmember-age
|
|
||||||
|
|
||||||
brmember-tests!
|
brmember-tests!
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
@ -99,7 +94,7 @@
|
||||||
(chicken irregex)
|
(chicken irregex)
|
||||||
(chicken string)
|
(chicken string)
|
||||||
(chicken format)
|
(chicken format)
|
||||||
srfi-1
|
util-list
|
||||||
util-bst-ldict
|
util-bst-ldict
|
||||||
testing
|
testing
|
||||||
cal-month
|
cal-month
|
||||||
|
|
@ -395,7 +390,6 @@
|
||||||
;; Predicates for all organizational bodies recognized
|
;; Predicates for all organizational bodies recognized
|
||||||
(define brmember-chair? (brmember-body? 'chair))
|
(define brmember-chair? (brmember-body? 'chair))
|
||||||
(define brmember-council? (brmember-body? 'council))
|
(define brmember-council? (brmember-body? 'council))
|
||||||
(define brmember-councilml? (brmember-body? 'councilml))
|
|
||||||
(define brmember-revision? (brmember-body? 'revision))
|
(define brmember-revision? (brmember-body? 'revision))
|
||||||
(define brmember-grant? (brmember-body? 'grant))
|
(define brmember-grant? (brmember-body? 'grant))
|
||||||
|
|
||||||
|
|
@ -427,8 +421,7 @@
|
||||||
(if (brmember-suspended? mr)
|
(if (brmember-suspended? mr)
|
||||||
(let ((period (cal-periods-match (brmember-info mr 'suspend))))
|
(let ((period (cal-periods-match (brmember-info mr 'suspend))))
|
||||||
(if period
|
(if period
|
||||||
(cal-month-diff (cal-ensure-month (cal-period-since period))
|
(cal-month-diff (cal-period-since period) (*current-month*))
|
||||||
(*current-month*))
|
|
||||||
0))
|
0))
|
||||||
0))
|
0))
|
||||||
|
|
||||||
|
|
@ -485,29 +478,6 @@
|
||||||
(cons ml
|
(cons ml
|
||||||
(brmember-mailman mr))))
|
(brmember-mailman mr))))
|
||||||
|
|
||||||
;; Returns special fee for current month or #f if it should be default
|
|
||||||
(define (brmember-spec-fee mr)
|
|
||||||
(let ((fee-periods (brmember-info mr 'fee #f)))
|
|
||||||
(if fee-periods
|
|
||||||
(let ((fee-period (cal-month-find-period fee-periods)))
|
|
||||||
(if fee-period
|
|
||||||
(let ()
|
|
||||||
(car (cal-period-scomment fee-period)))
|
|
||||||
#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
|
;; Self-tests
|
||||||
(define (brmember-tests!)
|
(define (brmember-tests!)
|
||||||
(run-tests
|
(run-tests
|
||||||
|
|
@ -516,8 +486,8 @@
|
||||||
(ldict-equal?
|
(ldict-equal?
|
||||||
(make-brmember '|1234| "members/1234" '(|member|))
|
(make-brmember '|1234| "members/1234" '(|member|))
|
||||||
(make-ldict
|
(make-ldict
|
||||||
`((TAG . ,TAG-BRMEMBER)
|
`((file-name . |1234|)
|
||||||
(file-name . |1234|)
|
(TAG . ,TAG-BRMEMBER)
|
||||||
(file-path . "members/1234")
|
(file-path . "members/1234")
|
||||||
(symlinks |member|)
|
(symlinks |member|)
|
||||||
(id . 1234)))))
|
(id . 1234)))))
|
||||||
|
|
|
||||||
|
|
@ -28,7 +28,6 @@
|
||||||
(module
|
(module
|
||||||
cal-period
|
cal-period
|
||||||
(
|
(
|
||||||
current-year
|
|
||||||
*current-month*
|
*current-month*
|
||||||
*current-day*
|
*current-day*
|
||||||
|
|
||||||
|
|
@ -45,8 +44,6 @@
|
||||||
cal-period-scomment
|
cal-period-scomment
|
||||||
cal-period-bcomment
|
cal-period-bcomment
|
||||||
|
|
||||||
set-cal-period-scomment
|
|
||||||
|
|
||||||
period-markers->cal-periods
|
period-markers->cal-periods
|
||||||
|
|
||||||
cal-periods-duration
|
cal-periods-duration
|
||||||
|
|
@ -54,8 +51,6 @@
|
||||||
cal-month-in-period?
|
cal-month-in-period?
|
||||||
cal-month-in-periods?
|
cal-month-in-periods?
|
||||||
|
|
||||||
cal-month-find-period
|
|
||||||
|
|
||||||
cal-day-in-period?
|
cal-day-in-period?
|
||||||
cal-day-in-periods?
|
cal-day-in-periods?
|
||||||
|
|
||||||
|
|
@ -86,9 +81,6 @@
|
||||||
;; Type tag
|
;; Type tag
|
||||||
(define TAG-CAL-PERIOD (make-tag CAL-PERIOD))
|
(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.
|
;; Current month - if changed, we get the actual state for given month.
|
||||||
(define *current-month*
|
(define *current-month*
|
||||||
(make-parameter
|
(make-parameter
|
||||||
|
|
@ -150,14 +142,6 @@
|
||||||
(define cal-period-scomment cadddr)
|
(define cal-period-scomment cadddr)
|
||||||
(define cal-period-bcomment (compose cadddr cdr))
|
(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
|
;; Type predicate
|
||||||
(define (cal-period? p)
|
(define (cal-period? p)
|
||||||
(and (pair? p)
|
(and (pair? p)
|
||||||
|
|
@ -271,19 +255,6 @@
|
||||||
#t
|
#t
|
||||||
(loop (cdr ps)))))))
|
(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
|
;; Checks whether given day belongs to day or month period
|
||||||
(define (cal-day-in-period? p . dl)
|
(define (cal-day-in-period? p . dl)
|
||||||
(let ((d (if (null? dl)
|
(let ((d (if (null? dl)
|
||||||
|
|
|
||||||
|
|
@ -40,7 +40,7 @@
|
||||||
(chicken base)
|
(chicken base)
|
||||||
(chicken process-context)
|
(chicken process-context)
|
||||||
(chicken format)
|
(chicken format)
|
||||||
srfi-1
|
util-list
|
||||||
testing
|
testing
|
||||||
util-proc)
|
util-proc)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
;;
|
;;
|
||||||
;; configuration.scm
|
;; configuraiton.scm
|
||||||
;;
|
;;
|
||||||
;; Configuration parameters used by various modules.
|
;; Configuration parameters used by various modules.
|
||||||
;;
|
;;
|
||||||
|
|
@ -42,8 +42,6 @@
|
||||||
*mailman3-bin*
|
*mailman3-bin*
|
||||||
*mailman3-sql*
|
*mailman3-sql*
|
||||||
*mailman3-sql-path*
|
*mailman3-sql-path*
|
||||||
*notifications-cc*
|
|
||||||
*dummy-run*
|
|
||||||
|
|
||||||
load-configuration!
|
load-configuration!
|
||||||
)
|
)
|
||||||
|
|
@ -101,7 +99,7 @@
|
||||||
|
|
||||||
;; Which version of mailman to use
|
;; Which version of mailman to use
|
||||||
(define *mailman-version* (make-parameter #f))
|
(define *mailman-version* (make-parameter #f))
|
||||||
(define =mailman-version= 3)
|
(define =mailman-version= 2)
|
||||||
|
|
||||||
;; What is the mailman 3 command
|
;; What is the mailman 3 command
|
||||||
(define *mailman3-bin* (make-parameter #f))
|
(define *mailman3-bin* (make-parameter #f))
|
||||||
|
|
@ -112,19 +110,12 @@
|
||||||
;; A string is the default, gets converted to boolean at the end of
|
;; A string is the default, gets converted to boolean at the end of
|
||||||
;; loading configuration
|
;; loading configuration
|
||||||
(define *mailman3-sql* (make-parameter #f))
|
(define *mailman3-sql* (make-parameter #f))
|
||||||
(define =mailman3-sql= "1")
|
(define =mailman3-sql= "0")
|
||||||
|
|
||||||
;; The path to SQLite3 DB file
|
;; The path to SQLite3 DB file
|
||||||
(define *mailman3-sql-path* (make-parameter #f))
|
(define *mailman3-sql-path* (make-parameter #f))
|
||||||
(define =mailman3-sql-path= "mailman.db")
|
(define =mailman3-sql-path= "mailman.db")
|
||||||
|
|
||||||
;; CC for notifications
|
|
||||||
(define *notifications-cc* (make-parameter #f))
|
|
||||||
(define =notifications-cc= "rada@brmlab.cz")
|
|
||||||
|
|
||||||
;; If #t, do not do anything
|
|
||||||
(define *dummy-run* (make-parameter #f))
|
|
||||||
|
|
||||||
(define (load-single-configuration! fname)
|
(define (load-single-configuration! fname)
|
||||||
(when (file-exists? fname)
|
(when (file-exists? fname)
|
||||||
(let loop ((lines (read-lines (open-input-file fname))))
|
(let loop ((lines (read-lines (open-input-file fname))))
|
||||||
|
|
@ -174,9 +165,6 @@
|
||||||
((mailman3-sql-path)
|
((mailman3-sql-path)
|
||||||
(when (not (*mailman3-sql-path*))
|
(when (not (*mailman3-sql-path*))
|
||||||
(*mailman3-sql-path* v)))
|
(*mailman3-sql-path* v)))
|
||||||
((notifications-cc)
|
|
||||||
(when (not (*notifications-cc*))
|
|
||||||
(*notifications-cc* v)))
|
|
||||||
)))
|
)))
|
||||||
(loop (cdr lines)))))))
|
(loop (cdr lines)))))))
|
||||||
|
|
||||||
|
|
@ -213,9 +201,6 @@
|
||||||
(*mailman3-sql* =mailman3-sql=))
|
(*mailman3-sql* =mailman3-sql=))
|
||||||
(*mailman3-sql* (not (equal? (*mailman3-sql*) "0")))
|
(*mailman3-sql* (not (equal? (*mailman3-sql*) "0")))
|
||||||
(when (not (*mailman3-sql-path*))
|
(when (not (*mailman3-sql-path*))
|
||||||
(*mailman3-sql-path* =mailman3-sql-path=))
|
(*mailman3-sql-path* =mailman3-sql-path=)))
|
||||||
(when (not (*notifications-cc*))
|
|
||||||
(*notifications-cc* =notifications-cc=))
|
|
||||||
)
|
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
|
||||||
|
|
@ -54,7 +54,7 @@
|
||||||
(users '()))
|
(users '()))
|
||||||
(if (null? lines)
|
(if (null? lines)
|
||||||
users
|
users
|
||||||
(let ((line (parser-preprocess-line (car lines) #:strip-comments? #f)))
|
(let ((line (parser-preprocess-line (car lines))))
|
||||||
(if (equal? line "")
|
(if (equal? line "")
|
||||||
(loop (cdr lines)
|
(loop (cdr lines)
|
||||||
users)
|
users)
|
||||||
|
|
@ -74,8 +74,8 @@
|
||||||
(handle-exceptions
|
(handle-exceptions
|
||||||
exn
|
exn
|
||||||
(let ()
|
(let ()
|
||||||
(log-warning "DokuWiki (~A) exception ~A" fname (condition->list exn))
|
(log-warning "DokuWiki: cannot open ~A" fname)
|
||||||
(stdout-printf "DokuWiki (~A) exception ~A" fname (condition->list exn))
|
(stdout-printf "DokuWiki: cannot open ~A" fname)
|
||||||
'())
|
'())
|
||||||
(with-input-from-file fname
|
(with-input-from-file fname
|
||||||
parse-dokuwiki-users-auth)))
|
parse-dokuwiki-users-auth)))
|
||||||
|
|
|
||||||
|
|
@ -135,12 +135,18 @@
|
||||||
res))))))
|
res))))))
|
||||||
|
|
||||||
(define (print-duck-signature sig)
|
(define (print-duck-signature sig)
|
||||||
|
;;(print sig)
|
||||||
(let* ((curry-depth (get-curry-depth sig))
|
(let* ((curry-depth (get-curry-depth sig))
|
||||||
(name (get-signature-name sig))
|
(name (get-signature-name sig))
|
||||||
(nameline (format " ~A~A" (make-string curry-depth #\() name))
|
(nameline (format " ~A~A" (make-string curry-depth #\() name))
|
||||||
(spaceline (make-string (add1 (string-length nameline)) #\space))
|
(spaceline (make-string (add1 (string-length nameline)) #\space))
|
||||||
(args (gather-signature-arguments sig))
|
(args (gather-signature-arguments sig))
|
||||||
(eargs (expand-signature-arguments args)))
|
(eargs (expand-signature-arguments args)))
|
||||||
|
;;(print " curry depth = " curry-depth)
|
||||||
|
;;(print " name = " name)
|
||||||
|
;;(print " args = " args)
|
||||||
|
;;(printf " eargs = ~S" eargs)
|
||||||
|
;;(newline)
|
||||||
(if (null? eargs)
|
(if (null? eargs)
|
||||||
(print nameline ")")
|
(print nameline ")")
|
||||||
(let loop ((args eargs)
|
(let loop ((args eargs)
|
||||||
|
|
|
||||||
|
|
@ -38,8 +38,7 @@
|
||||||
(chicken irregex)
|
(chicken irregex)
|
||||||
util-bst-ldict
|
util-bst-ldict
|
||||||
mbase
|
mbase
|
||||||
brmember
|
brmember)
|
||||||
configuration)
|
|
||||||
|
|
||||||
;; Prints single card type records.
|
;; Prints single card type records.
|
||||||
(define (cards-print/type mb type)
|
(define (cards-print/type mb type)
|
||||||
|
|
@ -85,8 +84,7 @@
|
||||||
|
|
||||||
;; Exports cards and desfires to the files specified.
|
;; Exports cards and desfires to the files specified.
|
||||||
(define (cards-export mb cardsfn desfirefn)
|
(define (cards-export mb cardsfn desfirefn)
|
||||||
(when (not (*dummy-run*))
|
|
||||||
(cards-export/type mb 'card cardsfn)
|
(cards-export/type mb 'card cardsfn)
|
||||||
(cards-export/type mb 'desfire desfirefn)))
|
(cards-export/type mb 'desfire desfirefn))
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
|
||||||
|
|
@ -1,226 +0,0 @@
|
||||||
;;
|
|
||||||
;; 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)
|
|
||||||
'(("--" . "--{}--"))))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -44,10 +44,7 @@
|
||||||
cal-day
|
cal-day
|
||||||
util-git
|
util-git
|
||||||
configuration
|
configuration
|
||||||
texts
|
texts)
|
||||||
logging
|
|
||||||
qr-payment
|
|
||||||
members-fees)
|
|
||||||
|
|
||||||
;; HTML entities
|
;; HTML entities
|
||||||
(define (sanitize-html str)
|
(define (sanitize-html str)
|
||||||
|
|
@ -90,8 +87,6 @@
|
||||||
(print "dd+dt,dd+dt+dd{border-top:1px solid #8cacbb}")
|
(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 "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 "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 "</style>")
|
||||||
(print "</head>")
|
(print "</head>")
|
||||||
(print "<body>")
|
(print "<body>")
|
||||||
|
|
@ -105,21 +100,10 @@
|
||||||
(brmember-nick mr) "</dd>")
|
(brmember-nick mr) "</dd>")
|
||||||
(print "<dt>Member ID, Variable Symbol for Payments<br>(Členské číslo, variabilní symbol plateb)</dt><dd>"
|
(print "<dt>Member ID, Variable Symbol for Payments<br>(Členské číslo, variabilní symbol plateb)</dt><dd>"
|
||||||
(brmember-id mr) "</dd>")
|
(brmember-id mr) "</dd>")
|
||||||
(print "<dt>Balance in CZK<br>(Zůstatek v Kč)</dt><dd>"
|
(print "<dt>Balance in CZK<br>(Zůstatek v Kč)</dt><dd>" (caar (reverse bhs)) "</dd>")
|
||||||
(if (null? bhs)
|
(print "<dt>Account for Payments<br>(Účet pro platbu příspěvků)</dt><dd>2500079551/2010</dd>")
|
||||||
"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 "</dl>")
|
||||||
(print "</div>")
|
(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 "<div class=\"bi\">")
|
||||||
(print "<h2>Payments History</h2>")
|
(print "<h2>Payments History</h2>")
|
||||||
(print "<table>")
|
(print "<table>")
|
||||||
|
|
@ -191,11 +175,10 @@
|
||||||
|
|
||||||
;; Generates all members in given directory
|
;; Generates all members in given directory
|
||||||
(define (gen-html-members mb dir)
|
(define (gen-html-members mb dir)
|
||||||
(when (not (*dummy-run*))
|
|
||||||
(ensure-directory dir)
|
(ensure-directory dir)
|
||||||
(with-mbase-progress%
|
(with-mbase-progress%
|
||||||
mb dir mr
|
mb dir mr
|
||||||
(gen-html-member mr dir))
|
(gen-html-member mr dir))
|
||||||
(clean-members-files mb dir)))
|
(clean-members-files mb dir))
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
|
||||||
|
|
@ -1,27 +1,3 @@
|
||||||
;;
|
|
||||||
;; gendoc.scm
|
|
||||||
;;
|
|
||||||
;; Generate documentation for all documented modules dynamically.
|
|
||||||
;;
|
|
||||||
;; ISC License
|
|
||||||
;;
|
|
||||||
;; Copyright 2023 Brmlab, z.s.
|
|
||||||
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
||||||
;;
|
|
||||||
;; Permission to use, copy, modify, and/or distribute this software
|
|
||||||
;; for any purpose with or without fee is hereby granted, provided
|
|
||||||
;; that the above copyright notice and this permission notice appear
|
|
||||||
;; in all copies.
|
|
||||||
;;
|
|
||||||
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
||||||
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
||||||
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
||||||
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
||||||
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
||||||
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
||||||
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
||||||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
;;
|
|
||||||
|
|
||||||
(import duck-extract)
|
(import duck-extract)
|
||||||
|
|
||||||
|
|
@ -50,6 +26,7 @@
|
||||||
util-io
|
util-io
|
||||||
util-stdout
|
util-stdout
|
||||||
util-parser
|
util-parser
|
||||||
|
util-list
|
||||||
util-proc
|
util-proc
|
||||||
util-format
|
util-format
|
||||||
util-tag
|
util-tag
|
||||||
|
|
|
||||||
|
|
@ -24,7 +24,6 @@
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(import (chicken repl)
|
(import (chicken repl)
|
||||||
(chicken format)
|
|
||||||
command-line
|
command-line
|
||||||
mbase
|
mbase
|
||||||
brmember
|
brmember
|
||||||
|
|
@ -48,12 +47,7 @@
|
||||||
util-stdout
|
util-stdout
|
||||||
table
|
table
|
||||||
export-web-static
|
export-web-static
|
||||||
dokuwiki
|
dokuwiki)
|
||||||
racket-kwargs
|
|
||||||
util-string
|
|
||||||
mailinglist
|
|
||||||
export-sheet
|
|
||||||
mbase-query)
|
|
||||||
|
|
||||||
;; Command-line options and configurable parameters
|
;; Command-line options and configurable parameters
|
||||||
(define -needs-bank- (make-parameter #f))
|
(define -needs-bank- (make-parameter #f))
|
||||||
|
|
@ -64,11 +58,10 @@
|
||||||
(define -run-tests?- (make-parameter #f))
|
(define -run-tests?- (make-parameter #f))
|
||||||
(define -web-dir- (make-parameter #f))
|
(define -web-dir- (make-parameter #f))
|
||||||
(define -normal-month- (make-parameter #t))
|
(define -normal-month- (make-parameter #t))
|
||||||
|
(define -ml-all- (make-parameter #f))
|
||||||
(define -show-destroyed- (make-parameter #f))
|
(define -show-destroyed- (make-parameter #f))
|
||||||
(define -show-only-active- (make-parameter #f))
|
|
||||||
(define -notify-months- (make-parameter 1))
|
(define -notify-months- (make-parameter 1))
|
||||||
(define -send-emails- (make-parameter #f))
|
(define -send-emails- (make-parameter #f))
|
||||||
(define -number- (make-parameter #f))
|
|
||||||
|
|
||||||
;; Arguments parsing
|
;; Arguments parsing
|
||||||
(command-line
|
(command-line
|
||||||
|
|
@ -116,8 +109,6 @@
|
||||||
(-mailman3-sql-path (path) "Set mailman3 direct SQL access path"
|
(-mailman3-sql-path (path) "Set mailman3 direct SQL access path"
|
||||||
(*mailman3-sql* "1")
|
(*mailman3-sql* "1")
|
||||||
(*mailman3-sql-path* path))
|
(*mailman3-sql-path* path))
|
||||||
(-n () "Do not do anything"
|
|
||||||
(*dummy-run* #t))
|
|
||||||
""
|
""
|
||||||
"Email options:"
|
"Email options:"
|
||||||
(-from (email) "Sender email address"
|
(-from (email) "Sender email address"
|
||||||
|
|
@ -144,8 +135,8 @@
|
||||||
"Misc options:"
|
"Misc options:"
|
||||||
(-destroyed () "Show destroyed members in -fees"
|
(-destroyed () "Show destroyed members in -fees"
|
||||||
(-show-destroyed- #t))
|
(-show-destroyed- #t))
|
||||||
(-only-active () "Show only active members in -fees"
|
(-ml-all () "Load all mailman lists"
|
||||||
(-show-only-active- #t))
|
(-ml-all- #t))
|
||||||
""
|
""
|
||||||
"Base Actions:"
|
"Base Actions:"
|
||||||
(-info () "Print information"
|
(-info () "Print information"
|
||||||
|
|
@ -186,14 +177,7 @@
|
||||||
(-action- 'genweb))
|
(-action- 'genweb))
|
||||||
(-stats (file:gnuplot-data) "Get stats for all months"
|
(-stats (file:gnuplot-data) "Get stats for all months"
|
||||||
(-action- 'print-stats)
|
(-action- 'print-stats)
|
||||||
(-needs-bank- #t)
|
|
||||||
(-fname- file:gnuplot-data))
|
(-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:"
|
"Mailman Actions:"
|
||||||
(-mlsync () "Synchronize internal ML"
|
(-mlsync () "Synchronize internal ML"
|
||||||
|
|
@ -245,15 +229,20 @@
|
||||||
#f))
|
#f))
|
||||||
|
|
||||||
;; Load ML(s) and merge them
|
;; Load ML(s) and merge them
|
||||||
(define-values (MB1 MLS)
|
(define-values (MB1 internal-ml)
|
||||||
(if MB0
|
(if MB0
|
||||||
|
(if (-ml-all-)
|
||||||
(let ()
|
(let ()
|
||||||
(define mls (load-mailman-lists))
|
(define mls (load-mailman-lists))
|
||||||
(values (foldl (lambda (mb ml)
|
(values (foldl (lambda (mb ml)
|
||||||
(mbase-merge-mailman mb ml))
|
(mbase-merge-mailman mb ml))
|
||||||
MB0
|
MB0
|
||||||
mls)
|
mls)
|
||||||
mls))
|
(find-mailman-list mls "internal")))
|
||||||
|
(let ()
|
||||||
|
(define internal-ml (load-mailman-list "internal"))
|
||||||
|
(values (mbase-merge-mailman MB0 internal-ml)
|
||||||
|
internal-ml)))
|
||||||
(values #f #f)))
|
(values #f #f)))
|
||||||
|
|
||||||
;; Load DokuWiki users
|
;; Load DokuWiki users
|
||||||
|
|
@ -286,19 +275,6 @@
|
||||||
;;
|
;;
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
;; Used both in print-info and git-status
|
|
||||||
(define (print-git-status)
|
|
||||||
(let ((status (git-status (*members-directory*))))
|
|
||||||
(newline)
|
|
||||||
(print "Repository " (*members-directory*) " status:")
|
|
||||||
(if (ldict-ref status 'clean)
|
|
||||||
(print " Repository up-to-date.")
|
|
||||||
(let loop ((keys '(unknown untracked modified)))
|
|
||||||
(when (not (null? keys))
|
|
||||||
(when (ldict-contains? status (car keys))
|
|
||||||
(print " " (car keys) ": " (length (ldict-ref status (car keys)))))
|
|
||||||
(loop (cdr keys)))))))
|
|
||||||
|
|
||||||
;; Perform requested action
|
;; Perform requested action
|
||||||
(case (-action-)
|
(case (-action-)
|
||||||
((print-info)
|
((print-info)
|
||||||
|
|
@ -310,8 +286,20 @@
|
||||||
(let ()
|
(let ()
|
||||||
(print-members-base-table MB)
|
(print-members-base-table MB)
|
||||||
(newline)
|
(newline)
|
||||||
(print-mailing-list-checks MB MLS)
|
(let-values (((missing surplus)
|
||||||
(print-git-status)))
|
(mailman-compare-members internal-ml
|
||||||
|
(mbase-active-emails MB #:suspended #t))))
|
||||||
|
(if (null? (cdr internal-ml))
|
||||||
|
(print "Skipping ML check - not loaded")
|
||||||
|
(if (and (null? missing)
|
||||||
|
(null? surplus))
|
||||||
|
(print "Internal mailing list membership in sync.")
|
||||||
|
(let ()
|
||||||
|
(print "Internal mailing list:")
|
||||||
|
(when (not (null? missing))
|
||||||
|
(print " Missing: " missing))
|
||||||
|
(when (not (null? surplus))
|
||||||
|
(print " Outsiders: " surplus))))))))
|
||||||
(newline))
|
(newline))
|
||||||
((print-stats)
|
((print-stats)
|
||||||
(newline)
|
(newline)
|
||||||
|
|
@ -360,45 +348,31 @@
|
||||||
(newline)
|
(newline)
|
||||||
(if mr
|
(if mr
|
||||||
(print-member-balances-table mr)
|
(print-member-balances-table mr)
|
||||||
(print-members-fees-table MB (-show-destroyed-) (-show-only-active-))))
|
(print-members-fees-table MB (-show-destroyed-))))
|
||||||
((repl)
|
((repl)
|
||||||
(repl))
|
(repl))
|
||||||
((genweb)
|
((genweb)
|
||||||
(log-info "Generating static web files")
|
(log-info "Generating static web files")
|
||||||
(gen-html-members MB (-web-dir-)))
|
(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)
|
((edit)
|
||||||
(if mr
|
(if mr
|
||||||
(let ()
|
|
||||||
(edit-file (brmember-file-path mr))
|
(edit-file (brmember-file-path mr))
|
||||||
(print-git-status))
|
|
||||||
(print "No member to edit.")))
|
(print "No member to edit.")))
|
||||||
((no-op) (void))
|
((no-op) (void))
|
||||||
((unpaired)
|
((unpaired)
|
||||||
(newline)
|
(newline)
|
||||||
(print-unpaired-table MB))
|
(print-unpaired-table MB))
|
||||||
((mlsync)
|
((mlsync)
|
||||||
(cond ((-normal-month-)
|
(if (-normal-month-)
|
||||||
(mailman-sync-members (find-mailman-list MLS "internal")
|
(mailman-sync-members internal-ml (mbase-active-emails MB #:suspended #t))
|
||||||
(mbase-active-emails MB #:suspended #t))
|
(print "Mailman synchronization disabled with manually specified current month.")))
|
||||||
(mailman-sync-members (find-mailman-list MLS "rada")
|
|
||||||
(mbase-active-emails MB
|
|
||||||
#:pred? rada-ml-pred?))
|
|
||||||
(mailman-sync-members (find-mailman-list MLS "rk")
|
|
||||||
(mbase-active-emails MB
|
|
||||||
#:pred? brmember-revision?)))
|
|
||||||
(else
|
|
||||||
(print "Mailman synchronization disabled with manually specified current month."))))
|
|
||||||
((notify)
|
((notify)
|
||||||
(let ((nmembers (members-to-notify MB (-notify-months-))))
|
(let ((nmembers (members-to-notify MB (-notify-months-))))
|
||||||
(stdout-newline)
|
(newline)
|
||||||
(if (null? nmembers)
|
(if (null? nmembers)
|
||||||
(print "Everyone paid on time.")
|
(print "Everyone paid on time.")
|
||||||
(let ()
|
(let ()
|
||||||
(stdout-print "Notify" (-notify-months-))
|
(print "Notify" (-notify-months-))
|
||||||
(let loop ((lst nmembers))
|
(let loop ((lst nmembers))
|
||||||
(when (and (not (null? lst))
|
(when (and (not (null? lst))
|
||||||
(or (not mr)
|
(or (not mr)
|
||||||
|
|
@ -409,11 +383,20 @@
|
||||||
(make+print-reminder-email (car lst)))
|
(make+print-reminder-email (car lst)))
|
||||||
(loop (cdr lst))))))))
|
(loop (cdr lst))))))))
|
||||||
((status)
|
((status)
|
||||||
(print-git-status))
|
(let ((status (git-status (*members-directory*))))
|
||||||
|
(newline)
|
||||||
|
(print "Repository " (*members-directory*) " status:")
|
||||||
|
(if (ldict-ref status 'clean)
|
||||||
|
(print " Repository up-to-date.")
|
||||||
|
(let loop ((keys '(unknown untracked modified)))
|
||||||
|
(when (not (null? keys))
|
||||||
|
(when (ldict-contains? status (car keys))
|
||||||
|
(print " " (car keys) ": " (length (ldict-ref status (car keys)))))
|
||||||
|
(loop (cdr keys)))))))
|
||||||
((summary)
|
((summary)
|
||||||
(if (-send-emails-)
|
(if (-send-emails-)
|
||||||
(make+send-summary-email MB MLS)
|
(make+send-summary-email MB)
|
||||||
(make+print-summary-email MB MLS)))
|
(make+print-summary-email MB)))
|
||||||
((list)
|
((list)
|
||||||
(for-each (lambda (mr)
|
(for-each (lambda (mr)
|
||||||
(print (brmember-nick mr)))
|
(print (brmember-nick mr)))
|
||||||
|
|
|
||||||
|
|
@ -1,79 +0,0 @@
|
||||||
;;
|
|
||||||
;; mailinglist.scm
|
|
||||||
;;
|
|
||||||
;; Common high-level mailinglist management procedures.
|
|
||||||
;;
|
|
||||||
;; ISC License
|
|
||||||
;;
|
|
||||||
;; Copyright 2023 Brmlab, z.s.
|
|
||||||
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
||||||
;;
|
|
||||||
;; Permission to use, copy, modify, and/or distribute this software
|
|
||||||
;; for any purpose with or without fee is hereby granted, provided
|
|
||||||
;; that the above copyright notice and this permission notice appear
|
|
||||||
;; in all copies.
|
|
||||||
;;
|
|
||||||
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
||||||
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
||||||
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
||||||
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
||||||
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
||||||
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
||||||
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
||||||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
;;
|
|
||||||
|
|
||||||
(declare (unit mailinglist))
|
|
||||||
|
|
||||||
(module
|
|
||||||
mailinglist
|
|
||||||
(
|
|
||||||
check-mailing-list
|
|
||||||
print-mailing-list-checks
|
|
||||||
|
|
||||||
rada-ml-pred?
|
|
||||||
)
|
|
||||||
|
|
||||||
(import scheme
|
|
||||||
(chicken base)
|
|
||||||
(chicken format)
|
|
||||||
racket-kwargs
|
|
||||||
mailman
|
|
||||||
mbase
|
|
||||||
util-string
|
|
||||||
brmember)
|
|
||||||
|
|
||||||
(define* (check-mailing-list MB mls name #:pred? (pred? #f) #:suspended (suspended #f))
|
|
||||||
(define ml (find-mailman-list mls name))
|
|
||||||
(when ml
|
|
||||||
(let-values (((missing surplus)
|
|
||||||
(mailman-compare-members ml
|
|
||||||
(mbase-active-emails MB
|
|
||||||
#:suspended suspended
|
|
||||||
#:pred? pred?
|
|
||||||
))))
|
|
||||||
(if (null? (cdr ml))
|
|
||||||
(print "Skipping ML check - not loaded")
|
|
||||||
(if (and (null? missing)
|
|
||||||
(null? surplus))
|
|
||||||
(print (format "~a mailing list membership in sync." (string-capitalize name)))
|
|
||||||
(let ()
|
|
||||||
(print (format "~a mailing list:" (string-capitalize name)))
|
|
||||||
(when (not (null? missing))
|
|
||||||
(print " Missing: " missing))
|
|
||||||
(when (not (null? surplus))
|
|
||||||
(print " Outsiders: " surplus))))))))
|
|
||||||
|
|
||||||
(define (print-mailing-list-checks MB MLS)
|
|
||||||
(check-mailing-list MB MLS "internal" #:suspended #t)
|
|
||||||
(check-mailing-list MB MLS "rada"
|
|
||||||
#:pred? rada-ml-pred?)
|
|
||||||
(check-mailing-list MB MLS "rk" #:pred? brmember-revision?))
|
|
||||||
|
|
||||||
(define (rada-ml-pred? mr)
|
|
||||||
(or (brmember-council? mr)
|
|
||||||
(brmember-chair? mr)
|
|
||||||
(brmember-revision? mr)
|
|
||||||
(brmember-councilml? mr)))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -49,6 +49,7 @@
|
||||||
(import scheme
|
(import scheme
|
||||||
(chicken base)
|
(chicken base)
|
||||||
(chicken module)
|
(chicken module)
|
||||||
|
mailman2
|
||||||
mailman-common
|
mailman-common
|
||||||
util-bst-lset
|
util-bst-lset
|
||||||
configuration
|
configuration
|
||||||
|
|
@ -58,17 +59,24 @@
|
||||||
;; Syntax for simplifying export of case-version procedures
|
;; Syntax for simplifying export of case-version procedures
|
||||||
(define-syntax define-mailman-proc
|
(define-syntax define-mailman-proc
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ name proc3)
|
((_ name proc2)
|
||||||
(begin
|
(begin
|
||||||
(export name)
|
(export name)
|
||||||
(define (name . args)
|
(define (name . args)
|
||||||
(case (*mailman-version*)
|
(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))))))))
|
((3) (apply proc3 args))))))))
|
||||||
|
|
||||||
(define-mailman-proc list-mailman-lists
|
(define-mailman-proc list-mailman-lists
|
||||||
list-mailman3-lists)
|
list-mailman2-lists list-mailman3-lists)
|
||||||
(define-mailman-proc list-mailman-list-members
|
(define-mailman-proc list-mailman-list-members
|
||||||
list-mailman3-list-members)
|
list-mailman2-list-members list-mailman3-list-members)
|
||||||
|
|
||||||
;; Loads a single mailman list as mailman structure, if
|
;; Loads a single mailman list as mailman structure, if
|
||||||
;; unsuccessfull, returns only a list with ML name and no member
|
;; unsuccessfull, returns only a list with ML name and no member
|
||||||
|
|
@ -104,9 +112,9 @@
|
||||||
(assoc name lsts))
|
(assoc name lsts))
|
||||||
|
|
||||||
(define-mailman-proc add-email-to-mailman-list
|
(define-mailman-proc add-email-to-mailman-list
|
||||||
add-email-to-mailman3-list)
|
add-email-to-mailman2-list add-email-to-mailman3-list)
|
||||||
(define-mailman-proc remove-email-from-mailman-list
|
(define-mailman-proc remove-email-from-mailman-list
|
||||||
remove-email-from-mailman3-list)
|
remove-email-from-mailman2-list remove-email-from-mailman3-list)
|
||||||
|
|
||||||
;; Ensures given email is in given ML
|
;; Ensures given email is in given ML
|
||||||
(define (mailman-ensure-member ml email)
|
(define (mailman-ensure-member ml email)
|
||||||
|
|
|
||||||
104
src/mailman2.scm
Normal file
104
src/mailman2.scm
Normal file
|
|
@ -0,0 +1,104 @@
|
||||||
|
;;
|
||||||
|
;; 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)
|
||||||
|
util-list
|
||||||
|
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))))))
|
||||||
|
|
||||||
|
)
|
||||||
|
|
@ -37,8 +37,7 @@
|
||||||
(chicken base)
|
(chicken base)
|
||||||
(chicken format)
|
(chicken format)
|
||||||
sqlite3
|
sqlite3
|
||||||
configuration
|
configuration)
|
||||||
(chicken condition))
|
|
||||||
|
|
||||||
;; Thread-local parameter to re-use SQLite3 DB handle for subsequent queries
|
;; Thread-local parameter to re-use SQLite3 DB handle for subsequent queries
|
||||||
(define *cached-mailman3-db* (make-parameter #f))
|
(define *cached-mailman3-db* (make-parameter #f))
|
||||||
|
|
@ -46,25 +45,16 @@
|
||||||
;; Returns (possibly cached) SQLite3 DB handle
|
;; Returns (possibly cached) SQLite3 DB handle
|
||||||
(define (mailman3-db)
|
(define (mailman3-db)
|
||||||
(when (not (*cached-mailman3-db*))
|
(when (not (*cached-mailman3-db*))
|
||||||
(*cached-mailman3-db*
|
(*cached-mailman3-db* (open-database (*mailman3-sql-path*))))
|
||||||
(let ((handler (make-busy-timeout 2000)))
|
|
||||||
(let ((db (open-database (*mailman3-sql-path*))))
|
|
||||||
(set-busy-handler! db handler)
|
|
||||||
db))))
|
|
||||||
(*cached-mailman3-db*))
|
(*cached-mailman3-db*))
|
||||||
|
|
||||||
;; Returns the list of mailman3 mailinglists by querying te
|
;; Returns the list of mailman3 mailinglists by querying te
|
||||||
;; underlying SQLite3 DB directly
|
;; underlying SQLite3 DB directly
|
||||||
(define (list-mailman3-sql-lists)
|
(define (list-mailman3-sql-lists)
|
||||||
(handle-exceptions
|
|
||||||
ex
|
|
||||||
'()
|
|
||||||
(let ((result
|
|
||||||
(let-values (((stmt _)
|
(let-values (((stmt _)
|
||||||
(prepare (mailman3-db)
|
(prepare (mailman3-db)
|
||||||
"SELECT list_name FROM mailinglist")))
|
"SELECT list_name FROM mailinglist")))
|
||||||
(map-row identity stmt))))
|
(map-row identity stmt)))
|
||||||
result)))
|
|
||||||
|
|
||||||
;; Returns a list of email addresses subscribed to given mailinglist
|
;; Returns a list of email addresses subscribed to given mailinglist
|
||||||
(define (list-mailman3-sql-list-members lst)
|
(define (list-mailman3-sql-list-members lst)
|
||||||
|
|
|
||||||
|
|
@ -42,7 +42,7 @@
|
||||||
(chicken format)
|
(chicken format)
|
||||||
configuration
|
configuration
|
||||||
util-io
|
util-io
|
||||||
srfi-1
|
util-list
|
||||||
mailman3-sql)
|
mailman3-sql)
|
||||||
|
|
||||||
;; Just a convenient converter
|
;; Just a convenient converter
|
||||||
|
|
@ -94,8 +94,7 @@
|
||||||
|
|
||||||
;; Adds given email
|
;; Adds given email
|
||||||
(define (add-email-to-mailman3-list lst email)
|
(define (add-email-to-mailman3-list lst email)
|
||||||
(print "Add " email " to " lst "." (if (*dummy-run*) " [no-op]" ""))
|
(print "Add " email " to " lst ".")
|
||||||
(when (not (*dummy-run*))
|
|
||||||
(let ((result
|
(let ((result
|
||||||
(mailman3-send/recv
|
(mailman3-send/recv
|
||||||
(list "addmembers" "-" (format "~A@brmlab.cz" lst))
|
(list "addmembers" "-" (format "~A@brmlab.cz" lst))
|
||||||
|
|
@ -103,12 +102,11 @@
|
||||||
(let loop ((lines result))
|
(let loop ((lines result))
|
||||||
(when (not (null? lines))
|
(when (not (null? lines))
|
||||||
(print " | " (car lines))
|
(print " | " (car lines))
|
||||||
(loop (cdr lines)))))))
|
(loop (cdr lines))))))
|
||||||
|
|
||||||
;; Removes given email from given listname
|
;; Removes given email from given listname
|
||||||
(define (remove-email-from-mailman3-list lst email)
|
(define (remove-email-from-mailman3-list lst email)
|
||||||
(print "Remove " email " from " lst "." (if (*dummy-run*) " [no-op]" ""))
|
(print "Remove " email " from " lst ".")
|
||||||
(when (not (*dummy-run*))
|
|
||||||
(let ((result
|
(let ((result
|
||||||
(get-mailman3-output-lines
|
(get-mailman3-output-lines
|
||||||
"delmembers"
|
"delmembers"
|
||||||
|
|
@ -117,6 +115,6 @@
|
||||||
(let loop ((lines result))
|
(let loop ((lines result))
|
||||||
(when (not (null? lines))
|
(when (not (null? lines))
|
||||||
(print " | " (car lines))
|
(print " | " (car lines))
|
||||||
(loop (cdr lines)))))))
|
(loop (cdr lines))))))
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
|
||||||
|
|
@ -40,7 +40,7 @@
|
||||||
(chicken file)
|
(chicken file)
|
||||||
(chicken format)
|
(chicken format)
|
||||||
(chicken irregex)
|
(chicken irregex)
|
||||||
srfi-1
|
util-list
|
||||||
testing
|
testing
|
||||||
util-bst-ldict
|
util-bst-ldict
|
||||||
brmember
|
brmember
|
||||||
|
|
|
||||||
|
|
@ -1,123 +0,0 @@
|
||||||
;;
|
|
||||||
;; 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))))))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -50,6 +50,8 @@
|
||||||
mbase-update-by-id
|
mbase-update-by-id
|
||||||
mbase-update
|
mbase-update
|
||||||
|
|
||||||
|
mbase-stats
|
||||||
|
|
||||||
mbase-add-unpaired
|
mbase-add-unpaired
|
||||||
mbase-unpaired
|
mbase-unpaired
|
||||||
|
|
||||||
|
|
@ -67,7 +69,7 @@
|
||||||
(chicken string)
|
(chicken string)
|
||||||
(chicken random)
|
(chicken random)
|
||||||
(chicken sort)
|
(chicken sort)
|
||||||
srfi-1
|
util-list
|
||||||
testing
|
testing
|
||||||
util-bst-ldict
|
util-bst-ldict
|
||||||
primes
|
primes
|
||||||
|
|
@ -205,6 +207,47 @@
|
||||||
(proc mr)
|
(proc mr)
|
||||||
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
|
;; Adds unpaired transaction to given members-base
|
||||||
(define (mbase-add-unpaired mb tr)
|
(define (mbase-add-unpaired mb tr)
|
||||||
(ldict-set mb 'unpaired
|
(ldict-set mb 'unpaired
|
||||||
|
|
@ -219,7 +262,6 @@
|
||||||
;; alphabetically
|
;; alphabetically
|
||||||
(define* (mbase-active-emails mb
|
(define* (mbase-active-emails mb
|
||||||
#:active (active #t)
|
#:active (active #t)
|
||||||
#:pred? (pred? #f)
|
|
||||||
#:suspended (suspended #f))
|
#:suspended (suspended #f))
|
||||||
(sort
|
(sort
|
||||||
(filter
|
(filter
|
||||||
|
|
@ -230,12 +272,10 @@
|
||||||
(bdict-filter-values
|
(bdict-filter-values
|
||||||
(mbase-members mb)
|
(mbase-members mb)
|
||||||
(lambda (id mr)
|
(lambda (id mr)
|
||||||
(and (or (not pred?)
|
|
||||||
(pred? mr))
|
|
||||||
(or (and active
|
(or (and active
|
||||||
(brmember-active? mr))
|
(brmember-active? mr))
|
||||||
(and suspended
|
(and suspended
|
||||||
(brmember-suspended? mr))))))))
|
(brmember-suspended? mr)))))))
|
||||||
string-ci<?))
|
string-ci<?))
|
||||||
|
|
||||||
;; Merges given ML members into members base
|
;; Merges given ML members into members base
|
||||||
|
|
|
||||||
|
|
@ -30,7 +30,6 @@
|
||||||
(
|
(
|
||||||
lookup-member-fee
|
lookup-member-fee
|
||||||
member-calendar
|
member-calendar
|
||||||
make-member-calendar-entry
|
|
||||||
member-calendar-first-month
|
member-calendar-first-month
|
||||||
member-calendar-last-month
|
member-calendar-last-month
|
||||||
member-calendar-query
|
member-calendar-query
|
||||||
|
|
@ -41,16 +40,13 @@
|
||||||
member-calendar->table
|
member-calendar->table
|
||||||
members-summary
|
members-summary
|
||||||
member-calendar-entry->fee
|
member-calendar-entry->fee
|
||||||
get-expected-income
|
|
||||||
get-expected-income-string
|
|
||||||
)
|
)
|
||||||
|
|
||||||
(import scheme
|
(import scheme
|
||||||
(chicken base)
|
(chicken base)
|
||||||
(chicken format)
|
(chicken format)
|
||||||
(chicken sort)
|
(chicken sort)
|
||||||
(chicken string)
|
util-list
|
||||||
srfi-1
|
|
||||||
configuration
|
configuration
|
||||||
brmember
|
brmember
|
||||||
cal-month
|
cal-month
|
||||||
|
|
@ -86,17 +82,12 @@
|
||||||
(if (cal-month>? cm last-month)
|
(if (cal-month>? cm last-month)
|
||||||
(reverse cal)
|
(reverse cal)
|
||||||
(loop (cal-month-add cm)
|
(loop (cal-month-add cm)
|
||||||
(cons (with-current-month
|
(cons (list cm
|
||||||
|
(with-current-month
|
||||||
cm
|
cm
|
||||||
(make-member-calendar-entry mr))
|
(brmember-flags mr)))
|
||||||
cal))))))
|
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
|
;; Returns the first month of the calendar
|
||||||
(define (member-calendar-first-month mc)
|
(define (member-calendar-first-month mc)
|
||||||
(caar mc))
|
(caar mc))
|
||||||
|
|
@ -120,16 +111,12 @@
|
||||||
(ansi-string #:bgblack "\xc2\xa0\xc2\xa0") ; Destroyed
|
(ansi-string #:bgblack "\xc2\xa0\xc2\xa0") ; Destroyed
|
||||||
(if (member 'student (cadr e))
|
(if (member 'student (cadr e))
|
||||||
(ansi-string #:bgyellow "\xc2\xa0\xc2\xa0") ; Student
|
(ansi-string #:bgyellow "\xc2\xa0\xc2\xa0") ; Student
|
||||||
(if (caddr e)
|
(ansi-string #:bggreen "\xc2\xa0\xc2\xa0")))) ; Normal
|
||||||
(ansi-string #:bgblue (format "~a" (caddr e)))
|
|
||||||
(ansi-string #:bggreen "\xc2\xa0\xc2\xa0"))))) ; Normal
|
|
||||||
"\xc2\xa0\xc2\xa0") ; Nonexistent - should not happen
|
"\xc2\xa0\xc2\xa0") ; Nonexistent - should not happen
|
||||||
"\xc2\xa0\xc2\xa0")) ; Nonexistent
|
"\xc2\xa0\xc2\xa0")) ; Nonexistent
|
||||||
|
|
||||||
;; Converts the entry into the fee
|
;; Converts the entry into the fee
|
||||||
(define (member-calendar-entry->fee e)
|
(define (member-calendar-entry->fee e)
|
||||||
(with-current-month
|
|
||||||
(car e)
|
|
||||||
(if e
|
(if e
|
||||||
(if (member 'existing (cadr e))
|
(if (member 'existing (cadr e))
|
||||||
(if (member 'suspended (cadr e))
|
(if (member 'suspended (cadr e))
|
||||||
|
|
@ -138,11 +125,9 @@
|
||||||
0 ; Destroyed
|
0 ; Destroyed
|
||||||
(if (member 'student (cadr e))
|
(if (member 'student (cadr e))
|
||||||
(lookup-member-fee 'student) ; Student
|
(lookup-member-fee 'student) ; Student
|
||||||
(if (caddr e)
|
(lookup-member-fee 'regular)))) ; Normal
|
||||||
(caddr e)
|
|
||||||
(lookup-member-fee 'regular))))) ; Normal
|
|
||||||
0) ; Nonexistent - should not happen
|
0) ; Nonexistent - should not happen
|
||||||
0))) ; Nonexistent
|
0)) ; Nonexistent
|
||||||
|
|
||||||
;; Converts the calendar into a table where rows represent years and
|
;; Converts the calendar into a table where rows represent years and
|
||||||
;; contain the year in the first cell and 12 cells for months after
|
;; contain the year in the first cell and 12 cells for months after
|
||||||
|
|
@ -209,38 +194,4 @@
|
||||||
(cons 0 0)
|
(cons 0 0)
|
||||||
members)))
|
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))))))
|
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
|
||||||
|
|
@ -48,7 +48,7 @@
|
||||||
(chicken process-context)
|
(chicken process-context)
|
||||||
(chicken pathname)
|
(chicken pathname)
|
||||||
(chicken condition)
|
(chicken condition)
|
||||||
srfi-1
|
util-list
|
||||||
bank-account
|
bank-account
|
||||||
brmember
|
brmember
|
||||||
mbase
|
mbase
|
||||||
|
|
@ -77,34 +77,13 @@
|
||||||
(string->number
|
(string->number
|
||||||
(bank-transaction-varsym transaction)))
|
(bank-transaction-varsym transaction)))
|
||||||
(varsym-id
|
(varsym-id
|
||||||
(if (and varsym-id0
|
(or varsym-id0
|
||||||
(> varsym-id0 1000))
|
|
||||||
varsym-id0
|
|
||||||
(let* ((msg (bank-transaction-message transaction))
|
(let* ((msg (bank-transaction-message transaction))
|
||||||
(ci1 (substring-index "," msg))
|
(ci (substring-index "," msg))
|
||||||
(vs1 (if ci1
|
(vs (if ci
|
||||||
(substring msg 0 ci1)
|
(substring msg 0 ci)
|
||||||
msg))
|
msg)))
|
||||||
(ci2 (substring-index " " msg))
|
(string->number vs)))))
|
||||||
(vs2 (if ci2
|
|
||||||
(substring msg 0 ci2)
|
|
||||||
msg))
|
|
||||||
(ci3 (substring-index "NULL" msg))
|
|
||||||
(vs3 (if (and ci3
|
|
||||||
(>= (string-length msg) (+ ci3 8)))
|
|
||||||
(substring msg (+ ci3 4) (+ ci3 4 4))
|
|
||||||
msg))
|
|
||||||
(ci4 (substring-index "VS" msg))
|
|
||||||
(vs4 (if (and ci4
|
|
||||||
(>= (string-length msg) (+ ci4 6)))
|
|
||||||
(substring msg (+ ci4 2) (+ ci4 6))
|
|
||||||
msg))
|
|
||||||
)
|
|
||||||
(or (string->number vs1)
|
|
||||||
(string->number vs2)
|
|
||||||
(string->number vs3)
|
|
||||||
(string->number vs4)
|
|
||||||
)))))
|
|
||||||
varsym-id)))
|
varsym-id)))
|
||||||
|
|
||||||
;; Special comparator (originally with JendaSAP hack)
|
;; Special comparator (originally with JendaSAP hack)
|
||||||
|
|
|
||||||
|
|
@ -48,7 +48,7 @@
|
||||||
(chicken string)
|
(chicken string)
|
||||||
(chicken sort)
|
(chicken sort)
|
||||||
(chicken format)
|
(chicken format)
|
||||||
srfi-1
|
util-list
|
||||||
util-bst-ldict
|
util-bst-ldict
|
||||||
brmember
|
brmember
|
||||||
cal-month
|
cal-month
|
||||||
|
|
@ -67,8 +67,7 @@
|
||||||
cal-format
|
cal-format
|
||||||
util-git
|
util-git
|
||||||
cal-day
|
cal-day
|
||||||
racket-kwargs
|
racket-kwargs)
|
||||||
tiocgwinsz)
|
|
||||||
|
|
||||||
(define *show-payments-count* (make-parameter 36))
|
(define *show-payments-count* (make-parameter 36))
|
||||||
|
|
||||||
|
|
@ -97,7 +96,7 @@
|
||||||
(body (map (lambda (k)
|
(body (map (lambda (k)
|
||||||
(let ((v (ldict-ref info k)))
|
(let ((v (ldict-ref info k)))
|
||||||
(case k
|
(case k
|
||||||
((card desfire phone)
|
((card desfire)
|
||||||
(list k
|
(list k
|
||||||
(table->string
|
(table->string
|
||||||
(map
|
(map
|
||||||
|
|
@ -114,7 +113,7 @@
|
||||||
(caddr c)))
|
(caddr c)))
|
||||||
(brmember-credit mr))
|
(brmember-credit mr))
|
||||||
#:border '(((#:right light) ... none) ...))))
|
#:border '(((#:right light) ... none) ...))))
|
||||||
((suspend student member council chair revision grant councilml)
|
((suspend student member council chair revision grant)
|
||||||
(let* ((pdata (cons (list "Since" "Until")
|
(let* ((pdata (cons (list "Since" "Until")
|
||||||
(map
|
(map
|
||||||
(lambda (p)
|
(lambda (p)
|
||||||
|
|
@ -129,25 +128,8 @@
|
||||||
(ptbl (table->string
|
(ptbl (table->string
|
||||||
pdata
|
pdata
|
||||||
#:border '(((#:right light) ... none) ...))))
|
#:border '(((#:right light) ... none) ...))))
|
||||||
(list k ptbl)))
|
;;(print pdata)
|
||||||
((fee)
|
;;(write ptbl)(newline)
|
||||||
(let* ((pdata
|
|
||||||
(cons
|
|
||||||
(list "Amount" "Since" "Until")
|
|
||||||
(map
|
|
||||||
(lambda (p)
|
|
||||||
(list
|
|
||||||
(format "\t~A" (car (cal-period-scomment p)))
|
|
||||||
(string-append (cal-day/month->string
|
|
||||||
(cal-period-since p)) " "
|
|
||||||
(or (cadr (cal-period-scomment p)) ""))
|
|
||||||
(string-append (cal-day/month->string
|
|
||||||
(cal-period-before p)) " "
|
|
||||||
(or (cal-period-bcomment p) ""))))
|
|
||||||
v)))
|
|
||||||
(ptbl (table->string
|
|
||||||
pdata
|
|
||||||
#:border '(((#:right light) ... none) ...))))
|
|
||||||
(list k ptbl)))
|
(list k ptbl)))
|
||||||
(else
|
(else
|
||||||
(if v
|
(if v
|
||||||
|
|
@ -178,6 +160,7 @@
|
||||||
(list (list (ansi-string #:red "DokuWiki")
|
(list (list (ansi-string #:red "DokuWiki")
|
||||||
(ansi-string #:red "---")))))
|
(ansi-string #:red "---")))))
|
||||||
(result (filter identity (append head body mailman dokuwiki))))
|
(result (filter identity (append head body mailman dokuwiki))))
|
||||||
|
;;(write result)(newline)
|
||||||
(table->string result
|
(table->string result
|
||||||
#:border '(((#:bottom #:right light) ... (#:bottom light))
|
#:border '(((#:bottom #:right light) ... (#:bottom light))
|
||||||
...
|
...
|
||||||
|
|
@ -284,9 +267,11 @@
|
||||||
(define (members-table-row a:? label mrs fmt)
|
(define (members-table-row a:? label mrs fmt)
|
||||||
(list (string-append "\t" a:? label)
|
(list (string-append "\t" a:? label)
|
||||||
(length mrs)
|
(length mrs)
|
||||||
|
(ansi-paragraph-format
|
||||||
(member-records->string
|
(member-records->string
|
||||||
(sort mrs brmember<?)
|
(sort mrs brmember<?)
|
||||||
fmt)))
|
fmt)
|
||||||
|
60)))
|
||||||
|
|
||||||
;; Generic table of members attributes
|
;; Generic table of members attributes
|
||||||
(define (members-attrs-table mrs fmt hdr row)
|
(define (members-attrs-table mrs fmt hdr row)
|
||||||
|
|
@ -316,7 +301,6 @@
|
||||||
|
|
||||||
;; Prints nicely aligned members base info
|
;; Prints nicely aligned members base info
|
||||||
(define (print-members-base-table mb)
|
(define (print-members-base-table mb)
|
||||||
(let-values (((rows columns) (term-size)))
|
|
||||||
(let* ((total-count (length
|
(let* ((total-count (length
|
||||||
(find-members-by-predicate mb brmember-usable?)))
|
(find-members-by-predicate mb brmember-usable?)))
|
||||||
(invalid-mrs (find-members-by-predicate
|
(invalid-mrs (find-members-by-predicate
|
||||||
|
|
@ -380,7 +364,7 @@
|
||||||
(members-table-row (ansi #:magenta #:bold) "Expire Soon:"
|
(members-table-row (ansi #:magenta #:bold) "Expire Soon:"
|
||||||
soon-expire-mrs "~N (~S)"))
|
soon-expire-mrs "~N (~S)"))
|
||||||
(members-pred-table-row mb
|
(members-pred-table-row mb
|
||||||
(ansi-string #:red #:bold "Problems:")
|
(ansi-string #:red #:bold "Prolems:")
|
||||||
brmember-has-problems?
|
brmember-has-problems?
|
||||||
"~N~E ~A")
|
"~N~E ~A")
|
||||||
(if (null? debtor-mrs)
|
(if (null? debtor-mrs)
|
||||||
|
|
@ -411,8 +395,8 @@
|
||||||
#:border '(((#:bottom #:right light) ... (#:bottom light))
|
#:border '(((#:bottom #:right light) ... (#:bottom light))
|
||||||
...
|
...
|
||||||
((#:right light) ... none))
|
((#:right light) ... none))
|
||||||
#:width (- columns 10)
|
#:width 70
|
||||||
#:ansi-reset? #t))))
|
#:ansi-reset? #t)))
|
||||||
(let ((pmrs (find-members-by-predicate mb brmember-file-has-problems?)))
|
(let ((pmrs (find-members-by-predicate mb brmember-file-has-problems?)))
|
||||||
(when (not (null? pmrs))
|
(when (not (null? pmrs))
|
||||||
(newline)
|
(newline)
|
||||||
|
|
@ -487,25 +471,11 @@
|
||||||
")"))))
|
")"))))
|
||||||
|
|
||||||
;; Prints summary table of all fees and credits for all members
|
;; Prints summary table of all fees and credits for all members
|
||||||
(define (print-members-fees-table MB . dsa)
|
(define (print-members-fees-table MB . ds)
|
||||||
(let ((destroyed? (if (null? dsa)
|
(let ((destroyed? (if (null? ds)
|
||||||
#f
|
#f
|
||||||
(car dsa)))
|
(car ds))))
|
||||||
(only-active? (if (or (null? dsa)
|
(let* ((members ;; Pass 1
|
||||||
(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
|
|
||||||
(map
|
(map
|
||||||
(lambda (mr)
|
(lambda (mr)
|
||||||
(let* ((balance (member-balance mr))
|
(let* ((balance (member-balance mr))
|
||||||
|
|
@ -526,15 +496,13 @@
|
||||||
payment
|
payment
|
||||||
total
|
total
|
||||||
balance
|
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))))
|
|
||||||
)))
|
)))
|
||||||
raw-members))
|
(sort
|
||||||
|
(if destroyed?
|
||||||
|
(find-members-by-predicate MB (lambda x #t))
|
||||||
|
(find-members-by-predicate MB (lambda (mr)
|
||||||
|
(not (brmember-destroyed? mr)))))
|
||||||
|
brmember<?)))
|
||||||
(balances (map (lambda (m)
|
(balances (map (lambda (m)
|
||||||
(list-ref m 6))
|
(list-ref m 6))
|
||||||
members)))
|
members)))
|
||||||
|
|
@ -543,7 +511,6 @@
|
||||||
(cons
|
(cons
|
||||||
(list (ansi-string #:bgblue #:brightyellow #:bold "Member")
|
(list (ansi-string #:bgblue #:brightyellow #:bold "Member")
|
||||||
(ansi-string #:bgblue #:brightyellow #:bold "Status")
|
(ansi-string #:bgblue #:brightyellow #:bold "Status")
|
||||||
(ansi-string #:bgblue #:brightyellow #:bold "Current")
|
|
||||||
(ansi-string #:bgblue #:brightyellow #:bold "Fees")
|
(ansi-string #:bgblue #:brightyellow #:bold "Fees")
|
||||||
(ansi-string #:bgblue #:brightyellow #:bold "Credit")
|
(ansi-string #:bgblue #:brightyellow #:bold "Credit")
|
||||||
(ansi-string #:bgblue #:brightyellow #:bold "Payments")
|
(ansi-string #:bgblue #:brightyellow #:bold "Payments")
|
||||||
|
|
@ -554,7 +521,6 @@
|
||||||
(let ((total (list-ref member 5)))
|
(let ((total (list-ref member 5)))
|
||||||
(list (list-ref member 0)
|
(list (list-ref member 0)
|
||||||
(list-ref member 1)
|
(list-ref member 1)
|
||||||
(sprintf "\t~A" (list-ref member 7))
|
|
||||||
(sprintf "\t~A" (list-ref member 2))
|
(sprintf "\t~A" (list-ref member 2))
|
||||||
(sprintf "\t~A" (list-ref member 3))
|
(sprintf "\t~A" (list-ref member 3))
|
||||||
(sprintf "\t~A" (list-ref member 4))
|
(sprintf "\t~A" (list-ref member 4))
|
||||||
|
|
@ -571,11 +537,9 @@
|
||||||
(let* ((fees (foldl + 0 (map (lambda (b) (ldict-ref b 'fees)) balances)))
|
(let* ((fees (foldl + 0 (map (lambda (b) (ldict-ref b 'fees)) balances)))
|
||||||
(credit (foldl + 0 (map (lambda (b) (ldict-ref b 'credit)) balances)))
|
(credit (foldl + 0 (map (lambda (b) (ldict-ref b 'credit)) balances)))
|
||||||
(payment (foldl + 0 (map (lambda (b) (ldict-ref b 'payment)) 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")
|
(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" fees))
|
||||||
(ansi-string "\t" #:bold (sprintf "~A" credit))
|
(ansi-string "\t" #:bold (sprintf "~A" credit))
|
||||||
(ansi-string "\t" #:bold (sprintf "~A" payment))
|
(ansi-string "\t" #:bold (sprintf "~A" payment))
|
||||||
|
|
@ -606,7 +570,19 @@
|
||||||
(map (lambda (member)
|
(map (lambda (member)
|
||||||
(min 0 (list-ref member 5)))
|
(min 0 (list-ref member 5)))
|
||||||
members)))
|
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)
|
(define (unpaired-table mb . args)
|
||||||
(apply
|
(apply
|
||||||
|
|
|
||||||
|
|
@ -40,7 +40,6 @@
|
||||||
(chicken format)
|
(chicken format)
|
||||||
(chicken string)
|
(chicken string)
|
||||||
(chicken sort)
|
(chicken sort)
|
||||||
(chicken port)
|
|
||||||
brmember
|
brmember
|
||||||
util-mail
|
util-mail
|
||||||
util-bst-ldict
|
util-bst-ldict
|
||||||
|
|
@ -54,17 +53,13 @@
|
||||||
members-print
|
members-print
|
||||||
table
|
table
|
||||||
bank-account
|
bank-account
|
||||||
logging
|
logging)
|
||||||
srfi-1
|
|
||||||
mailinglist)
|
|
||||||
|
|
||||||
;; Prints email to the console
|
;; Prints email to the console
|
||||||
(define (print-notification-email em)
|
(define (print-notification-email em)
|
||||||
(print "### From: " (ldict-ref em 'from (*email-from*)))
|
(print "### From: " (ldict-ref em 'from (*email-from*)))
|
||||||
(print "### To: " (ldict-ref em 'to))
|
(print "### To: " (ldict-ref em 'to))
|
||||||
(print "### Subject: " (ldict-ref em 'subject))
|
(print "### Subject: " (ldict-ref em 'subject))
|
||||||
(when (*notifications-cc*)
|
|
||||||
(print "### CC: " (*notifications-cc*)))
|
|
||||||
(let loop ((lines (ldict-ref em 'body)))
|
(let loop ((lines (ldict-ref em 'body)))
|
||||||
(when (not (null? lines))
|
(when (not (null? lines))
|
||||||
(print (car lines))
|
(print (car lines))
|
||||||
|
|
@ -80,11 +75,7 @@
|
||||||
""))
|
""))
|
||||||
(send-mail (ldict-ref em 'body)
|
(send-mail (ldict-ref em 'body)
|
||||||
#:from (*email-from*)
|
#:from (*email-from*)
|
||||||
#:headers (ldict-ref em 'headers '())
|
#:to (ldict-ref em 'to)
|
||||||
#:to (filter
|
|
||||||
identity
|
|
||||||
(list (ldict-ref em 'to)
|
|
||||||
(ldict-ref em 'cc #f)))
|
|
||||||
#:subject (ldict-ref em 'subject)))
|
#:subject (ldict-ref em 'subject)))
|
||||||
|
|
||||||
;; Creates reminder email body
|
;; Creates reminder email body
|
||||||
|
|
@ -125,13 +116,8 @@
|
||||||
(define (make-reminder-email mr)
|
(define (make-reminder-email mr)
|
||||||
(make-ldict
|
(make-ldict
|
||||||
`((to . ,(brmember-info mr 'mail))
|
`((to . ,(brmember-info mr 'mail))
|
||||||
(cc . ,(*notifications-cc*))
|
|
||||||
(subject . "Připomínka členských příspěvků / Membership fees reminder")
|
(subject . "Připomínka členských příspěvků / Membership fees reminder")
|
||||||
(body . ,(reminder-email-body mr))
|
(body . ,(reminder-email-body mr)))))
|
||||||
(headers . ,(list "Content-Type: text/plain; charset=\"UTF-8\""
|
|
||||||
(format "From: ~A" (*email-from*))
|
|
||||||
(format "CC: ~A" (*notifications-cc*))))
|
|
||||||
)))
|
|
||||||
|
|
||||||
;; Creates and prints reminder email for given member record
|
;; Creates and prints reminder email for given member record
|
||||||
(define (make+print-reminder-email mr)
|
(define (make+print-reminder-email mr)
|
||||||
|
|
@ -144,14 +130,16 @@
|
||||||
(send-notification-email em)))
|
(send-notification-email em)))
|
||||||
|
|
||||||
;; Summary email of membership fees payments
|
;; Summary email of membership fees payments
|
||||||
(define (summary-email-body mb mls)
|
(define (summary-email-body mb)
|
||||||
(let* ((mbs (members-summary mb))
|
(let* ((mbs (members-summary mb))
|
||||||
(students (car mbs))
|
(students (car mbs))
|
||||||
(full (cdr mbs))
|
(full (cdr mbs))
|
||||||
(income (+ (* (lookup-member-fee 'normal) full)
|
(income (+ (* (lookup-member-fee 'normal) full)
|
||||||
(* (lookup-member-fee 'student) students)))
|
(* (lookup-member-fee 'student) students)))
|
||||||
(income-lst
|
(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 (mbase-unpaired mb))
|
||||||
(unpaired-lst
|
(unpaired-lst
|
||||||
(if (null? unpaired)
|
(if (null? unpaired)
|
||||||
|
|
@ -160,30 +148,6 @@
|
||||||
(list ""
|
(list ""
|
||||||
"Unpaired transactions:")
|
"Unpaired transactions:")
|
||||||
(unpaired-table mb #:border-style 'ascii))))
|
(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
|
(debtors (sort
|
||||||
(members-to-notify mb 1)
|
(members-to-notify mb 1)
|
||||||
brmember<?))
|
brmember<?))
|
||||||
|
|
@ -251,62 +215,32 @@
|
||||||
#:border '(((#:bottom #:right light) ... (#:bottom light))
|
#:border '(((#:bottom #:right light) ... (#:bottom light))
|
||||||
((#:right light) ... none)
|
((#:right light) ... none)
|
||||||
...)
|
...)
|
||||||
))))
|
)))))
|
||||||
(dwpu (filter (lambda (dwu)
|
|
||||||
(or (member "member" (list-ref dwu 3))
|
|
||||||
(member "council" (list-ref dwu 3))
|
|
||||||
(member "admin" (list-ref dwu 3))))
|
|
||||||
(ldict-ref mb 'dokuwiki)))
|
|
||||||
(dw-lst
|
|
||||||
(if (null? dwpu)
|
|
||||||
'()
|
|
||||||
(list ""
|
|
||||||
"DokuWiki users (non-members) in wrong group(s):"
|
|
||||||
(string-append
|
|
||||||
" "
|
|
||||||
(string-intersperse
|
|
||||||
(map car dwpu)
|
|
||||||
", ")))))
|
|
||||||
(dwmu (find-members-by-predicate mb (compose not brmember-dokuwiki-groups-ok?)))
|
|
||||||
(dw2-lst
|
|
||||||
(if (null? dwmu)
|
|
||||||
'()
|
|
||||||
(list ""
|
|
||||||
"Members in wrong dokuwiki group(s):"
|
|
||||||
(string-append
|
|
||||||
" "
|
|
||||||
(string-intersperse
|
|
||||||
(map brmember-nick dwmu)
|
|
||||||
", "))))))
|
|
||||||
(append income-lst
|
(append income-lst
|
||||||
unpaired-lst
|
unpaired-lst
|
||||||
soonexps-lst
|
|
||||||
mlcheck-lst
|
|
||||||
debtors-lst
|
debtors-lst
|
||||||
boring-lst
|
boring-lst
|
||||||
dw-lst
|
|
||||||
dw2-lst
|
|
||||||
(list ""
|
(list ""
|
||||||
"--"
|
"--"
|
||||||
"Brmlab Hackerspace Members Database"
|
"Brmlab Hackerspace Members Database"
|
||||||
))))
|
))))
|
||||||
|
|
||||||
;; Creates the summary email structure
|
;; Creates the summary email structure
|
||||||
(define (make-summary-email mb mls)
|
(define (make-summary-email mb)
|
||||||
(make-ldict
|
(make-ldict
|
||||||
`((to . ,(*summary-mailto*))
|
`((to . ,(*summary-mailto*))
|
||||||
(subject . ,(format "Členské příspěvky ~A"
|
(subject . ,(format "Členské příspěvky ~A"
|
||||||
(today/iso)))
|
(today/iso)))
|
||||||
(body . ,(summary-email-body mb mls)))))
|
(body . ,(summary-email-body mb)))))
|
||||||
|
|
||||||
;; Just print to standard output
|
;; Just print to standard output
|
||||||
(define (make+print-summary-email mb mls)
|
(define (make+print-summary-email mb)
|
||||||
(let ((em (make-summary-email mb mls)))
|
(let ((em (make-summary-email mb)))
|
||||||
(print-notification-email em)))
|
(print-notification-email em)))
|
||||||
|
|
||||||
;; Actually send emails
|
;; Actually send emails
|
||||||
(define (make+send-summary-email mr mls)
|
(define (make+send-summary-email mr)
|
||||||
(let ((em (make-summary-email mr mls)))
|
(let ((em (make-summary-email mr)))
|
||||||
(send-notification-email em)))
|
(send-notification-email em)))
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
|
||||||
|
|
@ -35,7 +35,7 @@
|
||||||
|
|
||||||
(import scheme
|
(import scheme
|
||||||
(chicken base)
|
(chicken base)
|
||||||
srfi-1
|
util-list
|
||||||
testing)
|
testing)
|
||||||
|
|
||||||
;; Checks whether given number is prime by checking the remainder of
|
;; Checks whether given number is prime by checking the remainder of
|
||||||
|
|
|
||||||
|
|
@ -1,104 +0,0 @@
|
||||||
;;
|
|
||||||
;; 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)))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -366,6 +366,7 @@
|
||||||
slw))
|
slw))
|
||||||
state)))
|
state)))
|
||||||
(let ((sln (sgr-list-neutralize sl)))
|
(let ((sln (sgr-list-neutralize sl)))
|
||||||
|
;;(write sln)(newline)
|
||||||
(values (list sln) initial-state))))
|
(values (list sln) initial-state))))
|
||||||
|
|
||||||
;; Renders all the lines and appends the resulting blocks
|
;; Renders all the lines and appends the resulting blocks
|
||||||
|
|
|
||||||
|
|
@ -39,8 +39,7 @@
|
||||||
;; Convert into lookups - a list of (list period regular student)
|
;; Convert into lookups - a list of (list period regular student)
|
||||||
(define member-fees-lookup-table
|
(define member-fees-lookup-table
|
||||||
(make-cal-period-lookup-table
|
(make-cal-period-lookup-table
|
||||||
'(((2010 1) 500 250)
|
'(((2010 1) 500 250))))
|
||||||
((2024 1) 1000 250))))
|
|
||||||
|
|
||||||
;; Exchange rates
|
;; Exchange rates
|
||||||
(define exchange-rates-lookup-table
|
(define exchange-rates-lookup-table
|
||||||
|
|
|
||||||
|
|
@ -204,6 +204,8 @@
|
||||||
(tbl1 (render-cells-widths ptbl col-widths))
|
(tbl1 (render-cells-widths ptbl col-widths))
|
||||||
;;(_ (print tbl1))
|
;;(_ (print tbl1))
|
||||||
(tbl2 (map expand-row-height tbl1)))
|
(tbl2 (map expand-row-height tbl1)))
|
||||||
|
;;(write tbl1)(newline)
|
||||||
|
;;(write tbl2)(newline)
|
||||||
;; Just return the result - both the table and cached column widths
|
;; Just return the result - both the table and cached column widths
|
||||||
(values tbl2
|
(values tbl2
|
||||||
col-widths))))
|
col-widths))))
|
||||||
|
|
|
||||||
|
|
@ -88,6 +88,7 @@
|
||||||
(borders (expand-table-style border-spec num-columns num-rows))
|
(borders (expand-table-style border-spec num-columns num-rows))
|
||||||
(col-separators (table-col-separators? borders))
|
(col-separators (table-col-separators? borders))
|
||||||
(rows (merge-rows ptbl borders col-separators unicode?)))
|
(rows (merge-rows ptbl borders col-separators unicode?)))
|
||||||
|
;;(write rows)(newline)
|
||||||
(let loop ((rows rows)
|
(let loop ((rows rows)
|
||||||
(borders borders)
|
(borders borders)
|
||||||
(res '())
|
(res '())
|
||||||
|
|
|
||||||
|
|
@ -5,7 +5,7 @@
|
||||||
;;
|
;;
|
||||||
;; ISC License
|
;; ISC License
|
||||||
;;
|
;;
|
||||||
;; Copyright 2023-2025 Brmlab, z.s.
|
;; Copyright 2023 Brmlab, z.s.
|
||||||
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
||||||
;;
|
;;
|
||||||
;; Permission to use, copy, modify, and/or distribute this software
|
;; Permission to use, copy, modify, and/or distribute this software
|
||||||
|
|
@ -39,7 +39,7 @@
|
||||||
(chicken format))
|
(chicken format))
|
||||||
|
|
||||||
;; Short banner
|
;; Short banner
|
||||||
(define banner-line "HackerBase 1.19 (c) 2023-2025 Brmlab, z.s.")
|
(define banner-line "HackerBase 1.10 (c) 2023 Brmlab, z.s.")
|
||||||
|
|
||||||
;; Banner source with numbers for ANSI CSI SGR
|
;; Banner source with numbers for ANSI CSI SGR
|
||||||
(define banner-source "
|
(define banner-source "
|
||||||
|
|
|
||||||
|
|
@ -1,63 +0,0 @@
|
||||||
;;
|
|
||||||
;; tiocgwinsz.scm
|
|
||||||
;;
|
|
||||||
;; Get size of current terminal.
|
|
||||||
;;
|
|
||||||
;; ISC License
|
|
||||||
;;
|
|
||||||
;; Copyright 2023 Brmlab, z.s.
|
|
||||||
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
||||||
;;
|
|
||||||
;; Permission to use, copy, modify, and/or distribute this software
|
|
||||||
;; for any purpose with or without fee is hereby granted, provided
|
|
||||||
;; that the above copyright notice and this permission notice appear
|
|
||||||
;; in all copies.
|
|
||||||
;;
|
|
||||||
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
||||||
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
||||||
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
||||||
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
||||||
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
||||||
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
||||||
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
||||||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
;;
|
|
||||||
|
|
||||||
(declare (unit tiocgwinsz))
|
|
||||||
|
|
||||||
(import duck)
|
|
||||||
|
|
||||||
(foreign-declare "#include <sys/ioctl.h>")
|
|
||||||
|
|
||||||
(module*
|
|
||||||
tiocgwinsz
|
|
||||||
#:doc ("TTY terminal size support.")
|
|
||||||
(
|
|
||||||
term-size
|
|
||||||
)
|
|
||||||
|
|
||||||
(import scheme
|
|
||||||
(chicken foreign)
|
|
||||||
(chicken bitwise))
|
|
||||||
|
|
||||||
(define tiocgwinsz-ioctl
|
|
||||||
(foreign-lambda*
|
|
||||||
int ()
|
|
||||||
"
|
|
||||||
struct winsize wss;
|
|
||||||
if (ioctl(0, TIOCGWINSZ, &wss) == 0) {
|
|
||||||
C_return(wss.ws_row*65536+wss.ws_col);
|
|
||||||
} else {
|
|
||||||
C_return(0);
|
|
||||||
}
|
|
||||||
"
|
|
||||||
))
|
|
||||||
|
|
||||||
(define/doc (term-size)
|
|
||||||
("Returns the number of terminal rows and columns.")
|
|
||||||
(let ((res (tiocgwinsz-ioctl)))
|
|
||||||
(values
|
|
||||||
(arithmetic-shift res -16)
|
|
||||||
(bitwise-and res #xffff))))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -1,27 +1,3 @@
|
||||||
;;
|
|
||||||
;; util-bst-bdict.scm
|
|
||||||
;;
|
|
||||||
;; BST-based number dictionary.
|
|
||||||
;;
|
|
||||||
;; ISC License
|
|
||||||
;;
|
|
||||||
;; Copyright 2023 Brmlab, z.s.
|
|
||||||
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
||||||
;;
|
|
||||||
;; Permission to use, copy, modify, and/or distribute this software
|
|
||||||
;; for any purpose with or without fee is hereby granted, provided
|
|
||||||
;; that the above copyright notice and this permission notice appear
|
|
||||||
;; in all copies.
|
|
||||||
;;
|
|
||||||
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
||||||
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
||||||
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
||||||
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
||||||
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
||||||
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
||||||
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
||||||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
;;
|
|
||||||
|
|
||||||
(declare (unit util-bst-bdict))
|
(declare (unit util-bst-bdict))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,27 +1,3 @@
|
||||||
;;
|
|
||||||
;; util-bst-ldict.scm
|
|
||||||
;;
|
|
||||||
;; BST-based symbol dictionary.
|
|
||||||
;;
|
|
||||||
;; ISC License
|
|
||||||
;;
|
|
||||||
;; Copyright 2023 Brmlab, z.s.
|
|
||||||
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
||||||
;;
|
|
||||||
;; Permission to use, copy, modify, and/or distribute this software
|
|
||||||
;; for any purpose with or without fee is hereby granted, provided
|
|
||||||
;; that the above copyright notice and this permission notice appear
|
|
||||||
;; in all copies.
|
|
||||||
;;
|
|
||||||
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
||||||
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
||||||
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
||||||
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
||||||
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
||||||
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
||||||
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
||||||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
;;
|
|
||||||
|
|
||||||
(declare (unit util-bst-ldict))
|
(declare (unit util-bst-ldict))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,27 +1,3 @@
|
||||||
;;
|
|
||||||
;; util-bst-lset.scm
|
|
||||||
;;
|
|
||||||
;; BST-based set implementation.
|
|
||||||
;;
|
|
||||||
;; ISC License
|
|
||||||
;;
|
|
||||||
;; Copyright 2023 Brmlab, z.s.
|
|
||||||
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
||||||
;;
|
|
||||||
;; Permission to use, copy, modify, and/or distribute this software
|
|
||||||
;; for any purpose with or without fee is hereby granted, provided
|
|
||||||
;; that the above copyright notice and this permission notice appear
|
|
||||||
;; in all copies.
|
|
||||||
;;
|
|
||||||
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
||||||
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
||||||
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
||||||
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
||||||
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
||||||
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
||||||
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
||||||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
;;
|
|
||||||
|
|
||||||
(declare (unit util-bst-lset))
|
(declare (unit util-bst-lset))
|
||||||
|
|
||||||
|
|
@ -49,7 +25,7 @@
|
||||||
util-bst
|
util-bst
|
||||||
racket-kwargs
|
racket-kwargs
|
||||||
util-bst-ldict
|
util-bst-ldict
|
||||||
srfi-1)
|
util-list)
|
||||||
|
|
||||||
(define* (make-lset (equality? equal?))
|
(define* (make-lset (equality? equal?))
|
||||||
(make-bst 'lset equality? ldict<?))
|
(make-bst 'lset equality? ldict<?))
|
||||||
|
|
|
||||||
|
|
@ -1,27 +1,3 @@
|
||||||
;;
|
|
||||||
;; util-bst.scm
|
|
||||||
;;
|
|
||||||
;; Underlying BST implementation for sets and dictionaries.
|
|
||||||
;;
|
|
||||||
;; ISC License
|
|
||||||
;;
|
|
||||||
;; Copyright 2023 Brmlab, z.s.
|
|
||||||
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
||||||
;;
|
|
||||||
;; Permission to use, copy, modify, and/or distribute this software
|
|
||||||
;; for any purpose with or without fee is hereby granted, provided
|
|
||||||
;; that the above copyright notice and this permission notice appear
|
|
||||||
;; in all copies.
|
|
||||||
;;
|
|
||||||
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
||||||
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
||||||
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
||||||
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
||||||
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
||||||
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
||||||
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
||||||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
;;
|
|
||||||
|
|
||||||
(declare (unit util-bst))
|
(declare (unit util-bst))
|
||||||
|
|
||||||
|
|
@ -286,12 +262,10 @@
|
||||||
(call/cc
|
(call/cc
|
||||||
(lambda (cc)
|
(lambda (cc)
|
||||||
(set! break cc)
|
(set! break cc)
|
||||||
(cond (resume
|
(if resume
|
||||||
(resume '())
|
(resume '())
|
||||||
(break #f))
|
(bst-iter-kv bst yield))
|
||||||
(else
|
#f)))))
|
||||||
(bst-iter-kv bst yield)
|
|
||||||
(break #f))))))))
|
|
||||||
|
|
||||||
(define/doc (bst-keys bst)
|
(define/doc (bst-keys bst)
|
||||||
("Returns all the keys contained in given dictionary.")
|
("Returns all the keys contained in given dictionary.")
|
||||||
|
|
|
||||||
69
src/util-list.scm
Normal file
69
src/util-list.scm
Normal file
|
|
@ -0,0 +1,69 @@
|
||||||
|
;;
|
||||||
|
;; util-list.scm
|
||||||
|
;;
|
||||||
|
;; Various utilities so that no external libraries are needed.
|
||||||
|
;;
|
||||||
|
;; ISC License
|
||||||
|
;;
|
||||||
|
;; Copyright 2023 Brmlab, z.s.
|
||||||
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
||||||
|
;;
|
||||||
|
;; Permission to use, copy, modify, and/or distribute this software
|
||||||
|
;; for any purpose with or without fee is hereby granted, provided
|
||||||
|
;; that the above copyright notice and this permission notice appear
|
||||||
|
;; in all copies.
|
||||||
|
;;
|
||||||
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
||||||
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
||||||
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
||||||
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
||||||
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
||||||
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
||||||
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
||||||
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
||||||
|
;;
|
||||||
|
|
||||||
|
(declare (unit util-list))
|
||||||
|
|
||||||
|
(import duck)
|
||||||
|
|
||||||
|
(module*
|
||||||
|
util-list
|
||||||
|
#:doc ("This module implements basic list functionality which is common in
|
||||||
|
most scheme implementations.")
|
||||||
|
(
|
||||||
|
filter
|
||||||
|
util-list-tests!
|
||||||
|
)
|
||||||
|
|
||||||
|
(import scheme
|
||||||
|
(chicken base)
|
||||||
|
(chicken io)
|
||||||
|
(chicken process)
|
||||||
|
testing)
|
||||||
|
|
||||||
|
(define/doc (filter pred? lst)
|
||||||
|
("* ```pred?``` - procedure accepting any value and returning #t or #f
|
||||||
|
* ```lst``` - list to be filtered
|
||||||
|
|
||||||
|
Returns a list containing only elements matching given ```pred?```
|
||||||
|
predicate.")
|
||||||
|
(let loop ((lst lst)
|
||||||
|
(res '()))
|
||||||
|
(if (null? lst)
|
||||||
|
(reverse res)
|
||||||
|
(if (pred? (car lst))
|
||||||
|
(loop (cdr lst)
|
||||||
|
(cons (car lst) res))
|
||||||
|
(loop (cdr lst)
|
||||||
|
res)))))
|
||||||
|
|
||||||
|
;; Performs utils module self-tests.
|
||||||
|
(define (util-list-tests!)
|
||||||
|
(run-tests
|
||||||
|
util-list
|
||||||
|
(test-equal? filter (filter odd? '(1 2 3 4)) '(1 3))
|
||||||
|
(test-equal? filter (filter odd? '(2 4)) '())
|
||||||
|
))
|
||||||
|
|
||||||
|
)
|
||||||
|
|
@ -5,7 +5,7 @@
|
||||||
;;
|
;;
|
||||||
;; ISC License
|
;; ISC License
|
||||||
;;
|
;;
|
||||||
;; Copyright 2023-2024 Brmlab, z.s.
|
;; Copyright 2023 Brmlab, z.s.
|
||||||
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
||||||
;;
|
;;
|
||||||
;; Permission to use, copy, modify, and/or distribute this software
|
;; Permission to use, copy, modify, and/or distribute this software
|
||||||
|
|
@ -39,8 +39,6 @@
|
||||||
(chicken base)
|
(chicken base)
|
||||||
(chicken keyword)
|
(chicken keyword)
|
||||||
(chicken string)
|
(chicken string)
|
||||||
(chicken irregex)
|
|
||||||
(chicken format)
|
|
||||||
util-io
|
util-io
|
||||||
util-utf8
|
util-utf8
|
||||||
util-string
|
util-string
|
||||||
|
|
@ -63,25 +61,15 @@ sent to the address stored within.")
|
||||||
"?=")
|
"?=")
|
||||||
subj))
|
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.
|
;; Sends an email using the UNIX mail(1) utility.
|
||||||
(define*/doc (send-mail body-lines
|
(define*/doc (send-mail body-lines
|
||||||
#:from (from #f)
|
#:from (from #f)
|
||||||
#:to to
|
#:to to
|
||||||
#:subject subject
|
#:subject subject)
|
||||||
#:headers (headers '()))
|
|
||||||
("* ```body-lines``` - lines of the email
|
("* ```body-lines``` - lines of the email
|
||||||
* ```from``` - email address from string
|
* ```from``` - email address from string
|
||||||
* ```to``` - email address to string
|
* ```to``` - email address to string
|
||||||
* ```subject``` - email subject string
|
* ```subject``` - email subject string
|
||||||
* ```headers``` - list of headers to add
|
|
||||||
|
|
||||||
Sends email using mail(1) command. The arguments ```#:to``` and
|
Sends email using mail(1) command. The arguments ```#:to``` and
|
||||||
```#:subject``` are mandatory. Argument ```#:from``` is optional.")
|
```#:subject``` are mandatory. Argument ```#:from``` is optional.")
|
||||||
|
|
@ -90,25 +78,14 @@ Sends email using mail(1) command. The arguments ```#:to``` and
|
||||||
(list to)))
|
(list to)))
|
||||||
(real-tos (if (*mailto-override*)
|
(real-tos (if (*mailto-override*)
|
||||||
(list (*mailto-override*))
|
(list (*mailto-override*))
|
||||||
tos))
|
tos)))
|
||||||
(header-args
|
|
||||||
(flatten
|
|
||||||
(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
|
(apply process-send/recv
|
||||||
"mail"
|
"mail"
|
||||||
(append (if from
|
(append (if from
|
||||||
(list "-r" from-email)
|
(list "-r" from)
|
||||||
'())
|
'())
|
||||||
(list "-s" (encode-subject subject))
|
(list "-s" (encode-subject subject))
|
||||||
real-tos
|
real-tos)
|
||||||
header-args)
|
body-lines)))
|
||||||
body-lines))))
|
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
|
||||||
|
|
@ -39,12 +39,11 @@ member file parsers. All functions are UTF-8 aware.")
|
||||||
|
|
||||||
(import scheme
|
(import scheme
|
||||||
(chicken base)
|
(chicken base)
|
||||||
racket-kwargs
|
|
||||||
testing)
|
testing)
|
||||||
|
|
||||||
;; Pass 0: Removes any comments and removes any leading and trailing
|
;; Pass 0: Removes any comments and removes any leading and trailing
|
||||||
;; whitespace.
|
;; 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
|
("* ```line``` - a string with contents of one source line
|
||||||
|
|
||||||
If the input ```line``` contains the ```#``` character, the rest of
|
If the input ```line``` contains the ```#``` character, the rest of
|
||||||
|
|
@ -63,9 +62,7 @@ Returns a string representing the preprocessed line.")
|
||||||
(ploop (add1 pidx)))))
|
(ploop (add1 pidx)))))
|
||||||
(hpos (let hloop ((hidx ppos))
|
(hpos (let hloop ((hidx ppos))
|
||||||
(if (or (= hidx llen)
|
(if (or (= hidx llen)
|
||||||
(and (or strip-comments?
|
(eq? (string-ref line hidx) #\#))
|
||||||
(= hidx 0))
|
|
||||||
(eq? (string-ref line hidx) #\#)))
|
|
||||||
hidx
|
hidx
|
||||||
(hloop (add1 hidx)))))
|
(hloop (add1 hidx)))))
|
||||||
(spos (let sloop ((sidx (sub1 hpos)))
|
(spos (let sloop ((sidx (sub1 hpos)))
|
||||||
|
|
|
||||||
|
|
@ -37,8 +37,6 @@
|
||||||
|
|
||||||
string-upcase
|
string-upcase
|
||||||
|
|
||||||
string-capitalize
|
|
||||||
|
|
||||||
string-tests!
|
string-tests!
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
@ -102,18 +100,6 @@ using ```char-upcase```. Does not work with UTF-8.")
|
||||||
(map char-upcase
|
(map char-upcase
|
||||||
(string->list str))))
|
(string->list str))))
|
||||||
|
|
||||||
(define/doc (string-capitalize str)
|
|
||||||
("* ```str``` - arbitrary string
|
|
||||||
|
|
||||||
Returns the ```str``` with the first character converted to upper case
|
|
||||||
using ```char-upcase``` and the remainder converted to lower case
|
|
||||||
using ```char-downcase```. Does not work with UTF-8.")
|
|
||||||
(let ((l (string->list str)))
|
|
||||||
(list->string
|
|
||||||
(cons
|
|
||||||
(char-upcase (car l))
|
|
||||||
(map char-downcase (cdr l))))))
|
|
||||||
|
|
||||||
;; Performs utils module self-tests.
|
;; Performs utils module self-tests.
|
||||||
(define (string-tests!)
|
(define (string-tests!)
|
||||||
(run-tests
|
(run-tests
|
||||||
|
|
@ -136,12 +122,6 @@ using ```char-downcase```. Does not work with UTF-8.")
|
||||||
(test-equal? string-upcase
|
(test-equal? string-upcase
|
||||||
(string-upcase "asdFGH")
|
(string-upcase "asdFGH")
|
||||||
"ASDFGH")
|
"ASDFGH")
|
||||||
(test-equal? string-capitalize
|
|
||||||
(string-capitalize "asdf")
|
|
||||||
"Asdf")
|
|
||||||
(test-equal? string-capitalize
|
|
||||||
(string-capitalize "ASDF")
|
|
||||||
"Asdf")
|
|
||||||
))
|
))
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
|
||||||
|
|
@ -120,13 +120,13 @@ of the string and a list of remaining bytes (as integers).")
|
||||||
(define/doc (utf8-bytes->lists chars)
|
(define/doc (utf8-bytes->lists chars)
|
||||||
("The same as above but accepts a list of bytes (as integers).")
|
("The same as above but accepts a list of bytes (as integers).")
|
||||||
(let loop ((bytes chars)
|
(let loop ((bytes chars)
|
||||||
(rpending chars)
|
(rpending '())
|
||||||
(pending 0)
|
(pending 0)
|
||||||
(expected #f)
|
(expected #f)
|
||||||
(res '()))
|
(res '()))
|
||||||
(if (null? bytes)
|
(if (null? bytes)
|
||||||
(values (reverse res)
|
(values (reverse res)
|
||||||
rpending)
|
(reverse rpending))
|
||||||
(let ((byte (car bytes)))
|
(let ((byte (car bytes)))
|
||||||
(cond (expected
|
(cond (expected
|
||||||
;; Decode UTF-8 sequence
|
;; 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
|
(let ((char (integer->char (bitwise-ior pending
|
||||||
(bitwise-and byte #b111111)))))
|
(bitwise-and byte #b111111)))))
|
||||||
(loop (cdr bytes)
|
(loop (cdr bytes)
|
||||||
(cdr bytes)
|
'()
|
||||||
0
|
0
|
||||||
#f
|
#f
|
||||||
(cons char res))))
|
(cons char res))))
|
||||||
(else
|
(else
|
||||||
;; Intermediate bytes
|
;; Intermediate bytes
|
||||||
(loop (cdr bytes)
|
(loop (cdr bytes)
|
||||||
rpending
|
(cons byte rpending)
|
||||||
(arithmetic-shift (bitwise-ior pending
|
(arithmetic-shift (bitwise-ior pending
|
||||||
(bitwise-and byte #b111111)) 6)
|
(bitwise-and byte #b111111)) 6)
|
||||||
(sub1 expected)
|
(sub1 expected)
|
||||||
|
|
@ -152,7 +152,7 @@ of the string and a list of remaining bytes (as integers).")
|
||||||
(cond ((= (bitwise-and byte #b10000000) 0)
|
(cond ((= (bitwise-and byte #b10000000) 0)
|
||||||
;; ASCII
|
;; ASCII
|
||||||
(loop (cdr bytes)
|
(loop (cdr bytes)
|
||||||
(cdr bytes)
|
'()
|
||||||
0
|
0
|
||||||
#f
|
#f
|
||||||
(cons (integer->char byte) res)))
|
(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
|
;; First byte of UTF-8 sequence
|
||||||
(let-values
|
(let-values
|
||||||
(((first-byte char-bytes)
|
(((first-byte char-bytes)
|
||||||
(cond ((= (bitwise-and byte #b11100000) #b11000000)
|
(cond ((= (bitwise-and byte #b11000000) #b11000000)
|
||||||
(values (bitwise-and byte #b11111)
|
(values (bitwise-and byte #b11111)
|
||||||
2))
|
2))
|
||||||
((= (bitwise-and byte #b11110000) #b11100000)
|
((= (bitwise-and byte #b11100000) #b11100000)
|
||||||
(values (bitwise-and byte #b1111)
|
(values (bitwise-and byte #b1111)
|
||||||
3))
|
3))
|
||||||
((= (bitwise-and byte #b11111000) #b11110000)
|
((= (bitwise-and byte #b11110000) #b11110000)
|
||||||
(values (bitwise-and byte #b111)
|
(values (bitwise-and byte #b111)
|
||||||
4))
|
4))
|
||||||
(else
|
(else
|
||||||
;; Should not happen
|
;; Should not happen
|
||||||
(values 0 0)))))
|
(values 0 0)))))
|
||||||
(loop (cdr bytes)
|
(loop (cdr bytes)
|
||||||
bytes
|
(list byte)
|
||||||
(arithmetic-shift first-byte 6)
|
(arithmetic-shift first-byte 6)
|
||||||
(sub1 char-bytes)
|
(sub1 char-bytes)
|
||||||
res))))))))))
|
res))))))))))
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue