;;
;; hackerbase.scm
;;
;; Hackerspace Members Database management system.
;;
;; 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.
;;

(import (chicken repl)
	(chicken format)
	command-line
	mbase
	brmember
	configuration
	export-cards
	members-print
	members-payments
	environment
	mailman
	texts
	tests
	notifications
	util-mail
	logging
	progress
	cal-period
	cal-month
	cal-day
	util-git
	util-bst-ldict
	util-stdout
	table
	export-web-static
	dokuwiki
	racket-kwargs
	util-string)

;; Command-line options and configurable parameters
(define -needs-bank- (make-parameter #f))
(define -member-id- (make-parameter #f))
(define -member-nick- (make-parameter #f))
(define -action- (make-parameter #f))
(define -fname- (make-parameter #f))
(define -run-tests?- (make-parameter #f))
(define -web-dir- (make-parameter #f))
(define -normal-month- (make-parameter #t))
(define -show-destroyed- (make-parameter #f))
(define -notify-months- (make-parameter 1))
(define -send-emails- (make-parameter #f))

;; Arguments parsing
(command-line
 print-help
 (-h () "This help"
     (print banner-line)
     (newline)
     (print "Command-line options:")
     (print-help)
     (newline)
     (exit 0))
 (-license () "Show licensing terms"
	   (print banner)
	   (newline)
	   (print license)
	   (exit 0))
 ""
 "Configuration options:"
 (-config (fname) "Initial configuration"
	  (*etc-hackerbase* fname))
 (-members (dir) "Members base directory"
	   (*members-directory* dir))
 (-month (YYYY-MM) "Specify current month"
	 (-normal-month- #f)
	 (set-current-month! (string->cal-month YYYY-MM)))
 (-today (YYYY-MM-DD) "Specify current day"
	 (-normal-month- #f)
	 (set-current-day! (string->cal-day YYYY-MM-DD)))
 (-tstyle (style) "Use given table style: debug, ascii, unicode"
	  (*table-border-style* (string->symbol style)))
 (-apikey (fname) "File with Fio API keys"
	  (*apikeys-file* fname))
 (-bankdir (dir) "Where are bank CSV files"
	   (*bank-dir* dir))
 (-checked (file) "File with last checked bank transaction ID"
	   (*checked-file* file))
 (-dokuwiki (dir) "Base directory of DokuWiki"
	    (*doku-base* dir))
 (-count (count) "Maximum number of transactions shown"
	 (*show-payments-count* (string->number pcount)))
 (-mailman (version) "Version of mailman to use (2/3)"
	   (*mailman-version* (string->number version)))
 (-mailman3-sql () "Enable mailman3 direct SQL access"
		(*mailman3-sql* "1"))
 (-mailman3-sql-path (path) "Set mailman3 direct SQL access path"
		     (*mailman3-sql* "1")
		     (*mailman3-sql-path* path))
 ""
 "Email options:"
 (-from (email) "Sender email address"
	(*email-from* email))
 (-sendmail () "Actually send emails"
	    (-send-emails- #t))
 (-mailto (email) "Override all outgoing emails destination"
	  (*mailto-override* email))
 ""
 "Output options:"
 (-logfile (filename) "Enable logging to file"
	   (*log-file* filename))
 (-quiet () "Suppress all output"
	 (*stdout-quiet* #t)
	 (*progress-quiet* #t))
 ""
 "Query options:"
 (-mi (id) "Specify member by id" (-member-id- (string->number id)))
 (-mn (nick) "Specify member by nick"
      (when (not (-action-))
	(-action- 'no-op))
      (-member-nick- nick))
 ""
 "Misc options:"
 (-destroyed () "Show destroyed members in -fees"
	     (-show-destroyed- #t))
 ""
 "Base Actions:"
 (-info () "Print information"
	(-needs-bank- #t)
	(-action- 'print-info))
 (-print () "Print given member file"
	 (-action- 'print-member-file))
 (-blame () "Print annotated member file"
	 (-action- 'blame-member-file))
 (-fees () "Prints fees table"
	(-needs-bank- #t)
	(-action- 'fees))
 (-problems () "Prints all files with problems"
	    (-action- 'problems))
 (-status () "Show members directory status"
	  (-action- 'status))
 (-unpaired () "Show latest unpaired bank transactions"
	    (-needs-bank- #t)
	    (-action- 'unpaired))
 (-edit () "Edit selected user"
	(-action- 'edit))
 (-list () "Lists active members"
	(-action- 'list))
 ""
 "Id Management Actions:"
 (-idstats () "Returns information about available member ids"
	   (-action- 'print-idstats))
 (-genid () "Generates random member id"
	 (-action- 'genid))
 ""
 "Export Actions:"
 (-gencards (file:cards file:desfires) "Generates brmdoor-compatible card files"
	    (-action- 'gencards)
	    (-fname- (list file:cards file:desfires)))
 (-genweb (dir) "Generate static web files"
	  (-needs-bank- #t)
	  (-web-dir- dir)
	  (-action- 'genweb))
 (-stats (file:gnuplot-data) "Get stats for all months"
	 (-action- 'print-stats)
	 (-fname- file:gnuplot-data))
 ""
 "Mailman Actions:"
 (-mlsync () "Synchronize internal ML"
	  (-action- 'mlsync))
 ""
 "Email Actions:"
 (-notify () "Members with debt for more than 1 month"
	  (-notify-months- 1)
	  (-needs-bank- #t)
	  (-action- 'notify))
 (-notify3 () "Members with debt for more than 3 month"
	   (-notify-months- 3)
	   (-needs-bank- #t)
	   (-action- 'notify))
 (-summary () "Send summary email"
	   (-needs-bank- #t)
	   (-action- 'summary))
 ""
 "Development Actions:"
 (-tests () "Run self-tests upon startup"
	 (-run-tests?- #t))
 (-repl () "Start REPL with everything loaded"
	(-needs-bank- #t)
	(-action- 'repl))
 )

;; Print banner
(stdout-print banner-line)
(stdout-newline)

;; Load default configuration
(load-configuration!)

;; Run tests
(when (-run-tests?-)
  (run-all-tests!)
  (newline))

;; Start real work
(log-info "Loading")

;; Load the members database (required for everything anyway)
(define MB0
  (if (-action-)
      (let ((mb (load-mbase (*members-directory*) #t)))
	(if (-needs-bank-)
	    (members-payments-process mb (*apikeys-file*) (*bank-dir*) (*checked-file*))
	    mb))
      #f))

;; Load ML(s) and merge them
(define-values (MB1 MLS)
  (if MB0
      (let ()
	(define mls (load-mailman-lists))
	(values (foldl (lambda (mb ml)
			 (mbase-merge-mailman mb ml))
		       MB0
		       mls)
		mls))
      (values #f #f)))

;; Load DokuWiki users
(define MB (if MB1
	       (mbase-merge-dokuwiki MB1 (dokuwiki-load-users))
	       #f))

;; If a member is specified by either id or nick, get its record
(define mr
  (if (-member-id-)
      (let ((mr (find-member-by-id MB (-member-id-))))
	(when (not mr)
	  (print "Member id " (-member-id-) " not found!"))
	mr)
      (if (-member-nick-)
	  (let ((mrs (find-members-by-nick MB (-member-nick-))))
	    (cond ((null? mrs)
		   (newline)
		   (print "Member nick " (-member-nick-) " not found!")
		   #f)
		  ((> (length mrs) 1)
		   (newline)
		   (print "Found: " (member-records->string mrs))
		   (-action- 'no-op)
		   #f)
		  (else
		   (car mrs))))
	  #f)))

;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Used both in print-info and git-status
(define (print-git-status)
  (let ((status (git-status (*members-directory*))))
    (newline)
    (print "Repository " (*members-directory*) " status:")
    (if (ldict-ref status 'clean)
	(print "  Repository up-to-date.")
	(let loop ((keys '(unknown untracked modified)))
	  (when (not (null? keys))
	    (when (ldict-contains? status (car keys))
	      (print "  " (car keys) ": " (length (ldict-ref status (car keys)))))
	    (loop (cdr keys)))))))

(define* (check-mailing-list mls name #:pred? (pred? #f))
  (define ml (find-mailman-list mls name))
  (let-values (((missing surplus)
		(mailman-compare-members ml
					 (mbase-active-emails MB
							      #:suspended #t
							      #:pred? pred?
							      ))))
    (if (null? (cdr ml))
	(print "Skipping ML check - not loaded")
	(if (and (null? missing)
		 (null? surplus))
	    (print (format "~a mailing list membership in sync." (string-capitalize name)))
	    (let ()
	      (print (format "~a mailing list:" (string-capitalize name)))
	      (when (not (null? missing))
		(print "  Missing: " missing))
	      (when (not (null? surplus))
		(print "  Outsiders: " surplus)))))))

(define (rada-ml-pred? mr)
  (or (brmember-council? mr)
      (brmember-chair? mr)
      (brmember-revision? mr)))

;; Perform requested action
(case (-action-)
  ((print-info)
   (newline)
   (print "Current month: " (cal-month->string (*current-month*)))
   (newline)
   (if mr
       (print-member-table mr)
       (let ()
	 (print-members-base-table MB)
	 (newline)
	 (check-mailing-list MLS "internal")
	 (check-mailing-list MLS "rada"
			     #:pred? rada-ml-pred?)
	 (check-mailing-list MLS "rk" #:pred? brmember-revision?)
	 (print-git-status)))
   (newline))
  ((print-stats)
   (newline)
   (parameterize ((current-output-port (open-output-file (-fname-))))
     (print-members-base-stats
      (mbase-stats MB))))
  ((print-member-file)
   (cond (mr
	  (newline)
	  (print-member-source mr))
	 (else
	  (print "No member specified!"))))
  ((blame-member-file)
   (cond (mr
	  (newline)
	  (print-member-blame mr))
	 (else
	  (print "No member specified!"))))
  ((print-idstats)
   (newline)
   (print-members-ids-stats MB)
   (newline))
  ((genid)
   (newline)
   (print "New member id: " (mbase-gen-id MB))
   (newline))
  ((gencards)
   (if (-normal-month-)
       (apply cards-export MB (-fname-))
       (print "Cards export disabled with manually specified current month.")))
  ((problems)
   (let ((mrs (find-members-by-predicate MB (lambda (mr)
					      (or (brmember-has-problems? mr)
						  (brmember-has-highlights? mr))))))
     (cond ((null? mrs)
	    (newline)
	    (print "No problems found."))
	   (else
	    (let loop ((mrs mrs))
	      (when (not (null? mrs))
		(newline)
		(print-member-table (car mrs))
		(print-member-blame (car mrs))
		(loop (cdr mrs))))))))
  ((fees)
   (newline)
   (if mr
       (print-member-balances-table mr)
       (print-members-fees-table MB (-show-destroyed-))))
  ((repl)
   (repl))
  ((genweb)
   (log-info "Generating static web files")
   (gen-html-members MB (-web-dir-)))
  ((edit)
   (if mr
       (let ()
	 (edit-file (brmember-file-path mr))
	 (print-git-status))
       (print "No member to edit.")))
  ((no-op) (void))
  ((unpaired)
   (newline)
   (print-unpaired-table MB))
  ((mlsync)
   (cond ((-normal-month-)
	  (mailman-sync-members (find-mailman-list MLS "internal")
				(mbase-active-emails MB #:suspended #t))
	  (mailman-sync-members (find-mailman-list MLS "rada")
				(mbase-active-emails MB
						     #:pred? rada-ml-pred?))
	  (mailman-sync-members (find-mailman-list MLS "rk")
				(mbase-active-emails MB
						     #:pred? brmember-revision?)))
	 (else
	  (print "Mailman synchronization disabled with manually specified current month."))))
  ((notify)
   (let ((nmembers (members-to-notify MB (-notify-months-))))
     (newline)
     (if (null? nmembers)
	 (print "Everyone paid on time.")
	 (let ()
	   (stdout-print "Notify" (-notify-months-))
	   (let loop ((lst nmembers))
	     (when (and (not (null? lst))
			(or (not mr)
			    (eq? (brmember-id mr)
				 (brmember-id (car lst)))))
	       (if (-send-emails-)
		   (make+send-reminder-email (car lst))
		   (make+print-reminder-email (car lst)))
	       (loop (cdr lst))))))))
  ((status)
   (print-git-status))
  ((summary)
   (if (-send-emails-)
       (make+send-summary-email MB)
       (make+print-summary-email MB)))
  ((list)
   (for-each (lambda (mr)
	       (print (brmember-nick mr)))
	     (find-members-by-predicate MB brmember-active?)
	     ))
  (else
   (print "Nothing to do. Try running with: -h"))
  
  )

;; Finished
(log-info "Finished")