397 lines
12 KiB
Scheme
397 lines
12 KiB
Scheme
;;
|
|
;; member-record.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 member-record))
|
|
|
|
(module
|
|
member-record
|
|
(
|
|
make-member-record
|
|
|
|
member-file-path
|
|
member-record-input-file
|
|
|
|
member-record-set
|
|
member-record-add-highlight
|
|
member-record-sub-ref
|
|
member-record-sub-set
|
|
member-record-sub-prepend
|
|
member-record-sub-has-key?
|
|
member-record-sub-ensure
|
|
|
|
member-record-info
|
|
member-missing-keys
|
|
member-has-highlights?
|
|
member-record-usable?
|
|
member-has-problems?
|
|
|
|
member-destroyed?
|
|
member-suspended?
|
|
member-active?
|
|
member-student?
|
|
member-existing?
|
|
member-flags
|
|
|
|
member-nick
|
|
member-id
|
|
member-suspended-months
|
|
|
|
member-format
|
|
|
|
member<?
|
|
|
|
member-record-add-payment
|
|
member-payments
|
|
|
|
member-record-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken keyword)
|
|
(chicken irregex)
|
|
(chicken string)
|
|
(chicken format)
|
|
dictionary
|
|
testing
|
|
month
|
|
period
|
|
configuration
|
|
primes
|
|
utils)
|
|
|
|
;; 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-member-record 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-dict pairs)
|
|
(if (not (keyword? (car args)))
|
|
(error 'make-member-record "Optional arguments must be keywords" (car args))
|
|
(if (null? (cdr args))
|
|
(error 'make-member-record "Each optional keyword argument must have a value" (car args))
|
|
(loop (cddr args)
|
|
(cons (cons (string->symbol (keyword->string (car args)))
|
|
(cadr args))
|
|
pairs)))))))
|
|
|
|
;; Convenience accessor
|
|
(define (member-file-path mr)
|
|
(dict-ref mr 'file-path))
|
|
|
|
;; Returns opened input file for this record (used by parser).
|
|
(define (member-record-input-file mr)
|
|
(open-input-file
|
|
(dict-ref mr 'file-path)))
|
|
|
|
;; Sets pairs of keys/values for given member record.
|
|
(define (member-record-set mr . args)
|
|
(let loop ((args args)
|
|
(mr mr))
|
|
(if (null? args)
|
|
mr
|
|
(if (not (keyword? (car args)))
|
|
(error 'member-record-set "Needs argument keyword" (car args))
|
|
(if (null? (cdr args))
|
|
(error 'member-record-set "Argument needs value" (car args))
|
|
(loop (cddr args)
|
|
(dict-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 (member-record-add-highlight mr line-number message pass type)
|
|
(dict-set mr 'highlights
|
|
(cons (list line-number message pass type)
|
|
(dict-ref mr 'highlights '()))))
|
|
|
|
;; Returns a key from particular section
|
|
(define (member-record-sub-ref mr sec key . defaults)
|
|
(let ((sec-dict (dict-ref mr sec)))
|
|
(if (null? defaults)
|
|
(dict-ref sec-dict key)
|
|
(dict-ref sec-dict key (car defaults)))))
|
|
|
|
;; Sets a key in particular section
|
|
(define (member-record-sub-set mr sec key val)
|
|
(let ((sec-dict (dict-ref mr sec)))
|
|
(dict-set mr sec
|
|
(dict-set sec-dict key val))))
|
|
|
|
;; Prepends value to given subkey
|
|
(define (member-record-sub-prepend mr sec key val)
|
|
(member-record-sub-set mr sec key
|
|
(cons val
|
|
(member-record-sub-ref mr sec key '()))))
|
|
|
|
;; Returns true if given section contains given key
|
|
(define (member-record-sub-has-key? mr sec key)
|
|
(dict-has-key? (dict-ref mr sec) key))
|
|
|
|
;; Returns new member record with section updated by defaults, the
|
|
;; section must already exist.
|
|
(define (member-record-sub-ensure mr sec . kvs)
|
|
(let loop ((kvs kvs)
|
|
(sd (dict-ref mr sec)))
|
|
(if (null? kvs)
|
|
(dict-set mr sec sd)
|
|
(if (null? (cdr kvs))
|
|
(error 'member-record-sub-ensure "Needs pairs of keys and values" kvs)
|
|
(let ((key (car kvs))
|
|
(val (cadr kvs)))
|
|
(loop (cddr kvs)
|
|
(if (dict-has-key? sd key)
|
|
sd
|
|
(dict-set sd key val))))))))
|
|
|
|
;; Returns member info key value
|
|
(define (member-record-info mr key . defaults)
|
|
(let ((info (dict-ref mr 'info)))
|
|
(if (null? defaults)
|
|
(dict-ref info key)
|
|
(dict-ref info key (car defaults)))))
|
|
|
|
;; Return mandatory keys with #f as value
|
|
(define (member-missing-keys mr)
|
|
(dict-reduce '()
|
|
(lambda (acc k v)
|
|
(if v acc (cons k acc)))
|
|
(dict-ref mr 'info)))
|
|
|
|
;; True if there are any source highlights
|
|
(define (member-has-highlights? mr)
|
|
(dict-has-key? mr 'highlights))
|
|
|
|
;; Returns true if there is at least one highlight of given type
|
|
(define (member-highlights-has-type? mr type)
|
|
(let loop ((hls (dict-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 (member-record-usable? mr)
|
|
(dict-has-key? (dict-ref mr 'info) 'member))
|
|
|
|
;; True if member record is OK
|
|
(define (member-has-problems? mr)
|
|
(or (member-has-errors? mr)
|
|
(not (member-record-usable? mr))
|
|
(not (is-4digit-prime? (member-id mr)))))
|
|
|
|
;; Returns true if the member record represents non-existing
|
|
;; member. The *current-month* is a global parameter from period
|
|
;; module.
|
|
(define (member-destroyed? mr)
|
|
(and (not (member-existing? mr))
|
|
(let ((member (member-record-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 (member-record-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 (member-suspended? mr)
|
|
(and (member-is-suspended? mr)
|
|
(not (member-destroyed? mr))))
|
|
|
|
;; True if the member is student
|
|
(define member-is-student?
|
|
(member-period-predicate? 'student))
|
|
|
|
;; Only active members can be students.
|
|
(define (member-student? mr)
|
|
(and (member-active? mr)
|
|
(member-is-student? mr)))
|
|
|
|
;; Returns true if the member is active (not suspended or destroyed).
|
|
(define (member-active? mr)
|
|
(and (month-in-periods? (member-record-info mr 'member))
|
|
(not (member-suspended? mr))))
|
|
|
|
;; Returns true if the member is currently a member
|
|
(define (member-existing? mr)
|
|
(month-in-periods?
|
|
(member-record-info mr 'member)))
|
|
|
|
;; Returns a list of flags of given member record.
|
|
(define (member-flags mr)
|
|
(filter identity
|
|
(list (if (member-student? mr) 'student #f)
|
|
(if (member-suspended? mr) 'suspended #f)
|
|
(if (member-active? mr) 'active #f)
|
|
(if (member-destroyed? mr) 'destroyed #f)
|
|
(if (member-existing? mr) 'existing #f))))
|
|
|
|
;; Nickname as string
|
|
(define (member-nick mr)
|
|
(member-record-info mr 'nick))
|
|
|
|
;; Returns member id
|
|
(define (member-id mr)
|
|
(dict-ref mr 'id))
|
|
|
|
;; Returns the number of months the user is suspended. Zero if not
|
|
;; suspended.
|
|
(define (member-suspended-months mr)
|
|
(if (member-suspended? mr)
|
|
(let ((period (periods-match (member-record-info mr 'suspend))))
|
|
(if period
|
|
(month-diff (car period) (*current-month*))
|
|
0))
|
|
0))
|
|
|
|
;; Member formatting function for general use.
|
|
(define (member-format fmt mr)
|
|
(let loop ((fmtl (string->list fmt))
|
|
(resl '()))
|
|
(if (null? fmtl)
|
|
(string-intersperse (reverse resl) "")
|
|
(let ((ch (car fmtl)))
|
|
(if (eq? ch #\~)
|
|
(loop (cddr fmtl)
|
|
(cons (case (cadr fmtl)
|
|
((#\N) (member-record-info mr 'nick))
|
|
((#\I) (number->string (member-record-info mr 'id)))
|
|
((#\S) (number->string (member-suspended-months mr)))
|
|
((#\E)
|
|
(let ((n (length (dict-ref mr 'highlights '()))))
|
|
(if (eq? n 0)
|
|
""
|
|
(sprintf "[~A]" n))))
|
|
((#\~) "~"))
|
|
resl))
|
|
(loop (cdr fmtl)
|
|
(cons (make-string 1 (car fmtl)) resl)))))))
|
|
|
|
;; Comparator of member records based on nickname.
|
|
(define (member<? a b)
|
|
(string-ci<? (member-nick a)
|
|
(member-nick b)))
|
|
|
|
;; Prepends new payment to given member record payments
|
|
(define (member-record-add-payment mr pt)
|
|
(dict-set mr 'payments
|
|
(cons pt
|
|
(dict-ref mr 'payments '()))))
|
|
|
|
;; Returns alist of member payments
|
|
(define (member-payments mr)
|
|
(dict-ref mr 'payments '()))
|
|
|
|
;; Self-tests
|
|
(define (member-record-tests!)
|
|
(run-tests
|
|
member-record
|
|
(test-equal? make-member-record
|
|
(make-member-record '|1234| "members/1234" '(|member|))
|
|
'((file-name . |1234|)
|
|
(file-path . "members/1234")
|
|
(symlinks |member|)
|
|
(id . 1234)))
|
|
(test-equal? make-member-record
|
|
(make-member-record '|1234| "members/1234" '(|member|) #:msg "msg")
|
|
'((msg . "msg")
|
|
(file-name . |1234|)
|
|
(file-path . "members/1234")
|
|
(symlinks |member|)
|
|
(id . 1234)))
|
|
(test-equal? member-record-set
|
|
(member-record-set '() #:id 1234)
|
|
'((id . 1234)))
|
|
(test-equal? member-record-add-highlight
|
|
(member-record-add-highlight '() 123 "Interesting..." 0 'info)
|
|
'((highlights . ((123 "Interesting..." 0 info)))))
|
|
(test-true member-destroyed?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(member-destroyed? '((info . ((member . (((2010 1) (2010 5))))))))))
|
|
(test-false member-destroyed?
|
|
(parameterize ((*current-month* (list 2009 2)))
|
|
(member-destroyed? '((info . ((member . (((2001 1) (2010 5))))))))))
|
|
(test-false member-suspended?
|
|
(member-suspended? '((info . ((member . (((2015 1) #f))))))))
|
|
(test-true member-suspended?
|
|
(parameterize ((*current-month* (list 2015 2)))
|
|
(member-suspended? '((info . ((member . (((2015 1) #f)))
|
|
(suspend ((2010 1) (2022 4) #f #f))))))))
|
|
(test-true member-suspended?
|
|
(parameterize ((*current-month* (list 2015 2)))
|
|
(member-suspended? '((info . ((member . (((2015 1) #f)))
|
|
(suspend ((2010 1) #f #f #f))))))))
|
|
(test-false member-suspended?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(member-suspended? '((info . ((member . (((2015 1) #f)))
|
|
(suspend ((2010 1) (2022 4) #f #f))))))))
|
|
(test-true member-active?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(member-active? '((info . ((member . (((2015 1) #f)))
|
|
(suspend ((2010 1) (2022 4) #f #f))))))))
|
|
))
|
|
|
|
)
|