#lang syndicate
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2022-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

(provide (all-from-out syndicate/schemas/http)
         (struct-out mime)
         ->mime
         define-http-route
         define-plain-http-route
         headers-ref
         query-ref
         send-http-response!
         define-json-route
         json-body
         json-response
         send-json!
         resolve-req-relative-uri)

(require syndicate/schemas/http)

(require (for-syntax racket/base))
(require (for-syntax racket/syntax))
(require (for-syntax syntax/parse))
(require json)
(require net/url)
(require racket/async-channel)
(require racket/exn)
(require (only-in racket/format ~a))
(require racket/pretty)
(require racket/string)
(require racket/tcp)
(require syndicate/driver-support)
(require syndicate/async)

(require web-server/http/bindings)
(require web-server/http/cookie)
(require web-server/http/cookie-parse)
(require web-server/http/request)
(require web-server/http/request-structs)
(require web-server/http/response)
(require web-server/http/response-structs)
(require web-server/private/connection-manager)
(require (only-in web-server/private/util lowercase-symbol!))

(define-logger syndicate/drivers/http)

(struct active-handler (ref signal) #:transparent)

(provide-service [ds]
  (at ds
      (during/spawn (HttpBinding _ $port _ _ _)
        #:name `(http-server ,port)
        (define routes (make-hash)) ;; hostname -> path-pattern -> method -> (set handler)
        (run-listener ds port routes)
        (at ds
          (during (HttpListener port)
            (during (HttpBinding $host port $method $path $handler)
              (define service (HttpService host port method path))
              (define pattern-map (hash-ref! routes host make-hash))
              (define method-map (hash-ref! pattern-map path make-hash))
              (define handler-set (hash-ref! method-map method mutable-set))
              (unless (set-empty? handler-set)
                (log-syndicate/drivers/http-warning "Multiple active handlers for ~v" service))
              (define-field handler-terminated? #f)
              (define entry (active-handler handler handler-terminated?))
              (set-add! handler-set entry)
              (on-stop (handler-terminated? #t)
                       (set-remove! handler-set entry)
                       (when (set-empty? handler-set) (hash-remove! method-map method))
                       (when (hash-empty? method-map) (hash-remove! pattern-map path))
                       (when (hash-empty? pattern-map) (hash-remove! routes host)))
              (assert service)))))))

(define (run-listener ds port routes)
  (define listener-custodian (make-custodian))
  (on-start (log-syndicate/drivers/http-info "+listener on ~v" port))
  (on-stop  (log-syndicate/drivers/http-info "-listener on ~v" port))
  (actor-add-exit-hook! this-actor (lambda () (custodian-shutdown-all listener-custodian)))
  (linked-thread
   #:name (list 'http-listener port)
   (lambda (facet)
     (parameterize ((current-custodian listener-custodian))
       (define cm (start-connection-manager))
       (define listener (tcp-listen port 511 #t))
       (turn! facet (lambda () (at ds (assert (HttpListener port)))))
       (let loop ()
         (define connection-custodian (make-custodian listener-custodian))
         (define-values (i o) (parameterize ((current-custodian connection-custodian))
                                (tcp-accept listener)))
         (turn! facet (lambda ()
                        (parameterize ((current-custodian connection-custodian))
                          (react
                            (on-stop (custodian-shutdown-all connection-custodian))
                            (handle-connection ds cm i o port routes)))))
         (loop))))))

(define (handle-connection ds cm i o port routes)
  (define conn (new-connection cm 30 i o (make-custodian) #f))
  (define connection-name (gensym 'http-connection))
  (linked-thread
   #:name connection-name
   (lambda (facet)
     (let process-requests ()
       (define-values (req close?)
         (with-handlers ([exn:fail? (lambda (e) (values #f #t))])
           (read-request conn port tcp-addresses)))
       (when req
         ;; (log-syndicate/drivers/http-debug "~v ~v ~v ~v" connection-name routes req close?)
         (define continue-ch (make-async-channel))
         (turn! facet
                (lambda ()
                  (react
                    (local-connection-protocol ds connection-name conn port routes req)
                    (on-stop (async-channel-put continue-ch 'dummy)))))
         (async-channel-get continue-ch)
         (unless close? (process-requests)))))))

(define next-request-id (inexact->exact (floor (current-inexact-milliseconds))))

(define (local-connection-protocol ds connection-name conn port routes req)
  (let/ec return

    (define reply-sent? #f)
    (define (unless-reply-sent thunk)
      (unless reply-sent?
        (set! reply-sent? #t)
        (thunk)))

    (define (respond! resp)
      (unless-reply-sent
       (lambda ()
         (output-response/method conn resp (request-method req))))
      (stop-current-facet))

    (define (decode-bytes bs)
      (with-handlers [(exn:fail? (lambda (e)
                                   (respond! (response/full 400
                                                            #"Bad Request"
                                                            (current-seconds)
                                                            #"text/plain"
                                                            (list)
                                                            (list #"Invalid UTF-8")))
                                   (return (void))))]
        (bytes->string/utf-8 bs)))

    (define (headers-map hs)
      (for/hash [(h hs)]
        (values (lowercase-symbol! (decode-bytes (header-field h)))
                (decode-bytes (header-value h)))))

    (define (build-headers hs)
      (for/list ((h (in-list hs)))
        (header (string->bytes/utf-8 (symbol->string (car h)))
                (string->bytes/utf-8 (cdr h)))))

    (define headers (headers-map (request-headers/raw req)))

    (define host-and-port (cond [(assq 'host (request-headers req)) => cdr] [else #f]))
    (define host
      (match host-and-port
        [#f (RequestHost-absent)]
        [(regexp #px"(.*):\\d+" (list _ host)) (RequestHost-present host)]
        [host (RequestHost-present host)]))

    (define method (lowercase-symbol! (decode-bytes (request-method req))))

    (define path (map path/param-path (url-path (request-uri req))))

    (define query (for/fold [(q (hash))] [(b (in-list (request-bindings/raw req)))]
                    (match-define (binding id-bytes) b)
                    (define id (string->symbol (decode-bytes id-bytes)))
                    (hash-set q
                              id
                              (append (hash-ref q id '())
                                      (list (match b
                                              [(binding:form _ value)
                                               (QueryValue-string (decode-bytes value))]
                                              [(binding:file _ filename headers content)
                                               (QueryValue-file (decode-bytes filename)
                                                                (headers-map headers)
                                                                content)]))))))

    (define body (request-post-data/raw req))

    (define req-id next-request-id)
    (set! next-request-id (+ req-id 1))

    (define decoded-req (HttpRequest req-id host port method path headers query body))
    (at ds (assert decoded-req))

    (define (try-hostname n)
      (define pattern-map (hash-ref routes n hash))
      (for [((path-pattern method-map) (in-hash pattern-map))]
        (when (path-pattern-matches? path-pattern path)
          (define handler-set (or (hash-ref method-map method #f)
                                  (hash-ref method-map #f #f)
                                  (let ((methods (string->bytes/utf-8
                                                  (string-join
                                                   (for/list [(m (in-list (hash-keys method-map)))]
                                                     (string-upcase (symbol->string m)))
                                                   ", "))))
                                    (respond! (response/full 405
                                                             #"Method Not Allowed"
                                                             (current-seconds)
                                                             #"text/plain"
                                                             (list (header #"Allow" methods))
                                                             (list)))
                                    (return (void)))))
          (match-define (active-handler handler handler-terminated?) (set-first handler-set))
          (define pending-code 200)
          (define pending-message "OK")
          (define pending-headers-rev '())
          (define chunk-ch #f)

          (define (start-chunked-response!)
            (unless chunk-ch
              (set! chunk-ch (make-async-channel))
              (thread
               (lambda ()
                 (unless-reply-sent
                  (lambda ()
                    (output-response/method conn
                                            (response pending-code
                                                      (string->bytes/utf-8 pending-message)
                                                      (current-seconds)
                                                      #f
                                                      (build-headers (reverse pending-headers-rev))
                                                      (lambda (output-port)
                                                        (let loop ()
                                                          (match (async-channel-get chunk-ch)
                                                            [#f (void)]
                                                            [bs
                                                             (write-bytes bs output-port)
                                                             (flush-output output-port)
                                                             (loop)]))))
                                            (request-method req))))))))

          (define (send-final-chunk! chunk)
            (define bs (chunk->bytes chunk))
            (if chunk-ch
                (begin (async-channel-put chunk-ch bs)
                       (async-channel-put chunk-ch #f)
                       (stop-current-facet))
                (respond! (response/full pending-code
                                         (string->bytes/utf-8 pending-message)
                                         (current-seconds)
                                         #f
                                         (build-headers (reverse pending-headers-rev))
                                         (list bs)))))

          (begin/dataflow
            (when (handler-terminated?)
              (set! pending-code 500)
              (set! pending-message "Internal Server Error")
              (set! pending-headers-rev '())
              (send-final-chunk! *empty-chunk*)))

          (define res (object #:name connection-name
                              [#:message (HttpResponse-status code message)
                               (log-syndicate/drivers/http-debug "~v: status ~v ~v" connection-name
                                                                 code message)
                               (set! pending-code code)
                               (set! pending-message message)]
                              [#:message (HttpResponse-header name value)
                               (log-syndicate/drivers/http-debug "~v: header ~v ~v" connection-name
                                                                 name value)
                               (set! pending-headers-rev (cons (cons name value) pending-headers-rev))]
                              [#:message (HttpResponse-chunk chunk)
                               (start-chunked-response!)
                               (async-channel-put chunk-ch (chunk->bytes chunk))]
                              [#:message (HttpResponse-done chunk)
                               (send-final-chunk! chunk)]))
          (at handler (assert (HttpContext decoded-req res)))
          (return (void)))))

    (begin (when (RequestHost-present? host)
             (try-hostname (RequestHost-present-value host)))
           (try-hostname #f)
           (respond! (response/full 404
                                    #"Not Found"
                                    (current-seconds)
                                    #"text/plain"
                                    (list)
                                    (list))))))

(define (path-pattern-matches? pat p)
  (let loop ((pat pat) (p p))
    (match* [pat p]
      [['() '()] #t]
      [[(list '...) p] #t]
      [[(cons '_ pat) (cons _ p)] (loop pat p)]
      [[(cons expected pat) (cons actual p)] #:when (equal? expected actual) (loop pat p)]
      [[_ _] #f])))

(define *empty-chunk* (Chunk-bytes #""))

(define (chunk->bytes c)
  (match c
    [(Chunk-string s) (string->bytes/utf-8 s)]
    [(Chunk-bytes bs) bs]))

;;---------------------------------------------------------------------------

(struct mime (type data) #:prefab)

(define (->mime v)
  (match v
    [(mime (? symbol?) (? bytes?)) v]
    [(? string?) (mime 'text/plain (string->bytes/utf-8 v))]
    [(? bytes?) (mime 'application/octet-stream v)]
    [_ v]))

(define-syntax define-plain-http-route
  (lambda (stx)
    (syntax-parse stx
      [(_ [host port method [path-pattern-element ...] req res] body ...)
       (quasisyntax/loc stx
         (define-http-route*
           this-target
           (lambda () host)
           (lambda () port)
           (lambda () method)
           (lambda () (quote-path-pattern () (path-pattern-element ...)))
           (lambda (req res)
             (match (HttpRequest-path req)
               [#,(match-quote-path-pattern #'(path-pattern-element ...))
                (async (match (let () body ...)
                         [(mime (? symbol? type) (or (? bytes? data) (? string? data)))
                          (log-syndicate/drivers/http-debug "REPLY: ~a ~v" type data)
                          (send-http-response! res 200 "OK" #:mime-type type data)]
                         [(? void?)
                          (log-syndicate/drivers/http-debug "Assuming that reply sent previously")]
                         [bad
                          (log-syndicate/drivers/http-error "Bad MIME response: ~v" bad)
                          (send-http-response! res 500 "Internal Server Error")]))]
               [_ (send-http-response! res 400 "Bad request path")])
             (stop-current-facet))))])))

(define (define-http-route* ds host port method path-pattern handler)
  (at ds
    (assert (HttpBinding (host) (port) (method) (path-pattern)
                         (object
                           #:name (list 'http-route (host) (port) (method) (->preserve (path-pattern)))
                           [(HttpContext req res)
                            (handler req res)])))))

(define-syntax quote-path-pattern
  (lambda (stx)
    (syntax-parse stx
      #:datum-literals ((___ ...) (* _))
      [(_ (e ...) ())
       #'(list e ...)]
      [(_ (e ...) (id ___))
       #:when (identifier? #'id)
       #'(list e ... (PathPatternElement-rest))]
      [(_ (e ...) (* more ...))
       #'(quote-path-pattern (e ... (PathPatternElement-wildcard)) (more ...))]
      [(_ (e ...) (id more ...))
       #:when (identifier? #'id)
       #'(quote-path-pattern (e ... (PathPatternElement-wildcard)) (more ...))]
      [(_ (e ...) (label more ...))
       #'(quote-path-pattern (e ... (PathPatternElement-label label)) (more ...))])))

(define-for-syntax match-quote-path-pattern
  (lambda (elements)
    (let loop ((pieces '()) (elements elements))
      (syntax-parse elements
        #:datum-literals ((___ ...) (* _))
        [() #`(list #,@pieces)]
        [(id ___) #:when (identifier? #'id) #`(list* #,@pieces id)]
        [(* more ...) (loop (append pieces (list #`_)) #`(more ...))]
        [(id more ...) #:when (identifier? #'id) (loop (append pieces (list #`id)) #`(more ...))]
        [(label more ...) (loop (append pieces (list #`_)) #`(more ...))]))))

(define (headers-ref req name [default (lambda () (error 'headers-ref "Missing header ~v" name))])
  (hash-ref (Headers-value (HttpRequest-headers req)) name default))

(define (apply0 v)
  (if (procedure? v)
      (v)
      v))

(define (query-ref req name [default (lambda () (error 'query-ref "Missing query parameter ~v" name))])
  (QueryValue-string-value
   (car (hash-ref (HttpRequest-query req)
                  name
                  (lambda () (list (QueryValue-string (apply0 default))))))))

(define (send-http-response! res code message
                             #:headers [headers '()]
                             #:mime-type [mime-type #f]
                             #:done? [done? #t]
                             . chunks)
  (send! res (HttpResponse-status code message))
  (when mime-type
    (send! res (HttpResponse-header 'content-type (~a mime-type)))
    (set! headers (filter (lambda (h) (not (string-ci=? (symbol->string (car h)) "content-type")))
                          headers)))
  (for [(header headers)]
    (match-define (cons name value) header)
    (send! res (HttpResponse-header name value)))
  (let loop ((chunks chunks))
    (match chunks
      ['() (when done? (send! res (HttpResponse-done *empty-chunk*)))]
      [(list ch) (send! res ((if done? HttpResponse-done HttpResponse-chunk) ch))]
      [(cons ch more) (send! res (HttpResponse-chunk ch)) (loop more)])))

;;---------------------------------------------------------------------------

(define-syntax-rule (define-http-route [pat ... res]
                      [(info parse-body ...) ...]
                      body ...)
  (define-plain-http-route [pat ... res]
    (let/ec escape
      (define-values (info ...)
        (with-handlers [((lambda (e) #t)
                         (lambda (e)
                           (if (exn? e)
                               (log-syndicate/drivers/http-error "BAD REQUEST: ~a" (exn->string e))
                               (log-syndicate/drivers/http-error "NON-EXN ERROR: ~v" e))
                           (send-http-response! res 400 "Bad Request")
                           (escape (void))))]
          (let ()
            (define info (let () parse-body ...)) ...
            (values info ...))))
      (log-syndicate/drivers/http-debug "INFO: ~a = ~a" 'info (pretty-format info)) ...
      (->mime (let () body ...)))))

(define-syntax-rule (define-json-route [pat ... res]
                      [(info parse-body ...) ...]
                      body ...)
  (define-http-route [pat ... res]
    [(info parse-body ...) ...]
    (match (let () body ...) [(? void?) (void)] [j (json-response j)])))

(define (json-body req)
  (string->jsexpr (bytes->string/utf-8 (RequestBody-present-value (HttpRequest-body req)))))

(define (json-response v)
  (mime 'application/json (string->bytes/utf-8 (jsexpr->string (->preserve v)))))

(define (send-json! res v)
  (send-http-response! res 200 "OK" #:mime-type 'application/json (jsexpr->string (->preserve v))))

(define (resolve-req-relative-uri #:scheme [scheme "https"] req rel)
  (local-require net/url)
  (url->string (combine-url/relative
                (string->url (format "~a://~a/~a"
                                     scheme
                                     (HttpRequest-host req)
                                     (string-join (HttpRequest-path req) "/")))
                rel)))