diff --git a/rmq/server.rkt b/rmq/server.rkt index 8cacfa0..781a2e1 100644 --- a/rmq/server.rkt +++ b/rmq/server.rkt @@ -201,23 +201,30 @@ (define self-url (canonical-url canonical-host-name `("topic" (,topic ())))) (define discovery-headers (list (cons 'link (format "<~a>; rel=hub" hub-url)) (cons 'link (format "<~a>; rel=self" self-url)))) + + (define (topic-response id include-content?) ;; Used in both GET and HEAD requests + (if (current-content) + (web-respond/bytes! id + #:header (web-response-header + #:last-modified-seconds (last-modified-seconds) + #:mime-type (and (current-content-type) + (string->bytes/utf-8 + (current-content-type))) + #:headers discovery-headers) + (if include-content? (current-content) #"")) + (web-respond/bytes! id + #:header (web-response-header + #:code 204 + #:message #"No Content" + #:mime-type #f + #:headers discovery-headers) + #""))) ;; MUST NOT include a response body for 204 + + (on (web-request-incoming (id req) (vh host-name) 'head ("topic" (,topic ()))) + (topic-response id #f)) (on (web-request-get (id req) (vh host-name) ("topic" (,topic ()))) - (if (current-content) - (web-respond/bytes! id - #:header (web-response-header - #:last-modified-seconds (last-modified-seconds) - #:mime-type (and (current-content-type) - (string->bytes/utf-8 - (current-content-type))) - #:headers discovery-headers) - (current-content)) - (web-respond/bytes! id - #:header (web-response-header - #:code 204 - #:message #"No Content" - #:mime-type #f - #:headers discovery-headers) - #"")))) ;; MUST NOT include a response body for 204 + (topic-response id #t))) + (on (web-request-incoming (id req) (vh host-name) 'post ("topic" (,topic ())) $body) (define content-type (req-content-type req)) (log-info "Local topic ~a got ~v message ~v" topic content-type body)