Remove old member record.
This commit is contained in:
parent
785d4bd411
commit
6588c6576f
1 changed files with 0 additions and 291 deletions
|
|
@ -1,291 +0,0 @@
|
||||||
;;
|
|
||||||
;; 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
|
|
||||||
print-member-record-table
|
|
||||||
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)
|
|
||||||
(chicken format)
|
|
||||||
dictionary
|
|
||||||
period
|
|
||||||
testing
|
|
||||||
month
|
|
||||||
member-file
|
|
||||||
listing
|
|
||||||
ansi
|
|
||||||
configuration
|
|
||||||
table
|
|
||||||
utils)
|
|
||||||
|
|
||||||
;; 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)))))))
|
|
||||||
|
|
||||||
;; Prints nicely formatted table
|
|
||||||
(define (print-member-record-table mr)
|
|
||||||
(let* ((aliases (mr-ref mr 'symlinks))
|
|
||||||
(head (list (list "ID:" (mr-ref mr 'id))
|
|
||||||
(list (sprintf "Alias~A:" (if (> (length aliases) 1) "es" ""))
|
|
||||||
(string-intersperse (map symbol->string aliases) ", "))
|
|
||||||
(if (member-suspended? mr)
|
|
||||||
(list "Suspended for:"
|
|
||||||
(let ((msm (member-suspended-months mr)))
|
|
||||||
(sprintf "~A month~A" msm
|
|
||||||
(if (> msm 1) "s" ""))))
|
|
||||||
#f)))
|
|
||||||
(info (dict-ref mr 'info))
|
|
||||||
(sikeys (sort (dict-keys info)
|
|
||||||
(lambda (a b)
|
|
||||||
(string<?
|
|
||||||
(symbol->string a)
|
|
||||||
(symbol->string b)))))
|
|
||||||
(body (map (lambda (k)
|
|
||||||
(if (eq? k member-file-error-symbol)
|
|
||||||
#f
|
|
||||||
(let ((v (dict-ref info k)))
|
|
||||||
(case k
|
|
||||||
((joined)
|
|
||||||
(list k (month->string v)))
|
|
||||||
((card desfire credit)
|
|
||||||
(list k
|
|
||||||
(table->string
|
|
||||||
(map
|
|
||||||
(lambda (c)
|
|
||||||
(list (car c) (cdr c)))
|
|
||||||
v)
|
|
||||||
#:col-border #t)))
|
|
||||||
((suspend student)
|
|
||||||
(list k
|
|
||||||
(table->string
|
|
||||||
(cons (list "Since" "Until")
|
|
||||||
(map
|
|
||||||
(lambda (p)
|
|
||||||
(list
|
|
||||||
(month->string (car p))
|
|
||||||
(month->string (cdr p))))
|
|
||||||
v))
|
|
||||||
#:col-border #t)))
|
|
||||||
(else
|
|
||||||
(list k v))))))
|
|
||||||
sikeys))
|
|
||||||
(result (filter identity (append head body))))
|
|
||||||
(print (table->string result #:table-border #t #:row-border #t #:col-border #t))))
|
|
||||||
|
|
||||||
;; 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)))
|
|
||||||
((#\E)
|
|
||||||
(let ((n (length (mr-ref mr member-file-error-symbol '()))))
|
|
||||||
(if (<= n 2)
|
|
||||||
""
|
|
||||||
(sprintf "[~A]" (- n 2)))))
|
|
||||||
((#\~) "~"))
|
|
||||||
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))))))))
|
|
||||||
))
|
|
||||||
|
|
||||||
)
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue