drivers/http: avoid values, better async usage
This commit is contained in:
parent
b4b44b6444
commit
271da81942
|
@ -3,6 +3,8 @@
|
||||||
;;; SPDX-FileCopyrightText: Copyright © 2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
;;; SPDX-FileCopyrightText: Copyright © 2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||||
|
|
||||||
(provide (all-from-out syndicate/schemas/http)
|
(provide (all-from-out syndicate/schemas/http)
|
||||||
|
(struct-out mime)
|
||||||
|
->mime
|
||||||
define-http-route
|
define-http-route
|
||||||
define-plain-http-route
|
define-plain-http-route
|
||||||
headers-ref
|
headers-ref
|
||||||
|
@ -251,6 +253,15 @@
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(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
|
(define-syntax define-plain-http-route
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
|
@ -265,7 +276,19 @@
|
||||||
(lambda (req res)
|
(lambda (req res)
|
||||||
(match (HttpRequest-path req)
|
(match (HttpRequest-path req)
|
||||||
[#,(match-quote-path-pattern #'(path-pattern-element ...))
|
[#,(match-quote-path-pattern #'(path-pattern-element ...))
|
||||||
(async body ...)]
|
(async (match (with-handlers [((lambda (e) #t)
|
||||||
|
(lambda (e)
|
||||||
|
(send-http-response! res 500 "Internal Server Error")
|
||||||
|
(raise e)))]
|
||||||
|
(let () body ...))
|
||||||
|
[(mime (? symbol? type) (? bytes? 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")]))))])))
|
[_ (send-http-response! res 400 "Bad request path")]))))])))
|
||||||
|
|
||||||
(define (define-http-route* ds host port method path-pattern handler)
|
(define (define-http-route* ds host port method path-pattern handler)
|
||||||
|
@ -333,7 +356,8 @@
|
||||||
(let loop ((chunks chunks))
|
(let loop ((chunks chunks))
|
||||||
(cond [(null? chunks) (send! res (HttpResponse-done ""))]
|
(cond [(null? chunks) (send! res (HttpResponse-done ""))]
|
||||||
[(null? (cdr chunks)) (send! res (HttpResponse-done (car chunks)))]
|
[(null? (cdr chunks)) (send! res (HttpResponse-done (car chunks)))]
|
||||||
[else (send! res (HttpResponse-chunk (car chunks))) (loop (cdr chunks))])))
|
[else (send! res (HttpResponse-chunk (car chunks))) (loop (cdr chunks))]))
|
||||||
|
(void))
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -354,41 +378,29 @@
|
||||||
(define info (let () parse-body ...)) ...
|
(define info (let () parse-body ...)) ...
|
||||||
(values info ...))))
|
(values info ...))))
|
||||||
(log-syndicate/drivers/http-debug "INFO: ~a = ~a" 'info (pretty-format info)) ...
|
(log-syndicate/drivers/http-debug "INFO: ~a = ~a" 'info (pretty-format info)) ...
|
||||||
(call-with-values
|
(->mime (let () body ...)))))
|
||||||
(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]
|
(define-syntax-rule (define-json-route [pat ... res]
|
||||||
[(info parse-body ...) ...]
|
[(info parse-body ...) ...]
|
||||||
body ...)
|
body ...)
|
||||||
(define-http-route [pat ... res]
|
(define-http-route [pat ... res]
|
||||||
[(info parse-body ...) ...]
|
[(info parse-body ...) ...]
|
||||||
(define reply (let () body ...))
|
(match (let () body ...) [(? void?) (void)] [j (json-response j)])))
|
||||||
(if (and reply (not (void? reply)))
|
|
||||||
(json-response reply)
|
|
||||||
(values #f #f))))
|
|
||||||
|
|
||||||
(define (json-body req)
|
(define (json-body req)
|
||||||
(string->jsexpr (bytes->string/utf-8 (RequestBody-present-value (HttpRequest-body req)))))
|
(string->jsexpr (bytes->string/utf-8 (RequestBody-present-value (HttpRequest-body req)))))
|
||||||
|
|
||||||
(define (json-response v)
|
(define (json-response v)
|
||||||
(values 'application/json (jsexpr->string (->preserve v))))
|
(mime 'application/json (string->bytes/utf-8 (jsexpr->string (->preserve v)))))
|
||||||
|
|
||||||
(define (send-json! res v)
|
(define (send-json! res v)
|
||||||
(send-http-response! res 200 "OK" #:mime-type 'application/json (jsexpr->string (->preserve v))))
|
(send-http-response! res 200 "OK" #:mime-type 'application/json (jsexpr->string (->preserve v))))
|
||||||
|
|
||||||
(define (resolve-req-relative-uri req rel)
|
(define (resolve-req-relative-uri #:scheme [scheme "https"] req rel)
|
||||||
(local-require net/url)
|
(local-require net/url)
|
||||||
(url->string (combine-url/relative
|
(url->string (combine-url/relative
|
||||||
(string->url (format "https://~a/~a"
|
(string->url (format "~a://~a/~a"
|
||||||
|
scheme
|
||||||
(HttpRequest-host req)
|
(HttpRequest-host req)
|
||||||
(string-join (HttpRequest-path req) "/")))
|
(string-join (HttpRequest-path req) "/")))
|
||||||
rel)))
|
rel)))
|
||||||
|
|
Loading…
Reference in New Issue