;; ;; mbase.scm ;; ;; Storage for member files. ;; ;; ISC License ;; ;; Copyright 2023 Brmlab, z.s. ;; Dominik Pantůček ;; ;; 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 ( load-mbase mbase-members 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 members-base-info members-base-stats members-base-update members-base-add-unpaired members-base-unpaired members-base-active-emails members-base-merge-mailman ) (import scheme (chicken base) (chicken string) (chicken random) (chicken sort) testing util-list util-dict-list primes brmember ansi period month configuration progress members-dir) ;; 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 `((members . ,(with-progress% progress? "members" (let* ((fss (load-members-dir dn)) (tot (sub1 (length (ldict-keys fss)))) (mb0 (ldict-map (lambda (symfn symlinks prg) (progress%-advance (/ prg tot)) (members-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 mr acc)) mb1))) mb))))))) ;; Returns the internal members list (define (mbase-members mb) (ldict-ref mb 'members)) ;; Gets member based by generic predicate (define (find-member-by-predicate mb pred) (let loop ((mdb (mbase-members 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? (ldict-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=? (ldict-ref (ldict-ref mr 'info) 'nick) nick)))) ;; Returns a list of members which match given predicate. (define (find-members-by-predicate mb pred) (let loop ((mb (mbase-members mb)) (res '())) (if (null? mb) res (let ((mr (car mb))) (loop (cdr mb) (if (pred mr) (cons mr res) res)))))) ;; 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) (map (lambda (mr) (ldict-ref mr 'id)) (mbase-members mb))) ;; Returns all nicks found in the database (define (list-mbase-nicks mb) (map brmember-nick (mbase-members mb))) ;; 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 dictionary with statistics about the members base. (define (members-base-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))) di7)) (define (members-base-oldest-month mb) (make-month 2015 1)) ;; 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 (members-base-oldest-month mb))) (if (month