From 0370c19e43a698406bc7f63e3d2d45b44b3b6d0f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 9 Apr 2024 13:01:27 +0200 Subject: [PATCH] New http server protocol implementation and example --- syndicate-examples/http-server.rkt | 55 +++++++++++++ syndicate/drivers/http.rkt | 126 +++++++++++++++++------------ 2 files changed, 130 insertions(+), 51 deletions(-) create mode 100644 syndicate-examples/http-server.rkt diff --git a/syndicate-examples/http-server.rkt b/syndicate-examples/http-server.rkt new file mode 100644 index 0000000..69299c2 --- /dev/null +++ b/syndicate-examples/http-server.rkt @@ -0,0 +1,55 @@ +;;; SPDX-License-Identifier: LGPL-3.0-or-later +;;; SPDX-FileCopyrightText: Copyright © 2024 Tony Garnock-Jones + +#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 "\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"))))) + + ))) diff --git a/syndicate/drivers/http.rkt b/syndicate/drivers/http.rkt index 4bc2693..2dfced6 100644 --- a/syndicate/drivers/http.rkt +++ b/syndicate/drivers/http.rkt @@ -44,6 +44,8 @@ (define-logger syndicate/drivers/http) +(struct active-handler (ref signal) #:transparent) + (provide-service [ds] (at ds (during/spawn (HttpBinding _ $port _ _ _) @@ -59,8 +61,11 @@ (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)) - (set-add! handler-set handler) - (on-stop (set-remove! handler-set handler) + (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))) @@ -100,7 +105,7 @@ (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?) + ;; (log-syndicate/drivers/http-debug "~v ~v ~v ~v" connection-name routes req close?) (define continue-ch (make-async-channel)) (turn! facet (lambda () @@ -192,48 +197,73 @@ (list (header #"Allow" methods)) (list))) (return (void))))) - (define handler (set-first handler-set)) - (define pending-code #f) - (define pending-message #f) + (match-define (active-handler handler handler-terminated?) (set-first handler-set)) + (define processing #f) + (define pending-code 500) + (define pending-message "Internal Server Error") (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 + + (define (check-processing!) + (unless processing + (error 'HttpResponse "Attempt to reply before has been asserted"))) + + (define (send-headers!) + (unless chunk-ch + (set! chunk-ch (make-async-channel)) + (thread + (lambda () + (output-response/method conn + (response 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)])) + (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 (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))) (return (void))))) @@ -283,14 +313,11 @@ (lambda () method) (lambda () (quote-path-pattern () (path-pattern-element ...))) (lambda (req res) + (at res (assert (HttpResponse-processing))) (match (HttpRequest-path req) [#,(match-quote-path-pattern #'(path-pattern-element ...)) - (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)) + (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?) @@ -298,7 +325,8 @@ [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")]) + (stop-current-facet))))]))) (define (define-http-route* ds host port method path-pattern handler) (at ds @@ -362,11 +390,7 @@ (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))])) - (void)) + (for [(chunk chunks)] (send! res (HttpResponse-body chunk)))) ;;---------------------------------------------------------------------------