;;; Guile Knots
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;; Copyright (C)  2010-2013,2015,2017 Free Software Foundation, Inc.

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (knots web-server)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 control)
  #:use-module (fibers)
  #:use-module (fibers timers)
  #:use-module (fibers operations)
  #:use-module (fibers conditions)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 match)
  #:use-module (ice-9 exceptions)
  #:use-module ((srfi srfi-9 gnu) #:select (set-field))
  #:use-module (system repl error-handling)
  #:use-module (web uri)
  #:use-module (web http)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (knots)
  #:use-module (knots timeout)
  #:use-module (knots non-blocking)
  #:export (run-knots-web-server

            make-chunked-output-port/knots

            &request-body-ended-prematurely
            request-body-ended-prematurely-error?

            sanitize-response

            request-body-port/knots
            read-request-body/knots

            default-write-response-exception-handler

            web-server?
            web-server-socket
            web-server-port))

(define (make-default-socket family addr port)
  (let ((sock (socket PF_INET SOCK_STREAM 0)))
    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
    (fcntl sock F_SETFD FD_CLOEXEC)
    (bind sock family addr port)
    sock))

(define crlf-bv
  (string->utf8 "\r\n"))

(define (chunked-output-port-overhead-bytes write-size)
  (+ (string-length (number->string write-size 16))
     (bytevector-length crlf-bv)
     (bytevector-length crlf-bv)))

(define* (make-chunked-output-port/knots port #:key (keep-alive? #f)
                                         (buffering 1200))
  "Returns a new port which translates non-encoded data into a HTTP
chunked transfer encoded data and writes this to PORT. Data written to
this port is buffered until the port is flushed, at which point it is
all sent as one chunk.  The port will otherwise be flushed every
BUFFERING bytes, which defaults to 1200.  Take care to close the port
when done, as it will output the remaining data, and encode the final
zero chunk. When the port is closed it will also close PORT, unless
KEEP-ALIVE? is true."
  (define (write! bv start count)
    (let ((len-string
           (number->string count 16)))
      (put-string port len-string))
    (put-bytevector port crlf-bv 0 2)
    (put-bytevector port bv start count)
    (put-bytevector port crlf-bv 0 2)
    (force-output port)
    count)

  (define (close)
    (put-string port "0\r\n\r\n")
    (force-output port)
    (unless keep-alive?
      (close-port port)))

  (define ret
    (make-custom-binary-output-port "chunked http" write! #f #f close))
  (setvbuf ret 'block buffering)
  ret)

(define* (make-delimited-input-port port len fail
                                    #:key (keep-alive? #t))
  "Return an input port that reads from PORT, and makes sure that
exactly LEN bytes are available from PORT.  Closing the returned port
closes PORT, unless KEEP-ALIVE? is true."
  (define bytes-read 0)

  (define (read! bv start count)
    (let ((count (min count (- len bytes-read))))
      (let loop ((ret (get-bytevector-n! port bv start count)))
        (cond ((eof-object? ret)
               (if (= bytes-read len)
                   0                              ; EOF
                   (fail bytes-read)))
              ((and (zero? ret) (> count 0))
               ;; Do not return zero since zero means EOF, so try again.
               (loop (get-bytevector-n! port bv start count)))
              (else
               (set! bytes-read (+ bytes-read ret))
               ret)))))

  (define close
    (and (not keep-alive?)
         (lambda ()
           (close-port port))))

  (make-custom-binary-input-port "delimited input port" read! #f #f close))

;; Chunked Responses
(define &request-body-ended-prematurely
  (make-exception-type '&request-body-ended-prematurely
                       &external-error
                       '(bytes-read)))

(define make-request-body-ended-prematurely-error
  (record-constructor &request-body-ended-prematurely))

(define request-body-ended-prematurely-error?
  (exception-predicate &request-body-ended-prematurely))
(set-procedure-property! request-body-ended-prematurely-error? 'documentation
  "Return @code{#t} if OBJ is a @code{&request-body-ended-prematurely} exception.")

(define (request-body-port/knots request)
  "Return an input port for reading the body of request REQUEST.
Handles chunked transfer encoding."
  (cond
   ((member '(chunked) (request-transfer-encoding request))
    (make-chunked-input-port (request-port request)
                             #:keep-alive? #t))
   (else
    (let ((content-length
           (request-content-length request)))
      (make-delimited-input-port
       (request-port request)
       content-length
       (lambda (bytes-read)
         (raise-exception
          (make-request-body-ended-prematurely-error bytes-read))))))))

(define (read-request-body/knots r)
  "Read and return the full body of request R as a bytevector.
Handles chunked transfer encoding."
  (cond
   ((member '(chunked) (request-transfer-encoding r))
    (get-bytevector-all
     (request-body-port/knots r)))
   (else
    (let ((content-length
           (request-content-length r)))
      (if content-length
          (get-bytevector-n
           (request-body-port/knots r)
           content-length)
          #f)))))

(define (extend-response r k v . additional)
  (define (extend-alist alist k v)
    (let ((pair (assq k alist)))
      (acons k v (if pair (delq pair alist) alist))))
  (let ((r (set-field r (response-headers)
                      (extend-alist (response-headers r) k v))))
    (if (null? additional)
        r
        (apply extend-response r additional))))

(define (response-maybe-add-connection-header-value request response)
  (if (memq 'close (response-connection response))
      ;; Nothing to do
      response
      (let* ((v (request-version request))
             (add-close-header?
              (case (car v)
                ((1)
                 (case (cdr v)
                   ((1) (memq 'close (request-connection request)))
                   ((0) (not (memq 'keep-alive (request-connection request))))))
                (else #t))))
        (if add-close-header?
            (extend-response response 'connection '(close))
            (if (and (= 1 (car v))
                     (= 0 (cdr v)))
                (extend-response response 'connection '(keep-alive))
                response)))))

;; -> response body
(define (sanitize-response request response body)
  "\"Sanitize\" the given response and body, making them appropriate for
the given request.

As a convenience to web handler authors, RESPONSE may be given as
an alist of headers, in which case it is used to construct a default
response.  Ensures that the response version corresponds to the request
version.  If BODY is a string, encodes the string to a bytevector,
in an encoding appropriate for RESPONSE.  Adds a
‘content-length’ and ‘content-type’ header, as necessary.

If BODY is a procedure, it is called with a port as an argument,
and the output collected as a bytevector.  In the future we might try to
instead use a compressing, chunk-encoded port, and call this procedure
later, in the write-client procedure.  Authors are advised not to rely
on the procedure being called at any particular time."
  (cond
   ((list? response)
    (sanitize-response request
                       (build-response #:version (request-version request)
                                       #:headers response)
                       body))
   ((not (equal? (request-version request) (response-version response)))
    (sanitize-response request
                       (adapt-response-version response
                                               (request-version request))
                       body))
   ((string? body)
    (let* ((type (response-content-type response
                                        '(text/plain)))
           (declared-charset (assq-ref (cdr type) 'charset))
           (charset (or declared-charset "utf-8")))
      (sanitize-response
       request
       (if declared-charset
           response
           (extend-response response 'content-type
                            `(,@type (charset . ,charset))))
       (string->bytevector body charset))))
   ((not (or (bytevector? body)
             (procedure? body)
             (eq? #f body)))
    (raise-exception
     (make-exception-with-irritants
      (list (make-exception-with-message
             "unexpected body type")
            body))))
   ((and (response-must-not-include-body? response)
         body)
    (raise-exception
     (make-exception-with-irritants
      (list (make-exception-with-message
             "response with this status code must not include body")
            response))))
   (else
    ;; check length; assert type; add other required fields?
    (values (response-maybe-add-connection-header-value
             request
             (cond
              ((procedure? body)
               (if (response-content-length response)
                   response
                   (extend-response response
                                    'transfer-encoding
                                    '((chunked)))))
              ((bytevector? body)
               (let ((rlen (response-content-length response))
                     (blen (bytevector-length body)))
                 (cond
                  (rlen (if (= rlen blen)
                            response
                            (error "bad content-length" rlen blen)))
                  (else (extend-response response 'content-length blen)))))
              (else response)))
            (if (eq? (request-method request) 'HEAD)
                #f
                body)))))

(define (with-stack-and-prompt thunk)
  (call-with-prompt (default-prompt-tag)
                    (lambda () (start-stack #t (thunk)))
                    (lambda (k proc)
                      (with-stack-and-prompt (lambda () (proc k))))))

(define (keep-alive? response)
  (not (memq 'close (response-connection response))))

(define (default-read-request-exception-handler exn)
  (display/knots "While reading request:\n" (current-error-port))
  (print-exception
   (current-error-port)
   #f
   '%exception
   (list exn))

  #f)

(define (default-write-response-exception-handler exn request)
  "Default handler for exceptions raised while writing an HTTP response.
Logs the error for REQUEST to the current error port."
  (if (and (exception-with-origin? exn)
           (string=? (exception-origin exn)
                     "fport_write"))
      (simple-format/knots
       (current-error-port)
       "~A ~A: error replying to client\n"
       (request-method request)
       (uri-path (request-uri request)))
      (simple-format/knots
       (current-error-port)
       "knots web server: ~A ~A: exception replying to client: ~A\n"
       (request-method request)
       (uri-path (request-uri request))
       exn))

  ;; Close the client port
  #f)

(define* (handle-request handler client sockaddr
                         read-request-exception-handler
                         write-response-exception-handler
                         buffer-size
                         #:key post-request-hook)
  (define meta
    `((sockaddr . ,sockaddr)))

  (let ((request
         (with-exception-handler
             read-request-exception-handler
           (lambda ()
             (read-request client meta))
           #:unwind? #t))
        (read-request-time
         (get-internal-real-time)))
    (let ((response
           body
           (cond
            ((not request)
             ;; Bad request.
             (values (build-response
                      #:version '(1 . 0)
                      #:code 400
                      #:headers '((content-length . 0)
                                  (connection . (close))))
                     #vu8()))
            (else
             (with-exception-handler
                 (lambda (exn)
                   (sanitize-response
                    request
                    (build-response #:code 500)
                    (string->utf8
                     "internal server error")))
               (lambda ()
                 (with-exception-handler
                     (lambda (exn)
                       (let* ((error-string
                               (call-with-output-string
                                 (lambda (port)
                                   (simple-format
                                    port
                                    "exception when processing: ~A ~A\n"
                                    (request-method request)
                                    (uri-path (request-uri request)))
                                   (print-backtrace-and-exception/knots
                                    exn
                                    #:port port)))))
                         (display/knots error-string
                                        (current-error-port))))
                   (lambda ()
                     (start-stack
                      #t
                      (call-with-values
                          (lambda ()
                            (handler request))
                        (match-lambda*
                          ((response body)
                           (sanitize-response request response body))
                          (other
                           (raise-exception
                            (make-exception-with-irritants
                             (list (make-exception-with-message
                                    (simple-format
                                     #f
                                     "wrong number of values returned from handler, expecting 2, got ~A"
                                     (length other)))
                                   handler))))))))))
               #:unwind? #t)))))
      (with-exception-handler
          (lambda (exn)
            (write-response-exception-handler exn request))
        (lambda ()
          (write-response response client)

          (let ((response-start-time
                 (get-internal-real-time))
                (body-written?
                 (cond
                  ((and (procedure? body)
                        (not
                         (eq? (request-method request)
                              'HEAD)))
                   (let* ((type (response-content-type response
                                                       '(text/plain)))
                          (declared-charset (assq-ref (cdr type) 'charset))
                          (charset (or declared-charset "ISO-8859-1"))
                          (body-port
                           (if (response-content-length response)
                               client
                               (make-chunked-output-port/knots
                                client
                                #:keep-alive? #t
                                #:buffering
                                (- buffer-size
                                   (chunked-output-port-overhead-bytes
                                    buffer-size))))))
                     (set-port-encoding! body-port charset)
                     (let ((body-written?
                            (with-exception-handler
                                (lambda (exn)
                                  #f)
                              (lambda ()
                                (with-exception-handler
                                    (lambda (exn)
                                      (print-backtrace-and-exception/knots exn)
                                      (raise-exception exn))
                                  (lambda ()
                                    (body body-port)))
                                #t)
                              #:unwind? #t)))
                       (unless (response-content-length response)
                         (close-port body-port))
                       body-written?)))
                  ((bytevector? body)
                   (put-bytevector client body)
                   #t)
                  (else
                   ;; No body to write
                   #t))))
            (if body-written?
                (begin
                  (force-output client)
                  (when post-request-hook
                    (post-request-hook request
                                       #:read-request-time read-request-time
                                       #:response-start-time response-start-time
                                       #:response-end-time (get-internal-real-time)))
                  (when (and (procedure? body)
                             (response-content-length response))
                    (set-port-encoding! client "ISO-8859-1"))
                  (keep-alive? response))
                #f)))
        #:unwind? #t))))

(define* (client-loop client handler sockaddr
                      read-request-exception-handler
                      write-response-exception-handler
                      connection-idle-timeout
                      buffer-size
                      post-request-hook)
  ;; Always disable Nagle's algorithm, as we handle buffering
  ;; ourselves; when we force-output, we really want the data to go
  ;; out.
  (setvbuf client 'block buffer-size)
  (setsockopt client IPPROTO_TCP TCP_NODELAY 1)
  (let loop ()
    (cond
     ((with-exception-handler
          (lambda (exn)
            (unless (and (exception-with-origin? exn)
                         (string=? (exception-origin exn)
                                   "fport_read"))
              (display/knots "knots web-server, exception in client loop:\n"
                             (current-error-port))
              (display/knots
               (call-with-output-string
                 (lambda (port)
                   (print-exception
                    port
                    #f
                    '%exception
                    (list exn))))
               (current-error-port)))
            #t)
        (lambda ()
          (or
           (if (eq? #f connection-idle-timeout)
               #f
               (perform-operation
                (choice-operation (wrap-operation
                                   (wait-until-port-readable-operation client)
                                   (const #f))
                                  (wrap-operation
                                   (sleep-operation connection-idle-timeout)
                                   (const #t)))))
           (eof-object? (lookahead-u8 client))))
        #:unwind? #t)
      (close-port client))
     (else
      (let ((keep-alive? (handle-request handler client sockaddr
                                         read-request-exception-handler
                                         write-response-exception-handler
                                         buffer-size
                                         #:post-request-hook
                                         post-request-hook)))
        (if keep-alive?
            (loop)
            (close-port client)))))))

(define (post-request-hook/safe post-request-hook)
  (if post-request-hook
      (lambda args
        (with-exception-handler
            (lambda (exn) #f)
          (lambda ()
            (with-exception-handler
                (lambda (exn)
                  (print-backtrace-and-exception/knots exn)
                  (raise-exception exn))
              (lambda ()
                (apply post-request-hook args))))
          #:unwind? #t))
      #f))

(define-record-type <web-server>
  (make-web-server socket port)
  web-server?
  (socket    web-server-socket)
  (port      web-server-port))
(set-procedure-property!
 (macro-transformer (module-ref (current-module) 'web-server?))
 'documentation
 "Return @code{#t} if OBJ is a @code{<web-server>}.")
(set-procedure-property!
 (macro-transformer (module-ref (current-module) 'web-server-socket))
 'documentation
 "Return the socket of the web server.")
(set-procedure-property!
 (macro-transformer (module-ref (current-module) 'web-server-port))
 'documentation
 "Return the port number of the web server.")

(define* (run-knots-web-server handler #:key
                               (host #f)
                               (family AF_INET)
                               (addr (if host
                                         (inet-pton family host)
                                         INADDR_LOOPBACK))
                               (port 8080)
                               (socket (make-default-socket family addr port))
                               (read-request-exception-handler
                                default-read-request-exception-handler)
                               (write-response-exception-handler
                                default-write-response-exception-handler)
                               (connection-idle-timeout #f)
                               (connection-buffer-size 1024)
                               post-request-hook)
  "Run the knots web server.

HANDLER should be a procedure that takes one argument, the HTTP
request and returns two values, the response and response body.

For example, here is a simple \"Hello, World!\" server:

@example
 (define (handler request)
   (let ((body (read-request-body request)))
     (values '((content-type . (text/plain)))
             \"Hello, World!\")))
 (run-knots-web-server handler)
@end example

The response and body will be run through ‘sanitize-response’
before sending back to the client."
  (non-blocking-port socket)
  ;; We use a large backlog by default.  If the server is suddenly hit
  ;; with a number of connections on a small backlog, clients won't
  ;; receive confirmation for their SYN, leading them to retry --
  ;; probably successfully, but with a large latency.
  (listen socket 1024)
  (sigaction SIGPIPE SIG_IGN)

  (spawn-fiber
   (lambda ()
     (while #t
       (with-exception-handler
           (const #t)
         (lambda ()
           (with-exception-handler
               (lambda (exn)
                 (print-backtrace-and-exception/knots exn))
             (lambda ()
               (let loop ()
                 (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC))
                   ((client . sockaddr)
                    (spawn-fiber (lambda ()
                                   (client-loop client handler sockaddr
                                                read-request-exception-handler
                                                write-response-exception-handler
                                                connection-idle-timeout
                                                connection-buffer-size
                                                (post-request-hook/safe
                                                 post-request-hook)))
                                 #:parallel? #t)
                    (loop)))))))
         #:unwind? #t))))

  (make-web-server socket
                   (vector-ref (getsockname socket)
                               2)))  ; Not sure what this structure is
