;;; Development web server
;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Static file web server for development.
;;;
;;; Code:

(define-module (hoot web-server)
  #:use-module (fibers)
  #:use-module (fibers channels)
  #:use-module (fibers io-wakeup)
  #:use-module (fibers operations)
  #:use-module (fibers timers)
  #:use-module (hoot frontend)
  #:use-module (ice-9 atomic)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 format)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (sxml simple)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web socket)
  #:use-module (web socket client)
  #:use-module (web socket server)
  #:use-module (web uri)
  #:export (%mime-types
            bad-request
            not-found
            internal-server-error
            render-file
            render-directory
            render-file-or-directory
            serve*
            serve))

(define (bad-request)
  (values (build-response #:code 400) #f))

(define (not-found request)
  "Return a 404 response for @var{path}."
  (values (build-response #:code 404)
          (string-append "Resource not found: "
                         (uri-path (request-uri request)))))

(define (internal-server-error)
  "Return a 500 response."
  (values (build-response #:code 500) #f))

;; Some common file extensions and their MIME types.
(define %mime-types
  '(("js"   . application/javascript)
    ("bin"  . application/octet-stream)
    ("json" . application/json)
    ("pdf"  . application/pdf)
    ("wasm" . application/wasm)
    ("xml"  . application/xml)
    ("mp3"  . audio/mpeg)
    ("ogg"  . audio/ogg)
    ("wav"  . audio/wav)
    ("gif"  . image/gif)
    ("jpeg" . image/jpeg)
    ("jpg"  . image/jpeg)
    ("png"  . image/png)
    ("svg"  . image/svg+xml)
    ("webp" . image/webp)
    ("ico"  . image/x-icon)
    ("css"  . text/css)
    ("csv"  . text/csv)
    ("html" . text/html)
    ("txt"  . text/plain)
    ("text" . text/plain)
    ("mp4"  . video/mpeg)
    ("ogv"  . video/ogg)))

(define (mime-type-for-file mime-types file-name)
  "Lookup the MIME type for @var{file-name} in the alist @var{mime-types}
based upon its file extension, or return @code{text/plain} if there is
no such type."
  (define (file-extension file)
    (let ((dot (string-rindex file #\.)))
      (and dot (substring file (+ 1 dot) (string-length file)))))
  (or (assoc-ref mime-types (file-extension file-name))
      'text/plain))

(define (stat:directory? stat)
  "Return @var{#t} if @var{stat} is a directory."
  (eq? (stat:type stat) 'directory))

(define (directory? file-name)
  "Return @var{#t} if @var{file-name} is a directory."
  (stat:directory? (stat file-name)))

(define (directory-contents dir)
  "Return a list of the files contained within @var{dir}."
  (define name+directory?
    (match-lambda
      ((name stat)
       (list name (stat:directory? stat)))))
  (define (same-dir? other stat)
    (string=? dir other))
  (match (file-system-tree dir same-dir?)
    ;; We are not interested in the parent directory, only the
    ;; children.
    ((_ _ children ...)
     (map name+directory? children))))

(define (path-components->file-name components work-dir)
  "Return the absolute file name corresponding to @var{components} in the
context of @var{work-dir}, or @code{#f} if there is no such file."
  ;; Forbid accessing files outside of the directory being served.
  (define (forbidden-components? components)
    (any (lambda (str)
           (or (string=? str ".") (string=? str "..")))
         components))
  (define (resolve-file-name path)
    ;; Implicitly resolve paths like "/" to "/index.html" files when
    ;; an index.html file exists.
    (let* ((file-name (string-append work-dir path))
           (index-file-name (string-append file-name "/index.html")))
      (cond
       ((file-exists? index-file-name) index-file-name)
       ((file-exists? file-name) file-name)
       (else #f))))
  (and (not (forbidden-components? components))
       (resolve-file-name
        (string-join components "/" 'prefix))))

(define* (render-file request file-name #:optional (mime-types %mime-types))
  "Return a 200 OK HTTP response that renders the contents of
@var{file-name}."
  (match (stat file-name #f)
    (#f (not-found request))
    ((= stat:size len)
     (values `((content-type . (,(mime-type-for-file mime-types file-name)))
               (content-length . ,len))
             (lambda (client)
               (call-with-input-file file-name
                 (lambda (file)
                   (sendfile client file len 0))))))))

(define (render-directory request dir)
  "Render the contents of @var{dir} represented by @var{path}."
  (define path (uri-path (request-uri request)))
  (define (concat+uri-encode . file-names)
    (string-join (map uri-encode
                      (remove string-null?
                              (append-map (lambda (f) (string-split f #\/))
                                          file-names)))
                 "/" 'prefix))
  (define render-child
    (match-lambda
     ((file-name directory?)
      `(li
        (a (@ (href ,(concat+uri-encode path file-name)))
           ,(if directory?
                (string-append file-name "/")
                file-name))))))
  (define file-name<
    (match-lambda*
     (((name-a _) (name-b _))
      (string< name-a name-b))))
  (let* ((children (sort (directory-contents dir) file-name<))
         (title (string-append "Directory listing for " path))
         (view `(html
                (head
                 (title ,title))
                (body
                 (h1 ,title)
                 (ul ,@(map render-child children)))))
         (body (call-with-output-bytevector
                (lambda (port)
                  (display "<!DOCTYPE html>" port)
                  (sxml->xml view port)))))
    (values `((content-type . (text/html))
              (content-length . ,(bytevector-length body)))
            body)))

(define* (render-file-or-directory request components work-dir
                                   #:optional (mime-types %mime-types))
  "Return an HTTP response for the file represented by the URI in
@var{request}."
  (match (path-components->file-name components work-dir)
    (#f (not-found request))
    ((? directory? dir)
     (render-directory request dir))
    (file-name
     (render-file request file-name mime-types))))

(define *hoot-load-path*
  (make-atomic-box (append (hoot-system-load-path) (hoot-load-path))))

(define (serve-module-source request modname mime-types)
  (let ((path (uri-path (request-uri request))))
    (match (search-path (atomic-box-ref *hoot-load-path*)
                        (string-join modname "/")
                        (hoot-load-extensions))
      (#f (not-found request))
      (file-name
       (render-file request file-name mime-types)))))

(define (serve-hoot-load-path requeset)
  (values '((content-type . (application/x-scheme)))
          (lambda (port)
            (write (atomic-box-ref *hoot-load-path*) port))))

(define (add-to-hoot-load-path request body)
  (match (read (open-bytevector-input-port body))
    ((? string? dir)
     (let lp ()
       (let* ((prev (atomic-box-ref *hoot-load-path*))
              (new (cons dir prev)))
         (unless (eq? (atomic-box-compare-and-swap! *hoot-load-path* prev new) prev)
           (lp))))
     (values `((content-length . 0)) #f))))

(define* (make-server-socket addr port #:key (max-connections 10))
  (let ((sock (socket AF_INET SOCK_STREAM IPPROTO_TCP)))
    (fcntl sock F_SETFL (logior SOCK_NONBLOCK SOCK_CLOEXEC))
    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
    (bind sock AF_INET addr port)
    (listen sock max-connections)
    sock))

(define* (wait-until-readable port #:optional (timeout 10))
  (perform-operation
   (choice-operation
    (wrap-operation (wait-until-port-readable-operation port)
                    (lambda () 'ready))
    (wrap-operation (sleep-operation timeout)
                    (lambda () 'timeout)))))

(define (accept* sock)
  (perform-operation (wait-until-port-readable-operation sock))
  (match (accept sock (logior SOCK_CLOEXEC SOCK_NONBLOCK))
    (#f (accept* sock))
    (client client)))

(define (set-response-header response header value)
  (build-response
   #:version (response-version response)
   #:code (response-code response)
   #:reason-phrase (response-reason-phrase response)
   #:headers (cons (cons header value) (response-headers response))
   #:port (response-port response)))

(define (sanitize-response request response body)
  (cond
   ((pair? response)
    (sanitize-response request
                       (build-response #:version (request-version request)
                                       #:headers response)
                       body))
   ((not (response? response))
    (error "invalid response" response))
   ((not body)
    (values response body))
   ((response-must-not-include-body? response)
    ;; Make a special exception for WebSocket upgrades, which we allow
    ;; to have a procedure as a body to handle the upgraded
    ;; connection.
    (if (and (websocket-upgrade-response? response) (procedure? body))
        (values response body)
        (error "response must not include body" response)))
   ((string? body)
    (let ((bv (string->utf8 body)))
      (sanitize-response request
                         (set-response-header response 'content-length
                                              (bytevector-length bv))
                         bv)))
   ((bytevector? body)
    (let ((len (bytevector-length body))
          (expected (response-content-length response)))
      (unless (= len expected)
        (error "invalid content-length" len expected))
      (values response body)))
   ((procedure? body)
    (values response body))
   (else
    (error "invalid response body" body))))

(define (handle-request handler request body)
  (define (handle-exception exn)
    (print-exception (current-error-port)
                     ;; TODO: Capture stack.
                     #f
                     (exception-kind exn)
                     (exception-args exn))
    (internal-server-error))
  (with-exception-handler handle-exception
    (lambda ()
      (let-values (((response body) (handler request body)))
        (sanitize-response request response body)))
    #:unwind? #t))

(define (keep-alive? response)
  (let ((code (response-code response)))
    (and (or (< code 400) (= code 404))
         (match (response-version response)
           ((1 . minor)
            (let ((connection (response-connection response)))
              (match minor
                (1 (not (memq 'close connection)))
                (0 (memq 'keep-alive connection)))))
           (_ #f)))))

(define (serve-web-client handler client)
  (let lp ()
    (define (handle-exception exn)
      (close-port client))
    (with-exception-handler handle-exception
      (lambda ()
        (let* ((request (read-request client))
               (body (read-request-body request)))
          (let-values (((response body) (handle-request handler request body)))
            (write-response response client)
            (cond
             ;; For WebSocket upgrades, pass control to the body
             ;; procedure and terminate the connection upon return.
             ((websocket-upgrade-response? response)
              (force-output client)
              (body client)
              (close-websocket client))
             ;; For regular responses, write the response body and
             ;; loop if this is a keep-alive connection.
             (else
              (cond
               ((bytevector? body)
                (put-bytevector client body))
               ((procedure? body)
                (cond
                 ((response-content-length response)
                  (body client))
                 ;; TODO: Chunked responses.
                 (else
                  (display "error: chunked responses unsupported\n"
                           (current-error-port))
                  (error "chunked responses unsupported")))))
              (force-output client)
              (if (keep-alive? response)
                  (lp)
                  (close-port client)))))))
      #:unwind? #t)))

(define (run-server handler server)
  (let lp ()
    (match (accept* server)
      ((client . addr)
       ;; Disable Nagle's algorithm.
       (setsockopt client IPPROTO_TCP TCP_NODELAY 1)
       (setvbuf client 'block 1024)
       (spawn-fiber (lambda () (handler client)))
       (lp)))))

(define* (serve* #:key (work-dir (getcwd)) (port 8080) (repl-port 37146)
                 (addr INADDR_LOOPBACK) (mime-types %mime-types) router)
  (define-syntax-rule (log str arg ...)
    (begin
      (format #t str arg ...)
      (newline)))
  (define (wait-for-readable-or-get-message port ch)
    (perform-operation
     (choice-operation
      (wrap-operation (wait-until-port-readable-operation port)
                      (lambda () '(read)))
      (get-operation ch))))
  (define control-ch #f)
  (define (handle-repl client)
    (cond
     (control-ch
      (let* ((their-ch control-ch)
             (our-ch (make-channel))
             (id (let ((reply (make-channel)))
                   (put-message their-ch `(new ,our-ch ,reply))
                   (get-message reply))))
        (log "REPL #~a connected" id)
        (let lp ()
          (match (wait-for-readable-or-get-message client our-ch)
            (('read)
             (match (get-bytevector-some client)
               ((? eof-object?)
                (close-port client)
                (put-message their-ch `(close ,id)))
               ((? bytevector? bv)
                (put-message their-ch `(write ,id ,bv))
                (lp))))
            (('write bv)
             (put-bytevector client bv)
             (force-output client)
             (lp))
            (('stop)
             (close-port client))))
        (log "REPL #~a disconnected" id)))
     (else
      (display "Error: Connection failed\n" client)
      (display "No control WebSocket\n" client)
      (close-port client))))
  (define (handle-websocket ws)
    (let ((ws* (wrap-websocket ws
                               #:server-side? #t
                               #:wait-for-port wait-until-readable
                               #:max-attempts #f))
          (our-ch (make-channel))
          (clients (make-hash-table)))
      (set! control-ch our-ch)
      (log "REPL control WebSocket connected")
      (let lp ((counter 0))
        (match (wait-for-readable-or-get-message ws our-ch)
          (('read)
           (match (read ws*)
             ((or #f (? eof-object?))
              (hash-for-each (lambda (id their-ch)
                               (put-message their-ch '(stop)))
                             clients))
             (('close id)
              (match (hashv-ref clients id)
                (#f (values))
                (their-ch
                 (put-message their-ch '(stop))
                 (hashv-remove! clients id)))
              (lp counter))
             (('write id bv)
              (match (hashv-ref clients id)
                (#f (values))
                (their-ch (put-message their-ch `(write ,bv))))
              (lp counter))))
          (('new their-ch reply)
           (let ((id counter))
             (hashv-set! clients id their-ch)
             (put-message reply id)
             (write `(new ,id) ws*)
             (force-output ws*)
             (lp (1+ counter))))
          ((and ('close id) msg)
           (hashv-remove! clients id)
           (write msg ws*)
           (force-output ws*)
           (lp counter))
          (msg
           (write msg ws*)
           (force-output ws*)
           (lp counter))))
      (log "REPL control WebSocket disconnected")
      (set! control-ch #f)))
  (define (maybe-connect-repl request)
    (cond
     (control-ch
      (log "Error: Control WebSocket is in use")
      (bad-request))
     ((websocket-upgrade-request? request)
      (values (make-websocket-upgrade-response request) handle-websocket))
     (else
      (bad-request))))
  (define base-router
    (match-lambda
      (('GET "repl")
       (lambda (request body)
         (maybe-connect-repl request)))
      (('GET "repl" "load" modname ..1)
       (lambda (request body)
         (serve-module-source request modname mime-types)))
      (('GET "repl" "load-path")
       (lambda (request body)
         (serve-hoot-load-path request)))
      (('POST "repl" "load-path")
       (lambda (request body)
         (add-to-hoot-load-path request body)))
      (('GET . components)
       (lambda (request body)
         (render-file-or-directory request components work-dir mime-types)))
      (_ #f)))
  (define router*
    (if router
        (lambda (route)
          (or (router route) (base-router route)))
        base-router))
  (define (handle-request request body)
    (define method (request-method request))
    (define path (uri-path (request-uri request)))
    (define route (cons method (split-and-decode-uri-path path)))
    (log "~a ~a" method path)
    (match (router* route)
      ((? procedure? proc)
       (proc request body))
      (_ (values))))
  (define (handle-http client)
    (serve-web-client handle-request client))
  (let ((ip (inet-ntop AF_INET addr)))
    (log "Hoot development web server started")
    (log "Listening for HTTP requests on: ~a:~a" ip port)
    (log "Listening for REPL clients on:  ~a:~a" ip repl-port)
    (log "Working directory:              ~a" work-dir))
  (spawn-fiber
   (lambda ()
     (run-server handle-repl (make-server-socket addr repl-port))))
  (run-server handle-http (make-server-socket addr port)))

(define* (serve #:key (work-dir (getcwd)) (port 8080) (repl-port 37146)
                (addr INADDR_LOOPBACK) (mime-types %mime-types) router)
  "Run a simple HTTP server that serves the files in @var{work-dir} over
@var{PORT} listening on @var{addr}.  MIME types are looked up by file
extension in the @var{mime-types} association list.

To extend the server with custom HTTP endpoints, pass @var{router}, a
procedure of one argument: a route.  A route is a list whose first
element is a symbol representing the HTTP verb and the remaining
elements are strings for each component of the request path,
e.g. @code{(GET \"foo\" \"bar\")}."
  (install-suspendable-ports!)
  (run-fibers
   (lambda ()
     (serve* #:work-dir work-dir
             #:port port
             #:repl-port repl-port
             #:addr addr
             #:mime-types mime-types
             #:router router))))
