;;
;; 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
  list-members-nicks
  members-base-stats
  print-members-base-info
  print-members-base-stats
  get-free-members-ids
  print-members-ids-stats
  members-base-tests!
  )

 (import scheme
	 (chicken base)
	 (chicken pathname)
	 (chicken file posix)
	 (chicken file)
	 (chicken format)
	 (chicken irregex)
	 (chicken sort)
	 (chicken string)
	 (chicken format)
	 testing
	 utils
	 dictionary
	 member-file
	 primes
	 member-record
	 ansi
	 period
	 month
	 configuration
	 progress)
 
 ;; Gets all files and symbolic links from given directory. The
 ;; symbolic links are represented by cons cells with car being the
 ;; name and cdr the link target.
 (define (get-files+symlinks dn)
   (let loop ((fns (directory dn))
	      (rs '()))
     (if (null? fns)
	 rs
	 (let* ((fn (car fns))
		(ffn (make-pathname dn fn)))
	   (loop (cdr fns)
		 (if (symbolic-link? ffn)
		     (cons (cons (string->symbol fn)
				 (string->symbol (read-symbolic-link ffn)))
			   rs)
		     (if (regular-file? ffn)
			 (cons (string->symbol fn) rs)
			 rs)))))))

 ;; Converts a list of symlinks and files in aforementioned format
 ;; into a dictionary of regular files as keys with lists of symlinks
 ;; as values. If the target file does not exist, adds 'error-0 symbol
 ;; as the first alias to this list with the number increasing with
 ;; each nonexistent file encountered. The error record is also
 ;; generated for symlinks pointing outside of the directory.
 (define (files+symlinks->files-dictionary ls)
   (let* ((links (filter pair? ls))
	  (files (filter symbol? ls))
	  (fdict
	   (let loop ((files files)
		      (res (make-dict)))
	     (if (null? files)
		 res
		 (loop (cdr files)
		       (dict-set res (car files) '()))))))
     (let loop ((links links)
		(res fdict)
		(errs 0))
       (if (null? links)
	   res
	   (let* ((link (car links))
		  (name (car link))
		  (target (cdr link)))
	     (if (dict-has-key? res target)
		 (loop (cdr links)
		       (dict-set res target (cons name (dict-ref res target)))
		       errs)
		 (loop (cdr links)
		       (dict-set res target
				 (list (string->symbol (sprintf "error-~A" errs))
				       name))
		       (+ errs 1))))))))

 ;; Checks whether given string is a 4-digit decimal number.
 (define (is-4digit-string? s)
   (if (irregex-search (irregex "^[0-9]{4}$") s)
       #t
       #f))

 ;; checks whether given symbol is a 4-digit one.
 (define (is-4digit-symbol? s)
   (is-4digit-string?
    (symbol->string s)))

 ;; Returns true if the list contains at least one 4-digit symbol.
 (define (list-contains-4digit-symbol? lst)
   (let loop ((lst lst))
     (if (null? lst)
	 #f
	 (if (is-4digit-symbol? (car lst))
	     #t
	     (loop (cdr lst))))))

 ;; Returns the first 4-digit symbol from the list.
 (define (get-4digit-symbol-from-list lst)
   (let loop ((lst lst))
     (if (null? lst)
	 #f
	 (if (is-4digit-symbol? (car lst))
	     (car lst)
	     (loop (cdr lst))))))

 ;; Returns dictionary containing only records with either 4-digit
 ;; name or one of its aliases being 4-digit.
 (define (files-dictionary-filter-4digit-symbols d)
   (dict-filter
    (lambda (k v)
      (list-contains-4digit-symbol? (cons k v)))
    d))

 ;; Returns a dictionary containing file-name, symlinks, id and info
 ;; keys. The info key contains whatever load-member-file from the
 ;; member-file module returns. The id key contains whatever is the
 ;; first 4-digit symbol in (cons fname aliases) list.
 (define (members-base-load-member mdir fname symlinks)
   (let* ((mr0 (make-dict))
	  (mr-fn (dict-set mr0 'file-name fname))
	  (mr-sl (dict-set mr-fn 'symlinks symlinks))
	  (mr-id (dict-set mr-sl 'id
			   (string->number
			    (symbol->string
			     (get-4digit-symbol-from-list (cons fname symlinks)))))))
     (dict-set mr-id 'info
	       (load-member-file
		(make-pathname mdir (symbol->string fname))))))

 ;; 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? "Loading-members " " ok."
      (let* ((fss (files-dictionary-filter-4digit-symbols
		   (files+symlinks->files-dictionary
		    (get-files+symlinks dn))))
	     (mb0 (dict-map
		   (lambda (symfn symlinks)
		     (when progress?
		       (progress-advance "."))
		     (members-base-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)
      (equal?
       (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))

 ;; Converts member records to string, optional arguments are format
 ;; and separator. Format defaults to "~N" and separator to ", ".
 (define (member-records->string mrs . args)
   (let ((fmt (if (null? args) "~N" (car args)))
	 (sep (if (or (null? args)
		      (null? (cdr args)))
		  ", "
		  (cadr args))))
     (string-intersperse
      (map (lambda (mr)
	     (member-format fmt mr))
	   mrs)
      sep)))

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

 ;; 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 (*member-default-joined*)))
       (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))))))

 ;; Basic information about members-base in human-readable form.
 (define (print-members-base-info mb)
  (let ((nicks (list-members-nicks mb))
	(ids (list-members-ids mb)))
    (print "Known members: "
	   (length nicks))
    (let* ((bi (members-base-info mb))
	   (invalid-mrs (dict-ref bi 'invalid))
	   (active-mrs (dict-ref bi 'active))
	   (suspended-mrs (dict-ref bi 'suspended))
	   (destroyed-mrs (dict-ref bi 'destroyed))
	   (student-mrs (dict-ref bi 'students)))
      (print a:success "  Active (" (length active-mrs) "): " a:default
	     (member-records->string (sort active-mrs member<?) "~N~E"))
      (print a:warning "  Suspended (" (length suspended-mrs) "): " a:default
	     (member-records->string (sort suspended-mrs member<?) "~N~E"))
      (print a:warning "  Destroyed (" (length destroyed-mrs) "): " a:default
	     (member-records->string (sort destroyed-mrs member<?) "~N~E"))
      (print a:highlight "  Students (" (length student-mrs) "): " a:default
	     (member-records->string (sort student-mrs member<?)))
      (let ((suspended2 (filter-members-by-predicate
			 suspended-mrs
			 (lambda (mr)
			   (>= (member-suspended-months mr) 24)))))
	(when (not (null? suspended2))
	  (print "  Suspended for at least 24 months: "
		 (member-records->string (sort suspended2 member<?) "~N (~S)"))))
      (when (not (null? invalid-mrs))
	(print a:error "  Invalid Id (" (length invalid-mrs) "): "
	       (member-records->string (sort invalid-mrs member<?) "~N (~I)")
	       a:default)))))

 ;; Prints the stats in format used by gnuplot.
 (define (print-members-base-stats ms)
   (let ((keys (car ms))
	 (data (cadr ms)))
     (print "# " (string-intersperse (map symbol->string keys) " "))
     (let loop ((rows data))
       (when (not (null? rows))
	 (let* ((row (car rows))
		(month (month->string (car row)))
		(vals (cdr row)))
	   (print month " " (string-intersperse (map number->string vals) " "))
	   (loop (cdr rows)))))))

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

 ;; Prints statistics about allocated and unused valid/invalid IDs.
 (define (print-members-ids-stats MB)
   (print "Allocated IDs: "
	  (length (list-members-ids MB))
	  "/"
	  (length (gen-all-4digit-primes))
	  " ("
	  (length (get-free-members-ids MB))
	  " free)")
   (let ((iids (filter (compose not is-4digit-prime?) (list-members-ids MB))))
     (when (not (null? iids))
       (print "      Invalid: "
	      (length iids)
	      " ("
	      (string-intersperse (map number->string iids) ", ")
	      ")"))))

 ;; Performs self-tests of this module.
 (define (members-base-tests!)
   (run-tests
    members-base
    (test-equal? files+symlinks->files-dictionary
		 (files+symlinks->files-dictionary
		  '(joe (2803 . joe)))
		 '((joe 2803)))
    (test-equal? files+symlinks->files-dictionary
		 (files+symlinks->files-dictionary
		  '(joe
		    (2803 . joe)
		    (666 . nonexistent)))
		 '((nonexistent error-0 666)
		   (joe 2803)))
    (test-true is-4digit-string? (is-4digit-string? "0000"))
    (test-false is-4digit-string? (is-4digit-string? "AAAA"))
    (test-false is-4digit-string? (is-4digit-string? "666"))
    (test-true is-4digit-symbol? (is-4digit-symbol? '|0000|))
    (test-false is-4digit-symbol? (is-4digit-symbol? '|ABC|))
    (test-true list-contains-4digit-symbol? (list-contains-4digit-symbol? '(|0000| abc |666|)))
    (test-false list-contains-4digit-symbol? (list-contains-4digit-symbol? '(|00000| abc |666|)))
    (test-eq? get-4digit-symbol-from-list
	      (get-4digit-symbol-from-list '(|000| abc |6666| qwer))
	      '|6666|)
    ))

 )