473 lines
14 KiB
Scheme
473 lines
14 KiB
Scheme
;;
|
|
;; members-print.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 members-print))
|
|
|
|
(module
|
|
members-print
|
|
(
|
|
print-member-info
|
|
print-member-table
|
|
print-member-source
|
|
member-records->string
|
|
print-members-base-info
|
|
print-members-base-table
|
|
print-members-base-stats
|
|
print-members-ids-stats
|
|
print-members-fees-table
|
|
print-unpaired-table
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken string)
|
|
(chicken sort)
|
|
(chicken format)
|
|
util-dict-list
|
|
brmember
|
|
month
|
|
util-list
|
|
table
|
|
listing
|
|
ansi
|
|
period
|
|
primes
|
|
members-base
|
|
configuration
|
|
bank-account
|
|
member-fees
|
|
members-payments
|
|
brmember-format)
|
|
|
|
;; Prints human-readable information
|
|
(define (print-member-info mr)
|
|
(let* ((id (ldict-ref mr 'id))
|
|
(aliases (ldict-ref mr 'symlinks))
|
|
(info (ldict-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)))
|
|
(loop (cdr sinfo)))))))
|
|
|
|
;; Returns nicely formatted table
|
|
(define (member-info->table mr)
|
|
(let* ((aliases (ldict-ref mr 'symlinks))
|
|
(mid (member-id mr))
|
|
(head (list (if (is-4digit-prime? mid)
|
|
(list "ID:" mid)
|
|
(list (ansi-string #:red #:bold "ID:")
|
|
(ansi-string #:red #:bold (number->string mid) " (not prime)")))
|
|
(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 (ldict-ref mr 'info))
|
|
(sikeys (sort (ldict-keys info)
|
|
(lambda (a b)
|
|
(string<?
|
|
(symbol->string a)
|
|
(symbol->string b)))))
|
|
(body (map (lambda (k)
|
|
(let ((v (ldict-ref info k)))
|
|
(case k
|
|
((card desfire credit)
|
|
(list k
|
|
(table->string
|
|
(map
|
|
(lambda (c)
|
|
(list (car c) (cdr c)))
|
|
v)
|
|
#:col-border #t)))
|
|
((suspend student member)
|
|
(list k
|
|
(table->string
|
|
(cons (list "Since" "Until")
|
|
(map
|
|
(lambda (p)
|
|
(list
|
|
(string-append (month->string (period-since p)) " "
|
|
(or (period-scomment p) ""))
|
|
(string-append (month->string (period-before p)) " "
|
|
(or (period-bcomment p) ""))))
|
|
v))
|
|
#:col-border #t)))
|
|
(else
|
|
(if v
|
|
(list k v)
|
|
(list (ansi-string #:red #:bold (symbol->string k))
|
|
(ansi-string #:red #:bold "---")))))))
|
|
sikeys))
|
|
(mailman (list (list "Mailing Lists"
|
|
(string-intersperse (member-mailman mr) "\n"))))
|
|
(result (filter identity (append head body mailman))))
|
|
(table->string result #:table-border #f #:row-border #t #:col-border #t #:ansi #t)))
|
|
|
|
;; Prints nicely formatted table
|
|
(define (print-member-table mr)
|
|
(print
|
|
(table->string
|
|
(list (list "Basic Information" "Payments" "Membership Status")
|
|
(list (member-info->table mr)
|
|
(member-payments->table mr)
|
|
(member-calendar->table mr))
|
|
)
|
|
#:row0-border #t
|
|
#:col-border #t))
|
|
(let* ((balance (member-balance mr))
|
|
(fees (ldict-ref balance 'fees))
|
|
(credit (ldict-ref balance 'credit))
|
|
(payment (ldict-ref balance 'payment))
|
|
(total (- (+ credit payment) fees)))
|
|
(print "Total fees: " fees)
|
|
(print "Total credit: " credit)
|
|
(print "Total payments: " payment)
|
|
(print "Balance: " total)
|
|
))
|
|
|
|
;; Nicely prints the member source with any errors recorded.
|
|
(define (print-member-source mr)
|
|
(let* ((lines (brmember-source mr))
|
|
(file-name (ldict-ref mr 'file-name))
|
|
(hls (ldict-ref mr 'highlights '())))
|
|
(print file-name ":")
|
|
(print-source-listing
|
|
lines
|
|
hls
|
|
#:context -1
|
|
)))
|
|
|
|
;; Prints nicely printed payments
|
|
(define (member-payments->table mr)
|
|
(table->string (cons
|
|
(list "Var" "Amount" "Cur" "Date" "TrId")
|
|
(map (lambda (tr)
|
|
(list (sprintf "\t~A" (bank-transaction-varsym tr))
|
|
(sprintf "\t~A" (bank-transaction-amount tr))
|
|
(bank-transaction-currency tr)
|
|
(bank-transaction-date tr)
|
|
(bank-transaction-id tr)))
|
|
(member-payments mr)))
|
|
#:row0-border #t
|
|
#:col-border #t
|
|
))
|
|
|
|
;; Converts member records to string, optional arguments are format
|
|
;; and separator. Format defaults to "~N" and separator to ", ".
|
|
(define (member-records->string mrs . args)
|
|
(let ((fmt (if (null? args) "~N" (car args)))
|
|
(sep (if (or (null? args)
|
|
(null? (cdr args)))
|
|
", "
|
|
(cadr args))))
|
|
(string-intersperse
|
|
(map (lambda (mr)
|
|
(brmember-format fmt mr))
|
|
mrs)
|
|
sep)))
|
|
|
|
;; Basic information about members-base in human-readable form.
|
|
(define (print-members-base-info mb)
|
|
(let ((nicks (list-members-nicks mb))
|
|
(ids (list-members-ids mb)))
|
|
(print "Known members: "
|
|
(length nicks))
|
|
(let* ((bi (members-base-info mb))
|
|
(invalid-mrs (ldict-ref bi 'invalid))
|
|
(active-mrs (ldict-ref bi 'active))
|
|
(suspended-mrs (ldict-ref bi 'suspended))
|
|
(destroyed-mrs (ldict-ref bi 'destroyed))
|
|
(student-mrs (ldict-ref bi 'students)))
|
|
(print a:success " Active (" (length active-mrs) "): " a:default
|
|
(member-records->string (sort active-mrs member<?) "~N~E"))
|
|
(print a:warning " Suspended (" (length suspended-mrs) "): " a:default
|
|
(member-records->string (sort suspended-mrs member<?) "~N~E"))
|
|
(print a:warning " Destroyed (" (length destroyed-mrs) "): " a:default
|
|
(member-records->string (sort destroyed-mrs member<?) "~N~E"))
|
|
(print a:highlight " Students (" (length student-mrs) "): " a:default
|
|
(member-records->string (sort student-mrs member<?)))
|
|
(let ((suspended2 (filter
|
|
(lambda (mr)
|
|
(>= (member-suspended-months mr) 24))
|
|
suspended-mrs)))
|
|
(when (not (null? suspended2))
|
|
(print (ansi #:magenta) " Suspended for at least 24 months ("
|
|
(length suspended2) "): " a:default
|
|
(member-records->string (sort suspended2 member<?) "~N (~S)"))))
|
|
(when (not (null? invalid-mrs))
|
|
(print a:error " Invalid Id (" (length invalid-mrs) "): "
|
|
(member-records->string (sort invalid-mrs member<?) "~N (~I)")
|
|
a:default)))))
|
|
|
|
;; Helper function for pretty-formatting the filtered members lists
|
|
;; in a table.
|
|
(define (members-table-row a:? label mrs fmt)
|
|
(list (string-append "\t" a:? label)
|
|
(length mrs)
|
|
(ansi-paragraph-format
|
|
(member-records->string
|
|
(sort mrs member<?)
|
|
fmt)
|
|
60)))
|
|
|
|
;; Prints nicely aligned members base info
|
|
(define (print-members-base-table mb)
|
|
(let* ((bi (members-base-info mb))
|
|
(all-mrs (ldict-ref bi 'total))
|
|
(invalid-mrs (ldict-ref bi 'invalid))
|
|
(active-mrs (ldict-ref bi 'active))
|
|
(suspended-mrs (ldict-ref bi 'suspended))
|
|
(destroyed-mrs (ldict-ref bi 'destroyed))
|
|
(student-mrs (ldict-ref bi 'students)))
|
|
(print "Known members: " (length all-mrs))
|
|
(newline)
|
|
(print
|
|
(table->string
|
|
(filter
|
|
identity
|
|
(list (list "Type" "Count" "List")
|
|
(members-table-row a:success "Active:" active-mrs "~N~E")
|
|
(members-table-row a:highlight "Students:" student-mrs "~N~E")
|
|
(members-table-row a:warning "Suspended:" suspended-mrs "~N~E")
|
|
(members-table-row a:warning "Destroyed:" destroyed-mrs "~N~E")
|
|
(let ((suspended2 (filter
|
|
(lambda (mr)
|
|
(>= (member-suspended-months mr)
|
|
(*member-suspend-max-months*)))
|
|
suspended-mrs)))
|
|
(if (null? suspended2)
|
|
#f
|
|
(members-table-row (ansi #:magenta) "Suspended (long):" suspended2 "~N (~S)")))
|
|
))
|
|
#:ansi #t
|
|
#:row-border #t
|
|
#:col-border #t
|
|
)))
|
|
(let ((pmrs (filter-members-by-predicate mb member-has-problems?)))
|
|
(when (not (null? pmrs))
|
|
(newline)
|
|
(print "Member files with errors (" (length pmrs) "): "
|
|
(string-intersperse
|
|
(map brmember-file-path pmrs)
|
|
", "))))
|
|
(let ((pmrs (filter-members-by-predicate mb (lambda (mr)
|
|
(and (member-has-highlights? mr)
|
|
(not (member-has-problems? mr)))))))
|
|
(when (not (null? pmrs))
|
|
(newline)
|
|
(print "Member files with issues: "
|
|
(string-intersperse
|
|
(map brmember-file-path pmrs)
|
|
", ")))))
|
|
|
|
;; Prints the stats in format used by gnuplot.
|
|
(define (print-members-base-stats ms)
|
|
(let ((keys (car ms))
|
|
(data (cadr ms)))
|
|
(print "# " (string-intersperse (map symbol->string keys) " "))
|
|
(let loop ((rows data))
|
|
(when (not (null? rows))
|
|
(let* ((row (car rows))
|
|
(month (month->string (car row)))
|
|
(vals (cdr row)))
|
|
(print month " " (string-intersperse (map number->string vals) " "))
|
|
(loop (cdr rows)))))))
|
|
|
|
;; Prints statistics about allocated and unused valid/invalid IDs.
|
|
(define (print-members-ids-stats MB)
|
|
(print "Allocated IDs: "
|
|
(length (list-members-ids MB))
|
|
"/"
|
|
(length (gen-all-4digit-primes))
|
|
" ("
|
|
(length (get-free-members-ids MB))
|
|
" free)")
|
|
(let ((iids (filter (compose not is-4digit-prime?) (list-members-ids MB))))
|
|
(when (not (null? iids))
|
|
(print " Invalid: "
|
|
(length iids)
|
|
" ("
|
|
(string-intersperse
|
|
(map (lambda (id)
|
|
(let ((mr (find-member-by-id MB id)))
|
|
(brmember-format
|
|
"~I - ~N"
|
|
mr)))
|
|
iids)
|
|
", ")
|
|
")"))))
|
|
|
|
;; Prints summary table of all fees and credits for all members
|
|
(define (print-members-fees-table MB . ds)
|
|
(let ((destroyed? (if (null? ds)
|
|
#f
|
|
(car ds))))
|
|
(let* ((members ;; Pass 1
|
|
(map
|
|
(lambda (mr)
|
|
(let* ((balance (member-balance mr))
|
|
(fees (ldict-ref balance 'fees))
|
|
(credit (ldict-ref balance 'credit))
|
|
(payment (ldict-ref balance 'payment))
|
|
(total (- (+ credit payment) fees)))
|
|
(list (member-nick mr)
|
|
(if (member-suspended? mr)
|
|
'suspended
|
|
(if (member-student? mr)
|
|
'student
|
|
(if (member-destroyed? mr)
|
|
'destroyed
|
|
'active)))
|
|
fees
|
|
credit
|
|
payment
|
|
total
|
|
balance
|
|
)))
|
|
(sort
|
|
(if destroyed?
|
|
(members-base-members MB)
|
|
(filter (lambda (mr)
|
|
(not (member-destroyed? mr)))
|
|
(members-base-members MB)))
|
|
member<?)))
|
|
(balances (map (lambda (m)
|
|
(list-ref m 6))
|
|
members)))
|
|
(print
|
|
(table->string
|
|
(cons
|
|
(list (ansi-string #:bgblue #:brightyellow #:bold "Member")
|
|
(ansi-string #:bgblue #:brightyellow #:bold "Status")
|
|
(ansi-string #:bgblue #:brightyellow #:bold "Fees")
|
|
(ansi-string #:bgblue #:brightyellow #:bold "Credit")
|
|
(ansi-string #:bgblue #:brightyellow #:bold "Payments")
|
|
(ansi-string #:bgblue #:brightyellow #:bold "Balance"))
|
|
(append
|
|
(map ;; Pass 2
|
|
(lambda (member)
|
|
(let ((total (list-ref member 5)))
|
|
(list (list-ref member 0)
|
|
(list-ref member 1)
|
|
(sprintf "\t~A" (list-ref member 2))
|
|
(sprintf "\t~A" (list-ref member 3))
|
|
(sprintf "\t~A" (list-ref member 4))
|
|
(sprintf "\t~A~A~A"
|
|
(if (< total -500)
|
|
a:error
|
|
(if (< total 0)
|
|
a:warning
|
|
a:success))
|
|
(exact->inexact total)
|
|
a:default)
|
|
)))
|
|
members)
|
|
(let* ((fees (foldl + 0 (map (lambda (b) (ldict-ref b 'fees)) balances)))
|
|
(credit (foldl + 0 (map (lambda (b) (ldict-ref b 'credit)) balances)))
|
|
(payment (foldl + 0 (map (lambda (b) (ldict-ref b 'payment)) balances)))
|
|
(total (- (+ credit payment) fees)))
|
|
(list (list (ansi-string #:bold "Total")
|
|
""
|
|
(ansi-string "\t" #:bold (sprintf "~A" fees))
|
|
(ansi-string "\t" #:bold (sprintf "~A" credit))
|
|
(ansi-string "\t" #:bold (sprintf "~A" payment))
|
|
(ansi-string "\t" #:bold
|
|
(sprintf "~A~A"
|
|
(if (< total 0)
|
|
a:error
|
|
a:success)
|
|
total))
|
|
)))))
|
|
#:col-border #t #:row0-border #t #:ansi #t))
|
|
(print "Credit: "
|
|
(foldl + 0
|
|
(map (lambda (member)
|
|
(list-ref member 5))
|
|
members)))
|
|
(print "Advance: "
|
|
(foldl + 0
|
|
(map (lambda (member)
|
|
(max 0 (list-ref member 5)))
|
|
members)))
|
|
(print "Debt: "
|
|
(foldl + 0
|
|
(map (lambda (member)
|
|
(min 0 (list-ref member 5)))
|
|
members)))
|
|
(let* ((ns (foldl (lambda (acc member)
|
|
(cons (+ (car acc) (if (eq? 'student (cadr member)) 1 0))
|
|
(+ (cdr acc) (if (eq? 'active (cadr member)) 1 0))))
|
|
(cons 0 0)
|
|
members))
|
|
(students (car ns))
|
|
(full (cdr ns)))
|
|
(print "Expected income: "
|
|
(+ (* (lookup-member-fee 'normal) full)
|
|
(* (lookup-member-fee 'student) students))
|
|
" (" full " full members + " students " students)"))
|
|
)
|
|
))
|
|
|
|
;; Prints all transactions which the members base considers unpaired.
|
|
(define (print-unpaired-table mb)
|
|
(print
|
|
(table->string
|
|
(cons
|
|
(list "Id" "Date" "Amount" "" "VS" "Type" "Message" "Account" "Bank")
|
|
(map
|
|
(lambda (tr)
|
|
(list (bank-transaction-id tr)
|
|
(bank-transaction-date tr)
|
|
(sprintf "\t~A" (bank-transaction-amount tr))
|
|
(bank-transaction-currency tr)
|
|
(sprintf "\t~A" (bank-transaction-varsym tr))
|
|
(bank-transaction-type tr)
|
|
(bank-transaction-message tr)
|
|
(bank-transaction-account tr)
|
|
(bank-transaction-bank tr)
|
|
))
|
|
(members-base-unpaired mb)))
|
|
#:row0-border #t
|
|
#:col-border #t)))
|
|
|
|
)
|