169 lines
4.8 KiB
Scheme
169 lines
4.8 KiB
Scheme
;;
|
|
;; 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))
|