358 lines
9 KiB
Scheme
358 lines
9 KiB
Scheme
;;
|
|
;; mbase.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 mbase))
|
|
|
|
(module
|
|
mbase
|
|
(
|
|
TAG-MBASE
|
|
|
|
load-mbase
|
|
|
|
mbase?
|
|
|
|
find-member-by-predicate
|
|
find-member-by-id
|
|
find-member-by-nick
|
|
|
|
find-members-by-predicate
|
|
find-members-by-nick
|
|
|
|
list-mbase-ids
|
|
list-mbase-nicks
|
|
|
|
mbase-free-ids
|
|
mbase-gen-id
|
|
|
|
mbase-update-by-id
|
|
mbase-update
|
|
|
|
mbase-stats
|
|
|
|
mbase-add-unpaired
|
|
mbase-unpaired
|
|
|
|
mbase-active-emails
|
|
|
|
mbase-merge-mailman
|
|
mbase-merge-dokuwiki
|
|
|
|
do-with-mbase-progress%
|
|
with-mbase-progress%
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken string)
|
|
(chicken random)
|
|
(chicken sort)
|
|
util-list
|
|
testing
|
|
util-dict-list
|
|
primes
|
|
brmember
|
|
ansi
|
|
cal-period
|
|
cal-month
|
|
configuration
|
|
progress
|
|
mbase-dir
|
|
util-tag
|
|
racket-kwargs
|
|
util-bst-dict)
|
|
|
|
;; Constant unique tag
|
|
(define TAG-MBASE (make-tag mbase))
|
|
|
|
;; 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-mbase dn . opts)
|
|
(let ((progress? (and (not (null? opts))
|
|
(car opts))))
|
|
(make-ldict
|
|
`((TAG . ,TAG-MBASE)
|
|
(members
|
|
.
|
|
,(with-progress%
|
|
progress? "members"
|
|
(let* ((fss (load-mbase-dir dn))
|
|
(tot (sub1 (length (ldict-keys fss))))
|
|
(mb0 (ldict-map
|
|
(lambda (symfn symlinks prg)
|
|
(progress%-advance (/ prg tot))
|
|
(mbase-dir-load-member dn
|
|
symfn
|
|
symlinks))
|
|
fss))
|
|
(mb1 (ldict-reduce (make-ldict)
|
|
(lambda (acc symfn mr)
|
|
(ldict-set acc (ldict-ref mr 'id) mr))
|
|
mb0))
|
|
(mb (ldict-reduce '()
|
|
(lambda (acc id mr)
|
|
(cons (cons id mr) acc))
|
|
mb1)))
|
|
(list->bdict (sort mb (lambda (a b) (< (car a) (car b))))))))))))
|
|
|
|
;; Predicate
|
|
(define (mbase? v)
|
|
(and (ldict? v)
|
|
(eq? (ldict-ref v 'TAG #f) TAG-MBASE)))
|
|
|
|
;; Returns the internal members BST
|
|
(define (mbase-members mb)
|
|
(ldict-ref mb 'members))
|
|
|
|
;; Gets member based by generic predicate
|
|
(define (find-member-by-predicate mb pred?)
|
|
(bdict-find-value
|
|
(mbase-members mb)
|
|
(lambda (k v)
|
|
(pred? v))))
|
|
|
|
;; Returns member record found by id, accepts numeric id or #f
|
|
(define (find-member-by-id mb id)
|
|
(if id
|
|
(bdict-ref (mbase-members mb) id #f)
|
|
#f))
|
|
|
|
;; Returns member record found by id
|
|
(define (find-member-by-nick mb nick)
|
|
(find-member-by-predicate
|
|
mb
|
|
(lambda (mr)
|
|
(string-ci=?
|
|
(ldict-ref
|
|
(ldict-ref mr 'info)
|
|
'nick)
|
|
nick))))
|
|
|
|
;; Returns a list of members which match given predicate.
|
|
(define (find-members-by-predicate mb pred?)
|
|
(bdict-filter-values
|
|
(mbase-members mb)
|
|
(lambda (k v)
|
|
(pred? v))))
|
|
|
|
;; Returns a list of members whose nick contains pat
|
|
(define (find-members-by-nick mb pat)
|
|
(find-members-by-predicate
|
|
mb
|
|
(lambda (mr)
|
|
(substring-index pat (brmember-nick mr)))))
|
|
|
|
;; Returns all ids found in the database
|
|
(define (list-mbase-ids mb)
|
|
(bdict-keys (mbase-members mb)))
|
|
|
|
;; Returns all nicks found in the database
|
|
(define (list-mbase-nicks mb)
|
|
(bdict-map-list (mbase-members mb)
|
|
(lambda (id mr)
|
|
(brmember-nick mr))))
|
|
|
|
;; Returns all free ids
|
|
(define (mbase-free-ids mb)
|
|
(let ((ids (list-mbase-ids mb)))
|
|
(filter
|
|
(lambda (id)
|
|
(not (member id ids)))
|
|
(gen-all-4digit-primes))))
|
|
|
|
;; Generates random vector id.
|
|
(define (mbase-gen-id mb)
|
|
(let* ((fids (mbase-free-ids mb))
|
|
(vfids (list->vector fids)))
|
|
(vector-ref vfids (pseudo-random-integer (vector-length vfids)))))
|
|
|
|
;; Returns new members base with member specified by id processed by
|
|
;; proc.
|
|
(define (mbase-update-by-id mb id proc)
|
|
(ldict-set mb
|
|
'members
|
|
(bdict-update (mbase-members mb) id proc)))
|
|
|
|
;; Returns new members base with member records matching the
|
|
;; predicate processed by proc.
|
|
(define (mbase-update mb pred? proc)
|
|
(ldict-set mb
|
|
'members
|
|
(bdict-map-dict (mbase-members mb)
|
|
(lambda (id mr)
|
|
(if (pred? mr)
|
|
(proc mr)
|
|
mr)))))
|
|
|
|
;; Returns dictionary with statistics about the members base.
|
|
(define (mbase-info mb-arg)
|
|
(let* ((members (find-members-by-predicate mb-arg brmember-usable?))
|
|
(di0 (make-ldict))
|
|
(di1 (ldict-set di0 'invalid
|
|
(filter (compose not is-4digit-prime? brmember-id) members)))
|
|
(di2 (ldict-set di1 'active
|
|
(filter brmember-active? members)))
|
|
(di3 (ldict-set di2 'suspended
|
|
(filter brmember-suspended? members)))
|
|
(di4 (ldict-set di3 'students
|
|
(filter brmember-student? members)))
|
|
(di5 (ldict-set di4 'destroyed
|
|
(filter brmember-destroyed? members)))
|
|
(di6 (ldict-set di5 'month (*current-month*)))
|
|
(di7 (ldict-set di6 'total members))
|
|
(di8 (ldict-set di7 'problems
|
|
(find-members-by-predicate mb-arg brmember-has-problems?))))
|
|
di8))
|
|
|
|
(define (members-base-oldest-month mb)
|
|
(make-cal-month 2015 1))
|
|
|
|
;; Returns a list two lists: keys, data.
|
|
;; Each data record contains values for all keys.
|
|
(define (mbase-stats mb)
|
|
(let ((keys '(month total active suspended students destroyed invalid)))
|
|
(let mloop ((data '())
|
|
(month (members-base-oldest-month mb)))
|
|
(if (cal-month<=? month (*current-month*))
|
|
(let ((bi (with-current-month month
|
|
(mbase-info mb))))
|
|
(let kloop ((row (list (ldict-ref bi 'month)))
|
|
(keys (cdr keys)))
|
|
(if (null? keys)
|
|
(mloop (cons (reverse row) data)
|
|
(cal-month-add month 1))
|
|
(kloop (cons (length (ldict-ref bi (car keys))) row)
|
|
(cdr keys)))))
|
|
(list keys (reverse data))))))
|
|
|
|
;; Adds unpaired transaction to given members-base
|
|
(define (mbase-add-unpaired mb tr)
|
|
(ldict-set mb 'unpaired
|
|
(cons tr
|
|
(ldict-ref mb 'unpaired '()))))
|
|
|
|
;; Returns known unpaired transactions
|
|
(define (mbase-unpaired mb)
|
|
(ldict-ref mb 'unpaired '()))
|
|
|
|
;; Returns the list of emails of all active members sorted
|
|
;; alphabetically
|
|
(define* (mbase-active-emails mb
|
|
#:active (active #t)
|
|
#:suspended (suspended #f))
|
|
(sort
|
|
(filter
|
|
string?
|
|
(map
|
|
(lambda (mr)
|
|
(brmember-info mr 'mail))
|
|
(bdict-filter-values
|
|
(mbase-members mb)
|
|
(lambda (id mr)
|
|
(or (and active
|
|
(brmember-active? mr))
|
|
(and suspended
|
|
(brmember-suspended? mr)))))))
|
|
string-ci<?))
|
|
|
|
;; Merges given ML members into members base
|
|
(define (mbase-merge-mailman mb ml)
|
|
(let ((listname (car ml))
|
|
(emails (cdr ml)))
|
|
(foldl (lambda (mb email)
|
|
(mbase-update mb
|
|
(lambda (mr)
|
|
(equal? (brmember-info mr 'mail #f)
|
|
email))
|
|
(lambda (mr)
|
|
(brmember-add-mailman mr listname))))
|
|
mb
|
|
emails)))
|
|
|
|
;; Iteration with progress over all members
|
|
(define (do-with-mbase-progress% mb name proc)
|
|
(let* ((members-list (find-members-by-predicate mb brmember-existing?))
|
|
(mlen0 (length members-list))
|
|
(mlen (if (> mlen0 0)
|
|
mlen0
|
|
1)))
|
|
(with-progress%
|
|
#t name
|
|
(let loop ((mb members-list)
|
|
(i 0))
|
|
(if (not (null? mb))
|
|
(let ()
|
|
(progress%-advance (/ i mlen))
|
|
(proc (car mb))
|
|
(loop (cdr mb)
|
|
(add1 i))))
|
|
(progress%-advance 1)))))
|
|
|
|
;; Adds dokuwiki information to all users found, returns new mbase
|
|
;; and list of remaining users.
|
|
(define (mbase-merge-dokuwiki mb dw)
|
|
(if (null? dw)
|
|
(ldict-set
|
|
(mbase-update mb
|
|
(lambda (mr) #t)
|
|
(lambda (mr)
|
|
(brmember-set mr #:dokuwiki #t)))
|
|
'dokuwiki
|
|
'())
|
|
(let loop ((dw dw)
|
|
(mb mb)
|
|
(rem '()))
|
|
(if (null? dw)
|
|
(ldict-set mb 'dokuwiki rem)
|
|
(let* ((row (car dw))
|
|
(username (car row))
|
|
(mr (find-member-by-nick mb username))
|
|
(groups (list-ref row 3))
|
|
(email (list-ref row 2)))
|
|
(if mr
|
|
(let ((mid (brmember-id mr)))
|
|
(loop (cdr dw)
|
|
(mbase-update mb
|
|
(lambda (mr)
|
|
(eq? (brmember-id mr) mid))
|
|
(lambda (mr)
|
|
(let ((dws (ldict-ref mr 'dokuwiki (make-ldict))))
|
|
(brmember-set mr #:dokuwiki
|
|
(ldict-set
|
|
(ldict-set dws 'groups groups)
|
|
'email email)))))
|
|
rem))
|
|
(loop (cdr dw)
|
|
mb
|
|
(cons row rem))))))))
|
|
|
|
;; Simple syntax wrapper
|
|
(define-syntax with-mbase-progress%
|
|
(syntax-rules ()
|
|
((_ mb name mr body ...)
|
|
(do-with-mbase-progress% mb name (lambda (mr) body ...)))))
|
|
|
|
)
|