diff --git a/CHANGELOG.md b/CHANGELOG.md index 32d0c05..a5bfc54 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,14 @@ 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 -------------------------- diff --git a/doc/hackerbase.1 b/doc/hackerbase.1 index 27a71c2..531e4cb 100644 --- a/doc/hackerbase.1 +++ b/doc/hackerbase.1 @@ -273,10 +273,6 @@ Specify member by nickname. .B \-destroyed Show destroyed members in \fB-fees\fR action as well. -.TP -.B \-ml-all -Load all mailman list memberships to show them in members info. - .SH "FILES" All the information about members is stored in in members file in the diff --git a/src/Makefile b/src/Makefile index 010c646..8a9a50b 100644 --- a/src/Makefile +++ b/src/Makefile @@ -42,7 +42,9 @@ HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm \ tests.import.scm notifications.import.scm logging.import.scm \ progress.import.scm cal-period.import.scm \ util-stdout.import.scm export-web-static.import.scm \ - dokuwiki.import.scm mailinglist.import.scm + dokuwiki.import.scm mailinglist.import.scm \ + export-sheet.import.scm mbase-query.import.scm \ + qr-payment.import.scm HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \ cal-period.o ansi.o util-bst-ldict.o command-line.o mbase.o \ @@ -58,9 +60,9 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \ table-style.o sgr-state.o util-utf8.o sgr-cell.o \ template-list-expander.o box-drawing.o export-web-static.o \ util-dir.o dokuwiki.o racket-kwargs.o duck.o util-bst.o \ - util-bst-bdict.o util-bst-ldict.o util-bst-lset.o mailman2.o \ + util-bst-bdict.o util-bst-ldict.o util-bst-lset.o \ mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o \ - mailinglist.o + mailinglist.o export-sheet.o mbase-query.o qr-payment.o GENDOC-SOURCES=gendoc.scm duck-extract.import.scm \ util-time.import.scm util-csv.import.scm util-git.import.scm \ @@ -258,13 +260,6 @@ ENVIRONMENT-SOURCES=environment.scm ansi.import.scm environment.o: environment.import.scm environment.import.scm: $(ENVIRONMENT-SOURCES) -MAILMAN2-SOURCES=mailman2.scm util-bst-lset.import.scm \ - util-io.import.scm mailman-common.import.scm \ - configuration.import.scm - -mailman2.o: mailman2.import.scm -mailman2.import.scm: $(MAILMAN2-SOURCES) - UTIL-TIME-SOURCES=util-time.scm duck.import.scm util-time.o: util-time.import.scm @@ -473,7 +468,8 @@ box-drawing.import.scm: $(BOX-DRAWING-SOURCES) EXPORT-WEB-STATIC-SOURCES=export-web-static.scm brmember.import.scm \ util-dir.import.scm mbase.import.scm \ members-payments.import.scm cal-day.import.scm \ - util-git.import.scm configuration.import.scm texts.import.scm + util-git.import.scm configuration.import.scm texts.import.scm \ + members-fees.import.scm qr-payment.import.scm export-web-static.o: export-web-static.import.scm export-web-static.import.scm: $(EXPORT-WEB-STATIC-SOURCES) @@ -524,10 +520,9 @@ UTIL-BST-LSET-SOURCES=util-bst-lset.scm util-bst.import.scm \ util-bst-lset.o: util-bst-lset.import.scm util-bst-lset.import.scm: $(UTIL-BST-LSET-SOURCES) -MAILMAN-SOURCES=mailman.scm mailman2.import.scm \ - mailman-common.import.scm util-bst-lset.import.scm \ - configuration.import.scm mailman3.import.scm \ - progress.import.scm +MAILMAN-SOURCES=mailman.scm mailman-common.import.scm \ + util-bst-lset.import.scm configuration.import.scm \ + mailman3.import.scm progress.import.scm mailman.o: mailman.import.scm mailman.import.scm: $(MAILMAN-SOURCES) @@ -559,3 +554,25 @@ MAILINGLIST-SOURCES=mailinglist.scm racket-kwargs.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.scm b/src/brmember.scm index 496dc96..cb065f4 100644 --- a/src/brmember.scm +++ b/src/brmember.scm @@ -87,6 +87,8 @@ brmember-spec-fee + brmember-age + brmember-tests! ) @@ -492,6 +494,18 @@ #f)) #f))) + (define (brmember-age mr) + (let ((born (brmember-info mr 'born #f))) + (if born + (let ((lst (string-split born "-"))) + (if (null? lst) + #f + (let ((y (string->number (car lst)))) + (if y + (- (current-year) y) + #f)))) + #f))) + ;; Self-tests (define (brmember-tests!) (run-tests diff --git a/src/cal-period.scm b/src/cal-period.scm index ea1cf3d..447f563 100644 --- a/src/cal-period.scm +++ b/src/cal-period.scm @@ -26,460 +26,464 @@ (declare (unit cal-period)) (module - cal-period - ( - *current-month* - *current-day* - - set-current-month! - set-current-day! - - with-current-month - with-current-day - - make-cal-period - - cal-period-since - cal-period-before - cal-period-scomment - cal-period-bcomment - - set-cal-period-scomment - - period-markers->cal-periods - - cal-periods-duration - - cal-month-in-period? - cal-month-in-periods? - - cal-month-find-period - - cal-day-in-period? - cal-day-in-periods? - - cal-periods->string - cal-periods-match - - make-cal-period-lookup-table - lookup-by-cal-period - - cal-ensure-month - cal-ensure-day - - cal-period-tests! - ) - - (import scheme - (chicken base) - (chicken sort) - (chicken time) - (chicken time posix) - (chicken format) - (chicken string) - cal-month - testing - util-tag - cal-day) - - ;; Type tag - (define TAG-CAL-PERIOD (make-tag CAL-PERIOD)) - - ;; Current month - if changed, we get the actual state for given month. - (define *current-month* - (make-parameter - (let ((d (seconds->local-time (current-seconds)))) - (make-cal-month (+ 1900 (vector-ref d 5)) - (+ (vector-ref d 4) 1))))) - - ;; Current month - if changed, we get the actual state for given month. - (define *current-day* - (make-parameter - (let ((d (seconds->local-time (current-seconds)))) - (make-cal-day (+ 1900 (vector-ref d 5)) - (+ (vector-ref d 4) 1) - (vector-ref d 3))))) - - ;; Changes both current-month and current-day based on given month - (define (set-current-month! m) - (*current-month* m) - (*current-day* (cal-ensure-day m))) - - ;; Changes both current-day and current-month based on given day - (define (set-current-day! d) - (*current-day* d) - (*current-month* (cal-ensure-month d))) - - ;; Parameterizes both current-month and current-day based on given - ;; month - (define-syntax with-current-month - (syntax-rules () - ((_ ms body ...) - (let ((m ms)) - (parameterize ((*current-month* m) - (*current-day* (cal-ensure-day m))) - body ...))))) - - ;; Parameterizes both current-day and current-month based on given - ;; day - (define-syntax with-current-day - (syntax-rules () - ((_ ds body ...) - (let ((d ds)) - (parameterize ((*current-day* d) - (*current-month* (cal-ensure-month d))) - body ...))))) - - ;; Creates a new period value with optional since and before - ;; comments. - (define (make-cal-period since before . args) - (let ((scomment (if (not (null? args)) (car args) #f)) - (bcomment (if (and (not (null? args)) - (not (null? (cdr args)))) - (cadr args) - #f))) - (list TAG-CAL-PERIOD since before scomment bcomment))) - - ;; Simple accessors - (define cal-period-since cadr) - (define cal-period-before caddr) - (define cal-period-scomment cadddr) - (define cal-period-bcomment (compose cadddr cdr)) - - ;; Direct updater - (define (set-cal-period-scomment p c) - (list TAG-CAL-PERIOD - (cal-period-since p) - (cal-period-before p) - c - (cal-period-bcomment p))) - - ;; Type predicate - (define (cal-period? p) - (and (pair? p) - (eq? (car p) - TAG-CAL-PERIOD))) - - ;; Month subtype predicate - (define (cal-period-month? p) - (and (cal-period? p) - (cal-month? (cal-period-since p)) - (cal-month? (cal-period-before p)))) - - ;; Day subtype predicate - (define (cal-period-day? p) - (and (cal-period? p) - (cal-day? (cal-period-since p)) - (cal-day? (cal-period-before p)))) - - ;; Validation - (define (cal-period-valid? p) - (and (pair? p) - (eq? (car p) - TAG-CAL-PERIOD) - (let ((since (cal-period-since p)) - (before (cal-period-before p))) - (or (and (cal-month? since) - (cal-month? before) - (cal-month<=? since before)) - (and (cal-day? since) - (cal-day? before) - (cal-day<=? since before)))))) - - ;; Sorts period markers (be it start or end) chronologically and - ;; returns the sorted list. - (define (sort-period-markers l) - (sort l - (lambda (a b) - (cal-day/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)))) - `((start ,(make-cal-month 2022 3)) - (stop ,(make-cal-month 2022 10)) - (start ,(make-cal-month 2023 1)))) - (test-equal? period-markers->cal-periods - (period-markers->cal-periods + ( + current-year + *current-month* + *current-day* + + set-current-month! + set-current-day! + + with-current-month + with-current-day + + make-cal-period + + cal-period-since + cal-period-before + cal-period-scomment + cal-period-bcomment + + set-cal-period-scomment + + period-markers->cal-periods + + cal-periods-duration + + cal-month-in-period? + cal-month-in-periods? + + cal-month-find-period + + cal-day-in-period? + cal-day-in-periods? + + cal-periods->string + cal-periods-match + + make-cal-period-lookup-table + lookup-by-cal-period + + cal-ensure-month + cal-ensure-day + + cal-period-tests! + ) + + (import scheme + (chicken base) + (chicken sort) + (chicken time) + (chicken time posix) + (chicken format) + (chicken string) + cal-month + testing + util-tag + cal-day) + + ;; Type tag + (define TAG-CAL-PERIOD (make-tag CAL-PERIOD)) + + (define (current-year) + (cal-month-year (*current-month*))) + + ;; Current month - if changed, we get the actual state for given month. + (define *current-month* + (make-parameter + (let ((d (seconds->local-time (current-seconds)))) + (make-cal-month (+ 1900 (vector-ref d 5)) + (+ (vector-ref d 4) 1))))) + + ;; Current month - if changed, we get the actual state for given month. + (define *current-day* + (make-parameter + (let ((d (seconds->local-time (current-seconds)))) + (make-cal-day (+ 1900 (vector-ref d 5)) + (+ (vector-ref d 4) 1) + (vector-ref d 3))))) + + ;; Changes both current-month and current-day based on given month + (define (set-current-month! m) + (*current-month* m) + (*current-day* (cal-ensure-day m))) + + ;; Changes both current-day and current-month based on given day + (define (set-current-day! d) + (*current-day* d) + (*current-month* (cal-ensure-month d))) + + ;; Parameterizes both current-month and current-day based on given + ;; month + (define-syntax with-current-month + (syntax-rules () + ((_ ms body ...) + (let ((m ms)) + (parameterize ((*current-month* m) + (*current-day* (cal-ensure-day m))) + body ...))))) + + ;; Parameterizes both current-day and current-month based on given + ;; day + (define-syntax with-current-day + (syntax-rules () + ((_ ds body ...) + (let ((d ds)) + (parameterize ((*current-day* d) + (*current-month* (cal-ensure-month d))) + body ...))))) + + ;; Creates a new period value with optional since and before + ;; comments. + (define (make-cal-period since before . args) + (let ((scomment (if (not (null? args)) (car args) #f)) + (bcomment (if (and (not (null? args)) + (not (null? (cdr args)))) + (cadr args) + #f))) + (list TAG-CAL-PERIOD since before scomment bcomment))) + + ;; Simple accessors + (define cal-period-since cadr) + (define cal-period-before caddr) + (define cal-period-scomment cadddr) + (define cal-period-bcomment (compose cadddr cdr)) + + ;; Direct updater + (define (set-cal-period-scomment p c) + (list TAG-CAL-PERIOD + (cal-period-since p) + (cal-period-before p) + c + (cal-period-bcomment p))) + + ;; Type predicate + (define (cal-period? p) + (and (pair? p) + (eq? (car p) + TAG-CAL-PERIOD))) + + ;; Month subtype predicate + (define (cal-period-month? p) + (and (cal-period? p) + (cal-month? (cal-period-since p)) + (cal-month? (cal-period-before p)))) + + ;; Day subtype predicate + (define (cal-period-day? p) + (and (cal-period? p) + (cal-day? (cal-period-since p)) + (cal-day? (cal-period-before p)))) + + ;; Validation + (define (cal-period-valid? p) + (and (pair? p) + (eq? (car p) + TAG-CAL-PERIOD) + (let ((since (cal-period-since p)) + (before (cal-period-before p))) + (or (and (cal-month? since) + (cal-month? before) + (cal-month<=? since before)) + (and (cal-day? since) + (cal-day? before) + (cal-day<=? since before)))))) + + ;; Sorts period markers (be it start or end) chronologically and + ;; returns the sorted list. + (define (sort-period-markers l) + (sort l + (lambda (a b) + (cal-day/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)))) `((start ,(make-cal-month 2022 3)) (stop ,(make-cal-month 2022 10)) - (start ,(make-cal-month 2023 1)) - (stop ,(make-cal-month 2023 4)))) - `(#t - (,(make-cal-period (make-cal-month 2022 3) - (make-cal-month 2022 10) #f #f) - ,(make-cal-period (make-cal-month 2023 1) - (make-cal-month 2023 4) #f #f)) - "" - -1)) - (test-equal? period-markers->cal-periods-open - (period-markers->cal-periods - `((start ,(make-cal-month 2022 3)) - (stop ,(make-cal-month 2022 10)) - (start ,(make-cal-month 2023 1)) - (stop ,(make-cal-month 2023 4)) - (start ,(make-cal-month 2023 5)))) - `(#t - (,(make-cal-period (make-cal-month 2022 3) - (make-cal-month 2022 10) #f #f) - ,(make-cal-period (make-cal-month 2023 1) - (make-cal-month 2023 4) #f #f) - ,(make-cal-period (make-cal-month 2023 5) #f #f #f)) - "" - -1)) - (test-eq? cal-period->duration - (cal-period->duration (make-cal-period (make-cal-month 2023 1) - (make-cal-month 2023 4) #f #f)) - 3) - (parameterize ((*current-month* (make-cal-month 2023 4))) - (test-eq? cal-period->duration - (cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f)) - 3)) - (test-eq? cal-periods-duration - (cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3) - (make-cal-month 2022 10) #f #f) - ,(make-cal-period (make-cal-month 2023 1) - (make-cal-month 2023 4) #f #f))) - 10) - (test-true cal-month-in-period? - (cal-month-in-period? (make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f) - (make-cal-month 2022 3))) - (test-false cal-month-in-period? + (start ,(make-cal-month 2023 1)))) + (test-equal? period-markers->cal-periods + (period-markers->cal-periods + `((start ,(make-cal-month 2022 3)) + (stop ,(make-cal-month 2022 10)) + (start ,(make-cal-month 2023 1)) + (stop ,(make-cal-month 2023 4)))) + `(#t + (,(make-cal-period (make-cal-month 2022 3) + (make-cal-month 2022 10) #f #f) + ,(make-cal-period (make-cal-month 2023 1) + (make-cal-month 2023 4) #f #f)) + "" + -1)) + (test-equal? period-markers->cal-periods-open + (period-markers->cal-periods + `((start ,(make-cal-month 2022 3)) + (stop ,(make-cal-month 2022 10)) + (start ,(make-cal-month 2023 1)) + (stop ,(make-cal-month 2023 4)) + (start ,(make-cal-month 2023 5)))) + `(#t + (,(make-cal-period (make-cal-month 2022 3) + (make-cal-month 2022 10) #f #f) + ,(make-cal-period (make-cal-month 2023 1) + (make-cal-month 2023 4) #f #f) + ,(make-cal-period (make-cal-month 2023 5) #f #f #f)) + "" + -1)) + (test-eq? cal-period->duration + (cal-period->duration (make-cal-period (make-cal-month 2023 1) + (make-cal-month 2023 4) #f #f)) + 3) + (parameterize ((*current-month* (make-cal-month 2023 4))) + (test-eq? cal-period->duration + (cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f)) + 3)) + (test-eq? cal-periods-duration + (cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3) + (make-cal-month 2022 10) #f #f) + ,(make-cal-period (make-cal-month 2023 1) + (make-cal-month 2023 4) #f #f))) + 10) + (test-true cal-month-in-period? (cal-month-in-period? (make-cal-period (make-cal-month 2022 1) (make-cal-month 2022 4) #f #f) - (make-cal-month 2022 5))) - (test-true cal-month-in-periods? - (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f) - ,(make-cal-period (make-cal-month 2023 5) - (make-cal-month 2023 10) #f #f)) (make-cal-month 2022 3))) - (test-true cal-month-in-periods? - (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f) - ,(make-cal-period (make-cal-month 2023 5) - (make-cal-month 2023 10) #f #f)) - (make-cal-month 2023 7))) - (test-false cal-month-in-periods? + (test-false cal-month-in-period? + (cal-month-in-period? (make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f) + (make-cal-month 2022 5))) + (test-true cal-month-in-periods? (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) (make-cal-month 2022 4) #f #f) ,(make-cal-period (make-cal-month 2023 5) (make-cal-month 2023 10) #f #f)) - (make-cal-month 2022 10))) - (test-equal? cal-period->string - (cal-period->string (make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f)) - "2022-01..2022-04") - (test-equal? cal-periods->string - (cal-periods->string `(,(make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f) - ,(make-cal-period (make-cal-month 2022 12) - (make-cal-month 2023 2) #f #f))) - "2022-01..2022-04, 2022-12..2023-02") - (test-false cal-periods-match - (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f) - ,(make-cal-period (make-cal-month 2022 12) - (make-cal-month 2023 2) #f #f)) - (make-cal-month 2022 5))) - (test-equal? cal-periods-match + (make-cal-month 2022 3))) + (test-true cal-month-in-periods? + (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f) + ,(make-cal-period (make-cal-month 2023 5) + (make-cal-month 2023 10) #f #f)) + (make-cal-month 2023 7))) + (test-false cal-month-in-periods? + (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f) + ,(make-cal-period (make-cal-month 2023 5) + (make-cal-month 2023 10) #f #f)) + (make-cal-month 2022 10))) + (test-equal? cal-period->string + (cal-period->string (make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f)) + "2022-01..2022-04") + (test-equal? cal-periods->string + (cal-periods->string `(,(make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f) + ,(make-cal-period (make-cal-month 2022 12) + (make-cal-month 2023 2) #f #f))) + "2022-01..2022-04, 2022-12..2023-02") + (test-false cal-periods-match (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1) (make-cal-month 2022 4) #f #f) ,(make-cal-period (make-cal-month 2022 12) (make-cal-month 2023 2) #f #f)) - (make-cal-month 2022 2)) - (make-cal-period (make-cal-month 2022 1) - (make-cal-month 2022 4) #f #f)) - )) + (make-cal-month 2022 5))) + (test-equal? cal-periods-match + (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f) + ,(make-cal-period (make-cal-month 2022 12) + (make-cal-month 2023 2) #f #f)) + (make-cal-month 2022 2)) + (make-cal-period (make-cal-month 2022 1) + (make-cal-month 2022 4) #f #f)) + )) - ) + ) diff --git a/src/export-sheet.scm b/src/export-sheet.scm new file mode 100644 index 0000000..a907129 --- /dev/null +++ b/src/export-sheet.scm @@ -0,0 +1,226 @@ +;; +;; 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 4b0b15d..6647104 100644 --- a/src/export-web-static.scm +++ b/src/export-web-static.scm @@ -45,7 +45,9 @@ util-git configuration texts - logging) + logging + qr-payment + members-fees) ;; HTML entities (define (sanitize-html str) @@ -88,6 +90,8 @@ (print "dd+dt,dd+dt+dd{border-top:1px solid #8cacbb}") (print "dd{grid-column:2/3;font-weight:bold;margin:0px;padding-left:16px}") (print "footer{background:#dee7ec;border-top:1px solid #8cacbb;padding:16px}") + (print ".qr svg{width:100%;height:auto;max-width:10cm}") + (print ".qr{text-align: center}") (print "") (print "") (print "") @@ -109,6 +113,13 @@ (print "
Account for Payments
(Účet pro platbu příspěvků)
CZK: 2500079551/2010
EUR: CZ93 2010 0000 0021 0007 9552
") (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 0633a49..9f29a94 100644 --- a/src/hackerbase.scm +++ b/src/hackerbase.scm @@ -51,7 +51,9 @@ dokuwiki racket-kwargs util-string - mailinglist) + mailinglist + export-sheet + mbase-query) ;; Command-line options and configurable parameters (define -needs-bank- (make-parameter #f)) @@ -66,6 +68,7 @@ (define -show-only-active- (make-parameter #f)) (define -notify-months- (make-parameter 1)) (define -send-emails- (make-parameter #f)) +(define -number- (make-parameter #f)) ;; Arguments parsing (command-line @@ -181,7 +184,14 @@ (-action- 'genweb)) (-stats (file:gnuplot-data) "Get stats for all months" (-action- 'print-stats) + (-needs-bank- #t) (-fname- file:gnuplot-data)) + (-sheet (filename gmnum) "Generate attendance sheet for given GM number" + (-needs-bank- #t) + (-fname- filename) + (-number- gmnum) + (-action- 'gen-sheet)) + "" "Mailman Actions:" (-mlsync () "Synchronize internal ML" @@ -354,6 +364,10 @@ ((genweb) (log-info "Generating static web files") (gen-html-members MB (-web-dir-))) + ((gen-sheet) + (log-info "Generating attendance sheet") + (parameterize ((current-output-port (open-output-file (-fname-)))) + (print-attendance-sheet MB (-number-)))) ((edit) (if mr (let () diff --git a/src/mailman.scm b/src/mailman.scm index 29bd842..a8c9788 100644 --- a/src/mailman.scm +++ b/src/mailman.scm @@ -49,7 +49,6 @@ (import scheme (chicken base) (chicken module) - mailman2 mailman-common util-bst-lset configuration @@ -59,24 +58,17 @@ ;; Syntax for simplifying export of case-version procedures (define-syntax define-mailman-proc (syntax-rules () - ((_ name proc2) + ((_ name proc3) (begin (export name) (define (name . args) (case (*mailman-version*) - ((2) (apply proc2 args)))))) - ((_ name proc2 proc3) - (begin - (export name) - (define (name . args) - (case (*mailman-version*) - ((2) (apply proc2 args)) ((3) (apply proc3 args)))))))) (define-mailman-proc list-mailman-lists - list-mailman2-lists list-mailman3-lists) + list-mailman3-lists) (define-mailman-proc list-mailman-list-members - list-mailman2-list-members list-mailman3-list-members) + list-mailman3-list-members) ;; Loads a single mailman list as mailman structure, if ;; unsuccessfull, returns only a list with ML name and no member @@ -112,9 +104,9 @@ (assoc name lsts)) (define-mailman-proc add-email-to-mailman-list - add-email-to-mailman2-list add-email-to-mailman3-list) + add-email-to-mailman3-list) (define-mailman-proc remove-email-from-mailman-list - remove-email-from-mailman2-list remove-email-from-mailman3-list) + remove-email-from-mailman3-list) ;; Ensures given email is in given ML (define (mailman-ensure-member ml email) diff --git a/src/mailman2.scm b/src/mailman2.scm deleted file mode 100644 index 5825165..0000000 --- a/src/mailman2.scm +++ /dev/null @@ -1,104 +0,0 @@ -;; -;; 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 3412306..f2f12bb 100644 --- a/src/mbase.scm +++ b/src/mbase.scm @@ -50,8 +50,6 @@ mbase-update-by-id mbase-update - mbase-stats - mbase-add-unpaired mbase-unpaired @@ -207,47 +205,6 @@ (proc mr) mr))))) - ;; Returns dictionary with statistics about the members base. - (define (mbase-info mb-arg) - (let* ((members (find-members-by-predicate mb-arg brmember-usable?)) - (di0 (make-ldict)) - (di1 (ldict-set di0 'invalid - (filter (compose not is-4digit-prime? brmember-id) members))) - (di2 (ldict-set di1 'active - (filter brmember-active? members))) - (di3 (ldict-set di2 'suspended - (filter brmember-suspended? members))) - (di4 (ldict-set di3 'students - (filter brmember-student? members))) - (di5 (ldict-set di4 'destroyed - (filter brmember-destroyed? members))) - (di6 (ldict-set di5 'month (*current-month*))) - (di7 (ldict-set di6 'total members)) - (di8 (ldict-set di7 'problems - (find-members-by-predicate mb-arg brmember-has-problems?)))) - di8)) - - (define (members-base-oldest-month mb) - (make-cal-month 2015 1)) - - ;; Returns a list two lists: keys, data. - ;; Each data record contains values for all keys. - (define (mbase-stats mb) - (let ((keys '(month total active suspended students destroyed invalid))) - (let mloop ((data '()) - (month (members-base-oldest-month mb))) - (if (cal-month<=? month (*current-month*)) - (let ((bi (with-current-month month - (mbase-info mb)))) - (let kloop ((row (list (ldict-ref bi 'month))) - (keys (cdr keys))) - (if (null? keys) - (mloop (cons (reverse row) data) - (cal-month-add month 1)) - (kloop (cons (length (ldict-ref bi (car keys))) row) - (cdr keys))))) - (list keys (reverse data)))))) - ;; Adds unpaired transaction to given members-base (define (mbase-add-unpaired mb tr) (ldict-set mb 'unpaired diff --git a/src/members-fees.scm b/src/members-fees.scm index 5a3b0c3..1782f62 100644 --- a/src/members-fees.scm +++ b/src/members-fees.scm @@ -41,6 +41,7 @@ member-calendar->table members-summary member-calendar-entry->fee + get-expected-income get-expected-income-string ) @@ -208,6 +209,19 @@ (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) diff --git a/src/members-print.scm b/src/members-print.scm index 4d5b2dd..e8b6720 100644 --- a/src/members-print.scm +++ b/src/members-print.scm @@ -380,7 +380,7 @@ (members-table-row (ansi #:magenta #:bold) "Expire Soon:" soon-expire-mrs "~N (~S)")) (members-pred-table-row mb - (ansi-string #:red #:bold "Prolems:") + (ansi-string #:red #:bold "Problems:") brmember-has-problems? "~N~E ~A") (if (null? debtor-mrs) diff --git a/src/qr-payment.scm b/src/qr-payment.scm new file mode 100644 index 0000000..1550cdb --- /dev/null +++ b/src/qr-payment.scm @@ -0,0 +1,104 @@ +;; +;; qr-payment.scm +;; +;; QR payment generator. +;; +;; ISC License +;; +;; Copyright 2023-2025 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 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/texts.scm b/src/texts.scm index 6771016..a3383c6 100644 --- a/src/texts.scm +++ b/src/texts.scm @@ -5,7 +5,7 @@ ;; ;; ISC License ;; -;; Copyright 2023 Brmlab, z.s. +;; Copyright 2023-2025 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.17 (c) 2023-2024 Brmlab, z.s.") + (define banner-line "HackerBase 1.19-dev (c) 2023-2025 Brmlab, z.s.") ;; Banner source with numbers for ANSI CSI SGR (define banner-source "