291 lines
9.7 KiB
Racket
291 lines
9.7 KiB
Racket
#lang racket/base
|
|
(provide http-msg?
|
|
http-msg-headers
|
|
http-msg-header
|
|
http-msg-body
|
|
http-rsp-code
|
|
write-http-msg
|
|
read-http-msg
|
|
http-add-headers
|
|
http-set-body
|
|
|
|
http-req? make-http-req
|
|
http-res? make-http-res
|
|
|
|
http-body?
|
|
empty-http-body
|
|
write-http-body
|
|
force-http-body
|
|
in-http-body-chunks)
|
|
|
|
(require racket/match
|
|
racket/port
|
|
racket/stream
|
|
"./util.rkt")
|
|
|
|
(module+ test
|
|
(require rackunit))
|
|
|
|
;; ---------------------------------------------------------------------------------------
|
|
;; 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-add-headers (http-msg sln '() 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-header msg k) -> (or/c bytes? #f)
|
|
;; msg : http-msg?
|
|
;; k : symbol?
|
|
(define (http-msg-header msg k)
|
|
(cond
|
|
[(assoc k (http-msg-headers msg)) => cdr]
|
|
[else #f]))
|
|
|
|
;; (http-rsp-code msg) -> http-response-code?
|
|
;; msg : http-rsp?
|
|
(define (http-rsp-code msg)
|
|
(http-start-line:res-code (http-msg-start-line msg)))
|
|
|
|
;; (http-add-headers msg hdrs) -> http-msg?
|
|
;; msg : http-msg?
|
|
;; hdrs : (listof (cons/c symbol? any?))
|
|
(define (http-add-headers msg hdrs)
|
|
(struct-copy http-msg msg
|
|
[headers (append (http-msg-headers msg) hdrs)]))
|
|
|
|
;; (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 bdy*
|
|
(match how
|
|
[(? http-body? bdy*) bdy*]
|
|
[(? procedure? f) (f (http-msg-body msg))]))
|
|
(http-add-headers (struct-copy http-msg msg [body bdy*])
|
|
(http-body-additional-headers bdy*)))
|
|
|
|
;; We need an unchecked (no added headers) version because otherwise when parsing responses we add
|
|
;; duplicate headers
|
|
;; I was too lazy to abstract this i'm sorry milo ~ 🦈
|
|
|
|
;; (http-set-body/unchecked msg how) -> http-msg?
|
|
;; msg : http-msg?
|
|
;; how : (or/c http-body? (http-body? . -> . http-body?))
|
|
(define (http-set-body/unchecked msg how)
|
|
(define bdy*
|
|
(match how
|
|
[(? http-body? bdy*) bdy*]
|
|
[(? procedure? f) (f (http-msg-body msg))]))
|
|
(struct-copy http-msg msg [body 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 ([kv (in-list hdrs)])
|
|
(fprintf port "~a: ~a\r\n" (car kv) (cdr kv)))
|
|
(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"))
|
|
|
|
;; ---------------------------------------------------------------------------------------
|
|
;; Message bodies
|
|
|
|
(define (http-body? x)
|
|
(or (eq? x #f)
|
|
(bytes? x)
|
|
(stream? x)))
|
|
|
|
(define empty-http-body #f)
|
|
|
|
;; (write-http-body bdy [port]) -> void?
|
|
;; bdy : http-body?
|
|
;; port : output-port?
|
|
(define (write-http-body bdy [port (current-output-port)])
|
|
(match bdy
|
|
[#f (void)]
|
|
[(? bytes? bs) (void (write-bytes bs port))]
|
|
[(? stream? bss) (error 'write-http-body "chunked is not implemented sorry. ;(")]))
|
|
|
|
;; (in-http-body-chunks bdy) -> (streamof bytes)
|
|
;; bdy : http-body?
|
|
(define (in-http-body-chunks bdy)
|
|
(match bdy
|
|
[#f '()]
|
|
[(? bytes? bs) (list bs)]
|
|
[(? stream? bss) bss]))
|
|
|
|
;; (force-http-body bdy) -> void?
|
|
;; bdy : http-body?
|
|
(define (force-http-body bdy)
|
|
(when (stream? bdy)
|
|
(for ([x bdy]) (void))))
|
|
|
|
(define (http-body-additional-headers bdy)
|
|
(match bdy
|
|
[#f '()]
|
|
[(? bytes? bs) `([content-length . ,(number->string (bytes-length bs))])]
|
|
[(? stream?) '([transfer-encoding . #"chunked"])]))
|
|
|
|
;; ---------------------------------------------------------------------------------------
|
|
;; Parsing
|
|
|
|
(struct exn:fail:read-http exn:fail [] #:transparent)
|
|
|
|
(define (raise-read-http-error . fmt)
|
|
(raise (exn:fail:read-http (string-append "read-http-msg: " (apply format fmt))
|
|
(current-continuation-marks))))
|
|
|
|
(define (string->start-line s)
|
|
(match (regexp-match #px"^(HTTP/1\\.1 (\\d+) .*)|(([A-Z]+) ([^ ]+) HTTP/1\\.1)$" s)
|
|
[(list _ _ code #f #f #f)
|
|
(http-start-line:res (string->number code))]
|
|
[(list _ #f #f _ method path)
|
|
(http-start-line:req (string->symbol method) (build-path path))]
|
|
[_ #f]))
|
|
|
|
(define (string->header-kv s)
|
|
(match (regexp-match #px"^([^:]+):\\s*(.*)$" s)
|
|
[(list _ k v) (cons (string->symbol (string-downcase k)) v)]
|
|
[_ #f]))
|
|
|
|
(define (read-crlf-line port)
|
|
(match (regexp-match #px"^([^\r]*)\r\n" port)
|
|
[(list _ line) (bytes->string/utf-8 line)]
|
|
[_ (port->string port)]))
|
|
|
|
;; (read-http-msg [port]) -> http-msg?
|
|
;; port : input-port?
|
|
(define (read-http-msg [port (current-input-port)])
|
|
(define sln/str
|
|
(read-crlf-line port))
|
|
(define sln
|
|
(or (string->start-line sln/str)
|
|
(raise-read-http-error "invalid start line: ~s" sln/str)))
|
|
(define hdrs
|
|
(for/list ([hln (in-port read-crlf-line port)])
|
|
#:break (string=? hln "")
|
|
(or (string->header-kv hln)
|
|
(raise-read-http-error "read-http-msg: invalid header line: ~s" hln))))
|
|
(define msg (make-msg sln hdrs))
|
|
(define bdy (read-http-body (http-msg-header msg 'transfer-encoding)
|
|
(http-msg-header msg 'content-length)
|
|
port))
|
|
(http-set-body/unchecked msg bdy))
|
|
|
|
;; (http-body-reader tenc clen [port]) -> http-body?
|
|
;; tenc, clen : (or/c #f bytes?)
|
|
;; port : input-port?
|
|
(define (read-http-body tenc clen [port (current-input-port)])
|
|
(define len (and clen (string->int clen)))
|
|
(cond
|
|
[(equal? tenc "chunked") (read-chunked-stream port)]
|
|
[(number? len) (read-bytes len port)]
|
|
[(and (not tenc) (not len)) #f]
|
|
[else (raise-read-http-error "read-http-body: not sure how to read HTTP body")]))
|
|
|
|
;; input-port? -> [streamof bytes?]
|
|
(define (read-chunked-stream port)
|
|
(define len (string->number (read-crlf-line port) 16))
|
|
(unless (integer? len)
|
|
(raise-read-http-error "read-chunked-stream: invalid chunked encoding detected"))
|
|
(define data (read-bytes len port))
|
|
(match-define #"\r\n" (read-bytes 2 port))
|
|
(if (zero? len)
|
|
empty-stream
|
|
(stream-cons data (read-chunked-stream port))))
|
|
|
|
;; ==========================================
|
|
|
|
(module+ test
|
|
(define-syntax-rule (check-bytes->http-msg bs ... msg-expr)
|
|
(let ([p (open-input-bytes (bytes-append bs ...))])
|
|
(check-equal? (read-http-msg p) msg-expr)
|
|
(check-eq? (read-char p) eof)))
|
|
|
|
(check-bytes->http-msg #"GET /foo?a=z HTTP/1.1\r\n"
|
|
#"host: foobar\r\n"
|
|
#"\r\n"
|
|
(make-http-req 'GET "/foo?a=z" '([host . "foobar"])))
|
|
|
|
(check-bytes->http-msg #"HTTP/1.1 200 OK\r\n"
|
|
#"Content-Type: text/html\r\n"
|
|
#"Content-Length: 5\r\n"
|
|
#"\r\n"
|
|
#"hello"
|
|
(http-set-body/unchecked (make-http-res 200 '([content-type . "text/html"]
|
|
[content-length . "5"]))
|
|
#"hello"))
|
|
|
|
(let ([msg (read-http-msg
|
|
(open-input-bytes (bytes-append #"HTTP/1.1 200 OK\r\n"
|
|
#"Transfer-Encoding: chunked\r\n"
|
|
#"\r\n"
|
|
#"5\r\nhello\r\n"
|
|
#"2\r\n, \r\n"
|
|
#"6\r\nworld!\r\n"
|
|
#"0\r\n\r\n")))])
|
|
(check-equal? (for/list ([bs (in-http-body-chunks (http-msg-body msg))]) bs)
|
|
'(#"hello" #", " #"world!")))
|
|
|
|
;; "write --> read" works
|
|
(let-values ([(in out) (make-pipe)])
|
|
(thread (λ () (write-http-msg ex-req-/ out)))
|
|
(check-equal? (read-http-msg in) ex-req-/)))
|