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

optionally follow redirects in `web-request!`

This commit is contained in:
Tony Garnock-Jones 2016-10-31 17:49:06 -04:00
parent 1dec02fd3d
commit 06aab927bb
1 changed files with 25 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
rmq/private/util.rkt
View File

@ -6,6 +6,7 @@
web-respond/status!
web-request!)
(require racket/dict)
(require (only-in file/sha1 bytes->hex-string))
(require (only-in racket/random crypto-random-bytes))
(require net/url)
@ -35,20 +36,33 @@
#:headers '())
body))
(define (web-request! verb urlstr #:body [body #""] #:headers [headers '()])
(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))
(react/suspend (k)
(on-start
(printf "~a --> ~a ~a ~v\n" req-id verb urlstr body)
(send! (web-request req-id
'outbound
(web-request-header verb res headers (url-query u))
body)))
(stop-when (message (web-response-complete req-id $resp $body))
(printf "~a <-- ~v ~v\n" req-id resp body)
(k resp body))))
(define-values (resp response-body)
(react/suspend (k)
(on-start
(printf "~a --> ~a ~a ~v\n" 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))
(printf "~a <-- ~v ~v\n" req-id resp response-body)
(k resp response-body))))
(define location (dict-ref (web-response-header-headers resp) 'location #f))
(if (and (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)))
(module+ test
(check-equal? (extend-url-string-query "http://localhost/" '((a . "hi")))