207 lines
6.9 KiB
Racket
207 lines
6.9 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
|
|
racket/port
|
|
"./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-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)))
|
|
|
|
;; ---------------------------------------------------------------------------------------
|
|
;; 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))
|
|
(->bytes 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))))
|
|
;; TODO: response body; the reader should be determined by the headers
|
|
(make-msg sln hdrs))
|
|
|
|
;; ==========================================
|
|
|
|
(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"
|
|
#"\r\n"
|
|
(make-http-res 200 '([content-type . "text/html"])))
|
|
|
|
;; "write --> read" works
|
|
(let-values ([(in out) (make-pipe)])
|
|
(thread (λ () (write-http-msg ex-req-/ out)))
|
|
(check-equal? (read-http-msg in) ex-req-/)))
|