Rename mbase file, module and dependencies.

src/mbase.scm

@@ -0,0 +1,261 @@
+;;
+;; 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
+ (
+  load-members
+  members-base-members
+  find-member-by-id
+  find-member-by-nick
+  find-members-by-nick
+  list-members-ids
+  filter-members-by-predicate
+  list-members-nicks
+  members-base-info
+  members-base-stats
+  get-free-members-ids
+  gen-member-id
+  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-members 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 (members-base-members mb)
+   (ldict-ref mb 'members))
+
+ ;; Gets member based by generic predicate
+ (define (find-member-by-predicate mb pred)
+   (let loop ((mdb (members-base-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 whose nick contains pat
+ (define (find-members-by-nick mb pat)
+   (filter-members-by-predicate
+    mb
+    (lambda (mr)
+      (substring-index pat (brmember-nick mr)))))
+
+ ;; Returns all ids found in the database
+ (define (list-members-ids mb)
+   (map (lambda (mr) (ldict-ref mr 'id))
+	(members-base-members mb)))
+
+ ;; Returns a list of members which match given predicate.
+ (define (filter-members-by-predicate mb pred)
+   (let loop ((mb (members-base-members 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) (ldict-ref (ldict-ref mr 'info) 'nick))
+	(members-base-members mb)))
+
+ ;; Returns dictionary with statistics about the members base.
+ (define (members-base-info mb-arg)
+   (let* ((members (filter-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<? month (*current-month*))
+	   (let ((bi (parameterize ((*current-month* month))
+		       (members-base-info mb))))
+	     (let kloop ((row (list (ldict-ref bi 'month)))
+			 (keys (cdr keys)))
+	       (if (null? keys)
+		   (mloop (cons (reverse row) data)
+			  (month-add month 1))
+		   (kloop (cons (length (ldict-ref bi (car keys))) row)
+			  (cdr keys)))))
+	   (list keys (reverse data))))))
+
+
+ ;; 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))))
+
+ ;; 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)))))
+
+ ;; Returns new members base with member records matching the
+ ;; predicate processed by proc.
+ (define (members-base-update mb pred? proc)
+   (ldict-set mb
+	     'members
+	     (map (lambda (mr)
+		    (if (pred? mr)
+			(proc mr)
+			mr))
+		  (members-base-members mb))))
+
+ ;; Adds unpaired transaction to given members-base
+ (define (members-base-add-unpaired mb tr)
+   (ldict-set mb 'unpaired
+	     (cons tr
+		   (ldict-ref mb 'unpaired '()))))
+
+ ;; Returns known unpaired transactions
+ (define (members-base-unpaired mb)
+   (ldict-ref mb 'unpaired '()))
+
+ ;; Returns the list of emails of all active members sorted
+ ;; alphabetically
+ (define (members-base-active-emails mb)
+   (sort
+    (filter
+     string?
+     (map
+      (lambda (mr)
+	(brmember-info mr 'mail))
+      (filter brmember-active?
+	      (members-base-members mb))))
+    string-ci<?))
+
+ ;; Merges given ML members into members base
+ (define (members-base-merge-mailman mb ml)
+   (let ((listname (car ml))
+	 (emails (cdr ml)))
+     (foldl (lambda (mb email)
+	      (members-base-update mb
+				   (lambda (mr)
+				     (equal? (brmember-info mr 'mail #f)
+					     email))
+				   (lambda (mr)
+				     (brmember-add-mailman mr listname))))
+	    mb
+	    emails)))
+
+ )