diff --git a/syndicate/drivers/http.rkt b/syndicate/drivers/http.rkt index f1bfef2..0a07cb6 100644 --- a/syndicate/drivers/http.rkt +++ b/syndicate/drivers/http.rkt @@ -48,22 +48,22 @@ (at ds (during/spawn (HttpBinding _ $port _ _ _) #:name `(http-server ,port) - (define routes (make-hash)) ;; hostname -> method -> path-pattern -> (set handler) + (define routes (make-hash)) ;; hostname -> path-pattern -> method -> (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)) + (define pattern-map (hash-ref! routes host make-hash)) + (define method-map (hash-ref! pattern-map path make-hash)) + (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) - (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))) + (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))) (assert service))))))) (define (run-listener ds port routes) @@ -174,10 +174,24 @@ (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))] + (define (try-hostname n) + (define pattern-map (hash-ref routes n hash)) + (for [((path-pattern method-map) (in-hash pattern-map))] (when (path-pattern-matches? path-pattern path) + (define handler-set (or (hash-ref method-map method #f) + (hash-ref method-map #f #f) + (let ((methods (string->bytes/utf-8 + (string-join + (for/list [(m (in-list (hash-keys method-map)))] + (string-upcase (symbol->string m))) + ", ")))) + (respond! (response/full 405 + #"Method Not Allowed" + (current-seconds) + #"text/plain" + (list (header #"Allow" methods)) + (list))) + (return (void))))) (define handler (set-first handler-set)) (define pending-code #f) (define pending-message #f) @@ -223,11 +237,6 @@ (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