;;
;; brmember.scm
;;
;; Procedures working with complete member record (as loaded by the
;; members-base).
;;
;; 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 brmember))

(module
 brmember
 (
  TAG-BRMEMBER

  make-brmember

  brmember?

  brmember-file-name
  brmember-file-path
  brmember-input-file

  brmember-set
  brmember-add-highlight
  brmember-sub-ref
  brmember-sub-set
  brmember-sub-prepend
  brmember-sub-has-key?
  brmember-sub-ensure

  brmember-source
  brmember-info
  brmember-missing-keys
  brmember-has-highlights?
  brmember-usable?
  brmember-in-dokuwiki?
  brmember-dokuwiki-groups-ok?
  brmember-has-problems?
  brmember-file-has-problems?

  brmember-destroyed?
  brmember-suspended?
  brmember-active?
  brmember-student?
  brmember-existing?

  brmember-chair?
  brmember-council?
  brmember-revision?
  brmember-grant?
  
  brmember-flags

  brmember-nick
  brmember-id
  brmember-suspended-months
  brmember-suspended-for

  brmember<?

  brmember-add-payment
  brmember-payments

  brmember-credit

  brmember-mailman
  brmember-add-mailman

  brmember-spec-fee

  brmember-age

  brmember-tests!
  )

 (import scheme
	 (chicken base)
	 (chicken keyword)
	 (chicken irregex)
	 (chicken string)
	 (chicken format)
	 srfi-1
	 util-bst-ldict
	 testing
	 cal-month
	 cal-period
	 configuration
	 primes
	 bank-account
	 util-tag)

 ;; Unique tag
 (define TAG-BRMEMBER (make-tag brmember))

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

 ;; Creates new member record based on the file and symlinks
 ;; information received from the members directory. Any keyword
 ;; arguments are converted to respective symbols in the dictionary.
 (define (make-brmember file-name file-path symlinks . args)
   (let loop ((args args)
	      (pairs `((file-name . ,file-name)
		       (file-path . ,file-path)
		       (symlinks . ,symlinks)
		       (id . ,(string->number
			       (symbol->string
				(get-4digit-symbol-from-list (cons file-name symlinks))))))))
     (if (null? args)
	 (make-ldict (cons (cons 'TAG TAG-BRMEMBER)
			   pairs))
	 (if (not (keyword? (car args)))
	     (error 'make-brmember "Optional arguments must be keywords" (car args))
	     (if (null? (cdr args))
		 (error 'make-brmember "Each optional keyword argument must have a value" (car args))
		 (loop (cddr args)
		       (cons (cons (string->symbol (keyword->string (car args)))
				   (cadr args))
			     pairs)))))))

 ;; Predicate
 (define (brmember? v)
   (and (ldict? v)
	(eq? (ldict-ref v 'TAG #f) TAG-BRMEMBER)))

 ;; File name without directory
 (define (brmember-file-name mr)
   (ldict-ref mr 'file-name))

 ;; Convenience accessor for file name with directory
 (define (brmember-file-path mr)
   (ldict-ref mr 'file-path))
 
 ;; Returns opened input file for this record (used by parser).
 (define (brmember-input-file mr)
   (open-input-file
    (ldict-ref mr 'file-path)))

 ;; Sets pairs of keys/values for given member record.
 (define (brmember-set mr . args)
   (let loop ((args args)
	      (mr mr))
     (if (null? args)
	 mr
	 (if (not (keyword? (car args)))
	     (error 'brmember-set "Needs argument keyword" (car args))
	     (if (null? (cdr args))
		 (error 'brmember-set "Argument needs value" (car args))
		 (loop (cddr args)
		       (ldict-set mr (string->symbol (keyword->string (car args)))
				 (cadr args))))))))

 ;; Adds highlight identified by line number, message, pass number and
 ;; type (error, warning, info).
 (define (brmember-add-highlight mr line-number message pass type)
   (ldict-set mr 'highlights
	     (cons (list line-number message pass type)
		   (ldict-ref mr 'highlights '()))))

 ;; Returns a key from particular section
 (define (brmember-sub-ref mr sec key . defaults)
   (let ((sec-dict (ldict-ref mr sec)))
     (if (null? defaults)
	 (ldict-ref sec-dict key)
	 (ldict-ref sec-dict key (car defaults)))))

 ;; Sets a key in particular section
 (define (brmember-sub-set mr sec key val)
   (let ((sec-dict (ldict-ref mr sec)))
     (ldict-set mr sec
	       (ldict-set sec-dict key val))))

 ;; Prepends value to given subkey
 (define (brmember-sub-prepend mr sec key val)
   (brmember-sub-set mr sec key
			  (cons val
				(brmember-sub-ref mr sec key '()))))

 ;; Returns true if given section contains given key
 (define (brmember-sub-has-key? mr sec key)
   (ldict-contains? (ldict-ref mr sec) key))

 ;; Returns new member record with section updated by defaults, the
 ;; section must already exist.
 (define (brmember-sub-ensure mr sec . kvs)
   (let loop ((kvs kvs)
	      (sd (ldict-ref mr sec)))
     (if (null? kvs)
	 (ldict-set mr sec sd)
	 (if (null? (cdr kvs))
	     (error 'brmember-sub-ensure "Needs pairs of keys and values" kvs)
	     (let ((key (car kvs))
		   (val (cadr kvs)))
	       (loop (cddr kvs)
		     (if (ldict-contains? sd key)
			 sd
			 (ldict-set sd key val))))))))

 ;; Returns source lines
 (define (brmember-source mr)
   (ldict-ref mr 'source '()))

 ;; Returns member info key value
 (define (brmember-info mr key . defaults)
   (let ((info (ldict-ref mr 'info #f)))
     (if info
	 (if (null? defaults)
	     (ldict-ref info key)
	     (ldict-ref info key (car defaults)))
	 (if (null? defaults)
	     (error 'brmember-info "Info key is missing.")
	     (car defaults)))))

 ;; Return mandatory keys with #f as value
 (define (brmember-missing-keys mr)
   (ldict-reduce '()
		(lambda (acc k v)
		  (if v acc (cons k acc)))
		(ldict-ref mr 'info)))

 ;; True if there are any source highlights
 (define (brmember-has-highlights? mr)
   (ldict-contains? mr 'highlights))

 ;; Returns true if there is at least one highlight of given type
 (define (member-highlights-has-type? mr type)
   (let loop ((hls (ldict-ref mr 'highlights '())))
     (if (null? hls)
	 #f
	 (if (eq? (cadddr (car hls)) type)
	     #t
	     (loop (cdr hls))))))

 ;; Returns true if there is at least one highlight with error type
 (define (member-has-errors? mr)
   (member-highlights-has-type? mr 'error))

 ;; Absolutely required
 (define (brmember-usable? mr)
   (ldict-contains? (ldict-ref mr 'info) 'member))

 ;; Returns #t if this member is in dokuwiki
 (define (brmember-in-dokuwiki? mr)
   (ldict-contains? mr 'dokuwiki))

 ;; Returns #t if this member email is the same as the one in dokuwiki
 (define (brmember-dokuwiki-email-ok? mr)
   (let ((dw (ldict-ref mr 'dokuwiki #f)))
     (if (eq? dw #t)
	 #t
	 (if dw
	     (let ((email (brmember-info mr 'mail 0))
		   (memail (ldict-ref dw 'email 1)))
	       (equal? email memail))
	     #f))))

 ;; Returns #t if this member is in "member" group in dokuwiki.
 (define (brmember-dokuwiki-groups-ok? mr)
   (let ((dw (ldict-ref mr 'dokuwiki #f)))
     (if (eq? dw #t)
	 #t
	 (if dw
	     (let ((groups (ldict-ref dw 'groups '())))
	       (and
		;; member
		(or (and (member "member" groups)
			 (brmember-existing? mr))
		    (and (not (member "member" groups))
			 (not (brmember-existing? mr))))
		;; council, admin
		(or (and (or (member "council" groups)
			     (member "admin" groups))
			 (brmember-existing? mr)
			 (or (brmember-council? mr)
			     (brmember-chair? mr)
			     (brmember-revision? mr)))
		    (and (not (or (member "council" groups)
				  (member "admin" groups)))
			 (or (not (brmember-existing? mr))
			     (not (or (brmember-council? mr)
				      (brmember-chair? mr)
				      (brmember-revision? mr))))))
		))
	     (not (brmember-existing? mr))))))

 ;; True if member record is not OK
 (define (brmember-has-problems? mr)
   (or (member-has-errors? mr)
       (not (null? (brmember-missing-keys mr)))
       (not (brmember-usable? mr))
       (not (is-4digit-prime? (brmember-id mr)))
       (and (not (brmember-destroyed? mr))
	    (not (brmember-in-dokuwiki? mr)))
       (and (not (brmember-destroyed? mr))
	    (not (brmember-dokuwiki-email-ok? mr)))
       (not (brmember-dokuwiki-groups-ok? mr))
       ))

 ;; True if member record is not OK
 (define (brmember-file-has-problems? mr)
   (or (member-has-errors? mr)
       (not (null? (brmember-missing-keys mr)))
       (not (brmember-usable? mr))
       (not (is-4digit-prime? (brmember-id mr)))
       ))

 ;; Returns true if the member record represents non-existing
 ;; member. The *current-month* is a global parameter from period
 ;; module.
 (define (brmember-destroyed? mr)
   (and (not (brmember-existing? mr))
	(let ((member (brmember-info mr 'member)))
	  (if (null? member)
	      #f
	      (cal-month>=? (*current-month*)
			    (cal-period-since (car member)))))))

 ;; Generic period-based predicate
 (define ((member-period-predicate? key) mr)
   (let ((periods (brmember-info mr key #f)))
     (and periods
	  (cal-month-in-periods? periods))))

 ;; Returns true if the member is now suspended
 (define member-is-suspended?
   (member-period-predicate? 'suspend))

 ;; Suspended must not be destroyed
 (define (brmember-suspended? mr)
   (and (member-is-suspended? mr)
	(not (brmember-destroyed? mr))))

 ;; True if the member is student
 (define member-is-student?
   (member-period-predicate? 'student))

 ;; Only active members can be students.
 (define (brmember-student? mr)
   (and (brmember-active? mr)
	(member-is-student? mr)))

 ;; Returns true if the member is active (not suspended or destroyed).
 (define (brmember-active? mr)
   (and (cal-month-in-periods? (brmember-info mr 'member))
	(not (brmember-suspended? mr))))

 ;; Returns true if the member is currently a member
 (define (brmember-existing? mr)
   (cal-month-in-periods?
    (brmember-info mr 'member)))

 ;; Returns predicate for given organizational body membership
 (define (brmember-body? body)
   (lambda (mr)
     (cal-day-in-periods?
      (brmember-info mr body '()))))

 ;; Predicates for all organizational bodies recognized
 (define brmember-chair? (brmember-body? 'chair))
 (define brmember-council? (brmember-body? 'council))
 (define brmember-revision? (brmember-body? 'revision))
 (define brmember-grant? (brmember-body? 'grant))

 ;; Returns a list of flags of given member record.
 (define (brmember-flags mr)
   (filter identity
	   (list (if (brmember-student? mr) 'student #f)
		 (if (brmember-suspended? mr) 'suspended #f)
		 (if (brmember-active? mr) 'active #f)
		 (if (brmember-destroyed? mr) 'destroyed #f)
		 (if (brmember-existing? mr) 'existing #f)
		 (if (brmember-chair? mr) 'chair #f)
		 (if (brmember-council? mr) 'council #f)
		 (if (brmember-revision? mr) 'revision #f)
		 (if (brmember-grant? mr) 'grant #f)
		 )))

 ;; Nickname as string
 (define (brmember-nick mr)
   (brmember-info mr 'nick))

 ;; Returns member id
 (define (brmember-id mr)
   (ldict-ref mr 'id))

 ;; Returns the number of months the user is suspended. Zero if not
 ;; suspended.
 (define (brmember-suspended-months mr)
   (if (brmember-suspended? mr)
       (let ((period (cal-periods-match (brmember-info mr 'suspend))))
	 (if period
	     (cal-month-diff (cal-ensure-month (cal-period-since period))
			     (*current-month*))
	     0))
       0))

 ;; Creates configured predicate for the number of months the member
 ;; is suspended for.
 (define (brmember-suspended-for at-least . less-thans)
   (let ((less-than (if (null? less-thans)
			#f
			(car less-thans))))
     (lambda (mr)
       (let ((months (brmember-suspended-months mr)))
	 (and (>= months at-least)
	      (or (not less-than)
		  (< months less-than)))))))

 ;; Comparator of member records based on nickname.
 (define (brmember<? a b)
   (string-ci<? (brmember-nick a)
		(brmember-nick b)))

 ;; Prepends new payment to given member record payments
 (define (brmember-add-payment mr pt)
   (ldict-set mr 'payments
	     (cons pt
		   (ldict-ref mr 'payments '()))))

 ;; Returns a list of member payments
 (define (brmember-payments mr)
   (filter (lambda (tr)
	     (let* ((isodate (bank-transaction-date tr))
		    (month (iso-date->cal-month isodate)))
		    (cal-month<=? month (*current-month*))))
	   (ldict-ref mr 'payments '())))

 ;; Returns credit records - respects *current-month*
 (define (brmember-credit mr)
   (filter (lambda (cr)
	     (let* ((cmon (cadr cr))
		    (mon (if cmon
			     (cal-ensure-month cmon)
			     #f)))
	       (if mon
		   (cal-month<=? mon (*current-month*))
		   #t)))
	   (brmember-info mr 'credit '())))

 ;; Returns a list of MLs this member is subscribed to
 (define (brmember-mailman mr)
   (ldict-ref mr 'mailman '()))

 ;; Adds given ML to given member record
 (define (brmember-add-mailman mr ml)
   (ldict-set mr 'mailman
	     (cons ml
		   (brmember-mailman mr))))

 ;; Returns special fee for current month or #f if it should be default
 (define (brmember-spec-fee mr)
   (let ((fee-periods (brmember-info mr 'fee #f)))
     (if fee-periods
	 (let ((fee-period (cal-month-find-period fee-periods)))
	   (if fee-period
	       (let ()
		 (car (cal-period-scomment fee-period)))
	       #f))
	 #f)))

 (define (brmember-age mr)
   (let ((born (brmember-info mr 'born #f)))
     (if born
	 (let ((lst (string-split born "-")))
	   (if (null? lst)
	       #f
	       (let ((y (string->number (car lst))))
		 (if y		     
		     (- (current-year) y)
		     #f))))
	 #f)))

 ;; Self-tests
 (define (brmember-tests!)
   (run-tests
    brmember
    (test-true make-brmember
	       (ldict-equal?
		(make-brmember '|1234| "members/1234" '(|member|))
		(make-ldict
		 `((TAG . ,TAG-BRMEMBER)
		   (file-name . |1234|)
		   (file-path . "members/1234")
		   (symlinks |member|)
		   (id . 1234)))))
    (test-true make-brmember
	       (ldict-equal?
		(make-brmember '|1234| "members/1234" '(|member|) #:msg "msg")
		(make-ldict
		 `((msg . "msg")
		   (TAG . ,TAG-BRMEMBER)
		   (file-name . |1234|)
		   (file-path . "members/1234")
		   (symlinks |member|)
		   (id . 1234)))))
    (test-true brmember-set
	       (ldict-equal?
		(brmember-set (make-ldict) #:id 1234)
		(make-ldict
		 '((id . 1234)))))
    (test-true brmember-add-highlight
	       (ldict-equal?
		(brmember-add-highlight (make-ldict) 123 "Interesting..." 0 'info)
		(make-ldict
		 '((highlights . ((123 "Interesting..." 0 info)))))))
    (test-true brmember-destroyed?
	       (with-current-month
		(make-cal-month 2023 2)
		(brmember-destroyed?
		 (make-ldict `((info . ,(make-ldict
					 `((member . (,(make-cal-period
							(make-cal-month 2010 1)
							(make-cal-month 2010 5))))))))))))
    (test-false brmember-destroyed?
		(with-current-month
		 (make-cal-month 2009 2)
		 (brmember-destroyed?
		  (make-ldict `((info . ,(make-ldict
					  `((member . (,(make-cal-period
							 (make-cal-month 2001 1)
							 (make-cal-month 2010 5))))))))))))
    (test-false brmember-suspended?
		(brmember-suspended?
		 (make-ldict `((info . ,(make-ldict
					 `((member . (,(make-cal-period
							(make-cal-month 2015 1)
							#f))))))))))
    (test-true brmember-suspended?
	       (with-current-month
		(make-cal-month 2015 2)
		(brmember-suspended?
		 (make-ldict `((info . ,(make-ldict
					 `((member . (,(make-cal-period
							(make-cal-month 2015 1)
							#f)))
					   (suspend ,(make-cal-period
						      (make-cal-month 2010 1)
						      (make-cal-month 2022 4) #f #f))))))))))
    (test-true brmember-suspended?
	       (with-current-month
		(make-cal-month 2015 2)
		(brmember-suspended?
		 (make-ldict `((info . ,(make-ldict
					 `((member . (,(make-cal-period
							(make-cal-month 2015 1)
							#f)))
					   (suspend (make-cal-period
						     (make-cal-month 2010 1)
						     #f #f #f))))))))))
    (test-false brmember-suspended?
		(with-current-month
		 (make-cal-month 2023 2)
		  (brmember-suspended?
		   (make-ldict `((info . ,(make-ldict
					   `((member . (,(make-cal-period
							  (make-cal-month 2015 1) #f)))
					     (suspend ,(make-cal-period
							(make-cal-month 2010 1)
							(make-cal-month 2022 4)
							#f #f))))))))))
    (test-true brmember-active?
	       (with-current-month
		(make-cal-month 2023 2)
		(brmember-active?
		 (make-ldict `((info . ,(make-ldict
					 `((member . (,(make-cal-period
							(make-cal-month 2015 1)
							#f)))
					   (suspend ,(make-cal-period
						      (make-cal-month 2010 1)
						      (make-cal-month 2022 4)
						      #f #f))))))))))
    ))

 )