422 lines
12 KiB
Scheme
422 lines
12 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
|
|
(
|
|
make-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-has-problems?
|
|
|
|
brmember-destroyed?
|
|
brmember-suspended?
|
|
brmember-active?
|
|
brmember-student?
|
|
brmember-existing?
|
|
brmember-flags
|
|
|
|
brmember-nick
|
|
brmember-id
|
|
brmember-suspended-months
|
|
|
|
brmember<?
|
|
|
|
brmember-add-payment
|
|
brmember-payments
|
|
|
|
member-mailman
|
|
member-add-mailman
|
|
|
|
member-record-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken keyword)
|
|
(chicken irregex)
|
|
(chicken string)
|
|
(chicken format)
|
|
util-dict-list
|
|
testing
|
|
month
|
|
period
|
|
configuration
|
|
primes
|
|
util-list
|
|
bank-account)
|
|
|
|
;; 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 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)))))))
|
|
|
|
;; 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)))
|
|
(if (null? defaults)
|
|
(ldict-ref info key)
|
|
(ldict-ref info key (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))
|
|
|
|
;; True if member record is OK
|
|
(define (brmember-has-problems? mr)
|
|
(or (member-has-errors? 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
|
|
(month>=? (*current-month*)
|
|
(period-since (car member)))))))
|
|
|
|
;; Generic period-based predicate
|
|
(define ((member-period-predicate? key) mr)
|
|
(let ((periods (brmember-info mr key #f)))
|
|
(and periods
|
|
(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 (month-in-periods? (brmember-info mr 'member))
|
|
(not (brmember-suspended? mr))))
|
|
|
|
;; Returns true if the member is currently a member
|
|
(define (brmember-existing? mr)
|
|
(month-in-periods?
|
|
(brmember-info mr 'member)))
|
|
|
|
;; 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))))
|
|
|
|
;; 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 (periods-match (brmember-info mr 'suspend))))
|
|
(if period
|
|
(month-diff (car period) (*current-month*))
|
|
0))
|
|
0))
|
|
|
|
;; 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 alist of member payments
|
|
(define (brmember-payments mr)
|
|
(filter (lambda (tr)
|
|
(let* ((isodate (bank-transaction-date tr))
|
|
(month (iso-date->month isodate)))
|
|
(month<=? month (*current-month*))))
|
|
(ldict-ref mr 'payments '())))
|
|
|
|
;; Returns a list of MLs this member is subscribed to
|
|
(define (member-mailman mr)
|
|
(ldict-ref mr 'mailman '()))
|
|
|
|
;; Adds given ML to given member record
|
|
(define (member-add-mailman mr ml)
|
|
(ldict-set mr 'mailman
|
|
(cons ml
|
|
(member-mailman mr))))
|
|
|
|
;; Self-tests
|
|
(define (member-record-tests!)
|
|
(run-tests
|
|
member-record
|
|
(test-true make-brmember
|
|
(ldict-equal?
|
|
(make-brmember '|1234| "members/1234" '(|member|))
|
|
(make-ldict
|
|
'((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")
|
|
(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?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(brmember-destroyed?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (((2010 1) (2010 5))))))))))))
|
|
(test-false brmember-destroyed?
|
|
(parameterize ((*current-month* (list 2009 2)))
|
|
(brmember-destroyed?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (((2001 1) (2010 5))))))))))))
|
|
(test-false brmember-suspended?
|
|
(brmember-suspended?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (((2015 1) #f))))))))))
|
|
(test-true brmember-suspended?
|
|
(parameterize ((*current-month* (list 2015 2)))
|
|
(brmember-suspended?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (((2015 1) #f)))
|
|
(suspend ((2010 1) (2022 4) #f #f))))))))))
|
|
(test-true brmember-suspended?
|
|
(parameterize ((*current-month* (list 2015 2)))
|
|
(brmember-suspended?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (((2015 1) #f)))
|
|
(suspend ((2010 1) #f #f #f))))))))))
|
|
(test-false brmember-suspended?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(brmember-suspended?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (((2015 1) #f)))
|
|
(suspend ((2010 1) (2022 4) #f #f))))))))))
|
|
(test-true brmember-active?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(brmember-active?
|
|
(make-ldict `((info . ,(make-ldict
|
|
`((member . (((2015 1) #f)))
|
|
(suspend ((2010 1) (2022 4) #f #f))))))))))
|
|
))
|
|
|
|
)
|