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