hackerbase/members-base.scm

;;
;; 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
  filter-members-by-predicate
  list-members-nicks
  members-base-info
  members-base-stats
  get-free-members-ids
  gen-member-id
  members-base-update
  )

 (import scheme
	 (chicken base)
	 (chicken string)
	 (chicken random)
	 testing
	 utils
	 dictionary
	 primes
	 member-record
	 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))))
     (with-progress%
      progress? "members"
      (let* ((fss (load-members-dir dn))
	     (tot (sub1 (length (dict-keys fss))))
	     (mb0 (dict-map
		   (lambda (symfn symlinks prg)
		     (progress%-advance (/ prg tot))
		     (members-dir-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))

 ;; Returns dictionary with statistics about the members base.
 (define (members-base-info mb-arg)
   (let* ((mb (filter-members-by-predicate mb-arg member-record-usable?))
	  (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))

 (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 (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))))))


 ;; 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)
   (map (lambda (mr)
	  (if (pred? mr)
	      (proc mr)
	      mr))
	mb))

 )