(import (chicken io)
        (chicken port)
        (chicken file)
        (chicken string)
        (chicken pathname)
        (chicken condition)
        (chicken process-context)
        matchable srfi-13
        uri-common openssl)

(define SERVER-ROOT "public_gemini")
(define SERVER-HOST "localhost")
(define SERVER-HOST 1965)

(define-record config
  root-dir host port certfile keyfile) 

(define file-types
  '(("gmi" "text/gemini" "charset=utf-8")
    ("txt" "text/plain" "charset=utf-8")))

(define (process-request config request-line)
  ;; (condition-case
  (let ((uri (uri-normalize-path-segments (absolute-uri request-line))))
    (cond
     ((not (eq? (uri-scheme uri) 'gemini))
      (fail-permanent "Unsupported scheme."))
     ((not (uri-host uri))
      (fail-permanent "URL lacks host name."))
     ((not (equal? (uri-host uri) (config-host config)))
      (fail-permanent "Proxy requests forbidden."))
     ((uri-path-relative? uri)
      (fail-permanent "Path must be absolute."))
     ((not (document-available? config uri))
      (fail-permanent "Document not found."))
     (else 
      (serve-document config uri)))))
  ;; (o (exn)
  ;;    (print ((condition-property-accessor 'exn 'message) o))
  ;;    (fail-permanent "Failed to parse URL."))))

(define (fail-permanent reason)
  (print "50 " reason "\r"))

(define (document-available? config uri)
  (file-exists? (document-path config uri)))

(define (document-path config uri)
  (let* ((crumbs (reverse (cons (config-root-dir config) (cdr (uri-path uri)))))
         (path (make-pathname (reverse (cdr crumbs)) (car crumbs))))
    (if (directory-exists? path)
        (make-pathname path "index.gmi")
        path)))
    
(define (serve-document config uri)
  (let* ((path (document-path config uri))
         (ext (pathname-extension path))
         (mime-detected (assoc ext file-types))
         (mime (if mime-detected mime-detected (assoc "txt" file-types)))
         (mime-type (cadr mime)))
    (print "20 " (string-intersperse (cdr mime) ";") "\r")
    (cond 
      ((equal? mime-type "text/gemini") (serve-text-plain path))
      ((equal? mime-type "text/plain") (serve-text-plain path))
      (else (serve-binary)))))

(define (serve-text-plain path)
  (with-input-from-file path
    (lambda ()
      (let loop ((str (read-string)))
        (unless (eof-object? str)
          (print* str)
          (loop (read-string)))))))


(define (run-server config)
  (define listener (ssl-listen (config-port config)))

  (ssl-load-certificate-chain! listener (config-certfile config))
  (ssl-load-private-key! listener (config-keyfile config))

  (print "Host: '" (config-host config) "'\n"
         "Port: '" (config-port config) "'\n"
         "Root directory: '" (config-root-dir config) "'\n"
         "Cert file: '" (config-certfile config) "'\n"
         "Key file: '" (config-keyfile config) "'\n"
         "\n"
         "Gemini server listening ...")

  (let-values (((in-port out-port) (ssl-accept listener)))
    (let ((request-line (read-line in-port)))
      (with-output-to-port out-port
        (lambda ()
          (process-request config request-line))))))

(define (print-usage progname)
  (print "Usage: " progname " [-h] [-p port] server-root-dir hostname certfile keyfile"))

(define (main)
  (let* ((progname (pathname-file (car (argv))))
         (config (make-config #f #f 1965 #f #f)))
    (if (null? (cdr (argv)))
        (print-usage progname)
        (let loop ((args (cdr (argv))))
          (let ((this-arg (car args))
                (rest-args (cdr args)))
            (if (string-prefix? "-" this-arg)
                (cond
                 ((or (equal? this-arg "-h")
                      (equal? this-arg "--help"))
                  (print-usage progname))
                 ((or (equal? this-arg "-p")
                      (equal? this-arg "--port"))
                  (config-port-set! config (string->bumber (car rest-args)))
                  (loop (cdr rest-args)))
                 (else
                  (print-usage progname)))
                (match args
                  ((root-dir host certfile keyfile)
                   (config-root-dir-set! config root-dir)
                   (config-host-set! config host)
                   (config-certfile-set! config certfile)
                   (config-keyfile-set! config keyfile)
                   (run-server config))
                  (else
                   (print "One or more invalid arguments.")
                   (print-usage progname)))))))))


(main)