231 lines
6.6 KiB
Scheme
231 lines
6.6 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-existing?
|
|
member-format
|
|
member-suspended-months
|
|
member-source
|
|
print-member-source
|
|
member<?
|
|
member-record-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken string)
|
|
(chicken sort)
|
|
dictionary
|
|
period
|
|
testing
|
|
month
|
|
member-file
|
|
listing
|
|
ansi)
|
|
|
|
;; 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)
|
|
", "))
|
|
(when (member-suspended? mr)
|
|
(print " Suspended for " (member-suspended-months mr) " months."))
|
|
(newline)
|
|
(let loop ((sinfo sinfo))
|
|
(when (not (null? sinfo))
|
|
(let* ((kv (car sinfo))
|
|
(k (car kv))
|
|
(v (cdr kv)))
|
|
(when (not (eq? k member-file-error-symbol))
|
|
(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))
|
|
|
|
;; Returns true if the member has joined.
|
|
(define (member-existing? mr)
|
|
(let ((joined (mr-ref mr 'joined)))
|
|
(and joined
|
|
(month<? joined (*current-month*)))))
|
|
|
|
;; 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) (mr-ref mr 'nick))
|
|
((#\I) (number->string (mr-ref mr 'id)))
|
|
((#\S) (number->string (member-suspended-months mr)))
|
|
((#\~) "~"))
|
|
resl))
|
|
(loop (cdr fmtl)
|
|
(cons (make-string 1 (car fmtl)) resl)))))))
|
|
|
|
;; 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 (mr-ref mr 'suspend))))
|
|
(if period
|
|
(month-diff (car period) (*current-month*))
|
|
0))
|
|
0))
|
|
|
|
;; Returns source (including error) information
|
|
(define (member-source mr)
|
|
(mr-ref mr member-file-error-symbol))
|
|
|
|
;; Nicely prints the member source with any errors recorded.
|
|
(define (print-member-source mr)
|
|
(let* ((ms (member-source mr))
|
|
(file-name (car ms))
|
|
(lines (cadr ms))
|
|
(hls (cddr ms)))
|
|
(print file-name ":")
|
|
(print-source-listing
|
|
lines
|
|
hls
|
|
-1
|
|
a:error a:default
|
|
"" "" ; Not used
|
|
"..." ; Not used
|
|
)))
|
|
|
|
;; Comparator of member records based on nickname.
|
|
(define (member<? a b)
|
|
(string-ci<? (member-nick a)
|
|
(member-nick b)))
|
|
|
|
;; 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))))))))
|
|
))
|
|
|
|
)
|