syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

drivers/http: avoid values, better async usage

This commit is contained in:
Tony Garnock-Jones 2022-12-14 11:53:51 +13:00
parent b4b44b6444
commit 271da81942
1 changed files with 32 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
syndicate/drivers/http.rkt
View File

@ -3,6 +3,8 @@
;;; SPDX-FileCopyrightText: Copyright © 2022 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
@ -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
(lambda (stx)
(syntax-parse stx
@ -265,7 +276,19 @@
(lambda (req res)
(match (HttpRequest-path req)
[#,(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")]))))])))
(define (define-http-route* ds host port method path-pattern handler)
@ -333,7 +356,8 @@
(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))])))
[else (send! res (HttpResponse-chunk (car chunks))) (loop (cdr chunks))]))
(void))
;;---------------------------------------------------------------------------
@ -354,41 +378,29 @@
(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")]))))))
(->mime (let () body ...)))))
(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))))
(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)
(values 'application/json (jsexpr->string (->preserve 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 req rel)
(define (resolve-req-relative-uri #:scheme [scheme "https"] req rel)
(local-require net/url)
(url->string (combine-url/relative
(string->url (format "https://~a/~a"
(string->url (format "~a://~a/~a"
scheme
(HttpRequest-host req)
(string-join (HttpRequest-path req) "/")))
rel)))