New http server protocol implementation and example
This commit is contained in:
parent
e6234b7713
commit
0370c19e43
|
@ -0,0 +1,55 @@
|
||||||
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||||
|
;;; SPDX-FileCopyrightText: Copyright © 2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||||
|
|
||||||
|
#lang syndicate
|
||||||
|
;; Simple example of the HTTP server protocol and Racket implementation.
|
||||||
|
|
||||||
|
(require syndicate/drivers/http)
|
||||||
|
(require racket/pretty)
|
||||||
|
(require xml)
|
||||||
|
|
||||||
|
(define (html-response #:title title #:head [head '()] . body-items)
|
||||||
|
(parameterize ((current-unescaped-tags html-unescaped-tags)
|
||||||
|
(empty-tag-shorthand html-empty-tags))
|
||||||
|
(mime 'text/html
|
||||||
|
(string-append "<!DOCTYPE html>\n"
|
||||||
|
(xexpr->string
|
||||||
|
`(html
|
||||||
|
(head
|
||||||
|
(meta ((http-equiv "Content-Type") (content "text/html; charset=utf-8")))
|
||||||
|
(meta ((name "viewport") (content "width=device-width, initial-scale=1.0")))
|
||||||
|
(title ,title)
|
||||||
|
,@head)
|
||||||
|
(body ,@body-items)))))))
|
||||||
|
|
||||||
|
(module+ main
|
||||||
|
(standard-actor-system (ds)
|
||||||
|
(with-services [syndicate/drivers/http]
|
||||||
|
(spawn #:name 'logger
|
||||||
|
(at ds
|
||||||
|
(during (HttpRequest $id $host $port $method $path $headers $query $body)
|
||||||
|
(define start-time (current-inexact-milliseconds))
|
||||||
|
(on-start (log-info ":+ ~a ~a ~a ~a ~v" id method host port path))
|
||||||
|
(on-stop (define stop-time (current-inexact-milliseconds))
|
||||||
|
(define duration-ms (- stop-time start-time))
|
||||||
|
(log-info ":- ~a ~a ~a ~a ~v ~ams" id method host port path
|
||||||
|
duration-ms)))))
|
||||||
|
|
||||||
|
(spawn #:name 'server
|
||||||
|
(define-field counter 0)
|
||||||
|
|
||||||
|
(at ds
|
||||||
|
(define-http-route [#f 8080 'get [""] req res]
|
||||||
|
[]
|
||||||
|
(counter (+ (counter) 1))
|
||||||
|
(html-response #:title "Hello"
|
||||||
|
`(h1 "Hello world")
|
||||||
|
`(p "Counter " ,(number->string (counter)))
|
||||||
|
`(a ((href "/page2")) "Go forward")))
|
||||||
|
(define-http-route [#f 8080 'get ["page2"] req res]
|
||||||
|
[]
|
||||||
|
(html-response #:title "Page 2"
|
||||||
|
`(h1 "Second page")
|
||||||
|
`(a ((href "/")) "Go back")))))
|
||||||
|
|
||||||
|
)))
|
|
@ -44,6 +44,8 @@
|
||||||
|
|
||||||
(define-logger syndicate/drivers/http)
|
(define-logger syndicate/drivers/http)
|
||||||
|
|
||||||
|
(struct active-handler (ref signal) #:transparent)
|
||||||
|
|
||||||
(provide-service [ds]
|
(provide-service [ds]
|
||||||
(at ds
|
(at ds
|
||||||
(during/spawn (HttpBinding _ $port _ _ _)
|
(during/spawn (HttpBinding _ $port _ _ _)
|
||||||
|
@ -59,8 +61,11 @@
|
||||||
(define handler-set (hash-ref! method-map method mutable-set))
|
(define handler-set (hash-ref! method-map method mutable-set))
|
||||||
(unless (set-empty? handler-set)
|
(unless (set-empty? handler-set)
|
||||||
(log-syndicate/drivers/http-warning "Multiple active handlers for ~v" service))
|
(log-syndicate/drivers/http-warning "Multiple active handlers for ~v" service))
|
||||||
(set-add! handler-set handler)
|
(define-field handler-terminated? #f)
|
||||||
(on-stop (set-remove! handler-set handler)
|
(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 (set-empty? handler-set) (hash-remove! method-map method))
|
||||||
(when (hash-empty? method-map) (hash-remove! pattern-map path))
|
(when (hash-empty? method-map) (hash-remove! pattern-map path))
|
||||||
(when (hash-empty? pattern-map) (hash-remove! routes host)))
|
(when (hash-empty? pattern-map) (hash-remove! routes host)))
|
||||||
|
@ -100,7 +105,7 @@
|
||||||
(with-handlers ([exn:fail? (lambda (e) (values #f #t))])
|
(with-handlers ([exn:fail? (lambda (e) (values #f #t))])
|
||||||
(read-request conn port tcp-addresses)))
|
(read-request conn port tcp-addresses)))
|
||||||
(when req
|
(when req
|
||||||
;; (log-syndicate/drivers/http-debug "~v ~v ~v ~v ~v" connection-name routes req close?)
|
;; (log-syndicate/drivers/http-debug "~v ~v ~v ~v" connection-name routes req close?)
|
||||||
(define continue-ch (make-async-channel))
|
(define continue-ch (make-async-channel))
|
||||||
(turn! facet
|
(turn! facet
|
||||||
(lambda ()
|
(lambda ()
|
||||||
|
@ -192,48 +197,73 @@
|
||||||
(list (header #"Allow" methods))
|
(list (header #"Allow" methods))
|
||||||
(list)))
|
(list)))
|
||||||
(return (void)))))
|
(return (void)))))
|
||||||
(define handler (set-first handler-set))
|
(match-define (active-handler handler handler-terminated?) (set-first handler-set))
|
||||||
(define pending-code #f)
|
(define processing #f)
|
||||||
(define pending-message #f)
|
(define pending-code 500)
|
||||||
|
(define pending-message "Internal Server Error")
|
||||||
(define pending-headers-rev '())
|
(define pending-headers-rev '())
|
||||||
(define chunk-ch #f)
|
(define chunk-ch #f)
|
||||||
(define res (object #:name connection-name
|
|
||||||
[#:message (HttpResponse-status code message)
|
(define (check-processing!)
|
||||||
(set! pending-code code)
|
(unless processing
|
||||||
(set! pending-message message)]
|
(error 'HttpResponse "Attempt to reply before <processing> has been asserted")))
|
||||||
[#:message (HttpResponse-header name value)
|
|
||||||
(set! pending-headers-rev (cons (cons name value) pending-headers-rev))]
|
(define (send-headers!)
|
||||||
[#:message (HttpResponse-chunk chunk)
|
(unless chunk-ch
|
||||||
(unless chunk-ch
|
(set! chunk-ch (make-async-channel))
|
||||||
(set! chunk-ch (make-async-channel))
|
(thread
|
||||||
(output-response/method
|
(lambda ()
|
||||||
conn
|
(output-response/method conn
|
||||||
(response pending-code
|
(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)
|
(string->bytes/utf-8 pending-message)
|
||||||
(current-seconds)
|
(current-seconds)
|
||||||
#f
|
#f
|
||||||
(build-headers (reverse pending-headers-rev))
|
(build-headers (reverse pending-headers-rev))
|
||||||
(list (chunk->bytes chunk)))
|
(lambda (output-port)
|
||||||
(request-method req)))
|
(let loop ()
|
||||||
(stop-current-facet)]))
|
(match (async-channel-get chunk-ch)
|
||||||
|
[#f (void)]
|
||||||
|
[bs
|
||||||
|
(write-bytes bs output-port)
|
||||||
|
(flush-output output-port)
|
||||||
|
(loop)]))))
|
||||||
|
(request-method req))))))
|
||||||
|
|
||||||
|
(define (finish-request!)
|
||||||
|
(send-headers!)
|
||||||
|
(async-channel-put chunk-ch #f)
|
||||||
|
(stop-current-facet))
|
||||||
|
|
||||||
|
(begin/dataflow
|
||||||
|
(when (handler-terminated?)
|
||||||
|
(finish-request!)))
|
||||||
|
|
||||||
|
(define res (object #:name connection-name
|
||||||
|
[#:asserted (HttpResponse-processing)
|
||||||
|
(log-syndicate/drivers/http-debug "~v: +processing" connection-name)
|
||||||
|
(set! processing #t)
|
||||||
|
(set! pending-code 200)
|
||||||
|
(set! pending-message "OK")
|
||||||
|
#:retracted
|
||||||
|
(log-syndicate/drivers/http-debug "~v: -processing" connection-name)
|
||||||
|
(finish-request!)]
|
||||||
|
[#:message (HttpResponse-status code message)
|
||||||
|
(log-syndicate/drivers/http-debug "~v: status ~v ~v" connection-name
|
||||||
|
code message)
|
||||||
|
(check-processing!)
|
||||||
|
(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)
|
||||||
|
(check-processing!)
|
||||||
|
(set! pending-headers-rev (cons (cons name value) pending-headers-rev))]
|
||||||
|
[#:message (HttpResponse-body chunk)
|
||||||
|
(log-syndicate/drivers/http-debug "~v: chunk ~v" connection-name
|
||||||
|
chunk)
|
||||||
|
(check-processing!)
|
||||||
|
(send-headers!)
|
||||||
|
(async-channel-put chunk-ch (chunk->bytes chunk))]))
|
||||||
(at handler (assert (HttpContext decoded-req res)))
|
(at handler (assert (HttpContext decoded-req res)))
|
||||||
(return (void)))))
|
(return (void)))))
|
||||||
|
|
||||||
|
@ -283,14 +313,11 @@
|
||||||
(lambda () method)
|
(lambda () method)
|
||||||
(lambda () (quote-path-pattern () (path-pattern-element ...)))
|
(lambda () (quote-path-pattern () (path-pattern-element ...)))
|
||||||
(lambda (req res)
|
(lambda (req res)
|
||||||
|
(at res (assert (HttpResponse-processing)))
|
||||||
(match (HttpRequest-path req)
|
(match (HttpRequest-path req)
|
||||||
[#,(match-quote-path-pattern #'(path-pattern-element ...))
|
[#,(match-quote-path-pattern #'(path-pattern-element ...))
|
||||||
(async (match (with-handlers [((lambda (e) #t)
|
(async (match (let () body ...)
|
||||||
(lambda (e)
|
[(mime (? symbol? type) (or (? bytes? data) (? string? data)))
|
||||||
(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)
|
(log-syndicate/drivers/http-debug "REPLY: ~a ~v" type data)
|
||||||
(send-http-response! res 200 "OK" #:mime-type type data)]
|
(send-http-response! res 200 "OK" #:mime-type type data)]
|
||||||
[(? void?)
|
[(? void?)
|
||||||
|
@ -298,7 +325,8 @@
|
||||||
[bad
|
[bad
|
||||||
(log-syndicate/drivers/http-error "Bad MIME response: ~v" bad)
|
(log-syndicate/drivers/http-error "Bad MIME response: ~v" bad)
|
||||||
(send-http-response! res 500 "Internal Server Error")]))]
|
(send-http-response! res 500 "Internal Server Error")]))]
|
||||||
[_ (send-http-response! res 400 "Bad request path")]))))])))
|
[_ (send-http-response! res 400 "Bad request path")])
|
||||||
|
(stop-current-facet))))])))
|
||||||
|
|
||||||
(define (define-http-route* ds host port method path-pattern handler)
|
(define (define-http-route* ds host port method path-pattern handler)
|
||||||
(at ds
|
(at ds
|
||||||
|
@ -362,11 +390,7 @@
|
||||||
(for [(header headers)]
|
(for [(header headers)]
|
||||||
(match-define (cons name value) header)
|
(match-define (cons name value) header)
|
||||||
(send! res (HttpResponse-header name value)))
|
(send! res (HttpResponse-header name value)))
|
||||||
(let loop ((chunks chunks))
|
(for [(chunk chunks)] (send! res (HttpResponse-body chunk))))
|
||||||
(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))]))
|
|
||||||
(void))
|
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue