From 06aab927bbfe4e3c5133c27fb9dece6d9e48f383 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Mon, 31 Oct 2016 17:49:06 -0400
Subject: [PATCH] optionally follow redirects in `web-request!`

---
 rmq/private/util.rkt | 36 +++++++++++++++++++++++++-----------
 1 file changed, 25 insertions(+), 11 deletions(-)

diff --git a/rmq/private/util.rkt b/rmq/private/util.rkt
index 15e7828..d42cf63 100644
--- a/rmq/private/util.rkt
+++ b/rmq/private/util.rkt
@@ -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")))