151 lines
6.2 KiB
Racket
151 lines
6.2 KiB
Racket
#lang racket/base
|
|
|
|
(provide random-hex-string
|
|
extend-url-string-query
|
|
web-respond/status!
|
|
web-request!
|
|
web-post/form-parameters!
|
|
analyze-response
|
|
parse-link-headers
|
|
link-header-ref
|
|
maybe-link-header
|
|
vh
|
|
canonical-url)
|
|
|
|
(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)
|
|
(require net/uri-codec)
|
|
(require syndicate/actor)
|
|
(require syndicate/drivers/timer)
|
|
(require syndicate/drivers/web)
|
|
|
|
(module+ test (require rackunit))
|
|
|
|
(define (random-hex-string half-length)
|
|
(bytes->hex-string (crypto-random-bytes half-length)))
|
|
|
|
(define (extend-url-string-query urlstr extension)
|
|
(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
|
|
#:code code
|
|
#:message message
|
|
#:headers '())
|
|
body))
|
|
|
|
(define (web-request! verb urlstr
|
|
#:body [request-body #""]
|
|
#:headers [headers '()]
|
|
#:redirect-budget [redirect-budget 0])
|
|
(define req-id (gensym 'req))
|
|
(define u (string->url urlstr))
|
|
(define res (url->resource u))
|
|
(define-values (resp response-body)
|
|
(react/suspend (k)
|
|
(on-start
|
|
(log-info "~a --> ~a ~a ~v" req-id verb urlstr request-body)
|
|
(send! (web-request req-id
|
|
'outbound
|
|
(web-request-header verb res headers (url-query u))
|
|
request-body)))
|
|
(stop-when (message (web-response-complete req-id $resp $response-body))
|
|
(log-info "~a <-- ~v ~v" req-id resp response-body)
|
|
(k resp response-body))))
|
|
(define location (and resp (dict-ref (web-response-header-headers resp) 'location #f)))
|
|
(if (and resp
|
|
(eq? (web-response-header-code-type resp) 'redirection)
|
|
(positive? redirect-budget)
|
|
location)
|
|
(web-request! verb location
|
|
#:body request-body
|
|
#:headers headers
|
|
#:redirect-budget (- redirect-budget 1))
|
|
(values resp response-body)))
|
|
|
|
(define (web-post/form-parameters! urlstr query-alist
|
|
#:headers [headers '()]
|
|
#:redirect-budget [redirect-budget 0])
|
|
(web-request! 'post urlstr
|
|
#:headers (cons (cons 'content-type "application/x-www-form-urlencoded") headers)
|
|
#:body (string->bytes/utf-8 (alist->form-urlencoded query-alist))))
|
|
|
|
(define (analyze-response req-thunk k-successful k-unsuccessful)
|
|
(define-values (resp response-body) (req-thunk))
|
|
(if (web-response-successful? resp)
|
|
(k-successful)
|
|
(k-unsuccessful 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 (link-header-ref parsed-link-headers rel default)
|
|
(match (hash-ref parsed-link-headers rel '())
|
|
[(cons v _) v]
|
|
['() default]))
|
|
|
|
(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
|
|
(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"))))
|
|
|
|
(define (maybe-link-header urlstr rel)
|
|
(if urlstr
|
|
(list (cons 'link (format "<~a>; rel=~a" urlstr rel)))
|
|
'()))
|
|
|
|
(define (vh host-name port) (web-virtual-host "http" host-name port))
|
|
|
|
(define (canonical-url baseurl path)
|
|
(define b (url->resource (string->url baseurl)))
|
|
(url->string (resource->url (struct-copy web-resource b
|
|
[path (append-resource-path (web-resource-path b) path)]))))
|