syndicate-lang
/
racketmq-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

parse-link-headers (crude)

This commit is contained in:
Tony Garnock-Jones 2016-10-31 22:29:06 -04:00
parent c37aa8e786
commit 98b62a5bc8
1 changed files with 52 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
rmq/private/util.rkt
View File

@ -4,9 +4,12 @@
random-hex-string
extend-url-string-query
web-respond/status!
web-request!)
web-request!
parse-link-headers)
(require racket/dict)
(require racket/match)
(require racket/string)
(require (only-in file/sha1 bytes->hex-string))
(require (only-in racket/random crypto-random-bytes))
(require net/url)
@ -28,6 +31,20 @@
(define u (string->url urlstr))
(url->string (struct-copy url u [query (append (url-query u) extension)])))
(module+ test
(check-equal? (extend-url-string-query "http://localhost/" '((a . "hi")))
"http://localhost/?a=hi")
(check-equal? (extend-url-string-query "http://localhost/" '())
"http://localhost/")
(check-equal? (extend-url-string-query "http://localhost?foo=bar" '())
"http://localhost?foo=bar")
(check-equal? (extend-url-string-query "http://localhost/?foo=bar" '())
"http://localhost/?foo=bar")
(check-equal? (extend-url-string-query "http://localhost?foo=bar" '((a . "hi")))
"http://localhost?foo=bar&a=hi")
(check-equal? (extend-url-string-query "http://localhost/?foo=bar" '((a . "hi")))
"http://localhost/?foo=bar&a=hi"))
(define (web-respond/status! id code message [body #""])
(web-respond/bytes! id
#:header (web-response-header
@ -64,16 +81,38 @@
#:redirect-budget (- redirect-budget 1))
(values resp response-body)))
(define (parse-link-headers headers)
(define rel-dict-reverse-order
(for/fold [(seed (hasheq))] [(header headers)]
(if (eq? (car header) 'link)
(parse-link-header-value (cdr header) seed)
seed)))
(for/hasheq [((rel urls-rev) (in-hash rel-dict-reverse-order))]
(values rel (reverse urls-rev))))
(define (parse-link-header-value link-header seed)
;; This is not adequate with respect to the RFC 5988 grammar, which
;; includes a wide variety of link-params other than "rel".
(define pieces
(append (regexp-match* #rx"(<([^>]+)>; +rel=([^\"][^,]*))" link-header #:match-select values)
(regexp-match* #rx"(<([^>]+)>; +rel=\"([^\"]+)\")" link-header #:match-select values)))
(for/fold [(rel-dict seed)] [(piece pieces)]
(match-define (list _ _ url rels-str) piece)
(for/fold [(rel-dict rel-dict)] [(rel-str (string-split rels-str))]
(define rel (string->symbol rel-str))
(hash-set rel-dict rel (cons url (hash-ref rel-dict rel '()))))))
(module+ test
(check-equal? (extend-url-string-query "http://localhost/" '((a . "hi")))
"http://localhost/?a=hi")
(check-equal? (extend-url-string-query "http://localhost/" '())
"http://localhost/")
(check-equal? (extend-url-string-query "http://localhost?foo=bar" '())
"http://localhost?foo=bar")
(check-equal? (extend-url-string-query "http://localhost/?foo=bar" '())
"http://localhost/?foo=bar")
(check-equal? (extend-url-string-query "http://localhost?foo=bar" '((a . "hi")))
"http://localhost?foo=bar&a=hi")
(check-equal? (extend-url-string-query "http://localhost/?foo=bar" '((a . "hi")))
"http://localhost/?foo=bar&a=hi"))
(define combined "<http://phubb.cweiske.de/hub.php>; rel=\"hub\", <http://push-tester.cweiske.de/feed.php>; rel=\"self\"")
(define separate "<http://localhost:7827/hub>; rel=hub")
(check-equal? (parse-link-header-value combined (hasheq))
(hasheq 'hub (list "http://phubb.cweiske.de/hub.php")
'self (list "http://push-tester.cweiske.de/feed.php")))
(check-equal? (parse-link-header-value separate (hasheq))
(hasheq 'hub (list "http://localhost:7827/hub")))
(check-equal? (parse-link-headers (list (cons 'link combined)
(cons 'content-type "text/plain")
(cons 'link separate)))
(hasheq 'hub (list "http://phubb.cweiske.de/hub.php"
"http://localhost:7827/hub")
'self (list "http://push-tester.cweiske.de/feed.php"))))