;;
;; 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)
	api-servlets
	bar-db
	(chicken process-context posix)
	(chicken process-context)
	posix-groups)

(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))
(define -db-enabled- (make-parameter #t))

(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))
 (-dd () "Disable database"
      (-db-enabled- #f))
 )

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

(print "current user id: " (current-user-id))
(print "current effective user id: " (current-effective-user-id))
(when (-group-)	 ; group first, since only superuser can switch groups
  (let ((ginfo (group-information (-group-))))
    (unless ginfo
      (error "Group does not exist" (-group-)))
    (set! (current-group-id) (list-ref ginfo 2))))
(when (-user-)
  (let ((uinfo (user-information (-user-))))
    (unless uinfo
      (error "User does not exist" (-user-)))
    (set-environment-variable! "HOME" (list-ref uinfo 5))
    (initialize-groups (-user-) (list-ref uinfo 3))
    (unless (-group-)		    ; Already changed to target group?
      (set! (current-group-id) (list-ref uinfo 3)))
    (set! (current-user-id) (list-ref uinfo 2))))
(print "current user id: " (current-user-id))
(print "current effective user id: " (current-effective-user-id))

(when (-db-enabled-)
  (bar-db-init! (-db-name-) (-db-host-) (-db-user-) (-db-pass-)))

(define (handle-api-calls)
  (define plst (cdr (uri-path (request-uri (current-request)))))
  (cond ((and (not (null? plst))
	      (equal? (car plst) "api"))
	 (api-dispatch (cdr plst)))
	(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))