diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 index a5bfc54..0000000 --- a/CHANGELOG.md +++ /dev/null @@ -1,197 +0,0 @@ -ChangeLog -========= - -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 diff --git a/README.md b/README.md index 48798c6..9fcb37f 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ License ISC License -Copyright 2023-2024 Brmlab, z.s. +Copyright 2023 Brmlab, z.s. Dominik Pantůček Permission to use, copy, modify, and/or distribute this software diff --git a/doc/formats.md b/doc/formats.md index 36f8a73..ac5ccb8 100644 --- a/doc/formats.md +++ b/doc/formats.md @@ -56,6 +56,7 @@ Processed source is scanned for known keys. Known keys are: * nick * name * mail +* phone * born Multiple instances of single key are considered an error. @@ -82,7 +83,6 @@ line numbers as the value for such key. Multikeys are: * revisionstop * grantstart * grantstop -* phone The result is a valid dictionary of keys and multikeys. @@ -104,8 +104,7 @@ periods. The joined key is converted into a month value. 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 -phone numbers. +comment. Credit list is parsed to get a list of amounts and optional comments. diff --git a/doc/hackerbase.1 b/doc/hackerbase.1 index 531e4cb..27a71c2 100644 --- a/doc/hackerbase.1 +++ b/doc/hackerbase.1 @@ -273,6 +273,10 @@ Specify member by nickname. .B \-destroyed Show destroyed members in \fB-fees\fR action as well. +.TP +.B \-ml-all +Load all mailman list memberships to show them in members info. + .SH "FILES" All the information about members is stored in in members file in the diff --git a/src/Makefile b/src/Makefile index 8a9a50b..c71d1ff 100644 --- a/src/Makefile +++ b/src/Makefile @@ -42,9 +42,7 @@ HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm \ tests.import.scm notifications.import.scm logging.import.scm \ progress.import.scm cal-period.import.scm \ util-stdout.import.scm export-web-static.import.scm \ - dokuwiki.import.scm mailinglist.import.scm \ - export-sheet.import.scm mbase-query.import.scm \ - qr-payment.import.scm + dokuwiki.import.scm HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \ cal-period.o ansi.o util-bst-ldict.o command-line.o mbase.o \ @@ -60,9 +58,8 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \ table-style.o sgr-state.o util-utf8.o sgr-cell.o \ template-list-expander.o box-drawing.o export-web-static.o \ util-dir.o dokuwiki.o racket-kwargs.o duck.o util-bst.o \ - util-bst-bdict.o util-bst-ldict.o util-bst-lset.o \ - mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o \ - mailinglist.o export-sheet.o mbase-query.o qr-payment.o + util-bst-bdict.o util-bst-ldict.o util-bst-lset.o mailman2.o \ + mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \ util-time.import.scm util-csv.import.scm util-git.import.scm \ @@ -260,6 +257,13 @@ ENVIRONMENT-SOURCES=environment.scm ansi.import.scm environment.o: environment.import.scm environment.import.scm: $(ENVIRONMENT-SOURCES) +MAILMAN2-SOURCES=mailman2.scm util-bst-lset.import.scm \ + util-io.import.scm mailman-common.import.scm \ + configuration.import.scm + +mailman2.o: mailman2.import.scm +mailman2.import.scm: $(MAILMAN2-SOURCES) + UTIL-TIME-SOURCES=util-time.scm duck.import.scm util-time.o: util-time.import.scm @@ -287,7 +291,7 @@ util-io.o: util-io.import.scm util-io.import.scm: $(UTIL-IO-SOURCES) UTIL-PARSER-SOURCES=util-parser.scm testing.import.scm \ - duck.import.scm racket-kwargs.import.scm + duck.import.scm util-parser.o: util-parser.import.scm util-parser.import.scm: $(UTIL-PARSER-SOURCES) @@ -328,8 +332,7 @@ NOTIFICATIONS-SOURCES=notifications.scm brmember.import.scm \ brmember-format.import.scm configuration.import.scm \ util-time.import.scm members-fees.import.scm mbase.import.scm \ members-print.import.scm table.import.scm \ - bank-account.import.scm logging.import.scm \ - mailinglist.import.scm + bank-account.import.scm logging.import.scm notifications.o: notifications.import.scm notifications.import.scm: $(NOTIFICATIONS-SOURCES) @@ -468,8 +471,7 @@ box-drawing.import.scm: $(BOX-DRAWING-SOURCES) EXPORT-WEB-STATIC-SOURCES=export-web-static.scm brmember.import.scm \ util-dir.import.scm mbase.import.scm \ members-payments.import.scm cal-day.import.scm \ - util-git.import.scm configuration.import.scm texts.import.scm \ - members-fees.import.scm qr-payment.import.scm + util-git.import.scm configuration.import.scm texts.import.scm export-web-static.o: export-web-static.import.scm export-web-static.import.scm: $(EXPORT-WEB-STATIC-SOURCES) @@ -520,9 +522,10 @@ UTIL-BST-LSET-SOURCES=util-bst-lset.scm util-bst.import.scm \ util-bst-lset.o: util-bst-lset.import.scm util-bst-lset.import.scm: $(UTIL-BST-LSET-SOURCES) -MAILMAN-SOURCES=mailman.scm mailman-common.import.scm \ - util-bst-lset.import.scm configuration.import.scm \ - mailman3.import.scm progress.import.scm +MAILMAN-SOURCES=mailman.scm mailman2.import.scm \ + mailman-common.import.scm util-bst-lset.import.scm \ + configuration.import.scm mailman3.import.scm \ + progress.import.scm mailman.o: mailman.import.scm mailman.import.scm: $(MAILMAN-SOURCES) @@ -547,32 +550,3 @@ TIOCGWINSZ-SOURCES=tiocgwinsz.scm duck.import.scm tiocgwinsz.o: tiocgwinsz.import.scm tiocgwinsz.import.scm: $(TIOCGWINSZ-SOURCES) - -MAILINGLIST-SOURCES=mailinglist.scm racket-kwargs.import.scm \ - mailman.import.scm mbase.import.scm util-string.import.scm \ - brmember.import.scm - -mailinglist.o: mailinglist.import.scm -mailinglist.import.scm: $(MAILINGLIST-SOURCES) - -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) diff --git a/src/brmember-parser.scm b/src/brmember-parser.scm index 4c35225..8068404 100644 --- a/src/brmember-parser.scm +++ b/src/brmember-parser.scm @@ -48,7 +48,7 @@ cal-day) ;; Pass 2: known keys - (define mandatory-keys '(nick name mail)) + (define mandatory-keys '(nick name mail phone)) (define optional-keys '(born)) (define known-multikeys '(card desfire @@ -59,9 +59,7 @@ councilstart councilstop revisionstart revisionstop grantstart grantstop - joined destroyed - feestart feestop - phone)) + joined destroyed)) (define ignored-keys '(mail2)) (define known-keys (append mandatory-keys optional-keys)) @@ -85,9 +83,6 @@ (joined member start) (destroyed member stop) - - (feestart fee start) - (feestop fee stop) )) (define start-stop-markers (map car start-stop-markers-lookup)) @@ -114,38 +109,22 @@ (info ,(lambda (mr output key value) (case key - ((student suspend member revision chair council grant fee) + ((student suspend member revision chair council grant) (let* ((res (period-markers->cal-periods value)) (ok? (car res)) - (periods0 (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)) + (periods (cadr res)) (msg (caddr res)) (line-number (cadddr res)) (mr1 (brmember-sub-set mr output key periods))) (if ok? mr1 (brmember-add-highlight mr1 line-number msg 3 'error)))) - ((card desfire phone) + ((card desfire) (brmember-sub-set mr output key - (map - (lambda (rec) - (string-first+rest (car rec))) - value))) + (map + (lambda (rec) + (string-first+rest (car rec))) + value))) ((credit) (let loop ((mr mr) (src-credits value) @@ -274,7 +253,7 @@ (caar passes) (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) (let* ((mrif (brmember-input-file mr)) (source (read-lines mrif)) diff --git a/src/brmember.scm b/src/brmember.scm index cb065f4..8603e36 100644 --- a/src/brmember.scm +++ b/src/brmember.scm @@ -85,10 +85,6 @@ brmember-mailman brmember-add-mailman - brmember-spec-fee - - brmember-age - brmember-tests! ) @@ -425,8 +421,7 @@ (if (brmember-suspended? mr) (let ((period (cal-periods-match (brmember-info mr 'suspend)))) (if period - (cal-month-diff (cal-ensure-month (cal-period-since period)) - (*current-month*)) + (cal-month-diff (cal-period-since period) (*current-month*)) 0)) 0)) @@ -483,29 +478,6 @@ (cons ml (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 (define (brmember-tests!) (run-tests @@ -514,8 +486,8 @@ (ldict-equal? (make-brmember '|1234| "members/1234" '(|member|)) (make-ldict - `((TAG . ,TAG-BRMEMBER) - (file-name . |1234|) + `((file-name . |1234|) + (TAG . ,TAG-BRMEMBER) (file-path . "members/1234") (symlinks |member|) (id . 1234))))) diff --git a/src/cal-period.scm b/src/cal-period.scm index 447f563..74c6e15 100644 --- a/src/cal-period.scm +++ b/src/cal-period.scm @@ -26,464 +26,435 @@ (declare (unit cal-period)) (module + cal-period + ( + *current-month* + *current-day* + + set-current-month! + set-current-day! + + with-current-month + with-current-day + + make-cal-period + + cal-period-since + cal-period-before + cal-period-scomment + cal-period-bcomment + + period-markers->cal-periods + + cal-periods-duration + + cal-month-in-period? + cal-month-in-periods? + + cal-day-in-period? + cal-day-in-periods? + + cal-periods->string + cal-periods-match + + make-cal-period-lookup-table + lookup-by-cal-period + + cal-ensure-month + cal-ensure-day + + cal-period-tests! + ) + + (import scheme + (chicken base) + (chicken sort) + (chicken time) + (chicken time posix) + (chicken format) + (chicken string) + cal-month + testing + util-tag + cal-day) + + ;; Type tag + (define TAG-CAL-PERIOD (make-tag CAL-PERIOD)) + + ;; Current month - if changed, we get the actual state for given month. + (define *current-month* + (make-parameter + (let ((d (seconds->local-time (current-seconds)))) + (make-cal-month (+ 1900 (vector-ref d 5)) + (+ (vector-ref d 4) 1))))) + + ;; Current month - if changed, we get the actual state for given month. + (define *current-day* + (make-parameter + (let ((d (seconds->local-time (current-seconds)))) + (make-cal-day (+ 1900 (vector-ref d 5)) + (+ (vector-ref d 4) 1) + (vector-ref d 3))))) + + ;; Changes both current-month and current-day based on given month + (define (set-current-month! m) + (*current-month* m) + (*current-day* (cal-ensure-day m))) + + ;; Changes both current-day and current-month based on given day + (define (set-current-day! d) + (*current-day* d) + (*current-month* (cal-ensure-month d))) + + ;; Parameterizes both current-month and current-day based on given + ;; month + (define-syntax with-current-month + (syntax-rules () + ((_ ms body ...) + (let ((m ms)) + (parameterize ((*current-month* m) + (*current-day* (cal-ensure-day m))) + body ...))))) + + ;; Parameterizes both current-day and current-month based on given + ;; day + (define-syntax with-current-day + (syntax-rules () + ((_ ds body ...) + (let ((d ds)) + (parameterize ((*current-day* d) + (*current-month* (cal-ensure-month d))) + body ...))))) + + ;; Creates a new period value with optional since and before + ;; comments. + (define (make-cal-period since before . args) + (let ((scomment (if (not (null? args)) (car args) #f)) + (bcomment (if (and (not (null? args)) + (not (null? (cdr args)))) + (cadr args) + #f))) + (list TAG-CAL-PERIOD since before scomment bcomment))) + + ;; Simple accessors + (define cal-period-since cadr) + (define cal-period-before caddr) + (define cal-period-scomment cadddr) + (define cal-period-bcomment (compose cadddr cdr)) + + ;; Type predicate + (define (cal-period? p) + (and (pair? p) + (eq? (car p) + TAG-CAL-PERIOD))) + + ;; Month subtype predicate + (define (cal-period-month? p) + (and (cal-period? p) + (cal-month? (cal-period-since p)) + (cal-month? (cal-period-before p)))) + + ;; Day subtype predicate + (define (cal-period-day? p) + (and (cal-period? p) + (cal-day? (cal-period-since p)) + (cal-day? (cal-period-before p)))) + + ;; Validation + (define (cal-period-valid? p) + (and (pair? p) + (eq? (car p) + TAG-CAL-PERIOD) + (let ((since (cal-period-since p)) + (before (cal-period-before p))) + (or (and (cal-month? since) + (cal-month? before) + (cal-month<=? since before)) + (and (cal-day? since) + (cal-day? before) + (cal-day<=? since before)))))) + + ;; Sorts period markers (be it start or end) chronologically and + ;; returns the sorted list. + (define (sort-period-markers l) + (sort l + (lambda (a b) + (cal-day/monthcal-periods l) + (let loop ((l (sort-period-markers l)) + (ps '()) + (cb #f)) + (if (null? l) + (list #t + (if cb + (reverse (cons (make-cal-period (car cb) #f (cadr cb)) ps)) + (reverse ps)) + "" + -1) + (let* ((marker (car l)) + (rmt (if cb 'stop 'start)) + (mtype (car marker)) + (month (cadr marker)) + (line-number (if (null? (cddr marker)) + #f + (caddr marker))) + (comment (if (and line-number + (not (null? (cdddr marker)))) + (cadddr marker) + #f))) + (if (eq? mtype rmt) + (if cb + (loop (cdr l) + (cons (make-cal-period (car cb) month (cadr cb) comment) ps) + #f) + (loop (cdr l) + ps + (list month comment))) + (list #f + (reverse ps) + (sprintf "Invalid start/stop sequence marker ~A" marker) + line-number)))))) + + ;; Returns duration of period in months. Start is included, end is + ;; not. The period contains the month just before the specified end. + (define (cal-period->duration p) + (let* ((b (cal-period-since p)) + (e (cal-period-before p)) + (e- (if e e (*current-month*)))) + (cal-month-diff b e-))) + + ;; Returns sum of periods lengths. + (define (cal-periods-duration l) + (apply + (map cal-period->duration l))) + + ;; True if month belongs to given month period - start inclusive, end + ;; exclusive. + (define (cal-month-in-period? p . ml) + (let ((m (if (null? ml) + (*current-month*) + (cal-ensure-month (car ml)))) + (before (cal-ensure-month (cal-period-before p) #t)) + (since (cal-ensure-month (cal-period-since p)))) + (and (or (not before) + (cal-monthstring p) + (sprintf "~A..~A" + (cal-day/month->string (cal-period-since p)) + (cal-day/month->string (cal-period-before p)))) + + ;; Returns a string representing a list of periods. + (define (cal-periods->string ps) + (string-intersperse + (map cal-period->string ps) + ", ")) + + ;; Finds a period the month matches and returns it. If no period + ;; matches, it returns #f. + (define (cal-periods-match ps . ml) + (let ((m (if (null? ml) (*current-month*) (car ml)))) + (let loop ((ps ps)) + (if (null? ps) + #f + (if (cal-month-in-period? (car ps) m) + (car ps) + (loop (cdr ps))))))) + + ;; Creates lookup table from definition source + (define (make-cal-period-lookup-table source) + (let loop ((lst source) + (res '()) + (prev #f)) + (if (null? lst) + (reverse + (cons (cons (make-cal-period (apply make-cal-month (car prev)) #f) + (cdr prev)) + res)) + (loop (cdr lst) + (if prev + (cons (cons (make-cal-period (apply make-cal-month (car prev)) + (apply make-cal-month (caar lst))) + (cdr prev)) + res) + res) + (car lst))))) + + ;; Looks up current month and returns associated definitions + (define (lookup-by-cal-period table) + (let loop ((lst table)) + (if (null? lst) + #f + (if (cal-month-in-period? (caar lst)) + (cdar lst) + (loop (cdr lst)))))) + + ;; Wrapper that accepts either day or month and returns testable month + (define (cal-ensure-month v . stop?s) + (if v + (if (cal-month? v) + v + (if (cal-day? v) + (apply cal-day->month v stop?s) + #f)) + #f)) + + ;; Ensures day for checking the periods + (define (cal-ensure-day v) + (if v + (if (cal-day? v) + v + (if (cal-month? v) + (make-cal-day (cal-month-year v) + (cal-month-month v) + 1) + #f)) + #f)) + + ;; Performs self-tests of the period module. + (define (cal-period-tests!) + (run-tests cal-period - ( - current-year - *current-month* - *current-day* - - set-current-month! - set-current-day! - - with-current-month - with-current-day - - make-cal-period - - cal-period-since - cal-period-before - cal-period-scomment - cal-period-bcomment - - set-cal-period-scomment - - period-markers->cal-periods - - cal-periods-duration - - cal-month-in-period? - cal-month-in-periods? - - cal-month-find-period - - cal-day-in-period? - cal-day-in-periods? - - cal-periods->string - cal-periods-match - - make-cal-period-lookup-table - lookup-by-cal-period - - cal-ensure-month - cal-ensure-day - - cal-period-tests! - ) - - (import scheme - (chicken base) - (chicken sort) - (chicken time) - (chicken time posix) - (chicken format) - (chicken string) - cal-month - testing - util-tag - cal-day) - - ;; Type tag - (define TAG-CAL-PERIOD (make-tag CAL-PERIOD)) - - (define (current-year) - (cal-month-year (*current-month*))) - - ;; Current month - if changed, we get the actual state for given month. - (define *current-month* - (make-parameter - (let ((d (seconds->local-time (current-seconds)))) - (make-cal-month (+ 1900 (vector-ref d 5)) - (+ (vector-ref d 4) 1))))) - - ;; Current month - if changed, we get the actual state for given month. - (define *current-day* - (make-parameter - (let ((d (seconds->local-time (current-seconds)))) - (make-cal-day (+ 1900 (vector-ref d 5)) - (+ (vector-ref d 4) 1) - (vector-ref d 3))))) - - ;; Changes both current-month and current-day based on given month - (define (set-current-month! m) - (*current-month* m) - (*current-day* (cal-ensure-day m))) - - ;; Changes both current-day and current-month based on given day - (define (set-current-day! d) - (*current-day* d) - (*current-month* (cal-ensure-month d))) - - ;; Parameterizes both current-month and current-day based on given - ;; month - (define-syntax with-current-month - (syntax-rules () - ((_ ms body ...) - (let ((m ms)) - (parameterize ((*current-month* m) - (*current-day* (cal-ensure-day m))) - body ...))))) - - ;; Parameterizes both current-day and current-month based on given - ;; day - (define-syntax with-current-day - (syntax-rules () - ((_ ds body ...) - (let ((d ds)) - (parameterize ((*current-day* d) - (*current-month* (cal-ensure-month d))) - body ...))))) - - ;; Creates a new period value with optional since and before - ;; comments. - (define (make-cal-period since before . args) - (let ((scomment (if (not (null? args)) (car args) #f)) - (bcomment (if (and (not (null? args)) - (not (null? (cdr args)))) - (cadr args) - #f))) - (list TAG-CAL-PERIOD since before scomment bcomment))) - - ;; Simple accessors - (define cal-period-since cadr) - (define cal-period-before caddr) - (define cal-period-scomment cadddr) - (define cal-period-bcomment (compose cadddr cdr)) - - ;; Direct updater - (define (set-cal-period-scomment p c) - (list TAG-CAL-PERIOD - (cal-period-since p) - (cal-period-before p) - c - (cal-period-bcomment p))) - - ;; Type predicate - (define (cal-period? p) - (and (pair? p) - (eq? (car p) - TAG-CAL-PERIOD))) - - ;; Month subtype predicate - (define (cal-period-month? p) - (and (cal-period? p) - (cal-month? (cal-period-since p)) - (cal-month? (cal-period-before p)))) - - ;; Day subtype predicate - (define (cal-period-day? p) - (and (cal-period? p) - (cal-day? (cal-period-since p)) - (cal-day? (cal-period-before p)))) - - ;; Validation - (define (cal-period-valid? p) - (and (pair? p) - (eq? (car p) - TAG-CAL-PERIOD) - (let ((since (cal-period-since p)) - (before (cal-period-before p))) - (or (and (cal-month? since) - (cal-month? before) - (cal-month<=? since before)) - (and (cal-day? since) - (cal-day? before) - (cal-day<=? since before)))))) - - ;; Sorts period markers (be it start or end) chronologically and - ;; returns the sorted list. - (define (sort-period-markers l) - (sort l - (lambda (a b) - (cal-day/monthcal-periods l) - (let loop ((l (sort-period-markers l)) - (ps '()) - (cb #f)) - (if (null? l) - (list #t - (if cb - (reverse (cons (make-cal-period (car cb) #f (cadr cb)) ps)) - (reverse ps)) - "" - -1) - (let* ((marker (car l)) - (rmt (if cb 'stop 'start)) - (mtype (car marker)) - (month (cadr marker)) - (line-number (if (null? (cddr marker)) - #f - (caddr marker))) - (comment (if (and line-number - (not (null? (cdddr marker)))) - (cadddr marker) - #f))) - (if (eq? mtype rmt) - (if cb - (loop (cdr l) - (cons (make-cal-period (car cb) month (cadr cb) comment) ps) - #f) - (loop (cdr l) - ps - (list month comment))) - (list #f - (reverse ps) - (sprintf "Invalid start/stop sequence marker ~A" marker) - line-number)))))) - - ;; Returns duration of period in months. Start is included, end is - ;; not. The period contains the month just before the specified end. - (define (cal-period->duration p) - (let* ((b (cal-period-since p)) - (e (cal-period-before p)) - (e- (if e e (*current-month*)))) - (cal-month-diff b e-))) - - ;; Returns sum of periods lengths. - (define (cal-periods-duration l) - (apply + (map cal-period->duration l))) - - ;; True if month belongs to given month period - start inclusive, end - ;; exclusive. - (define (cal-month-in-period? p . ml) - (let ((m (if (null? ml) - (*current-month*) - (cal-ensure-month (car ml)))) - (before (cal-ensure-month (cal-period-before p) #t)) - (since (cal-ensure-month (cal-period-since p)))) - (and (or (not before) - (cal-monthstring p) - (sprintf "~A..~A" - (cal-day/month->string (cal-period-since p)) - (cal-day/month->string (cal-period-before p)))) - - ;; Returns a string representing a list of periods. - (define (cal-periods->string ps) - (string-intersperse - (map cal-period->string ps) - ", ")) - - ;; Finds a period the month matches and returns it. If no period - ;; matches, it returns #f. - (define (cal-periods-match ps . ml) - (let ((m (if (null? ml) (*current-month*) (car ml)))) - (let loop ((ps ps)) - (if (null? ps) - #f - (if (cal-month-in-period? (car ps) m) - (car ps) - (loop (cdr ps))))))) - - ;; Creates lookup table from definition source - (define (make-cal-period-lookup-table source) - (let loop ((lst source) - (res '()) - (prev #f)) - (if (null? lst) - (reverse - (cons (cons (make-cal-period (apply make-cal-month (car prev)) #f) - (cdr prev)) - res)) - (loop (cdr lst) - (if prev - (cons (cons (make-cal-period (apply make-cal-month (car prev)) - (apply make-cal-month (caar lst))) - (cdr prev)) - res) - res) - (car lst))))) - - ;; Looks up current month and returns associated definitions - (define (lookup-by-cal-period table) - (let loop ((lst table)) - (if (null? lst) - #f - (if (cal-month-in-period? (caar lst)) - (cdar lst) - (loop (cdr lst)))))) - - ;; Wrapper that accepts either day or month and returns testable month - (define (cal-ensure-month v . stop?s) - (if v - (if (cal-month? v) - v - (if (cal-day? v) - (apply cal-day->month v stop?s) - #f)) - #f)) - - ;; Ensures day for checking the periods - (define (cal-ensure-day v) - (if v - (if (cal-day? v) - v - (if (cal-month? v) - (make-cal-day (cal-month-year v) - (cal-month-month v) - 1) - #f)) - #f)) - - ;; Performs self-tests of the period module. - (define (cal-period-tests!) - (run-tests - cal-period - (test-equal? sort-period-markers - (sort-period-markers - `((start ,(make-cal-month 2023 1)) - (stop ,(make-cal-month 2022 10)) - (start ,(make-cal-month 2022 3)))) + (test-equal? sort-period-markers + (sort-period-markers + `((start ,(make-cal-month 2023 1)) + (stop ,(make-cal-month 2022 10)) + (start ,(make-cal-month 2022 3)))) + `((start ,(make-cal-month 2022 3)) + (stop ,(make-cal-month 2022 10)) + (start ,(make-cal-month 2023 1)))) + (test-equal? period-markers->cal-periods + (period-markers->cal-periods `((start ,(make-cal-month 2022 3)) (stop ,(make-cal-month 2022 10)) - (start ,(make-cal-month 2023 1)))) - (test-equal? period-markers->cal-periods - (period-markers->cal-periods - `((start ,(make-cal-month 2022 3)) - (stop ,(make-cal-month 2022 10)) - (start ,(make-cal-month 2023 1)) - (stop ,(make-cal-month 2023 4)))) - `(#t - (,(make-cal-period (make-cal-month 2022 3) - (make-cal-month 2022 10) #f #f) - ,(make-cal-period (make-cal-month 2023 1) - (make-cal-month 2023 4) #f #f)) - "" - -1)) - (test-equal? period-markers->cal-periods-open - (period-markers->cal-periods - `((start ,(make-cal-month 2022 3)) - (stop ,(make-cal-month 2022 10)) - (start ,(make-cal-month 2023 1)) - (stop ,(make-cal-month 2023 4)) - (start ,(make-cal-month 2023 5)))) - `(#t - (,(make-cal-period (make-cal-month 2022 3) - (make-cal-month 2022 10) #f #f) - ,(make-cal-period (make-cal-month 2023 1) - (make-cal-month 2023 4) #f #f) - ,(make-cal-period (make-cal-month 2023 5) #f #f #f)) - "" - -1)) - (test-eq? cal-period->duration - (cal-period->duration (make-cal-period (make-cal-month 2023 1) - (make-cal-month 2023 4) #f #f)) - 3) - (parameterize ((*current-month* (make-cal-month 2023 4))) - (test-eq? cal-period->duration - (cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f)) - 3)) - (test-eq? cal-periods-duration - (cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3) - (make-cal-month 2022 10) #f #f) - ,(make-cal-period (make-cal-month 2023 1) - (make-cal-month 2023 4) #f #f))) - 10) - (test-true cal-month-in-period? + (start ,(make-cal-month 2023 1)) + (stop ,(make-cal-month 2023 4)))) + `(#t + (,(make-cal-period (make-cal-month 2022 3) + (make-cal-month 2022 10) #f #f) + ,(make-cal-period (make-cal-month 2023 1) + (make-cal-month 2023 4) #f #f)) + "" + -1)) + (test-equal? period-markers->cal-periods-open + (period-markers->cal-periods + `((start ,(make-cal-month 2022 3)) + (stop ,(make-cal-month 2022 10)) + (start ,(make-cal-month 2023 1)) + (stop ,(make-cal-month 2023 4)) + (start ,(make-cal-month 2023 5)))) + `(#t + (,(make-cal-period (make-cal-month 2022 3) + (make-cal-month 2022 10) #f #f) + ,(make-cal-period (make-cal-month 2023 1) + (make-cal-month 2023 4) #f #f) + ,(make-cal-period (make-cal-month 2023 5) #f #f #f)) + "" + -1)) + (test-eq? cal-period->duration + (cal-period->duration (make-cal-period (make-cal-month 2023 1) + (make-cal-month 2023 4) #f #f)) + 3) + (parameterize ((*current-month* (make-cal-month 2023 4))) + (test-eq? cal-period->duration + (cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f)) + 3)) + (test-eq? cal-periods-duration + (cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3) + (make-cal-month 2022 10) #f #f) + ,(make-cal-period (make-cal-month 2023 1) + (make-cal-month 2023 4) #f #f))) + 10) + (test-true cal-month-in-period? + (cal-month-in-period? (make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f) + (make-cal-month 2022 3))) + (test-false cal-month-in-period? (cal-month-in-period? (make-cal-period (make-cal-month 2022 1) (make-cal-month 2022 4) #f #f) + (make-cal-month 2022 5))) + (test-true cal-month-in-periods? + (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f) + ,(make-cal-period (make-cal-month 2023 5) + (make-cal-month 2023 10) #f #f)) (make-cal-month 2022 3))) - (test-false cal-month-in-period? - (cal-month-in-period? (make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f) - (make-cal-month 2022 5))) - (test-true cal-month-in-periods? + (test-true cal-month-in-periods? + (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f) + ,(make-cal-period (make-cal-month 2023 5) + (make-cal-month 2023 10) #f #f)) + (make-cal-month 2023 7))) + (test-false cal-month-in-periods? (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) (make-cal-month 2022 4) #f #f) ,(make-cal-period (make-cal-month 2023 5) (make-cal-month 2023 10) #f #f)) - (make-cal-month 2022 3))) - (test-true cal-month-in-periods? - (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f) - ,(make-cal-period (make-cal-month 2023 5) - (make-cal-month 2023 10) #f #f)) - (make-cal-month 2023 7))) - (test-false cal-month-in-periods? - (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f) - ,(make-cal-period (make-cal-month 2023 5) - (make-cal-month 2023 10) #f #f)) - (make-cal-month 2022 10))) - (test-equal? cal-period->string - (cal-period->string (make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f)) - "2022-01..2022-04") - (test-equal? cal-periods->string - (cal-periods->string `(,(make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f) - ,(make-cal-period (make-cal-month 2022 12) - (make-cal-month 2023 2) #f #f))) - "2022-01..2022-04, 2022-12..2023-02") - (test-false cal-periods-match + (make-cal-month 2022 10))) + (test-equal? cal-period->string + (cal-period->string (make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f)) + "2022-01..2022-04") + (test-equal? cal-periods->string + (cal-periods->string `(,(make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f) + ,(make-cal-period (make-cal-month 2022 12) + (make-cal-month 2023 2) #f #f))) + "2022-01..2022-04, 2022-12..2023-02") + (test-false cal-periods-match + (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f) + ,(make-cal-period (make-cal-month 2022 12) + (make-cal-month 2023 2) #f #f)) + (make-cal-month 2022 5))) + (test-equal? cal-periods-match (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1) (make-cal-month 2022 4) #f #f) ,(make-cal-period (make-cal-month 2022 12) (make-cal-month 2023 2) #f #f)) - (make-cal-month 2022 5))) - (test-equal? cal-periods-match - (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f) - ,(make-cal-period (make-cal-month 2022 12) - (make-cal-month 2023 2) #f #f)) - (make-cal-month 2022 2)) - (make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f)) - )) + (make-cal-month 2022 2)) + (make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f)) + )) - ) + ) diff --git a/src/dokuwiki.scm b/src/dokuwiki.scm index 40c2585..db944ce 100644 --- a/src/dokuwiki.scm +++ b/src/dokuwiki.scm @@ -54,7 +54,7 @@ (users '())) (if (null? lines) users - (let ((line (parser-preprocess-line (car lines) #:strip-comments? #f))) + (let ((line (parser-preprocess-line (car lines)))) (if (equal? line "") (loop (cdr lines) users) @@ -74,8 +74,8 @@ (handle-exceptions exn (let () - (log-warning "DokuWiki (~A) exception ~A" fname (condition->list exn)) - (stdout-printf "DokuWiki (~A) exception ~A" fname (condition->list exn)) + (log-warning "DokuWiki: cannot open ~A" fname) + (stdout-printf "DokuWiki: cannot open ~A" fname) '()) (with-input-from-file fname parse-dokuwiki-users-auth))) diff --git a/src/duck-extract.scm b/src/duck-extract.scm index 968621b..3948e2d 100644 --- a/src/duck-extract.scm +++ b/src/duck-extract.scm @@ -135,12 +135,18 @@ res)))))) (define (print-duck-signature sig) + ;;(print sig) (let* ((curry-depth (get-curry-depth sig)) (name (get-signature-name sig)) (nameline (format " ~A~A" (make-string curry-depth #\() name)) (spaceline (make-string (add1 (string-length nameline)) #\space)) (args (gather-signature-arguments sig)) (eargs (expand-signature-arguments args))) + ;;(print " curry depth = " curry-depth) + ;;(print " name = " name) + ;;(print " args = " args) + ;;(printf " eargs = ~S" eargs) + ;;(newline) (if (null? eargs) (print nameline ")") (let loop ((args eargs) diff --git a/src/export-sheet.scm b/src/export-sheet.scm deleted file mode 100644 index a907129..0000000 --- a/src/export-sheet.scm +++ /dev/null @@ -1,226 +0,0 @@ -;; -;; export-sheet.scm -;; -;; Export attendance sheet as MarkDown document. -;; -;; ISC License -;; -;; Copyright 2024 Brmlab, z.s. -;; Dominik Pantůček -;; -;; Permission to use, copy, modify, and/or distribute this software -;; for any purpose with or without fee is hereby granted, provided -;; that the above copyright notice and this permission notice appear -;; in all copies. -;; -;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL -;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE -;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR -;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS -;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, -;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN -;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -;; - -(declare (unit 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 (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) - '(("--" . "--{}--")))) - - ) diff --git a/src/export-web-static.scm b/src/export-web-static.scm index 6647104..fb2bed2 100644 --- a/src/export-web-static.scm +++ b/src/export-web-static.scm @@ -44,10 +44,7 @@ cal-day util-git configuration - texts - logging - qr-payment - members-fees) + texts) ;; HTML entities (define (sanitize-html str) @@ -90,8 +87,6 @@ (print "dd+dt,dd+dt+dd{border-top:1px solid #8cacbb}") (print "dd{grid-column:2/3;font-weight:bold;margin:0px;padding-left:16px}") (print "footer{background:#dee7ec;border-top:1px solid #8cacbb;padding:16px}") - (print ".qr svg{width:100%;height:auto;max-width:10cm}") - (print ".qr{text-align: center}") (print "") (print "") (print "") @@ -105,21 +100,10 @@ (brmember-nick mr) "") (print "
Member ID, Variable Symbol for Payments
(Členské číslo, variabilní symbol plateb)
" (brmember-id mr) "
") - (print "
Balance in CZK
(Zůstatek v Kč)
" - (if (null? bhs) - "0" - (caar (reverse bhs))) - "
") - (print "
Account for Payments
(Účet pro platbu příspěvků)
CZK: 2500079551/2010
EUR: CZ93 2010 0000 0021 0007 9552
") + (print "
Balance in CZK
(Zůstatek v Kč)
" (caar (reverse bhs)) "
") + (print "
Account for Payments
(Účet pro platbu příspěvků)
2500079551/2010
") (print "") (print "") - (print "
") - (let ((fee (member-calendar-entry->fee - (make-member-calendar-entry mr)))) - (print "

Payment of membership fee " fee " CZK
(Platba členského příspěvku)

") - (print (make-brmlab-qrp-svg-string - fee "CZK" (brmember-id mr)))) - (print "
") (print "
") (print "

Payments History

") (print "") diff --git a/src/hackerbase.scm b/src/hackerbase.scm index 9f29a94..24552d1 100644 --- a/src/hackerbase.scm +++ b/src/hackerbase.scm @@ -50,10 +50,7 @@ export-web-static dokuwiki racket-kwargs - util-string - mailinglist - export-sheet - mbase-query) + util-string) ;; Command-line options and configurable parameters (define -needs-bank- (make-parameter #f)) @@ -68,7 +65,6 @@ (define -show-only-active- (make-parameter #f)) (define -notify-months- (make-parameter 1)) (define -send-emails- (make-parameter #f)) -(define -number- (make-parameter #f)) ;; Arguments parsing (command-line @@ -184,14 +180,7 @@ (-action- 'genweb)) (-stats (file:gnuplot-data) "Get stats for all months" (-action- 'print-stats) - (-needs-bank- #t) (-fname- file:gnuplot-data)) - (-sheet (filename gmnum) "Generate attendance sheet for given GM number" - (-needs-bank- #t) - (-fname- filename) - (-number- gmnum) - (-action- 'gen-sheet)) - "" "Mailman Actions:" (-mlsync () "Synchronize internal ML" @@ -297,6 +286,31 @@ (print " " (car keys) ": " (length (ldict-ref status (car keys))))) (loop (cdr keys))))))) +(define* (check-mailing-list mls name #:pred? (pred? #f)) + (define ml (find-mailman-list mls name)) + (let-values (((missing surplus) + (mailman-compare-members ml + (mbase-active-emails MB + #:suspended #t + #:pred? pred? + )))) + (if (null? (cdr ml)) + (print "Skipping ML check - not loaded") + (if (and (null? missing) + (null? surplus)) + (print (format "~a mailing list membership in sync." (string-capitalize name))) + (let () + (print (format "~a mailing list:" (string-capitalize name))) + (when (not (null? missing)) + (print " Missing: " missing)) + (when (not (null? surplus)) + (print " Outsiders: " surplus))))))) + +(define (rada-ml-pred? mr) + (or (brmember-council? mr) + (brmember-chair? mr) + (brmember-revision? mr))) + ;; Perform requested action (case (-action-) ((print-info) @@ -308,7 +322,10 @@ (let () (print-members-base-table MB) (newline) - (print-mailing-list-checks MB MLS) + (check-mailing-list MLS "internal") + (check-mailing-list MLS "rada" + #:pred? rada-ml-pred?) + (check-mailing-list MLS "rk" #:pred? brmember-revision?) (print-git-status))) (newline)) ((print-stats) @@ -364,10 +381,6 @@ ((genweb) (log-info "Generating static web files") (gen-html-members MB (-web-dir-))) - ((gen-sheet) - (log-info "Generating attendance sheet") - (parameterize ((current-output-port (open-output-file (-fname-)))) - (print-attendance-sheet MB (-number-)))) ((edit) (if mr (let () @@ -392,7 +405,7 @@ (print "Mailman synchronization disabled with manually specified current month.")))) ((notify) (let ((nmembers (members-to-notify MB (-notify-months-)))) - (stdout-newline) + (newline) (if (null? nmembers) (print "Everyone paid on time.") (let () @@ -410,8 +423,8 @@ (print-git-status)) ((summary) (if (-send-emails-) - (make+send-summary-email MB MLS) - (make+print-summary-email MB MLS))) + (make+send-summary-email MB) + (make+print-summary-email MB))) ((list) (for-each (lambda (mr) (print (brmember-nick mr))) diff --git a/src/mailinglist.scm b/src/mailinglist.scm deleted file mode 100644 index 73f3e5b..0000000 --- a/src/mailinglist.scm +++ /dev/null @@ -1,78 +0,0 @@ -;; -;; mailinglist.scm -;; -;; Common high-level mailinglist management procedures. -;; -;; ISC License -;; -;; Copyright 2023 Brmlab, z.s. -;; Dominik Pantůček -;; -;; Permission to use, copy, modify, and/or distribute this software -;; for any purpose with or without fee is hereby granted, provided -;; that the above copyright notice and this permission notice appear -;; in all copies. -;; -;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL -;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE -;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR -;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS -;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, -;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN -;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -;; - -(declare (unit mailinglist)) - -(module - mailinglist - ( - check-mailing-list - print-mailing-list-checks - - rada-ml-pred? - ) - - (import scheme - (chicken base) - (chicken format) - racket-kwargs - mailman - mbase - util-string - brmember) - - (define* (check-mailing-list MB mls name #:pred? (pred? #f) #:suspended (suspended #f)) - (define ml (find-mailman-list mls name)) - (when ml - (let-values (((missing surplus) - (mailman-compare-members ml - (mbase-active-emails MB - #:suspended suspended - #:pred? pred? - )))) - (if (null? (cdr ml)) - (print "Skipping ML check - not loaded") - (if (and (null? missing) - (null? surplus)) - (print (format "~a mailing list membership in sync." (string-capitalize name))) - (let () - (print (format "~a mailing list:" (string-capitalize name))) - (when (not (null? missing)) - (print " Missing: " missing)) - (when (not (null? surplus)) - (print " Outsiders: " surplus)))))))) - - (define (print-mailing-list-checks MB MLS) - (check-mailing-list MB MLS "internal" #:suspended #t) - (check-mailing-list MB MLS "rada" - #:pred? rada-ml-pred?) - (check-mailing-list MB MLS "rk" #:pred? brmember-revision?)) - - (define (rada-ml-pred? mr) - (or (brmember-council? mr) - (brmember-chair? mr) - (brmember-revision? mr))) - - ) diff --git a/src/mailman.scm b/src/mailman.scm index a8c9788..29bd842 100644 --- a/src/mailman.scm +++ b/src/mailman.scm @@ -49,6 +49,7 @@ (import scheme (chicken base) (chicken module) + mailman2 mailman-common util-bst-lset configuration @@ -58,17 +59,24 @@ ;; Syntax for simplifying export of case-version procedures (define-syntax define-mailman-proc (syntax-rules () - ((_ name proc3) + ((_ name proc2) (begin (export name) (define (name . args) (case (*mailman-version*) + ((2) (apply proc2 args)))))) + ((_ name proc2 proc3) + (begin + (export name) + (define (name . args) + (case (*mailman-version*) + ((2) (apply proc2 args)) ((3) (apply proc3 args)))))))) (define-mailman-proc list-mailman-lists - list-mailman3-lists) + list-mailman2-lists list-mailman3-lists) (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 ;; unsuccessfull, returns only a list with ML name and no member @@ -104,9 +112,9 @@ (assoc name lsts)) (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 - remove-email-from-mailman3-list) + remove-email-from-mailman2-list remove-email-from-mailman3-list) ;; Ensures given email is in given ML (define (mailman-ensure-member ml email) diff --git a/src/mailman2.scm b/src/mailman2.scm new file mode 100644 index 0000000..5825165 --- /dev/null +++ b/src/mailman2.scm @@ -0,0 +1,104 @@ +;; +;; mailman2.scm +;; +;; Mailman management interface - Mailman version 2.x support +;; +;; ISC License +;; +;; Copyright 2023 Brmlab, z.s. +;; Dominik Pantůček +;; +;; Permission to use, copy, modify, and/or distribute this software +;; for any purpose with or without fee is hereby granted, provided +;; that the above copyright notice and this permission notice appear +;; in all copies. +;; +;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR +;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, +;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN +;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +;; + +(declare (unit mailman2)) + +(module + mailman2 + ( + list-mailman2-lists + list-mailman2-list-members + + add-email-to-mailman2-list + remove-email-from-mailman2-list + ) + + (import scheme + (chicken base) + (chicken pathname) + (chicken string) + (chicken sort) + (chicken format) + srfi-1 + util-bst-lset + util-io + mailman-common + configuration) + + ;; Returns full path to given mailman binary + (define (mailman-bin bin) + (make-pathname (*mailman2-bin*) bin)) + + ;; Mailman-specific process output lines capture + (define (get-mailman-output-lines bin . args) + (apply + get-process-output-lines + (mailman-bin bin) + args)) + + ;; Sends all lines to the process + (define (mailman-send/recv bin args . lines) + (apply + process-send/recv + (mailman-bin bin) + args + lines)) + + ;; Returns the list of available lists + (define (list-mailman2-lists) + (get-mailman-output-lines "list_lists" "-b")) + + ;; Returns the list of members of given list + (define (list-mailman2-list-members lst) + (sort + (get-mailman-output-lines "list_members" lst) + string-ci -;; -;; 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)))))) - - ) diff --git a/src/mbase.scm b/src/mbase.scm index f2f12bb..3412306 100644 --- a/src/mbase.scm +++ b/src/mbase.scm @@ -50,6 +50,8 @@ mbase-update-by-id mbase-update + mbase-stats + mbase-add-unpaired mbase-unpaired @@ -205,6 +207,47 @@ (proc mr) mr))))) + ;; Returns dictionary with statistics about the members base. + (define (mbase-info mb-arg) + (let* ((members (find-members-by-predicate mb-arg brmember-usable?)) + (di0 (make-ldict)) + (di1 (ldict-set di0 'invalid + (filter (compose not is-4digit-prime? brmember-id) members))) + (di2 (ldict-set di1 'active + (filter brmember-active? members))) + (di3 (ldict-set di2 'suspended + (filter brmember-suspended? members))) + (di4 (ldict-set di3 'students + (filter brmember-student? members))) + (di5 (ldict-set di4 'destroyed + (filter brmember-destroyed? members))) + (di6 (ldict-set di5 'month (*current-month*))) + (di7 (ldict-set di6 'total members)) + (di8 (ldict-set di7 'problems + (find-members-by-predicate mb-arg brmember-has-problems?)))) + di8)) + + (define (members-base-oldest-month mb) + (make-cal-month 2015 1)) + + ;; Returns a list two lists: keys, data. + ;; Each data record contains values for all keys. + (define (mbase-stats mb) + (let ((keys '(month total active suspended students destroyed invalid))) + (let mloop ((data '()) + (month (members-base-oldest-month mb))) + (if (cal-month<=? month (*current-month*)) + (let ((bi (with-current-month month + (mbase-info mb)))) + (let kloop ((row (list (ldict-ref bi 'month))) + (keys (cdr keys))) + (if (null? keys) + (mloop (cons (reverse row) data) + (cal-month-add month 1)) + (kloop (cons (length (ldict-ref bi (car keys))) row) + (cdr keys))))) + (list keys (reverse data)))))) + ;; Adds unpaired transaction to given members-base (define (mbase-add-unpaired mb tr) (ldict-set mb 'unpaired diff --git a/src/members-fees.scm b/src/members-fees.scm index 1782f62..1d92ab9 100644 --- a/src/members-fees.scm +++ b/src/members-fees.scm @@ -30,7 +30,6 @@ ( lookup-member-fee member-calendar - make-member-calendar-entry member-calendar-first-month member-calendar-last-month member-calendar-query @@ -41,15 +40,12 @@ member-calendar->table members-summary member-calendar-entry->fee - get-expected-income - get-expected-income-string ) (import scheme (chicken base) (chicken format) (chicken sort) - (chicken string) srfi-1 configuration brmember @@ -86,17 +82,12 @@ (if (cal-month>? cm last-month) (reverse cal) (loop (cal-month-add cm) - (cons (with-current-month - cm - (make-member-calendar-entry mr)) + (cons (list cm + (with-current-month + cm + (brmember-flags mr))) cal)))))) - ;; Assumes current-month is specified correctly - (define (make-member-calendar-entry mr) - (list (*current-month*) - (brmember-flags mr) - (brmember-spec-fee mr))) - ;; Returns the first month of the calendar (define (member-calendar-first-month mc) (caar mc)) @@ -120,29 +111,23 @@ (ansi-string #:bgblack "\xc2\xa0\xc2\xa0") ; Destroyed (if (member 'student (cadr e)) (ansi-string #:bgyellow "\xc2\xa0\xc2\xa0") ; Student - (if (caddr e) - (ansi-string #:bgblue (format "~a" (caddr e))) - (ansi-string #:bggreen "\xc2\xa0\xc2\xa0"))))) ; Normal + (ansi-string #:bggreen "\xc2\xa0\xc2\xa0")))) ; Normal "\xc2\xa0\xc2\xa0") ; Nonexistent - should not happen "\xc2\xa0\xc2\xa0")) ; Nonexistent ;; Converts the entry into the fee (define (member-calendar-entry->fee e) - (with-current-month - (car e) - (if e - (if (member 'existing (cadr e)) - (if (member 'suspended (cadr e)) - 0 ; Suspended - (if (member 'destroyed (cadr e)) - 0 ; Destroyed - (if (member 'student (cadr e)) - (lookup-member-fee 'student) ; Student - (if (caddr e) - (caddr e) - (lookup-member-fee 'regular))))) ; Normal - 0) ; Nonexistent - should not happen - 0))) ; Nonexistent + (if e + (if (member 'existing (cadr e)) + (if (member 'suspended (cadr e)) + 0 ; Suspended + (if (member 'destroyed (cadr e)) + 0 ; Destroyed + (if (member 'student (cadr e)) + (lookup-member-fee 'student) ; Student + (lookup-member-fee 'regular)))) ; Normal + 0) ; Nonexistent - should not happen + 0)) ; Nonexistent ;; Converts the calendar into a table where rows represent years and ;; contain the year in the first cell and 12 cells for months after @@ -208,39 +193,5 @@ (+ (cdr acc) (if (brmember-student? mr) 0 1)))) (cons 0 0) members))) - - (define (get-expected-income mb) - (let* ((flst - (map (compose member-calendar-entry->fee make-member-calendar-entry) - (find-members-by-predicate mb brmember-active?))) - (amts (sort (delete-duplicates flst) <)) - (sums - (map - (lambda (amt) - (cons amt - (length (filter (lambda (v) (= v amt)) flst)))) - amts))) - (foldl + 0 (map (lambda (p) (* (car p) (cdr p))) sums)))) - - (define (get-expected-income-string mb) - (let* ((flst - (map (compose member-calendar-entry->fee make-member-calendar-entry) - (find-members-by-predicate mb brmember-active?))) - (amts (sort (delete-duplicates flst) <)) - (sums - (map - (lambda (amt) - (cons amt - (length (filter (lambda (v) (= v amt)) flst)))) - amts))) - (string-append - "Expected income: " - (string-intersperse (map - (lambda (p) - (format "~A*~A" (cdr p) (car p))) - sums) - " + ") - " = " - (number->string (foldl + 0 (map (lambda (p) (* (car p) (cdr p))) sums)))))) ) diff --git a/src/members-payments.scm b/src/members-payments.scm index 8c8fc41..bf2c416 100644 --- a/src/members-payments.scm +++ b/src/members-payments.scm @@ -90,21 +90,12 @@ (substring msg 0 ci2) msg)) (ci3 (substring-index "NULL" msg)) - (vs3 (if (and ci3 - (>= (string-length msg) (+ ci3 8))) + (vs3 (if ci3 (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)) - ) + msg))) (or (string->number vs1) (string->number vs2) - (string->number vs3) - (string->number vs4) - ))))) + (string->number vs3)))))) varsym-id))) ;; Special comparator (originally with JendaSAP hack) diff --git a/src/members-print.scm b/src/members-print.scm index e8b6720..86e14c1 100644 --- a/src/members-print.scm +++ b/src/members-print.scm @@ -97,7 +97,7 @@ (body (map (lambda (k) (let ((v (ldict-ref info k))) (case k - ((card desfire phone) + ((card desfire) (list k (table->string (map @@ -129,25 +129,8 @@ (ptbl (table->string pdata #:border '(((#:right light) ... none) ...)))) - (list k ptbl))) - ((fee) - (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) ...)))) + ;;(print pdata) + ;;(write ptbl)(newline) (list k ptbl))) (else (if v @@ -178,6 +161,7 @@ (list (list (ansi-string #:red "DokuWiki") (ansi-string #:red "---"))))) (result (filter identity (append head body mailman dokuwiki)))) + ;;(write result)(newline) (table->string result #:border '(((#:bottom #:right light) ... (#:bottom light)) ... @@ -380,7 +364,7 @@ (members-table-row (ansi #:magenta #:bold) "Expire Soon:" soon-expire-mrs "~N (~S)")) (members-pred-table-row mb - (ansi-string #:red #:bold "Problems:") + (ansi-string #:red #:bold "Prolems:") brmember-has-problems? "~N~E ~A") (if (null? debtor-mrs) @@ -495,17 +479,7 @@ (null? (cdr dsa))) #f (cadr dsa)))) - (let* ((raw-members - (sort - (if destroyed? - (find-members-by-predicate MB (lambda x #t)) - (if only-active? - (find-members-by-predicate MB (lambda (mr) - (brmember-active? mr))) - (find-members-by-predicate MB (lambda (mr) - (not (brmember-destroyed? mr)))))) - brmemberfee - (list (*current-month*) - (brmember-flags mr) - spec-fee)))) ))) - 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 -;; -;; 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))) - - ) diff --git a/src/sgr-block.scm b/src/sgr-block.scm index f8e1f8a..d3c2bbc 100644 --- a/src/sgr-block.scm +++ b/src/sgr-block.scm @@ -366,6 +366,7 @@ slw)) state))) (let ((sln (sgr-list-neutralize sl))) + ;;(write sln)(newline) (values (list sln) initial-state)))) ;; Renders all the lines and appends the resulting blocks diff --git a/src/specification.scm b/src/specification.scm index b2bc5bf..310d8d4 100644 --- a/src/specification.scm +++ b/src/specification.scm @@ -39,8 +39,7 @@ ;; Convert into lookups - a list of (list period regular student) (define member-fees-lookup-table (make-cal-period-lookup-table - '(((2010 1) 500 250) - ((2024 1) 1000 250)))) + '(((2010 1) 500 250)))) ;; Exchange rates (define exchange-rates-lookup-table diff --git a/src/table-processor.scm b/src/table-processor.scm index ff79d9f..956d9fd 100644 --- a/src/table-processor.scm +++ b/src/table-processor.scm @@ -204,6 +204,8 @@ (tbl1 (render-cells-widths ptbl col-widths)) ;;(_ (print tbl1)) (tbl2 (map expand-row-height tbl1))) + ;;(write tbl1)(newline) + ;;(write tbl2)(newline) ;; Just return the result - both the table and cached column widths (values tbl2 col-widths)))) diff --git a/src/table.scm b/src/table.scm index 719fb1a..43041ff 100644 --- a/src/table.scm +++ b/src/table.scm @@ -88,6 +88,7 @@ (borders (expand-table-style border-spec num-columns num-rows)) (col-separators (table-col-separators? borders)) (rows (merge-rows ptbl borders col-separators unicode?))) + ;;(write rows)(newline) (let loop ((rows rows) (borders borders) (res '()) diff --git a/src/texts.scm b/src/texts.scm index a3383c6..2ee52b7 100644 --- a/src/texts.scm +++ b/src/texts.scm @@ -5,7 +5,7 @@ ;; ;; ISC License ;; -;; Copyright 2023-2025 Brmlab, z.s. +;; Copyright 2023 Brmlab, z.s. ;; Dominik Pantůček ;; ;; Permission to use, copy, modify, and/or distribute this software @@ -39,7 +39,7 @@ (chicken format)) ;; Short banner - (define banner-line "HackerBase 1.19-dev (c) 2023-2025 Brmlab, z.s.") + (define banner-line "HackerBase 1.14 (c) 2023 Brmlab, z.s.") ;; Banner source with numbers for ANSI CSI SGR (define banner-source " diff --git a/src/util-bst.scm b/src/util-bst.scm index 236fdd3..c27d518 100644 --- a/src/util-bst.scm +++ b/src/util-bst.scm @@ -286,12 +286,10 @@ (call/cc (lambda (cc) (set! break cc) - (cond (resume - (resume '()) - (break #f)) - (else - (bst-iter-kv bst yield) - (break #f)))))))) + (if resume + (resume '()) + (bst-iter-kv bst yield)) + #f))))) (define/doc (bst-keys bst) ("Returns all the keys contained in given dictionary.") diff --git a/src/util-mail.scm b/src/util-mail.scm index 9ab448c..8a7e8b5 100644 --- a/src/util-mail.scm +++ b/src/util-mail.scm @@ -5,7 +5,7 @@ ;; ;; ISC License ;; -;; Copyright 2023-2024 Brmlab, z.s. +;; Copyright 2023 Brmlab, z.s. ;; Dominik Pantůček ;; ;; Permission to use, copy, modify, and/or distribute this software @@ -39,8 +39,6 @@ (chicken base) (chicken keyword) (chicken string) - (chicken irregex) - (chicken format) util-io util-utf8 util-string @@ -63,14 +61,6 @@ sent to the address stored within.") "?=") subj)) - ;; Extracts only usernam@domain from given full RFC email address - (define (extract-email-email str) - (let* ((irr (irregex "(?:\"?([^\"]*)\"?\\s)?(?:]+)>?)")) - (em (irregex-match irr str)) - (name (irregex-match-substring em 1)) - (email (irregex-match-substring em 2))) - email)) - ;; Sends an email using the UNIX mail(1) utility. (define*/doc (send-mail body-lines #:from (from #f) @@ -93,22 +83,17 @@ Sends email using mail(1) command. The arguments ```#:to``` and 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 - "mail" - (append (if from - (list "-r" from-email) - '()) - (list "-s" (encode-subject subject)) - real-tos - header-args) - body-lines)))) + (map + (lambda (h) (list "-a" h)) + headers)))) + (apply process-send/recv + "mail" + (append (if from + (list "-r" from) + '()) + (list "-s" (encode-subject subject)) + real-tos + header-args) + body-lines))) ) diff --git a/src/util-parser.scm b/src/util-parser.scm index 24e05ed..789827f 100644 --- a/src/util-parser.scm +++ b/src/util-parser.scm @@ -39,12 +39,11 @@ member file parsers. All functions are UTF-8 aware.") (import scheme (chicken base) - racket-kwargs testing) ;; Pass 0: Removes any comments and removes any leading and trailing ;; whitespace. - (define*/doc (parser-preprocess-line line #:strip-comments? (strip-comments? #t)) + (define/doc (parser-preprocess-line line) ("* ```line``` - a string with contents of one source line If the input ```line``` contains the ```#``` character, the rest of @@ -63,9 +62,7 @@ Returns a string representing the preprocessed line.") (ploop (add1 pidx))))) (hpos (let hloop ((hidx ppos)) (if (or (= hidx llen) - (and (or strip-comments? - (= hidx 0)) - (eq? (string-ref line hidx) #\#))) + (eq? (string-ref line hidx) #\#)) hidx (hloop (add1 hidx))))) (spos (let sloop ((sidx (sub1 hpos))) diff --git a/src/util-utf8.scm b/src/util-utf8.scm index 0deef64..14a4c6b 100644 --- a/src/util-utf8.scm +++ b/src/util-utf8.scm @@ -120,13 +120,13 @@ of the string and a list of remaining bytes (as integers).") (define/doc (utf8-bytes->lists chars) ("The same as above but accepts a list of bytes (as integers).") (let loop ((bytes chars) - (rpending chars) + (rpending '()) (pending 0) (expected #f) (res '())) (if (null? bytes) (values (reverse res) - rpending) + (reverse rpending)) (let ((byte (car bytes))) (cond (expected ;; Decode UTF-8 sequence @@ -135,14 +135,14 @@ of the string and a list of remaining bytes (as integers).") (let ((char (integer->char (bitwise-ior pending (bitwise-and byte #b111111))))) (loop (cdr bytes) - (cdr bytes) + '() 0 #f (cons char res)))) (else ;; Intermediate bytes (loop (cdr bytes) - rpending + (cons byte rpending) (arithmetic-shift (bitwise-ior pending (bitwise-and byte #b111111)) 6) (sub1 expected) @@ -152,7 +152,7 @@ of the string and a list of remaining bytes (as integers).") (cond ((= (bitwise-and byte #b10000000) 0) ;; ASCII (loop (cdr bytes) - (cdr bytes) + '() 0 #f (cons (integer->char byte) res))) @@ -160,20 +160,20 @@ of the string and a list of remaining bytes (as integers).") ;; First byte of UTF-8 sequence (let-values (((first-byte char-bytes) - (cond ((= (bitwise-and byte #b11100000) #b11000000) + (cond ((= (bitwise-and byte #b11000000) #b11000000) (values (bitwise-and byte #b11111) 2)) - ((= (bitwise-and byte #b11110000) #b11100000) + ((= (bitwise-and byte #b11100000) #b11100000) (values (bitwise-and byte #b1111) 3)) - ((= (bitwise-and byte #b11111000) #b11110000) + ((= (bitwise-and byte #b11110000) #b11110000) (values (bitwise-and byte #b111) 4)) (else ;; Should not happen (values 0 0))))) (loop (cdr bytes) - bytes + (list byte) (arithmetic-shift first-byte 6) (sub1 char-bytes) res))))))))))