139 lines
4.5 KiB
Racket
139 lines
4.5 KiB
Racket
#lang racket/base
|
|
(provide http-msg?
|
|
http-msg-headers
|
|
http-msg-body
|
|
write-http-msg
|
|
|
|
http-req? make-http-req
|
|
http-res? make-http-res
|
|
|
|
http-body?
|
|
empty-http-body
|
|
write-http-body)
|
|
|
|
(require racket/match
|
|
"./util.rkt")
|
|
|
|
(module+ test
|
|
(require rackunit racket/port))
|
|
|
|
;; ---------------------------------------------------------------------------------------
|
|
;; HTTP messages
|
|
|
|
(struct http-msg [start-line headers body] #:transparent)
|
|
(struct http-start-line:req [method path] #:transparent)
|
|
(struct http-start-line:res [code] #:transparent)
|
|
|
|
;; any? -> boolean?
|
|
(define (http-req? h)
|
|
(and (http-msg? h) (http-start-line:req? (http-msg-start-line h))))
|
|
(define (http-res? h)
|
|
(and (http-msg? h) (http-start-line:res? (http-msg-start-line h))))
|
|
|
|
(define (make-msg sln hdrs)
|
|
(http-set-headers (http-msg sln (hasheq) empty-http-body) hdrs))
|
|
|
|
;; (make-http-req method path [hdrs]) -> http-req?
|
|
;; method : http-request-method?
|
|
;; path : path-string?
|
|
;; hdrs : (listof (cons/c symbol? any?))
|
|
(define (make-http-req method path [hdrs '()])
|
|
(make-msg (http-start-line:req method (build-path path)) hdrs))
|
|
|
|
;; (make-http-res code [hdrs]) -> http-res?
|
|
;; code : http-response-code?
|
|
;; hdrs : (listof (cons/c symbol? any?))
|
|
(define (make-http-res code [hdrs '()])
|
|
(make-msg (http-start-line:res code) hdrs))
|
|
|
|
;; (http-set-headers msg hdrs) -> http-msg?
|
|
;; msg : http-msg?
|
|
;; hdrs : (listof (cons/c symbol? any?))
|
|
(define (http-set-headers msg hdrs)
|
|
(struct-copy http-msg msg
|
|
[headers (for/fold ([hdrs (http-msg-headers msg)])
|
|
([kv (in-list hdrs)])
|
|
(if (cdr kv)
|
|
(hash-set hdrs (car kv) (->bytes (cdr kv)))
|
|
(hash-remove hdrs (car kv))))]))
|
|
|
|
;; (http-set-body msg how) -> http-msg?
|
|
;; msg : http-msg?
|
|
;; how : (or/c http-body? (http-body? . -> . http-body?))
|
|
(define (http-set-body msg how)
|
|
(define remove-old-headers
|
|
(for/list ([kv (in-list (http-body-additional-headers (http-msg-body msg)))])
|
|
(cons (car kv) #f)))
|
|
(define bdy*
|
|
(match how
|
|
[(? http-body? bdy*) bdy*]
|
|
[(? procedure? f) (f (http-msg-body msg))]))
|
|
(http-set-headers (struct-copy http-msg msg [body bdy*])
|
|
(append remove-old-headers
|
|
(http-body-additional-headers bdy*))))
|
|
|
|
;; (write-http-msg msg [port]) -> void?
|
|
;; msg : http-msg?
|
|
;; port : output-port?
|
|
(define (write-http-msg msg [port (current-output-port)])
|
|
(match-define (http-msg sln hdrs body) msg)
|
|
(match sln
|
|
[(http-start-line:req mthd path)
|
|
(fprintf port "~a ~a HTTP/1.1\r\n" mthd path)]
|
|
[(http-start-line:res code)
|
|
(fprintf port "HTTP/1.1 ~a ~a\r\n" code (http-response-code-name code))])
|
|
(for ([k (in-list (sort (hash-keys hdrs) symbol<?))])
|
|
(fprintf port "~a: ~a\r\n" k (hash-ref hdrs k)))
|
|
(write-bytes #"\r\n" port)
|
|
(write-http-body body port))
|
|
|
|
;; ==========================================
|
|
|
|
(module+ test
|
|
(define ex-req-/ (make-http-req 'GET "/" '([host . "localhost"])))
|
|
(define ex-res-ok (http-set-body (make-http-res 200) #"Hello world"))
|
|
|
|
(check-pred http-req? ex-req-/)
|
|
(check-pred http-res? ex-res-ok)
|
|
|
|
(check-equal? (hash-ref (http-msg-headers ex-req-/) 'host) #"localhost")
|
|
(check-equal? (hash-ref (http-msg-headers ex-res-ok) 'content-length) #"11")
|
|
|
|
(define-syntax-rule (check-http-msg->bytes msg bs ...)
|
|
(check-equal? (let ([p (open-output-bytes)])
|
|
(write-http-msg msg p)
|
|
(get-output-bytes p))
|
|
(bytes-append bs ...)))
|
|
|
|
(check-http-msg->bytes ex-req-/
|
|
#"GET / HTTP/1.1\r\n"
|
|
#"host: localhost\r\n"
|
|
#"\r\n")
|
|
|
|
(check-http-msg->bytes ex-res-ok
|
|
#"HTTP/1.1 200 OK\r\n"
|
|
#"content-length: 11\r\n"
|
|
#"\r\n"
|
|
#"Hello world")
|
|
|
|
(check-http-msg->bytes (http-set-body ex-res-ok empty-http-body)
|
|
#"HTTP/1.1 200 OK\r\n"
|
|
#"\r\n"))
|
|
|
|
;; ---------------------------------------------------------------------------------------
|
|
;; Message bodies
|
|
|
|
(define (http-body? x)
|
|
(or (eq? x #f)
|
|
(bytes? x)))
|
|
|
|
(define empty-http-body #f)
|
|
|
|
(define (http-body-additional-headers bdy)
|
|
(match bdy
|
|
[#f '()]
|
|
[(? bytes? bs) `([content-length . ,(bytes-length bs)])]))
|
|
|
|
(define (write-http-body bdy [port (current-output-port)])
|
|
(when bdy (write-bytes bdy port)))
|