;;
;; 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-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)
	 srfi-1
	 testing
	 util-bst-ldict
	 primes
	 brmember
	 ansi
	 cal-period
	 cal-month
	 configuration
	 progress
	 mbase-dir
	 util-tag
	 racket-kwargs
	 util-bst-bdict)

 ;; 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 mb))))))))

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

 ;; 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)
			       #:pred? (pred? #f)
			       #:suspended (suspended #f))
   (sort
    (filter
     string?
     (map
      (lambda (mr)
	(brmember-info mr 'mail))
      (bdict-filter-values
       (mbase-members mb)
       (lambda (id mr)
	 (and (or (not pred?)
		  (pred? 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 ...)))))

 )