#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*
)
(define (extract-http-ver&code&text h)
(match h
[(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?)
(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?)
(heads-dict->string (heads-string->dict heads ",")))
(define (validate-tx-or-rx-header s)
(match s
[(pregexp "^HTTP/1\\.[01].+?\r\n(.+?)$"
(list _ heads))
(validate-header heads)]
[else
(validate-header s)])
s)
(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)))))
(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"))
(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)))))
(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")))