453 lines
20 KiB
Racket
453 lines
20 KiB
Racket
#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)))
|