;;
;; brminv.scm
;;
;; Main program of Brm Inventory - the server.
;;
;; ISC License
;;
;; Copyright 2023-2025 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 frontend
	command-line
	texts
	spiffy
	openssl
	(chicken tcp)
	intarweb
	uri-common
	(chicken string)
	postgresql)

(define -port- (make-parameter #f))
(define -certificate- (make-parameter #f))
(define -key- (make-parameter #f))
(define -user- (make-parameter #f))
(define -group- (make-parameter #f))
(define -db-host- (make-parameter #f))
(define -db-user- (make-parameter #f))
(define -db-name- (make-parameter #f))
(define -db-pass- (make-parameter #f))

(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-line)
	   (newline)
	   (print license)
	   (exit 0))
 ""
 "Configuration options:"
 (-p (port) "Listen port"
     (-port- (string->number port)))
 (-c (cert) "Certificate"
     (-certificate- cert))
 (-k (key) "Private key"
     (-key- key))
 (-u (user) "User to run as (if started as root)"
     (-user- user))
 (-g (group) "Group to run as (if started as root)"
     (-group- group))
 (-dh (hostname) "Database hostname"
      (-db-host- hostname))
 (-dn (dbname) "Database name"
      (-db-name- dbname))
 (-du (dbuser) "Database username"
      (-db-user- dbuser))
 (-dp (dbpass) "Database password"
      (-db-pass- dbpass))
 )

(define ssl? (and (-certificate-) (-key-) #t))
(define port (or (-port-) (if ssl? 443 80)))

(print banner-line)
(print "Port: " port)
(print "SSL: " ssl?)
(when ssl?
  (print "  Certificate: " (-certificate-))
  (print "  Key: " (-key-)))

(define listener
  (if ssl?
      (ssl-listen* port: port
		   certificate: (-certificate-)
		   private-key: (-key-))
      (tcp-listen port)))

(when (and (-user-) (-group-))
  (switch-user/group (-user-) (-group-)))

(define dbconn
  (connect
   `((dbname . ,(-db-name-))
     (host . ,(-db-host-))
     (user . ,(-db-user-))
     (password . ,(-db-pass-)))))
(print dbconn)

(define (handle-api-calls)
  (define plst (cdr (uri-path (request-uri (current-request)))))
  (cond ((and (not (null? plst))
	      (equal? (car plst) "api"))
	 (send-response #:body "API call")
	 #t)
	(else
	 #f)))

(handle-not-found
 (lambda (path)
   (define upath
     (string-intersperse
      (map ->string (cdr (uri-path (request-uri (current-request)))))
      "/"))
   (print 'log: upath)
   (cond ((equal? upath "")
	  (send-response #:body (frontend-lookup "index.html")))
	 (else
	  (let ((maybe-asset (frontend-lookup upath #f)))
	    (cond (maybe-asset
		   (send-response
		    #:headers (let ((ext (car (reverse (string-split upath ".")))))
				(cond ((equal? ext "css")
				       '((content-type #("text/css" ()))))
				      ((equal? ext "js")
				       '((content-type #("text/javascript" ()))))
				      (else
				       '())))
		    #:body maybe-asset))
		  (else
		   (when (not (handle-api-calls))
		     (send-response #:body (frontend-lookup "index.html"))))))))))

(accept-loop listener
	     (if ssl?
		 ssl-accept
		 tcp-accept)
	     (if ssl?
		 (lambda (p)
		   (tcp-addresses (ssl-port->tcp-port p)))
		 tcp-addresses))