Add request forwarding.

backend/Main.hs

@@ -25,10 +25,18 @@ import qualified Utils
 import Paths_elm_reactor (version)
 import Elm.Utils ((|>))
 
+import Network.HTTP.Client (withManager, defaultManagerSettings, httpLbs,
+  responseStatus, responseHeaders, parseUrl, RequestBody(RequestBodyLBS),
+  responseBody)
+import Network.HTTP.Types(Status(statusCode))
+import qualified Network.HTTP.Client as HTTP (Request(path, method,
+  requestHeaders, requestBody))
+
 
 data Flags = Flags
     { bind :: String
     , port :: Int
+    , forward :: Maybe String
     }
     deriving (Data,Typeable,Show,Eq)
 
@@ -37,6 +45,13 @@ flags :: Flags
 flags = Flags
   { bind = "0.0.0.0" &= help "set the host to bind to (default: 0.0.0.0)" &= typ "SPEC"
   , port = 8000 &= help "set the port of the reactor (default: 8000)"
+  , forward = Nothing &= help (
+      "Forward requests that would otherwise return a 404 to the given\
+      \ server. The path portion of the url is ignored and replaced with\
+      \ the path of the request. This is useful for avoiding cross-origin web\
+      \ requests when using elm-reactor to debug elm programs that make server\
+      \ requests."
+    ) &= typ "URL"
   } &= help "Interactive development tool that makes it easy to develop and debug Elm programs.\n\
             \    Read more about it at <https://github.com/elm-lang/elm-reactor>."
     &= helpArg [explicit, name "help", name "h"]
@@ -66,9 +81,44 @@ main =
           <|> route [ ("socket", socket) ]
           <|> serveDirectoryWith directoryConfig "."
           <|> serveAssets
+          <|> forwardRequest (forward cargs)
           <|> error404
 
 
+forwardRequest :: Maybe String -> Snap ()
+forwardRequest Nothing = pass
+forwardRequest (Just forwardUrl) = do
+  rqHeaders <- getsRequest headers
+  method_ <- getsRequest rqMethod
+  uri <- getsRequest rqURI
+  rqBody <- readRequestBody maxBound
+  request <- makeRequest uri rqHeaders method_ rqBody
+  response <- liftIO $ withManager defaultManagerSettings (httpLbs request)
+  modifyResponse (
+      setHeaders (responseHeaders response)
+      . setResponseCode (statusCode (responseStatus response))
+    )
+  writeLBS (responseBody response)
+  where
+    setHeaders hrds response =
+      foldr (uncurry setHeader) response (filter notSpecial hrds)
+
+    notSpecial ("content-length", _) = False
+    notSpecial _ = True
+
+    makeRequest uri hrds m rqBody = liftIO $ do
+      req <- parseUrl forwardUrl
+      return req {
+        HTTP.path = uri,
+        HTTP.method = showMethod m,
+        HTTP.requestHeaders = listHeaders hrds,
+        HTTP.requestBody = RequestBodyLBS rqBody
+      }
+
+    showMethod (Method m_) = m_
+    showMethod m_ = BSC.pack (show m_)
+
+
 startupMessage :: String
 startupMessage =
   "Elm Reactor " ++ Version.showVersion version

elm-reactor.cabal

@@ -78,7 +78,8 @@ Executable elm-reactor
     elm-compiler >= 0.14.1 && < 0.15,
     filepath,
     fsnotify >= 0.1.0.2,
-    HTTP,
+    http-client,
+    http-types,
     mtl,
     process,
     snap-core,