611 lines
17 KiB
Scheme
611 lines
17 KiB
Scheme
;;
|
|
;; brmember.scm
|
|
;;
|
|
;; Procedures working with complete member record (as loaded by the
|
|
;; members-base).
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
|
|
(declare (unit brmember))
|
|
|
|
(module
|
|
brmember
|
|
(
|
|
TAG-BRMEMBER
|
|
|
|
make-brmember
|
|
|
|
brmember?
|
|
|
|
brmember-file-name
|
|
brmember-file-path
|
|
brmember-input-file
|
|
|
|
brmember-set
|
|
brmember-add-highlight
|
|
brmember-sub-ref
|
|
brmember-sub-set
|
|
brmember-sub-prepend
|
|
brmember-sub-has-key?
|
|
brmember-sub-ensure
|
|
|
|
brmember-source
|
|
brmember-info
|
|
brmember-missing-keys
|
|
brmember-has-highlights?
|
|
brmember-usable?
|
|
brmember-in-dokuwiki?
|
|
brmember-dokuwiki-groups-ok?
|
|
brmember-has-problems?
|
|
brmember-file-has-problems?
|
|
|
|
brmember-destroyed?
|
|
brmember-suspended?
|
|
brmember-active?
|
|
brmember-student?
|
|
brmember-existing?
|
|
|
|
brmember-chair?
|
|
brmember-council?
|
|
brmember-revision?
|
|
brmember-grant?
|
|
|
|
brmember-flags
|
|
|
|
brmember-nick
|
|
brmember-id
|
|
brmember-suspended-months
|
|
brmember-suspended-for
|
|
|
|
brmember<?
|
|
|
|
brmember-add-payment
|
|
brmember-payments
|
|
|
|
brmember-credit
|
|
|
|
brmember-mailman
|
|
brmember-add-mailman
|
|
|
|
brmember-spec-fee
|
|
|
|
brmember-age
|
|
|
|
brmember-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken keyword)
|
|
(chicken irregex)
|
|
(chicken string)
|
|
(chicken format)
|
|
srfi-1
|
|
util-bst-ldict
|
|
testing
|
|
cal-month
|
|
cal-period
|
|
configuration
|
|
primes
|
|
bank-account
|
|
util-tag)
|
|
|
|
;; Unique tag
|
|
(define TAG-BRMEMBER (make-tag brmember))
|
|
|
|
;; Checks whether given string is a 4-digit decimal number.
|
|
(define (is-4digit-string? s)
|
|
(if (irregex-search (irregex "^[0-9]{4}$") s)
|
|
#t
|
|
#f))
|
|
|
|
;; checks whether given symbol is a 4-digit one.
|
|
(define (is-4digit-symbol? s)
|
|
(is-4digit-string?
|
|
(symbol->string s)))
|
|
|
|
;; Returns the first 4-digit symbol from the list.
|
|
(define (get-4digit-symbol-from-list lst)
|
|
(let loop ((lst lst))
|
|
(if (null? lst)
|
|
#f
|
|
(if (is-4digit-symbol? (car lst))
|
|
(car lst)
|
|
(loop (cdr lst))))))
|
|
|
|
;; Creates new member record based on the file and symlinks
|
|
;; information received from the members directory. Any keyword
|
|
;; arguments are converted to respective symbols in the dictionary.
|
|
(define (make-brmember file-name file-path symlinks . args)
|
|
(let loop ((args args)
|
|
(pairs `((file-name . ,file-name)
|
|
(file-path . ,file-path)
|
|
(symlinks . ,symlinks)
|
|
(id . ,(string->number
|
|
(symbol->string
|
|
(get-4digit-symbol-from-list (cons file-name symlinks))))))))
|
|
(if (null? args)
|
|
(make-ldict (cons (cons 'TAG TAG-BRMEMBER)
|
|
pairs))
|
|
(if (not (keyword? (car args)))
|
|
(error 'make-brmember "Optional arguments must be keywords" (car args))
|
|
(if (null? (cdr args))
|
|
(error 'make-brmember "Each optional keyword argument must have a value" (car args))
|
|
(loop (cddr args)
|
|
(cons (cons (string->symbol (keyword->string (car args)))
|
|
(cadr args))
|
|
pairs)))))))
|
|
|
|
;; Predicate
|
|
(define (brmember? v)
|
|
(and (ldict? v)
|
|
(eq? (ldict-ref v 'TAG #f) TAG-BRMEMBER)))
|
|
|
|
;; File name without directory
|
|
(define (brmember-file-name mr)
|
|
(ldict-ref mr 'file-name))
|
|
|
|
;; Convenience accessor for file name with directory
|
|
(define (brmember-file-path mr)
|
|
(ldict-ref mr 'file-path))
|
|
|
|
;; Returns opened input file for this record (used by parser).
|
|
(define (brmember-input-file mr)
|
|
(open-input-file
|
|
(ldict-ref mr 'file-path)))
|
|
|
|
;; Sets pairs of keys/values for given member record.
|
|
(define (brmember-set mr . args)
|
|
(let loop ((args args)
|
|
(mr mr))
|
|
(if (null? args)
|
|
mr
|
|
(if (not (keyword? (car args)))
|
|
(error 'brmember-set "Needs argument keyword" (car args))
|
|
(if (null? (cdr args))
|
|
(error 'brmember-set "Argument needs value" (car args))
|
|
(loop (cddr args)
|
|
(ldict-set mr (string->symbol (keyword->string (car args)))
|
|
(cadr args))))))))
|
|
|
|
;; Adds highlight identified by line number, message, pass number and
|
|
;; type (error, warning, info).
|
|
(define (brmember-add-highlight mr line-number message pass type)
|
|
(ldict-set mr 'highlights
|
|
(cons (list line-number message pass type)
|
|
(ldict-ref mr 'highlights '()))))
|
|
|
|
;; Returns a key from particular section
|
|
(define (brmember-sub-ref mr sec key . defaults)
|
|
(let ((sec-dict (ldict-ref mr sec)))
|
|
(if (null? defaults)
|
|
(ldict-ref sec-dict key)
|
|
(ldict-ref sec-dict key (car defaults)))))
|
|
|
|
;; Sets a key in particular section
|
|
(define (brmember-sub-set mr sec key val)
|
|
(let ((sec-dict (ldict-ref mr sec)))
|
|
(ldict-set mr sec
|
|
(ldict-set sec-dict key val))))
|
|
|
|
;; Prepends value to given subkey
|
|
(define (brmember-sub-prepend mr sec key val)
|
|
(brmember-sub-set mr sec key
|
|
(cons val
|
|
(brmember-sub-ref mr sec key '()))))
|
|
|
|
;; Returns true if given section contains given key
|
|
(define (brmember-sub-has-key? mr sec key)
|
|
(ldict-contains? (ldict-ref mr sec) key))
|
|
|
|
;; Returns new member record with section updated by defaults, the
|
|
;; section must already exist.
|
|
(define (brmember-sub-ensure mr sec . kvs)
|
|
(let loop ((kvs kvs)
|
|
(sd (ldict-ref mr sec)))
|
|
(if (null? kvs)
|
|
(ldict-set mr sec sd)
|
|
(if (null? (cdr kvs))
|
|
(error 'brmember-sub-ensure "Needs pairs of keys and values" kvs)
|
|
(let ((key (car kvs))
|
|
(val (cadr kvs)))
|
|
(loop (cddr kvs)
|
|
(if (ldict-contains? sd key)
|
|
sd
|
|
(ldict-set sd key val))))))))
|
|
|
|
;; Returns source lines
|
|
(define (brmember-source mr)
|
|
(ldict-ref mr 'source '()))
|
|
|
|
;; Returns member info key value
|
|
(define (brmember-info mr key . defaults)
|
|
(let ((info (ldict-ref mr 'info #f)))
|
|
(if info
|
|
(if (null? defaults)
|
|
(ldict-ref info key)
|
|
(ldict-ref info key (car defaults)))
|
|
(if (null? defaults)
|
|
(error 'brmember-info "Info key is missing.")
|
|
(car defaults)))))
|
|
|
|
;; Return mandatory keys with #f as value
|
|
(define (brmember-missing-keys mr)
|
|
(ldict-reduce '()
|
|
(lambda (acc k v)
|
|
(if v acc (cons k acc)))
|
|
(ldict-ref mr 'info)))
|
|
|
|
;; True if there are any source highlights
|
|
(define (brmember-has-highlights? mr)
|
|
(ldict-contains? mr 'highlights))
|
|
|
|
;; Returns true if there is at least one highlight of given type
|
|
(define (member-highlights-has-type? mr type)
|
|
(let loop ((hls (ldict-ref mr 'highlights '())))
|
|
(if (null? hls)
|
|
#f
|
|
(if (eq? (cadddr (car hls)) type)
|
|
#t
|
|
(loop (cdr hls))))))
|
|
|
|
;; Returns true if there is at least one highlight with error type
|
|
(define (member-has-errors? mr)
|
|
(member-highlights-has-type? mr 'error))
|
|
|
|
;; Absolutely required
|
|
(define (brmember-usable? mr)
|
|
(ldict-contains? (ldict-ref mr 'info) 'member))
|
|
|
|
;; Returns #t if this member is in dokuwiki
|
|
(define (brmember-in-dokuwiki? mr)
|
|
(ldict-contains? mr 'dokuwiki))
|
|
|
|
;; Returns #t if this member email is the same as the one in dokuwiki
|
|
(define (brmember-dokuwiki-email-ok? mr)
|
|
(let ((dw (ldict-ref mr 'dokuwiki #f)))
|
|
(if (eq? dw #t)
|
|
#t
|
|
(if dw
|
|
(let ((email (brmember-info mr 'mail 0))
|
|
(memail (ldict-ref dw 'email 1)))
|
|
(equal? email memail))
|
|
#f))))
|
|
|
|
;; Returns #t if this member is in "member" group in dokuwiki.
|
|
(define (brmember-dokuwiki-groups-ok? mr)
|
|
(let ((dw (ldict-ref mr 'dokuwiki #f)))
|
|
(if (eq? dw #t)
|
|
#t
|
|
(if dw
|
|
(let ((groups (ldict-ref dw 'groups '())))
|
|
(and
|
|
;; member
|
|
(or (and (member "member" groups)
|
|
(brmember-existing? mr))
|
|
(and (not (member "member" groups))
|
|
(not (brmember-existing? mr))))
|
|
;; council, admin
|
|
(or (and (or (member "council" groups)
|
|
(member "admin" groups))
|
|
(brmember-existing? mr)
|
|
(or (brmember-council? mr)
|
|
(brmember-chair? mr)
|
|
(brmember-revision? mr)))
|
|
(and (not (or (member "council" groups)
|
|
(member "admin" groups)))
|
|
(or (not (brmember-existing? mr))
|
|
(not (or (brmember-council? mr)
|
|
(brmember-chair? mr)
|
|
(brmember-revision? mr))))))
|
|
))
|
|
(not (brmember-existing? mr))))))
|
|
|
|
;; True if member record is not OK
|
|
(define (brmember-has-problems? mr)
|
|
(or (member-has-errors? mr)
|
|
(not (null? (brmember-missing-keys mr)))
|
|
(not (brmember-usable? mr))
|
|
(not (is-4digit-prime? (brmember-id mr)))
|
|
(and (not (brmember-destroyed? mr))
|
|
(not (brmember-in-dokuwiki? mr)))
|
|
(and (not (brmember-destroyed? mr))
|
|
(not (brmember-dokuwiki-email-ok? mr)))
|
|
(not (brmember-dokuwiki-groups-ok? mr))
|
|
))
|
|
|
|
;; True if member record is not OK
|
|
(define (brmember-file-has-problems? mr)
|
|
(or (member-has-errors? mr)
|
|
(not (null? (brmember-missing-keys mr)))
|
|
(not (brmember-usable? mr))
|
|
(not (is-4digit-prime? (brmember-id mr)))
|
|
))
|
|
|
|
;; Returns true if the member record represents non-existing
|
|
;; member. The *current-month* is a global parameter from period
|
|
;; module.
|
|
(define (brmember-destroyed? mr)
|
|
(and (not (brmember-existing? mr))
|
|
(let ((member (brmember-info mr 'member)))
|
|
(if (null? member)
|
|
#f
|
|
(cal-month>=? (*current-month*)
|
|
(cal-period-since (car member)))))))
|
|
|
|
;; Generic period-based predicate
|
|
(define ((member-period-predicate? key) mr)
|
|
(let ((periods (brmember-info mr key #f)))
|
|
(and periods
|
|
(cal-month-in-periods? periods))))
|
|
|
|
;; Returns true if the member is now suspended
|
|
(define member-is-suspended?
|
|
(member-period-predicate? 'suspend))
|
|
|
|
;; Suspended must not be destroyed
|
|
(define (brmember-suspended? mr)
|
|
(and (member-is-suspended? mr)
|
|
(not (brmember-destroyed? mr))))
|
|
|
|
;; True if the member is student
|
|
(define member-is-student?
|
|
(member-period-predicate? 'student))
|
|
|
|
;; Only active members can be students.
|
|
(define (brmember-student? mr)
|
|
(and (brmember-active? mr)
|
|
(member-is-student? mr)))
|
|
|
|
;; Returns true if the member is active (not suspended or destroyed).
|
|
(define (brmember-active? mr)
|
|
(and (cal-month-in-periods? (brmember-info mr 'member))
|
|
(not (brmember-suspended? mr))))
|
|
|
|
;; Returns true if the member is currently a member
|
|
(define (brmember-existing? mr)
|
|
(cal-month-in-periods?
|
|
(brmember-info mr 'member)))
|
|
|
|
;; Returns predicate for given organizational body membership
|
|
(define (brmember-body? body)
|
|
(lambda (mr)
|
|
(cal-day-in-periods?
|
|
(brmember-info mr body '()))))
|
|
|
|
;; Predicates for all organizational bodies recognized
|
|
(define brmember-chair? (brmember-body? 'chair))
|
|
(define brmember-council? (brmember-body? 'council))
|
|
(define brmember-revision? (brmember-body? 'revision))
|
|
(define brmember-grant? (brmember-body? 'grant))
|
|
|
|
;; Returns a list of flags of given member record.
|
|
(define (brmember-flags mr)
|
|
(filter identity
|
|
(list (if (brmember-student? mr) 'student #f)
|
|
(if (brmember-suspended? mr) 'suspended #f)
|
|
(if (brmember-active? mr) 'active #f)
|
|
(if (brmember-destroyed? mr) 'destroyed #f)
|
|
(if (brmember-existing? mr) 'existing #f)
|
|
(if (brmember-chair? mr) 'chair #f)
|
|
(if (brmember-council? mr) 'council #f)
|
|
(if (brmember-revision? mr) 'revision #f)
|
|
(if (brmember-grant? mr) 'grant #f)
|
|
)))
|
|
|
|
;; Nickname as string
|
|
(define (brmember-nick mr)
|
|
(brmember-info mr 'nick))
|
|
|
|
;; Returns member id
|
|
(define (brmember-id mr)
|
|
(ldict-ref mr 'id))
|
|
|
|
;; Returns the number of months the user is suspended. Zero if not
|
|
;; suspended.
|
|
(define (brmember-suspended-months mr)
|
|
(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*))
|
|
0))
|
|
0))
|
|
|
|
;; Creates configured predicate for the number of months the member
|
|
;; is suspended for.
|
|
(define (brmember-suspended-for at-least . less-thans)
|
|
(let ((less-than (if (null? less-thans)
|
|
#f
|
|
(car less-thans))))
|
|
(lambda (mr)
|
|
(let ((months (brmember-suspended-months mr)))
|
|
(and (>= months at-least)
|
|
(or (not less-than)
|
|
(< months less-than)))))))
|
|
|
|
;; Comparator of member records based on nickname.
|
|
(define (brmember<? a b)
|
|
(string-ci<? (brmember-nick a)
|
|
(brmember-nick b)))
|
|
|
|
;; Prepends new payment to given member record payments
|
|
(define (brmember-add-payment mr pt)
|
|
(ldict-set mr 'payments
|
|
(cons pt
|
|
(ldict-ref mr 'payments '()))))
|
|
|
|
;; Returns a list of member payments
|
|
(define (brmember-payments mr)
|
|
(filter (lambda (tr)
|
|
(let* ((isodate (bank-transaction-date tr))
|
|
(month (iso-date->cal-month isodate)))
|
|
(cal-month<=? month (*current-month*))))
|
|
(ldict-ref mr 'payments '())))
|
|
|
|
;; Returns credit records - respects *current-month*
|
|
(define (brmember-credit mr)
|
|
(filter (lambda (cr)
|
|
(let* ((cmon (cadr cr))
|
|
(mon (if cmon
|
|
(cal-ensure-month cmon)
|
|
#f)))
|
|
(if mon
|
|
(cal-month<=? mon (*current-month*))
|
|
#t)))
|
|
(brmember-info mr 'credit '())))
|
|
|
|
;; Returns a list of MLs this member is subscribed to
|
|
(define (brmember-mailman mr)
|
|
(ldict-ref mr 'mailman '()))
|
|
|
|
;; Adds given ML to given member record
|
|
(define (brmember-add-mailman mr ml)
|
|
(ldict-set mr 'mailman
|
|
(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
|
|
brmember
|
|
(test-true make-brmember
|
|
(ldict-equal?
|
|
(make-brmember '|1234| "members/1234" '(|member|))
|
|
(make-ldict
|
|
`((TAG . ,TAG-BRMEMBER)
|
|
(file-name . |1234|)
|
|
(file-path . "members/1234")
|
|
(symlinks |member|)
|
|
(id . 1234)))))
|
|
(test-true make-brmember
|
|
(ldict-equal?
|
|
(make-brmember '|1234| "members/1234" '(|member|) #:msg "msg")
|
|
(make-ldict
|
|
`((msg . "msg")
|
|
(TAG . ,TAG-BRMEMBER)
|
|
(file-name . |1234|)
|
|
(file-path . "members/1234")
|
|
(symlinks |member|)
|
|
(id . 1234)))))
|
|
(test-true brmember-set
|
|
(ldict-equal?
|
|
(brmember-set (make-ldict) #:id 1234)
|
|
(make-ldict
|
|
'((id . 1234)))))
|
|
(test-true brmember-add-highlight
|
|
(ldict-equal?
|
|
(brmember-add-highlight (make-ldict) 123 "Interesting..." 0 'info)
|
|
(make-ldict
|
|
'((highlights . ((123 "Interesting..." 0 info)))))))
|
|
(test-true brmember-destroyed?
|
|
(with-current-month
|
|
(make-cal-month 2023 2)
|
|
(brmember-destroyed?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (,(make-cal-period
|
|
(make-cal-month 2010 1)
|
|
(make-cal-month 2010 5))))))))))))
|
|
(test-false brmember-destroyed?
|
|
(with-current-month
|
|
(make-cal-month 2009 2)
|
|
(brmember-destroyed?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (,(make-cal-period
|
|
(make-cal-month 2001 1)
|
|
(make-cal-month 2010 5))))))))))))
|
|
(test-false brmember-suspended?
|
|
(brmember-suspended?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (,(make-cal-period
|
|
(make-cal-month 2015 1)
|
|
#f))))))))))
|
|
(test-true brmember-suspended?
|
|
(with-current-month
|
|
(make-cal-month 2015 2)
|
|
(brmember-suspended?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (,(make-cal-period
|
|
(make-cal-month 2015 1)
|
|
#f)))
|
|
(suspend ,(make-cal-period
|
|
(make-cal-month 2010 1)
|
|
(make-cal-month 2022 4) #f #f))))))))))
|
|
(test-true brmember-suspended?
|
|
(with-current-month
|
|
(make-cal-month 2015 2)
|
|
(brmember-suspended?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (,(make-cal-period
|
|
(make-cal-month 2015 1)
|
|
#f)))
|
|
(suspend (make-cal-period
|
|
(make-cal-month 2010 1)
|
|
#f #f #f))))))))))
|
|
(test-false brmember-suspended?
|
|
(with-current-month
|
|
(make-cal-month 2023 2)
|
|
(brmember-suspended?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (,(make-cal-period
|
|
(make-cal-month 2015 1) #f)))
|
|
(suspend ,(make-cal-period
|
|
(make-cal-month 2010 1)
|
|
(make-cal-month 2022 4)
|
|
#f #f))))))))))
|
|
(test-true brmember-active?
|
|
(with-current-month
|
|
(make-cal-month 2023 2)
|
|
(brmember-active?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (,(make-cal-period
|
|
(make-cal-month 2015 1)
|
|
#f)))
|
|
(suspend ,(make-cal-period
|
|
(make-cal-month 2010 1)
|
|
(make-cal-month 2022 4)
|
|
#f #f))))))))))
|
|
))
|
|
|
|
)
|