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

New http server protocol implementation and example

This commit is contained in:
Tony Garnock-Jones 2024-04-09 13:01:27 +02:00
parent e6234b7713
commit 0370c19e43
2 changed files with 130 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
syndicate-examples/http-server.rkt Normal file
View File

@ -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")))))
)))

126
syndicate/drivers/http.rkt
View File

@ -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 <processing> 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))))
;;---------------------------------------------------------------------------