diff --git a/syndicate/drivers/http.rkt b/syndicate/drivers/http.rkt
new file mode 100644
index 0000000..2deb425
--- /dev/null
+++ b/syndicate/drivers/http.rkt
@@ -0,0 +1,394 @@
+#lang syndicate
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+(provide (all-from-out syndicate/schemas/http)
+         define-http-route
+         define-plain-http-route
+         headers-ref
+         query-ref
+         send-http-response!
+         define-json-route
+         json-body
+         json-response
+         send-json!
+         resolve-req-relative-uri)
+
+(require syndicate/schemas/http)
+
+(require (for-syntax racket/base))
+(require (for-syntax racket/syntax))
+(require (for-syntax syntax/parse))
+(require json)
+(require net/url)
+(require racket/async-channel)
+(require racket/exn)
+(require (only-in racket/format ~a))
+(require racket/pretty)
+(require racket/string)
+(require racket/tcp)
+(require syndicate/driver-support)
+(require syndicate/async)
+
+(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!))
+
+(define-logger syndicate/drivers/http)
+
+(provide-service [ds]
+  (at ds
+      (during/spawn (HttpBinding _ $port _ _ _)
+        #:name `(http-server ,port)
+        (define routes (make-hash)) ;; hostname -> method -> path-pattern -> (set handler)
+        (run-listener ds port routes)
+        (at ds
+          (during (HttpListener port)
+            (during (HttpBinding $host port $method $path $handler)
+              (define service (HttpService host port method path))
+              (define method-map (hash-ref! routes host make-hash))
+              (define pattern-map (hash-ref! method-map method make-hash))
+              (define handler-set (hash-ref! pattern-map path 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)
+                       (when (set-empty? handler-set) (hash-remove! pattern-map path))
+                       (when (hash-empty? pattern-map) (hash-remove! method-map method))
+                       (when (hash-empty? method-map) (hash-remove! routes host)))
+              (assert service)))))))
+
+(define (run-listener ds port routes)
+  (define listener-custodian (make-custodian))
+  (on-start (log-syndicate/drivers/http-info "+listener on ~v" port))
+  (on-stop  (log-syndicate/drivers/http-info "-listener on ~v" port))
+  (actor-add-exit-hook! this-actor (lambda () (custodian-shutdown-all listener-custodian)))
+  (linked-thread
+   #:name (list 'http-listener port)
+   (lambda (facet)
+     (parameterize ((current-custodian listener-custodian))
+       (define cm (start-connection-manager))
+       (define listener (tcp-listen port 511 #t))
+       (turn! facet (lambda () (at ds (assert (HttpListener port)))))
+       (let loop ()
+         (define connection-custodian (make-custodian listener-custodian))
+         (define-values (i o) (parameterize ((current-custodian connection-custodian))
+                                (tcp-accept listener)))
+         (turn! facet (lambda ()
+                        (parameterize ((current-custodian connection-custodian))
+                          (react
+                            (on-stop (custodian-shutdown-all connection-custodian))
+                            (handle-connection ds cm i o port routes)))))
+         (loop))))))
+
+(define (handle-connection ds cm i o port routes)
+  (define conn (new-connection cm 30 i o (make-custodian) #f))
+  (define connection-name (gensym 'http-connection))
+  (linked-thread
+   #:name connection-name
+   (lambda (facet)
+     (let process-requests ()
+       (define-values (req close?)
+         (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?)
+         (define continue-ch (make-async-channel))
+         (turn! facet
+                (lambda ()
+                  (react
+                    (local-connection-protocol ds connection-name conn routes req)
+                    (on-stop (async-channel-put continue-ch 'dummy)))))
+         (async-channel-get continue-ch)
+         (unless close? (process-requests)))))))
+
+(define next-request-id (inexact->exact (floor (current-inexact-milliseconds))))
+
+(define (local-connection-protocol ds connection-name conn routes req)
+  (let/ec return
+
+    (define (respond! resp)
+      (output-response/method conn resp (request-method req))
+      (stop-current-facet))
+
+    (define (decode-bytes bs)
+      (with-handlers [(exn:fail? (lambda (e)
+                                   (respond! (response/full 400
+                                                            #"Bad Request"
+                                                            (current-seconds)
+                                                            #"text/plain"
+                                                            (list)
+                                                            (list #"Invalid UTF-8")))
+                                   (return (void))))]
+        (bytes->string/utf-8 bs)))
+
+    (define (headers-map hs)
+      (for/hash [(h hs)]
+        (values (lowercase-symbol! (decode-bytes (header-field h)))
+                (decode-bytes (header-value h)))))
+
+    (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)))))
+
+    (define headers (headers-map (request-headers/raw req)))
+
+    (define host-and-port (cond [(assq 'host (request-headers req)) => cdr] [else #f]))
+    (define-values (host port)
+      (match host-and-port
+        [(regexp #px"(.*):(\\d+)" (list _ host port)) (values host (string->number port))]
+        [host (values host 80)]))
+
+    (define method (lowercase-symbol! (decode-bytes (request-method req))))
+
+    (define path (map path/param-path (url-path (request-uri req))))
+
+    (define query (for/fold [(q (hash))] [(b (in-list (request-bindings/raw req)))]
+                    (match-define (binding id-bytes) b)
+                    (define id (string->symbol (decode-bytes id-bytes)))
+                    (hash-set q
+                              id
+                              (append (hash-ref q id '())
+                                      (list (match b
+                                              [(binding:form _ value)
+                                               (QueryValue-string (decode-bytes value))]
+                                              [(binding:file _ filename headers content)
+                                               (QueryValue-file (decode-bytes filename)
+                                                                (headers-map headers)
+                                                                content)]))))))
+
+    (define body (request-post-data/raw req))
+
+    (define req-id next-request-id)
+    (set! next-request-id (+ req-id 1))
+
+    (define decoded-req (HttpRequest req-id host port method path headers query body))
+    (at ds (assert decoded-req))
+
+    (define (try-method method-map m)
+      (define pattern-map (hash-ref method-map m hash))
+      (for [((path-pattern handler-set) (in-hash pattern-map))]
+        (when (path-pattern-matches? path-pattern path)
+          (define handler (set-first handler-set))
+          (define pending-code #f)
+          (define pending-message #f)
+          (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
+                                                   (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)]))
+          (at handler (assert (HttpContext decoded-req res)))
+          (return (void)))))
+
+    (define (try-hostname n)
+      (define method-map (hash-ref routes n hash))
+      (try-method method-map method)
+      (try-method method-map #f))
+
+    (begin (try-hostname host)
+           (try-hostname #f)
+           (respond! (response/full 404
+                                    #"Not Found"
+                                    (current-seconds)
+                                    #"text/plain"
+                                    (list)
+                                    (list))))))
+
+(define (path-pattern-matches? pat p)
+  (let loop ((pat pat) (p p))
+    (match* [pat p]
+      [['() '()] #t]
+      [[(list '...) p] #t]
+      [[(cons '_ pat) (cons _ p)] (loop pat p)]
+      [[(cons expected pat) (cons actual p)] #:when (equal? expected actual) (loop pat p)]
+      [[_ _] #f])))
+
+(define (chunk->bytes c)
+  (match c
+    [(Chunk-string s) (string->bytes/utf-8 s)]
+    [(Chunk-bytes bs) bs]))
+
+;;---------------------------------------------------------------------------
+
+(define-syntax define-plain-http-route
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ [host port method [path-pattern-element ...] req res] body ...)
+       (quasisyntax/loc stx
+         (define-http-route*
+           this-target
+           (lambda () host)
+           (lambda () port)
+           (lambda () method)
+           (lambda () (quote-path-pattern () (path-pattern-element ...)))
+           (lambda (req res)
+             (match (HttpRequest-path req)
+               [#,(match-quote-path-pattern #'(path-pattern-element ...))
+                (async body ...)]
+               [_ (send-http-response! res 400 "Bad request path")]))))])))
+
+(define (define-http-route* ds host port method path-pattern handler)
+  (at ds
+    (assert (HttpBinding (host) (port) (method) (path-pattern)
+                         (object
+                           #:name (list 'http-route (host) (port) (method) (->preserve (path-pattern)))
+                           [(HttpContext req res)
+                            (handler req res)])))))
+
+(define-syntax quote-path-pattern
+  (lambda (stx)
+    (syntax-parse stx
+      #:datum-literals ((___ ...) (* _))
+      [(_ (e ...) ())
+       #'(list e ...)]
+      [(_ (e ...) (id ___))
+       #:when (identifier? #'id)
+       #'(list e ... (PathPatternElement-rest))]
+      [(_ (e ...) (* more ...))
+       #'(quote-path-pattern (e ... (PathPatternElement-wildcard)) (more ...))]
+      [(_ (e ...) (id more ...))
+       #:when (identifier? #'id)
+       #'(quote-path-pattern (e ... (PathPatternElement-wildcard)) (more ...))]
+      [(_ (e ...) (label more ...))
+       #'(quote-path-pattern (e ... (PathPatternElement-label label)) (more ...))])))
+
+(define-for-syntax match-quote-path-pattern
+  (lambda (elements)
+    (let loop ((pieces '()) (elements elements))
+      (syntax-parse elements
+        #:datum-literals ((___ ...) (* _))
+        [() #`(list #,@pieces)]
+        [(id ___) #:when (identifier? #'id) #`(list* #,@pieces id)]
+        [(* more ...) (loop (append pieces (list #`_)) #`(more ...))]
+        [(id more ...) #:when (identifier? #'id) (loop (append pieces (list #`id)) #`(more ...))]
+        [(label more ...) (loop (append pieces (list #`_)) #`(more ...))]))))
+
+(define (headers-ref req name [default (lambda () (error 'headers-ref "Missing header ~v" name))])
+  (hash-ref (Headers-value (HttpRequest-headers req)) name default))
+
+(define (apply0 v)
+  (if (procedure? v)
+      (v)
+      v))
+
+(define (query-ref req name [default (lambda () (error 'query-ref "Missing query parameter ~v" name))])
+  (QueryValue-string-value
+   (car (hash-ref (HttpRequest-query req)
+                  name
+                  (lambda () (list (QueryValue-string (apply0 default))))))))
+
+(define (send-http-response! res code message
+                             #:headers [headers '()]
+                             #:mime-type [mime-type #f]
+                             . chunks)
+  (send! res (HttpResponse-status code message))
+  (when mime-type
+    (send! res (HttpResponse-header 'content-type (~a mime-type)))
+    (set! headers (filter (lambda (h) (not (string-ci=? (symbol->string (car h)) "content-type")))
+                          headers)))
+  (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))])))
+
+;;---------------------------------------------------------------------------
+
+(define-syntax-rule (define-http-route [pat ... res]
+                      [(info parse-body ...) ...]
+                      body ...)
+  (define-plain-http-route [pat ... res]
+    (let/ec escape
+      (define-values (info ...)
+        (with-handlers [((lambda (e) #t)
+                         (lambda (e)
+                           (if (exn? e)
+                               (log-syndicate/drivers/http-error "BAD REQUEST: ~a" (exn->string e))
+                               (log-syndicate/drivers/http-error "NON-EXN ERROR: ~v" e))
+                           (send-http-response! res 400 "Bad Request")
+                           (escape (void))))]
+          (let ()
+            (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")]))))))
+
+(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))))
+
+(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))))
+
+(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)
+  (local-require net/url)
+  (url->string (combine-url/relative
+                (string->url (format "https://~a/~a"
+                                     (HttpRequest-host req)
+                                     (string-join (HttpRequest-path req) "/")))
+                rel)))