Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
194 lines (170 sloc) 6.48 KB
#lang racket
(require net/head
)
(provide extract-http-ver&code&text
extract-http-ver
extract-http-code
extract-http-text
extract-field/number
maybe-insert-field
coalesce-fields
validate-tx-or-rx-header
heads-string->dict
heads-dict->string
maybe-dict-set
maybe-dict-set*
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supplement "missing" functions in net/head
;; Headers represented as string.
(define (extract-http-ver&code&text h)
(match h
;; Remember that status description text is optional. For instance
;; "HTTP/1.1 200" is valid (the "OK" part is optional).
[(pregexp "^HTTP/(1\\.[01])\\s+(\\d{3})\\s*(.*?)\\s*\r\n"
(list _ ver code text))
(values ver (string->number code) text)]
[else
(log-warning (string-append "bad response header: " h))
(values "???" 999 "Bad Response")]))
(define (extract-http-ver h)
(define-values (ver code text) (extract-http-ver&code&text h))
ver)
(define (extract-http-code h)
(define-values (ver code text) (extract-http-ver&code&text h))
code)
(define (extract-http-text h)
(define-values (ver code text) (extract-http-ver&code&text h))
text)
(define (extract-field/number k h [radix 10])
(define (trim s)
(match s
[(pregexp "^\\s*?(\\S*)\\s*?$" (list _ s)) s]
[else s]))
(match (extract-field k h)
[#f #f]
[(var x)
(match (string->number (trim x) radix)
[#f #f]
[(var n) n])]))
(define/contract (maybe-insert-field k v h)
((or/c string? symbol?) any/c string? . -> . string?)
;; Insert the field into the header only if it does not already
;; exist in the header.
(let ([k (if (symbol? k) (symbol->string k) k)])
(if (extract-field k h)
h
(insert-field k (format "~a" v) h))))
(define/contract (coalesce-fields heads)
(string? . -> . string?)
;; Combine header fields with the same name into one
;; "header-name:comma-separated-value-list" pair as prescribed by
;; RFC 2616, section 4.2, without any white-space between
;; values. For example, the two metadata headers
;; 'x-amz-meta-username: fred' and 'x-amz-meta-username: barney'
;; would be combined into the single header 'x-amz-meta-username:
;; fred,barney'.
;;
;; Implementation is trivial we have heads-string->dict
;; which already handles dupes. Simply give it our desired separate
;; of "," instead of its default "\n".
(heads-dict->string (heads-string->dict heads ",")))
(define (validate-tx-or-rx-header s)
;; (string? . -> . string?)
;; Unlike net/head validate-header, this permits response header
;; with intial HTTP line. Also, if the header is OK and no exception
;; is thrown, we return the string passed in, making it more
;; convenient to call this in an expression.
(match s
[(pregexp "^HTTP/1\\.[01].+?\r\n(.+?)$"
(list _ heads))
(validate-header heads)]
[else
(validate-header s)])
s)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; headers as a `dict'
;; Convert a header string of the form specified in net/head to a
;; dict.
;;
;; Specifically, handle the case of duplicate headers. A real-world
;; example of such duplicate headers is Set-Cookie. Other than
;; association lists, most types of dicts don't permit duplicate keys,
;; so we can't store duplicate headers like that. Instead, duplicate
;; headers are stored in the dict under the same key, with the various
;; values separated by \n. Precedent: How Rack handles this.
(define/contract (heads-string->dict s [dupe-sep "\n"])
((string?) (string?) . ->* . dict?)
(for/fold ([h (hash)])
([x (in-list (extract-all-fields s))])
(match-define (cons k v) x)
(let ([k (string->symbol k)])
(if (hash-has-key? h k)
(hash-set h k (string-append (hash-ref h k) dupe-sep v))
(hash-set h k v)))))
;; Convert a dict into a string of the form specified in net/head,
;; including the trailing \r\n to end all the headers.
;;
;; Does the complement of the duplicate header handling described
;; above.
(define/contract (heads-dict->string h [dupe-sep "\n"])
((dict?) (string?) . ->* . string?)
(string-append
(for*/fold ([s ""])
([(k v) (in-dict h)]
[v (in-list (regexp-split dupe-sep (format "~a" v)))])
(string-append s (format "~a: ~a\r\n" k v)))
"\r\n"))
;; Like dict-set*, but will set the new value for a key only if the
;; key does not already exist in d.
(define/contract (maybe-dict-set* d . kvs)
(((and/c dict? dict-can-functional-set?))
#:rest list?
. ->* . (and/c dict? dict-can-functional-set?))
(let loop ([d d]
[kvs kvs])
(if (null? kvs)
d
(loop (maybe-dict-set d (car kvs) (cadr kvs))
(cddr kvs)))))
;; Like dict-set, but will set the new value for a key only if the
;; key does not already exist in d.
(define (maybe-dict-set d k v)
(if (dict-has-key? d k)
d
(dict-set d k v)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(require rackunit)
(define tx/string (string-append "Date: adsfasd;lkfj\r\n"
"Host: www.fake.com\r\n"
"Content-Length: 999\r\n"
"Base-16: FF\r\n"
"Expect: 100-continue\r\n"
"\r\n"))
(define rx/string (string-append "HTTP/1.1 200 OK\r\n" tx/string))
(test-case
"extract-field/number"
(check-equal? (extract-field/number "Content-Length" rx/string 10)
999)
(check-equal? (extract-field/number "Base-16" rx/string 16)
255)
(check-equal? (extract-field/number "Not-There" rx/string 10)
#f)
(check-equal? (extract-field/number "Content-Type" rx/string 10)
#f))
(test-case
"coalesce-fields"
(check-equal? (coalesce-fields "X: 1\r\nX: 2\r\n\r\n")
"X: 1,2\r\n\r\n"))
(test-case
"heads string <-> dict"
(define s "Set-Cookie: A\r\nSet-Cookie: B\r\n\r\n")
(check-equal? (heads-dict->string (heads-string->dict s))
s))
(test-case
"maybe-dict-set and maybe-dict-set*"
(check-equal? (dict-ref (maybe-dict-set '([a . "10"]) 'a "10000") 'a)
"10")
(check-equal? (dict-ref (maybe-dict-set '([a . "10"]) 'a "10000") 'a)
"10")))
Something went wrong with that request. Please try again.