160 lines
4.7 KiB
Scheme
160 lines
4.7 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
|
|
(
|
|
print-member-record-info
|
|
member-destroyed?
|
|
member-suspended?
|
|
member-active?
|
|
member-student?
|
|
member-nick
|
|
member-id
|
|
member-record-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken string)
|
|
(chicken sort)
|
|
dictionary
|
|
period
|
|
testing
|
|
month)
|
|
|
|
;; Prints human-readable information
|
|
(define (print-member-record-info mr)
|
|
(let* ((id (dict-ref mr 'id))
|
|
(aliases (dict-ref mr 'symlinks))
|
|
(info (dict-ref mr 'info))
|
|
(sinfo (sort info
|
|
(lambda (a b)
|
|
(string<?
|
|
(symbol->string (car a))
|
|
(symbol->string (car b)))))))
|
|
(print "User " id " alias(es): "
|
|
(string-intersperse
|
|
(map symbol->string aliases)
|
|
", "))
|
|
(newline)
|
|
(let loop ((sinfo sinfo))
|
|
(when (not (null? sinfo))
|
|
(let* ((kv (car sinfo))
|
|
(k (car kv))
|
|
(v (cdr kv)))
|
|
(print " " k ":\t"
|
|
(if (member k '(student suspend))
|
|
(periods->string v)
|
|
v))
|
|
(loop (cdr sinfo)))))))
|
|
|
|
;; Returns key from the top-level (members-base) record if it exists,
|
|
;; queries the 'info key otherwise. Optional default argument works
|
|
;; like with dict-ref.
|
|
(define (mr-ref mr key . dfl)
|
|
(if (dict-has-key? mr key)
|
|
(dict-ref mr key)
|
|
(if (null? dfl)
|
|
(dict-ref (dict-ref mr 'info (make-dict)) key)
|
|
(dict-ref (dict-ref mr 'info (make-dict)) key (car dfl)))))
|
|
|
|
;; Returns true if the member record represents destroyed member. The
|
|
;; *current-month* is a global parameter from period module.
|
|
(define (member-destroyed? mr)
|
|
(let ((destroyed (mr-ref mr 'destroyed #f)))
|
|
(and destroyed
|
|
(month<? (string->month destroyed)
|
|
(*current-month*)))))
|
|
|
|
;; Generic period-based predicate
|
|
(define ((member-period-predicate? key) mr)
|
|
(let ((periods (mr-ref 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 (not (member-destroyed? mr))
|
|
(not (member-suspended? mr))))
|
|
|
|
;; Nickname as string
|
|
(define (member-nick mr)
|
|
(mr-ref mr 'nick))
|
|
|
|
;; Returns member id
|
|
(define (member-id mr)
|
|
(mr-ref mr 'id))
|
|
|
|
;; Performs module self-tests.
|
|
(define (member-record-tests!)
|
|
(run-tests
|
|
member-record
|
|
(test-true member-destroyed?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(member-destroyed? '((info . ((destroyed . "2010-05")))))))
|
|
(test-false member-destroyed?
|
|
(parameterize ((*current-month* (list 2009 2)))
|
|
(member-destroyed? '((info . ((destroyed . "2010-05")))))))
|
|
(test-false member-destroyed?
|
|
(member-destroyed? '((info . ()))))
|
|
(test-false member-suspended?
|
|
(member-suspended? '((info . ()))))
|
|
(test-true member-suspended?
|
|
(parameterize ((*current-month* (list 2015 2)))
|
|
(member-suspended? '((info . ((suspend ((2010 1) 2022 4))))))))
|
|
(test-true member-suspended?
|
|
(parameterize ((*current-month* (list 2015 2)))
|
|
(member-suspended? '((info . ((suspend ((2010 1) . #f))))))))
|
|
(test-false member-suspended?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(member-suspended? '((info . ((suspend ((2010 1) 2022 4))))))))
|
|
(test-true member-active?
|
|
(parameterize ((*current-month* (list 2023 2)))
|
|
(member-active? '((info . ((suspend ((2010 1) 2022 4))))))))
|
|
))
|
|
|
|
)
|