(import (scheme base)
        (scheme write)
        (scm fs)
        (scm io)
        (scm list)
        (scm module)
        (scm net http request)
        (scm net http response)
        (scm net http route)
        (scm net http server))

(define script-dir (directory-name (absolute-path script-name)))
(define base-dir (directory-name script-dir))
(module-search-path! (list (join-path base-dir "scm")))

(import (splg utils)
        (splg options)
        (splg grouper)
        (splg service))

(define *default-host* "127.0.0.1")
(define *default-port* 8080)
(define *default-max-threads* 32)
(define *default-read-timeout-ms* 30000)
(define *default-max-body-bytes* (* 4 1024 1024))
(define *default-graceful-stop-ms* 10000)

(define (display-help)
  (format #t "Service mode (REST):~%")
  (format #t "--service~%")
  (format #t "    start the REST service~%")
  (format #t "Common options:~%")
  (format #t "--cfg-dir <path>~%")
  (format #t "--spitalliste <file>~%")
  (format #t "    use the given spitalliste file (repeatable)~%")
  (format #t "--sl <string>~%")
  (format #t "    add an inline spitalliste entry; format:~%")
  (format #t "      burnr,plz,standort,referenz,kanton,year[,splg[:vfrom[:vto]],...]~%")
  (format #t "    repeatable to add multiple hospital entries~%")
  (format #t "--wohnkanton-override <kanton>~%")
  (format #t "Service options:~%")
  (format #t "--host <hostname>          (default: 127.0.0.1)~%")
  (format #t "--port <n>                 (default: 8080)~%")
  (format #t "--max-threads <n>          (default: 32; excess => 503)~%")
  (format #t "--read-timeout-ms <n>      (default: 30000)~%")
  (format #t "--max-body-bytes <n>       (default: 4194304; oversize => 413)~%")
  (format #t "--graceful-stop-ms <n>     (default: 10000)~%")
  (format #t "--help~%"))

(define (parse-options args)
  (let loop ((args args)
             (options `((cfg-dir ,(join-path base-dir "cfg"))
                        (spitallisten ())
                        (inline-sls ())
                        (host ,*default-host*)
                        (port ,*default-port*)
                        (max-threads ,*default-max-threads*)
                        (read-timeout-ms ,*default-read-timeout-ms*)
                        (max-body-bytes ,*default-max-body-bytes*)
                        (graceful-stop-ms ,*default-graceful-stop-ms*))))
    (if (null? args)
        options
        (let ((arg (car args)))
          (cond
           ((equal? arg "--service")
            (loop (cdr args) options))
           ((equal? arg "--cfg-dir")
            (loop (cddr args)
                  (set-option options 'cfg-dir (cadr args))))
           ((equal? arg "--spitalliste")
            (loop (cddr args)
                  (set-option options 'spitallisten
                              (append (get-property options 'spitallisten)
                                      (list (cadr args))))))
           ((equal? arg "--sl")
            (loop (cddr args)
                  (set-option options 'inline-sls
                              (append (get-property options 'inline-sls)
                                      (list (cadr args))))))
           ((equal? arg "--wohnkanton-override")
            (loop (cddr args)
                  (set-option options 'wohnkanton-override
                              (string->symbol (cadr args)))))
           ((equal? arg "--host")
            (loop (cddr args) (set-option options 'host (cadr args))))
           ((or (equal? arg "--port")
                (equal? arg "--max-threads")
                (equal? arg "--read-timeout-ms")
                (equal? arg "--max-body-bytes")
                (equal? arg "--graceful-stop-ms"))
            (let ((n (string->number (cadr args)))
                  (key (string->symbol (substring arg 2 (string-length arg)))))
              (if (and n (integer? n) (>= n 0))
                  (loop (cddr args) (set-option options key (exact n)))
                  (begin
                    (format #t "Invalid value for ~a: ~a~%" arg (cadr args))
                    #f))))
           ((or (equal? arg "--help") (equal? arg "-h"))
            (display-help)
            #f)
           (else
            (format #t "Unknown option ~a~%" arg)
            #f))))))

;; -- Handlers --------------------------------------------------------------

(define (json-response status text body)
  (make-http-response
   status
   '(("Content-Type" . "application/json; charset=utf-8"))
   body))

(define (handle-version req params)
  (json-response
   200
   "OK"
   (envelope-json
    200 "OK"
    (string-append "{\"version\":\""
                   grouper-version
                   "\"}"))))

(define (handle-healthz req params)
  ;; Liveness probe for systemd / nginx upstream checks. Cheap and
  ;; dependency-free — does not touch the cfg cache or filesystem.
  (json-response 200 "OK" "{\"status\":\"ok\"}"))

(define (handle-group base-options req params)
  (let* ((release-str (params-ref params "release"))
         (release (and release-str (string->symbol release-str)))
         (cfg-dir (get-property base-options 'cfg-dir))
         (release-dir (and release (join-path cfg-dir
                                              (symbol->string release)))))
    (cond
     ((or (not release) (string=? release-str ""))
      (json-response
       400 "Bad Request"
       (envelope-json 400 "release missing in URL" #f)))
     ((not (directory-exists? release-dir))
      (json-response
       404 "Not Found"
       (envelope-json
        404
        (string-append "release " release-str " not available")
        #f)))
     (else
      (let ((cfg (get-cached-cfg base-options release)))
        (cond
         ((not cfg)
          (json-response
           403 "Forbidden"
           (envelope-json
            403
            (string-append "cannot load release " release-str
                           " (license missing or invalid?)")
            #f)))
         (else
          (let ((body (http-request-body req)))
            (cond
             ((or (not body) (string=? body ""))
              (json-response
               400 "Bad Request"
               (envelope-json 400 "empty request body" #f)))
             (else
              (guard
               (e (#t
                   (json-response
                    500 "Internal Server Error"
                    (envelope-json 500
                                   (let ((msg (error-object-message e)))
                                     (if (string? msg) msg "grouping failed"))
                                   #f))))
               (let* ((fall (parse-fall-from-json-string body))
                      (result (and fall (group-via-service cfg fall))))
                 (cond
                  ((not fall)
                   (json-response
                    400 "Bad Request"
                    (envelope-json 400 "invalid request body" #f)))
                  (else
                   (json-response
                    200 "OK"
                    (envelope-json 200 "OK"
                                   (result->rest-json result cfg)))))))))))))))))

;; -- Main ------------------------------------------------------------------

(let ((options (parse-options script-arguments)))
  (when options
    (let ((host             (get-property options 'host))
          (port             (get-property options 'port))
          (max-threads      (get-property options 'max-threads))
          (read-timeout-ms  (get-property options 'read-timeout-ms))
          (max-body-bytes   (get-property options 'max-body-bytes))
          (graceful-stop-ms (get-property options 'graceful-stop-ms)))
      (get! "/version" handle-version)
      (get! "/healthz" handle-healthz)
      (post! "/group/:release"
             (lambda (req params) (handle-group options req params)))
      (format #t "SPLG-Grouper REST service ~a~%" grouper-version)
      (format #t "Listening on http://~a:~a/~%" host port)
      (format #t "  GET  /version~%")
      (format #t "  GET  /healthz~%")
      (format #t "  POST /group/<Release>~%")
      ;; Start without blocking so we can install the shutdown hook before
      ;; waiting. This makes systemctl stop / Ctrl+C drain in-flight requests
      ;; up to graceful-stop-ms instead of cutting them.
      (let ((server (start-app port
                               max-threads
                               host
                               read-timeout-ms
                               max-body-bytes
                               graceful-stop-ms)))
        (server-install-shutdown-hook server graceful-stop-ms)
        (server-wait server)))))
