HTTP driver
This commit is contained in:
parent
bd5cb6e35c
commit
9cbe11b32d
|
@ -0,0 +1,394 @@
|
|||
#lang syndicate
|
||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||
;;; SPDX-FileCopyrightText: Copyright © 2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
|
||||
(provide (all-from-out syndicate/schemas/http)
|
||||
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)
|
||||
|
||||
(provide-service [ds]
|
||||
(at ds
|
||||
(during/spawn (HttpBinding _ $port _ _ _)
|
||||
#:name `(http-server ,port)
|
||||
(define routes (make-hash)) ;; hostname -> method -> path-pattern -> (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 method-map (hash-ref! routes host make-hash))
|
||||
(define pattern-map (hash-ref! method-map method make-hash))
|
||||
(define handler-set (hash-ref! pattern-map path mutable-set))
|
||||
(unless (set-empty? handler-set)
|
||||
(log-syndicate/drivers/http-warning "Multiple active handlers for ~v" service))
|
||||
(set-add! handler-set handler)
|
||||
(on-stop (set-remove! handler-set handler)
|
||||
(when (set-empty? handler-set) (hash-remove! pattern-map path))
|
||||
(when (hash-empty? pattern-map) (hash-remove! method-map method))
|
||||
(when (hash-empty? method-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 ~v" connection-name routes req close?)
|
||||
(define continue-ch (make-async-channel))
|
||||
(turn! facet
|
||||
(lambda ()
|
||||
(react
|
||||
(local-connection-protocol ds connection-name conn 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 routes req)
|
||||
(let/ec return
|
||||
|
||||
(define (respond! resp)
|
||||
(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-values (host port)
|
||||
(match host-and-port
|
||||
[(regexp #px"(.*):(\\d+)" (list _ host port)) (values host (string->number port))]
|
||||
[host (values host 80)]))
|
||||
|
||||
(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-method method-map m)
|
||||
(define pattern-map (hash-ref method-map m hash))
|
||||
(for [((path-pattern handler-set) (in-hash pattern-map))]
|
||||
(when (path-pattern-matches? path-pattern path)
|
||||
(define handler (set-first handler-set))
|
||||
(define pending-code #f)
|
||||
(define pending-message #f)
|
||||
(define pending-headers-rev '())
|
||||
(define chunk-ch #f)
|
||||
(define res (object #:name connection-name
|
||||
[#:message (HttpResponse-status code message)
|
||||
(set! pending-code code)
|
||||
(set! pending-message message)]
|
||||
[#:message (HttpResponse-header name value)
|
||||
(set! pending-headers-rev (cons (cons name value) pending-headers-rev))]
|
||||
[#:message (HttpResponse-chunk chunk)
|
||||
(unless chunk-ch
|
||||
(set! chunk-ch (make-async-channel))
|
||||
(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) (loop)]))))
|
||||
(request-method req)))
|
||||
(async-channel-put chunk-ch (chunk->bytes chunk))]
|
||||
[#:message (HttpResponse-done chunk)
|
||||
(if chunk-ch
|
||||
(begin (async-channel-put chunk-ch (chunk->bytes chunk))
|
||||
(async-channel-put chunk-ch #f))
|
||||
(output-response/method
|
||||
conn
|
||||
(response/full pending-code
|
||||
(string->bytes/utf-8 pending-message)
|
||||
(current-seconds)
|
||||
#f
|
||||
(build-headers (reverse pending-headers-rev))
|
||||
(list (chunk->bytes chunk)))
|
||||
(request-method req)))
|
||||
(stop-current-facet)]))
|
||||
(at handler (assert (HttpContext decoded-req res)))
|
||||
(return (void)))))
|
||||
|
||||
(define (try-hostname n)
|
||||
(define method-map (hash-ref routes n hash))
|
||||
(try-method method-map method)
|
||||
(try-method method-map #f))
|
||||
|
||||
(begin (try-hostname 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 (chunk->bytes c)
|
||||
(match c
|
||||
[(Chunk-string s) (string->bytes/utf-8 s)]
|
||||
[(Chunk-bytes bs) bs]))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(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 body ...)]
|
||||
[_ (send-http-response! res 400 "Bad request path")]))))])))
|
||||
|
||||
(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]
|
||||
. 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))
|
||||
(cond [(null? chunks) (send! res (HttpResponse-done ""))]
|
||||
[(null? (cdr chunks)) (send! res (HttpResponse-done (car chunks)))]
|
||||
[else (send! res (HttpResponse-chunk (car chunks))) (loop (cdr chunks))])))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(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)) ...
|
||||
(call-with-values
|
||||
(lambda () body ...)
|
||||
(lambda vs
|
||||
(match vs
|
||||
[(list mime-type reply)
|
||||
(log-syndicate/drivers/http-debug "REPLY: ~a ~a" mime-type (pretty-format reply))
|
||||
(send-http-response! res 200 "OK" #:mime-type mime-type reply)]
|
||||
[(or (list #f #f)
|
||||
(list #f)
|
||||
(list (? void?)))
|
||||
(log-syndicate/drivers/http-debug "NO IMMEDIATE REPLY")]))))))
|
||||
|
||||
(define-syntax-rule (define-json-route [pat ... res]
|
||||
[(info parse-body ...) ...]
|
||||
body ...)
|
||||
(define-http-route [pat ... res]
|
||||
[(info parse-body ...) ...]
|
||||
(define reply (let () body ...))
|
||||
(if (and reply (not (void? reply)))
|
||||
(json-response reply)
|
||||
(values #f #f))))
|
||||
|
||||
(define (json-body req)
|
||||
(string->jsexpr (bytes->string/utf-8 (RequestBody-present-value (HttpRequest-body req)))))
|
||||
|
||||
(define (json-response v)
|
||||
(values 'application/json (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 req rel)
|
||||
(local-require net/url)
|
||||
(url->string (combine-url/relative
|
||||
(string->url (format "https://~a/~a"
|
||||
(HttpRequest-host req)
|
||||
(string-join (HttpRequest-path req) "/")))
|
||||
rel)))
|
Loading…
Reference in New Issue