syndicate-rkt/syndicate/drivers/web.rkt

352 lines
16 KiB
Racket

;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(provide (struct-out http-server)
(struct-out http-resource)
(struct-out http-request)
(struct-out http-accepted)
(except-out (struct-out http-response) http-response)
(rename-out [make-http-response http-response]
[http-response <http-response>])
(except-out (struct-out http-response-websocket) http-response-websocket)
(rename-out [make-http-response-websocket http-response-websocket]
[http-response-websocket <http-response-websocket>])
(struct-out http-request-peer-details)
(struct-out http-request-cookie)
(struct-out http-response-chunk)
(struct-out websocket-out)
(struct-out websocket-in)
xexpr->bytes/utf-8)
(require racket/async-channel)
(require racket/exn)
(require (only-in racket/list flatten))
(require (only-in racket/string string-append*))
(require (only-in racket/bytes bytes-append*))
(require racket/tcp)
(require net/rfc6455)
(require net/rfc6455/conn-api)
(require net/rfc6455/dispatcher)
(require net/url)
(require struct-defaults)
(require web-server/http/bindings)
(require web-server/http/cookie)
(require web-server/http/cookie-parse)
(require web-server/http/request)
(require web-server/http/request-structs)
(require web-server/http/response)
(require web-server/http/response-structs)
(require web-server/private/connection-manager)
(require (only-in web-server/private/util lowercase-symbol!))
(require web-server/dispatchers/dispatch)
(require xml)
(module+ test (require rackunit))
(define-logger syndicate/drivers/web)
(define (url-path->resource-path up)
(define elements (for/list [(p (in-list up))]
(match-define (path/param path-element params) p)
(list* path-element params)))
(foldr (lambda (e acc) (append e (list acc))) '() elements))
(define (build-headers hs)
(for/list ((h (in-list hs)))
(header (string->bytes/utf-8 (symbol->string (car h)))
(string->bytes/utf-8 (cdr h)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; API/Protocol
(assertion-struct http-server (host port ssl?))
(assertion-struct http-resource (server path))
(assertion-struct http-request (id method resource headers query body))
(assertion-struct http-accepted (id))
(assertion-struct http-response (id code message last-modified-seconds mime-type headers detail))
;; ^ detail = (U Bytes 'chunked)
(assertion-struct http-response-websocket (id headers))
(assertion-struct http-request-peer-details (id local-ip local-port remote-ip remote-port))
(assertion-struct http-request-cookie (id name value domain path))
(message-struct http-response-chunk (id bytes))
(message-struct websocket-out (id body))
(message-struct websocket-in (id body))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Ground messages
(message-struct web-raw-request (id port connection addresses req control-ch))
(message-struct web-raw-client-conn (id connection))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define web-server-max-waiting (make-parameter 511)) ;; sockets
(define web-server-connection-manager (make-parameter #f))
(define web-server-initial-connection-timeout (make-parameter 30)) ;; seconds
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn
#:name 'http-server-factory
(during (observe (http-request _ _ (http-resource $server _) _ _ _))
(assert server))
(during/spawn (http-server _ $port _)
#:name (list 'http-listener port)
(define ssl? #f)
(on (asserted (http-server _ port #t))
(error 'http-listener "SSL service not yet implemented")) ;; TODO
(define cm (or (web-server-connection-manager) (start-connection-manager)))
(define listener (tcp-listen port (web-server-max-waiting) #t))
(define listener-control (make-channel))
(thread (lambda ()
(let loop ()
(sync (handle-evt (tcp-accept-evt listener)
(lambda (ports)
(connection-thread port cm ports)
(loop)))
(handle-evt listener-control
(match-lambda
[(list 'quit k-ch)
(tcp-close listener)
(signal-background-activity! -1)
(channel-put k-ch (void))]))))))
(signal-background-activity! +1)
(on-start (log-syndicate/drivers/web-debug "Starting listener on port ~v" port))
(on-stop (define k-ch (make-channel))
(log-syndicate/drivers/web-debug "Stopping listener on port ~v" port)
(channel-put listener-control (list 'quit k-ch))
(channel-get k-ch)
(log-syndicate/drivers/web-debug "Stopped listener on port ~v" port))
(on (message (inbound (web-raw-request $id port $conn $addresses $lowlevel-req $control-ch)))
(spawn #:name (list 'http-request id)
(define root-facet (current-facet))
(define method
(string->symbol (string-downcase (bytes->string/latin-1 (request-method lowlevel-req)))))
(define resource (http-resource (req->http-server lowlevel-req port ssl?)
(url-path->resource-path
(url-path (request-uri lowlevel-req)))))
(assert (http-request id
method
resource
(request-headers lowlevel-req)
(url-query (request-uri lowlevel-req))
(request-post-data/raw lowlevel-req)))
(for [(c (request-cookies lowlevel-req))]
(match-define (client-cookie n v d p) c)
(assert (http-request-cookie id n v d p)))
(match-let ([(list Lip Lport Rip Rport) addresses])
(assert (http-request-peer-details id Lip Lport Rip Rport)))
(define (respond! resp)
(match-define (http-response _ c m lms mime-type headers body) resp)
(define hs (build-headers headers))
(channel-put control-ch
(list 'response
(response/full c m lms mime-type hs (flatten body)))))
(define (respond/chunked! resp)
(match-define (http-response _ c m lms mime-type headers _) resp)
(define hs (build-headers headers))
(define stream-ch (make-async-channel))
(define (output-writer op)
(match (async-channel-get stream-ch)
[#f (void)]
[bss (for [(bs bss)] (write-bytes bs op))
;; (flush-output op) ;; seemingly does nothing. TODO
(output-writer op)]))
(react (stop-when (retracted resp))
(on-stop (async-channel-put stream-ch #f)
(stop-facet root-facet))
(on (message (http-response-chunk id $chunk))
(async-channel-put stream-ch (flatten chunk)))
(on-start (channel-put control-ch
(list 'response
(response c m lms mime-type hs output-writer))))))
(define (respond/websocket! headers)
(define ws-ch (make-channel))
(define hs (build-headers headers))
(react (stop-when (retracted (http-response-websocket id headers)))
(on-start (channel-put control-ch (list 'websocket hs ws-ch)))
(on-stop (channel-put ws-ch 'quit)
(stop-facet root-facet))
(on (message (websocket-out id $body))
(define flat (flatten body))
(define payload (cond [(null? flat) ""]
[(bytes? (car flat)) (bytes-append* flat)]
[(string? (car flat)) (string-append* flat)]
[else (error 'respond/websocket!
"Bad payload: mixed content: ~v"
flat)]))
(channel-put ws-ch (list 'send payload)))
(on (message (inbound (websocket-in id $body)))
(if (eof-object? body)
(stop-current-facet)
(send! (websocket-in id body))))))
(field [respondent-exists? #f])
(on-start (for [(i 3)] (flush!)) ;; TODO: UGHHHH
(when (not (respondent-exists?))
(stop-facet root-facet
(respond! (make-http-response #:code 404
#:message #"Not found"
id
(xexpr->bytes/utf-8
`(html (h1 "Not found"))))))))
(on (asserted (http-accepted id))
(respondent-exists? #t)
(react
(stop-when (retracted (http-accepted id))
(stop-facet root-facet
(respond! (make-http-response #:code 500
#:message #"Server error"
id
(xexpr->bytes/utf-8
`(html (h1 "Server error")))))))
(stop-when (asserted ($ resp (http-response id _ _ _ _ _ $detail)))
(match detail
['chunked (respond/chunked! resp)]
[_ (stop-facet root-facet (respond! resp))]))
(stop-when (asserted (http-response-websocket id $headers))
(respond/websocket! headers))))))))
(define (req->http-server r port ssl?)
(match (assq 'host (request-headers r))
[#f
(http-server #f port ssl?)]
[(cons _ (regexp #px"(.*):(\\d+)" (list _ host port)))
(http-server host (string->number port) ssl?)]
[(cons _ host)
(http-server host port ssl?)]))
(define (connection-thread listen-port cm connection-ports)
(signal-background-activity! +1)
(thread
(lambda ()
(match-define (list i o) connection-ports)
;; Deliberately construct an empty custodian for the connection. Killing the connection
;; abruptly can cause deadlocks since the connection thread communicates with Syndicate
;; via synchronous channels.
(define conn
(new-connection cm (web-server-initial-connection-timeout) i o (make-custodian) #f))
(define addresses
(let-values (((Lip Lport Rip Rport) (tcp-addresses i #t)))
(list Lip Lport Rip Rport)))
(define control-ch (make-channel))
(let do-request ()
(define-values (req should-close?)
(with-handlers ([exn:fail? (lambda (e) (values #f #f))])
(read-request conn listen-port tcp-addresses)))
(when req
(define id (gensym 'web))
(ground-send! (inbound (web-raw-request id listen-port conn addresses req control-ch)))
(sync (handle-evt control-ch
(match-lambda
[(list 'websocket reply-headers ws-ch)
(with-handlers ((exn:dispatcher?
(lambda (_e)
(define resp
(response/full 400
#"Bad request"
(current-seconds)
#"text/plain"
(list)
(list)))
(output-response/method conn
resp
(request-method req))
(drain-ws-ch! ws-ch))))
((make-general-websockets-dispatcher
(websocket-connection-main id ws-ch)
(lambda _args (values reply-headers (void))))
conn req))]
[(list 'response resp)
(output-response/method conn resp (request-method req))
(when (not should-close?)
(do-request))])))))
(with-handlers ([exn:fail? (lambda (e) (values #f #f))]) (close-input-port i))
(with-handlers ([exn:fail? (lambda (e) (values #f #f))]) (close-output-port o))
(signal-background-activity! -1))))
(define ((websocket-connection-main id ws-ch) wsc _ws-connection-state)
(define quit-seen? #f)
(define (shutdown!)
(ground-send! (inbound (websocket-in id eof)))
(with-handlers ([(lambda (e) #t)
(lambda (e) (log-syndicate/drivers/web-error
"Unexpected ws-close! error: ~a"
(if (exn? e)
(exn->string e)
(format "~v" e))))])
(ws-close! wsc)))
(with-handlers [(exn:fail:network? (lambda (e) (shutdown!)))
(exn:fail:port-is-closed? (lambda (e) (shutdown!)))
(exn:fail? (lambda (e)
(log-syndicate/drivers/web-error "Unexpected websocket error: ~a"
(exn->string e))
(shutdown!)))]
(let loop ()
(sync (handle-evt (ws-recv-evt wsc #:payload-type 'auto)
(lambda (msg)
(ground-send! (inbound (websocket-in id msg)))
(loop)))
(handle-evt ws-ch (match-lambda
['quit
(set! quit-seen? #t)
(void)]
[(list 'send m)
(ws-send! wsc m #:payload-type (if (bytes? m) 'binary 'text))
(loop)]))))
(ws-close! wsc))
(when (not quit-seen?)
(drain-ws-ch! ws-ch)))
(define (drain-ws-ch! ws-ch)
(when (not (equal? (channel-get ws-ch) 'quit))
(drain-ws-ch! ws-ch)))
;; D-: uck barf
;; TODO: something to fix this :-/
(define (exn:fail:port-is-closed? e)
(and (exn:fail? e)
(regexp-match #px"port is closed" (exn-message e))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(begin-for-declarations
(define-struct-defaults make-http-response http-response
(#:code [http-response-code 200]
#:message [http-response-message #"OK"]
#:last-modified-seconds [http-response-last-modified-seconds (current-seconds)]
#:mime-type [http-response-mime-type #"text/html"]
#:headers [http-response-headers '()]))
(define-struct-defaults make-http-response-websocket http-response-websocket
(#:headers [http-response-websocket-headers '()])))
(define (xexpr->bytes/utf-8 #:preamble [preamble #"<!DOCTYPE html>"] xexpr)
(bytes-append preamble (string->bytes/utf-8 (xexpr->string xexpr))))