;;
;; 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
  members-base-tests!
  )

 (import scheme
	 (chicken base)
	 (chicken pathname)
	 (chicken file posix)
	 (chicken file)
	 (chicken format)
	 (chicken irregex)
	 testing
	 utils
	 dictionary
	 member-file)

 ;; 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)))
     (dict-set mr-sl 'info
	       (load-member-file
		(make-pathname mdir 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))))
     (when progress?
       (display "Loading members "))
     (let* ((fss (files-dictionary-filter-4digit-symbols
		  (files+symlinks->files-dictionary
		   (get-files+symlinks dn))))
	    (mb0 (dict-map
		 (lambda (symfn symlinks)
		   (when progress?
		     (display "."))
		   (members-base-load-member dn
					     (symbol->string symfn)
					     symlinks))
		 fss))
	    (mb (dict-reduce (make-dict)
			     (lambda (acc key val)
			       #f)
			     mb0)))
       (when progress?
	 (print " ok."))
       mb0)))

 (define (find-member-by-id mb id)
   #f)

 (define (find-member-by-nick mb nick)
   #f)

 (define (list-members-ids mb)
   #f)

 (define (list-members-nicks mb)
   #f)

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

 )