419 lines
13 KiB
Scheme
419 lines
13 KiB
Scheme
;;
|
|
;; members-base.scm
|
|
;;
|
|
;; Storage for member files.
|
|
;;
|
|
;; 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-base))
|
|
|
|
(module
|
|
members-base
|
|
(
|
|
load-members
|
|
find-member-by-id
|
|
find-member-by-nick
|
|
list-members-ids
|
|
list-members-nicks
|
|
members-base-stats
|
|
print-members-base-info
|
|
print-members-base-table
|
|
print-members-base-stats
|
|
get-free-members-ids
|
|
print-members-ids-stats
|
|
gen-member-id
|
|
members-base-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken pathname)
|
|
(chicken file posix)
|
|
(chicken file)
|
|
(chicken format)
|
|
(chicken irregex)
|
|
(chicken sort)
|
|
(chicken string)
|
|
(chicken format)
|
|
(chicken random)
|
|
testing
|
|
utils
|
|
dictionary
|
|
member-file
|
|
primes
|
|
member-record
|
|
ansi
|
|
period
|
|
month
|
|
configuration
|
|
progress
|
|
table)
|
|
|
|
;; Gets all files and symbolic links from given directory. The
|
|
;; symbolic links are represented by cons cells with car being the
|
|
;; name and cdr the link target.
|
|
(define (get-files+symlinks dn)
|
|
(let loop ((fns (directory dn))
|
|
(rs '()))
|
|
(if (null? fns)
|
|
rs
|
|
(let* ((fn (car fns))
|
|
(ffn (make-pathname dn fn)))
|
|
(loop (cdr fns)
|
|
(if (symbolic-link? ffn)
|
|
(cons (cons (string->symbol fn)
|
|
(string->symbol (read-symbolic-link ffn)))
|
|
rs)
|
|
(if (regular-file? ffn)
|
|
(cons (string->symbol fn) rs)
|
|
rs)))))))
|
|
|
|
;; Converts a list of symlinks and files in aforementioned format
|
|
;; into a dictionary of regular files as keys with lists of symlinks
|
|
;; as values. If the target file does not exist, adds 'error-0 symbol
|
|
;; as the first alias to this list with the number increasing with
|
|
;; each nonexistent file encountered. The error record is also
|
|
;; generated for symlinks pointing outside of the directory.
|
|
(define (files+symlinks->files-dictionary ls)
|
|
(let* ((links (filter pair? ls))
|
|
(files (filter symbol? ls))
|
|
(fdict
|
|
(let loop ((files files)
|
|
(res (make-dict)))
|
|
(if (null? files)
|
|
res
|
|
(loop (cdr files)
|
|
(dict-set res (car files) '()))))))
|
|
(let loop ((links links)
|
|
(res fdict)
|
|
(errs 0))
|
|
(if (null? links)
|
|
res
|
|
(let* ((link (car links))
|
|
(name (car link))
|
|
(target (cdr link)))
|
|
(if (dict-has-key? res target)
|
|
(loop (cdr links)
|
|
(dict-set res target (cons name (dict-ref res target)))
|
|
errs)
|
|
(loop (cdr links)
|
|
(dict-set res target
|
|
(list (string->symbol (sprintf "error-~A" errs))
|
|
name))
|
|
(+ errs 1))))))))
|
|
|
|
;; Checks whether given string is a 4-digit decimal number.
|
|
(define (is-4digit-string? s)
|
|
(if (irregex-search (irregex "^[0-9]{4}$") s)
|
|
#t
|
|
#f))
|
|
|
|
;; checks whether given symbol is a 4-digit one.
|
|
(define (is-4digit-symbol? s)
|
|
(is-4digit-string?
|
|
(symbol->string s)))
|
|
|
|
;; Returns true if the list contains at least one 4-digit symbol.
|
|
(define (list-contains-4digit-symbol? lst)
|
|
(let loop ((lst lst))
|
|
(if (null? lst)
|
|
#f
|
|
(if (is-4digit-symbol? (car lst))
|
|
#t
|
|
(loop (cdr lst))))))
|
|
|
|
;; Returns the first 4-digit symbol from the list.
|
|
(define (get-4digit-symbol-from-list lst)
|
|
(let loop ((lst lst))
|
|
(if (null? lst)
|
|
#f
|
|
(if (is-4digit-symbol? (car lst))
|
|
(car lst)
|
|
(loop (cdr lst))))))
|
|
|
|
;; Returns dictionary containing only records with either 4-digit
|
|
;; name or one of its aliases being 4-digit.
|
|
(define (files-dictionary-filter-4digit-symbols d)
|
|
(dict-filter
|
|
(lambda (k v)
|
|
(list-contains-4digit-symbol? (cons k v)))
|
|
d))
|
|
|
|
;; Returns a dictionary containing file-name, symlinks, id and info
|
|
;; keys. The info key contains whatever load-member-file from the
|
|
;; member-file module returns. The id key contains whatever is the
|
|
;; first 4-digit symbol in (cons fname aliases) list.
|
|
(define (members-base-load-member mdir fname symlinks)
|
|
(let* ((mr0 (make-dict))
|
|
(mr-fn (dict-set mr0 'file-name fname))
|
|
(mr-sl (dict-set mr-fn 'symlinks symlinks))
|
|
(mr-id (dict-set mr-sl 'id
|
|
(string->number
|
|
(symbol->string
|
|
(get-4digit-symbol-from-list (cons fname symlinks)))))))
|
|
(dict-set mr-id 'info
|
|
(load-member-file
|
|
(make-pathname mdir (symbol->string fname))))))
|
|
|
|
;; Loads members database, if the second argument is true, shows
|
|
;; progress. Members database is a dictionary with id being the key
|
|
;; (number) and member record being the value.
|
|
(define (load-members dn . opts)
|
|
(let ((progress? (and (not (null? opts))
|
|
(car opts))))
|
|
(with-progress
|
|
progress? "Loading-members " " ok."
|
|
(let* ((fss (files-dictionary-filter-4digit-symbols
|
|
(files+symlinks->files-dictionary
|
|
(get-files+symlinks dn))))
|
|
(mb0 (dict-map
|
|
(lambda (symfn symlinks)
|
|
(when progress?
|
|
(progress-advance "."))
|
|
(members-base-load-member dn
|
|
symfn
|
|
symlinks))
|
|
fss))
|
|
(mb1 (dict-reduce (make-dict)
|
|
(lambda (acc symfn mr)
|
|
(dict-set acc (dict-ref mr 'id) mr))
|
|
mb0))
|
|
(mb (dict-reduce '()
|
|
(lambda (acc id mr)
|
|
(cons mr acc))
|
|
mb1)))
|
|
mb))))
|
|
|
|
;; Gets member based by generic predicate
|
|
(define (find-member-by-predicate mb pred)
|
|
(let loop ((mdb mb))
|
|
(if (null? mdb)
|
|
#f
|
|
(let ((mr (car mdb)))
|
|
(if (pred mr)
|
|
mr
|
|
(loop (cdr mdb)))))))
|
|
|
|
;; Returns member record found by id
|
|
(define (find-member-by-id mb id)
|
|
(find-member-by-predicate
|
|
mb
|
|
(lambda (mr)
|
|
(eq? (dict-ref mr 'id) id))))
|
|
|
|
;; Returns member record found by id
|
|
(define (find-member-by-nick mb nick)
|
|
(find-member-by-predicate
|
|
mb
|
|
(lambda (mr)
|
|
(string-ci=?
|
|
(dict-ref
|
|
(dict-ref mr 'info)
|
|
'nick)
|
|
nick))))
|
|
|
|
;; Returns all ids found in the database
|
|
(define (list-members-ids mb)
|
|
(map (lambda (mr) (dict-ref mr 'id)) mb))
|
|
|
|
;; Returns a list of members which match given predicate.
|
|
(define (filter-members-by-predicate mb pred)
|
|
(let loop ((mb mb)
|
|
(res '()))
|
|
(if (null? mb)
|
|
res
|
|
(let ((mr (car mb)))
|
|
(loop (cdr mb)
|
|
(if (pred mr)
|
|
(cons mr res)
|
|
res))))))
|
|
|
|
;; Returns all nicks found in the database
|
|
(define (list-members-nicks mb)
|
|
(map (lambda (mr) (dict-ref (dict-ref mr 'info) 'nick)) mb))
|
|
|
|
;; 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)
|
|
(member-format fmt mr))
|
|
mrs)
|
|
sep)))
|
|
|
|
;; Returns dictionary with statistics about the members base.
|
|
(define (members-base-info mb-arg)
|
|
(let* ((mb (filter-members-by-predicate mb-arg member-existing?))
|
|
(di0 (make-dict))
|
|
(di1 (dict-set di0 'invalid
|
|
(filter-members-by-predicate mb
|
|
(compose not is-4digit-prime? member-id))))
|
|
(di2 (dict-set di1 'active
|
|
(filter-members-by-predicate mb member-active?)))
|
|
(di3 (dict-set di2 'suspended
|
|
(filter-members-by-predicate mb member-suspended?)))
|
|
(di4 (dict-set di3 'students
|
|
(filter-members-by-predicate mb member-student?)))
|
|
(di5 (dict-set di4 'destroyed
|
|
(filter-members-by-predicate mb member-destroyed?)))
|
|
(di6 (dict-set di5 'month (*current-month*)))
|
|
(di7 (dict-set di6 'total mb)))
|
|
di7))
|
|
|
|
;; Returns a list two lists: keys, data.
|
|
;; Each data record contains values for all keys.
|
|
(define (members-base-stats mb)
|
|
(let ((keys '(month total active suspended students destroyed invalid)))
|
|
(let mloop ((data '())
|
|
(month (*member-default-joined*)))
|
|
(if (month<? month (*current-month*))
|
|
(let ((bi (parameterize ((*current-month* month))
|
|
(members-base-info mb))))
|
|
(let kloop ((row (list (dict-ref bi 'month)))
|
|
(keys (cdr keys)))
|
|
(if (null? keys)
|
|
(mloop (cons (reverse row) data)
|
|
(month-add month 1))
|
|
(kloop (cons (length (dict-ref bi (car keys))) row)
|
|
(cdr keys)))))
|
|
(list keys (reverse data))))))
|
|
|
|
;; 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 (dict-ref bi 'invalid))
|
|
(active-mrs (dict-ref bi 'active))
|
|
(suspended-mrs (dict-ref bi 'suspended))
|
|
(destroyed-mrs (dict-ref bi 'destroyed))
|
|
(student-mrs (dict-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-members-by-predicate
|
|
suspended-mrs
|
|
(lambda (mr)
|
|
(>= (member-suspended-months mr) 24)))))
|
|
(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)))))
|
|
|
|
;; Prints nicely aligned members base info
|
|
(define (print-members-base-table mb)
|
|
(print "TEST"))
|
|
|
|
;; 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)))))))
|
|
|
|
;; Returns all free ids
|
|
(define (get-free-members-ids mb)
|
|
(let ((ids (list-members-ids mb)))
|
|
(filter
|
|
(lambda (id)
|
|
(not (member id ids)))
|
|
(gen-all-4digit-primes))))
|
|
|
|
;; 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)))
|
|
(member-format
|
|
"~I - ~N"
|
|
mr)))
|
|
iids)
|
|
", ")
|
|
")"))))
|
|
|
|
;; Generates random vector id.
|
|
(define (gen-member-id mb)
|
|
(let* ((fids (get-free-members-ids mb))
|
|
(vfids (list->vector fids)))
|
|
(vector-ref vfids (pseudo-random-integer (vector-length vfids)))))
|
|
|
|
;; Performs self-tests of this module.
|
|
(define (members-base-tests!)
|
|
(run-tests
|
|
members-base
|
|
(test-equal? files+symlinks->files-dictionary
|
|
(files+symlinks->files-dictionary
|
|
'(joe (2803 . joe)))
|
|
'((joe 2803)))
|
|
(test-equal? files+symlinks->files-dictionary
|
|
(files+symlinks->files-dictionary
|
|
'(joe
|
|
(2803 . joe)
|
|
(666 . nonexistent)))
|
|
'((nonexistent error-0 666)
|
|
(joe 2803)))
|
|
(test-true is-4digit-string? (is-4digit-string? "0000"))
|
|
(test-false is-4digit-string? (is-4digit-string? "AAAA"))
|
|
(test-false is-4digit-string? (is-4digit-string? "666"))
|
|
(test-true is-4digit-symbol? (is-4digit-symbol? '|0000|))
|
|
(test-false is-4digit-symbol? (is-4digit-symbol? '|ABC|))
|
|
(test-true list-contains-4digit-symbol? (list-contains-4digit-symbol? '(|0000| abc |666|)))
|
|
(test-false list-contains-4digit-symbol? (list-contains-4digit-symbol? '(|00000| abc |666|)))
|
|
(test-eq? get-4digit-symbol-from-list
|
|
(get-4digit-symbol-from-list '(|000| abc |6666| qwer))
|
|
'|6666|)
|
|
))
|
|
|
|
)
|