I have a yesod site serving content that includes rest WaiSubsites. all working. I have a need to serve a small REACT based site and I'd like to use the same basic infrastructure to add a simple reverse proxying subset would embed that REACT server. I'm aware that I could put nginx etc. in front but I don't want to do that.
Is there an easy solution?
thanks,
Stephen.
update. So I've built a basic solution, but I'd like to be able to map random /x/y to /y and so I need to rewrite the response content URLs of form /y to /x/y. having trouble workin out the process response handler. anyone?
makeExternalServerProxy :: Manager -> ByteString -> Int -> Application
makeExternalServerProxy manager host port =
simpleCors $ S.serveWithContext (S.Proxy :: S.Proxy S.Raw) S.EmptyContext forwardH
where -- | proxy based forwarding of non API requests to host:port
forwardH :: S.Tagged S.Handler Application
forwardH = S.Tagged $ waiProxyToSettings
forwardRequest proxySettings manager
forwardRequest :: Network.Wai.Request -> IO WaiProxyResponse
forwardRequest req =
pure $ WPRModifiedRequest
(rewriteRequestPure (\(pq,q) _ -> ( case pq of
[] -> []
(_:xs) -> xs
, q)) req)
(ProxyDest host port)
-- | Sends a simple 402 error message with the contents of the exception.
handleException :: SomeException -> Application
handleException exc _ sr = sr $ responseLBS
HT.status402
[("content-type", "text/plain")]
("We're sorry: Internal Error:\n\n" <>
TLE.encodeUtf8 (pack $ show exc))
proxySettings = defaultWaiProxySettings
{ wpsOnExc = handleException
, wpsProcessBody = processResponse
}
processResponse :: Network.Wai.Request -> Response () -> Maybe (ConduitT ByteString (Flush Builder) IO ())
processResponse = undefined
Related
I'm trying to build a web server in Haskell with Servant where part of the api works as a reverse proxy to another api.
I found an example of how to achieve this. But it seems that it doesn't work:
type API
= "cat" :> Get '[JSON] Cat
newtype Cat = Cat { cat :: String }
instance ToJSON Cat where
toJSON (Cat mew) =
object [ "cat" .= mew ]
server :: Server API
server = pure (Cat { cat = "mrowl" })
api :: Proxy (API :<|> Raw)
api = Proxy
app :: Manager -> Application
app manager =
serve api $ server :<|> waiProxyTo forwardRequest defaultOnExc manager
forwardRequest :: Request -> IO WaiProxyResponse
forwardRequest _ =
pure . WPRProxyDest . ProxyDest "127.0.0.1" $ 4567
startApp :: IO ()
startApp = do
manager <- newManager defaultManagerSettings
run 8080 (app manager)
It gives the following type error (when I try it in my own code base):
• Couldn't match type ‘Request
-> (Response -> IO ResponseReceived) -> IO ResponseReceived’
with ‘Tagged Handler Application’
Expected type: Server (API :<|> Raw)
Actual type: Handler Cat :<|> Application
• In the second argument of ‘($)’, namely
‘server :<|> waiProxyTo forwardRequest defaultOnExc manager’
In the expression:
serve api
$ server :<|> waiProxyTo forwardRequest defaultOnExc manager
In an equation for ‘app’:
app manager
= serve api
$ server :<|> waiProxyTo forwardRequest defaultOnExc manager
|
32 | serve api $ server :<|> waiProxyTo forwardRequest defaultOnExc manager
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(My interpretation is that :<|> has changed to not accept combing Server and Application since the example was written.)
What can I replace waiProxyTo forwardRequest defaultOnExc manager with to make this work?
I don't fully understand why this works but I got it working by mimicking how serveDirectoryWith works:
import Servant.Server (ServerT, Tagged)
import Network.HTTP.Client (Manager)
import Network.HTTP.ReverseProxy
( WaiProxyResponse, WaiProxyResponse(WPRProxyDest)
, ProxyDest(ProxyDest), waiProxyTo, defaultOnExc)
{- ... -}
forwardServer :: Manager -> ServerT Raw m
forwardServer manager =
Tagged $ waiProxyTo forwardRequest defaultOnExc manager
forwardRequest :: Request -> IO WaiProxyResponse
forwardRequest _ =
pure . WPRProxyDest . ProxyDest "127.0.0.1" $ 4567
app :: Manager -> Application
app manager =
serve api $ server :<|> (forwardServer manager)
Visualize a bytestring body on a webserver run on Spock (localhost for instance)
My goal : create website and view a bytestring (converted to text)
Framework: Http Simple for performing request to restAPI
Spock for my server
I don't want for instance to create a JSON as I need to manipulate/inspect my response before creating a JSON structure. General idea is that I want to use the response body to construct a JSON query structure (the user will be able to compose his question) that will be sent to the restAPI website.
I manage to build a request like this:
connect = do
request' <- (parseRequest "http://localhost")
let request = setRequestMethod "POST"
$ setRequestHost (S8.pack ("xx.xxx.xxx.xxx"))
$ setRequestPath "/api/Integration/Login"
$ setRequestBodyJSON me
$ setRequestPort 1000
$ request'
response <- httpJSON request
return (getResponseBody response :: Auth)
then I used it to query the API page
getRequest :: RequestPath -> HtmlT IO L.ByteString
getRequest rpath = do
atoken <- liftIO connect
request' <- liftIO (parseRequest "http://localhost")
let request = setRequestMethod "POST"
$ setRequestHost (S8.pack ("xx.xxx.xxx.xxx"))
$ setRequestPort 1000
$ setRequestPath (S8.pack ("/api/Integration/" ++ rpath))
$ addRequestHeader hAuthorization (S8.pack (unpack (token_type (atoken)) ++ " " ++ unpack (access_token (atoken))))
$ setRequestBodyJSON r1
$ request'
response <- httpLBS request
return (getResponseBody (response))
then I follow with a short SpockM monad:
app1 = do get root $ text "root"
fct
with fct equal to
fct = do get "/further" $ lucidIO ( fmap TL.decodeUtf8 (getRequest "GetProperties"))
Everything compile fine I am even able to see the result in GHCI with invocation like : connect >>= (\ x -> print x) (same with getRequest "GetProperties" )
What I don't understand is that lucidIO should give me a ActionCtxtT ctx m b type, which perfectly fit the type of a handler (for example like the text function in the do get ... $ text -> ActionCtxT ctx m a) and should be processed by the spock function in main() ie runSpock 8080 (spock spockCfg app1)
I tried to get rid of the ByteString 'ending' type replacing it with a () in order to mimic as close as possible the Html () type which shows up and work in lot of examples I studied.
All parsing and request building is done with the HTTP.Simple (it's not very elegant I know for instance it just have to work) which pulls me from start in a monad (due to the first function 'parseRequest' -> m Request) from which I cannot escape until lucidIO - may be I am choosing the wrong Monad (ie IO : but with IO I am able to check everything in ghci). Could you give me some hints on how to get this ByteString printed in my browser?
So finally I achieve what I was looking for - woua I am really proud of me ...
Okay for those who will look for the same thing, what I've manage to do, to recap my main problem was to escape the IO monad (my choice may be not clever but still) in which I was stuck due to the use of request parsers from HTTP.simple library.
My code change a little bit but the general idea stays the same:
building a Response query:
getResponseMethod :: RequestPath -> RequestBody -> IO (Maybe Value)
from which thanks to the decode function (aeson package) a Maybe Value is obtained (wrapped in IO but that's okay)
then my little spock server:
main :: IO ()
main = do
spockCfg <- defaultSpockCfg () PCNoDatabase ()
runSpock 8080 (spock spockCfg app)
I work a lot to have the right app -> SpockM () () () ()
I started with the simplest app we could imagine:
app = do get root $ text "Hello!"
noticing that the text function is producing a MonadIO m => ActionCtxT cxt m a monad so my thought was that if I 'sprinkle' some clever LiftIO thing it should do the job.
I create a helper function:
extrct :: MonadIO m => ActionCtxT ctx m Text
extrct = liftIO $ do
a <- getResponseMethod "GetProperties" r1
return (pack $ show a)
and with a twist of hand adjust my app
app :: SpockM () () () ()
app = do get root $ do
a <- extrct
text a
and finally I was able to see the string representation of the Maybe Value :: JSON on my spock local webserver. That's what I was looking for. Now I can work on cleaning my code. From what I understand using liftIO will place the IO monad in the rigth place in the Monad Stack that's because IO is always at the bottom?
I was using servant-generic-0.1.0.3 and servant-server-0.13.0.1 to do the following:
data Site route = Site
{ page :: route :-
"page" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] [Int]
, home :: route :-
Raw
} deriving (Generic)
type API = ToServant (Site AsApi)
siteServer :: Pool Connection -> Site AsServer
siteServer pool = Site
{ page = \x y ->
liftIO $ withResource pool $ \conn -> someDbFunction conn x y
, home = serveDirectoryWebApp "static"
}
api :: Proxy API
api = Proxy
app :: Pool Connection -> Application
app pool = serve api (toServant $ siteServer pool)
That worked fine, then I tried to use ReaderT to avoid passing Pool Connection to siteServer, so I added AppM and replaced siteServer like this:
type AppM = ReaderT (Pool Connection) IO
siteServer :: ServerT API AppM
siteServer = Site
{ page = do
pool <- ask
\x y ->
liftIO $ withResource pool $ \conn -> someDbFunction conn x y
, home = serveDirectoryWebApp "static"
}
but I got a bunch of errors when I tried to compile it.
I followed the same steps shown in the servant cookbook, but I couldn't make this work with generic routes, although it works when using regular routes.
Am I missing something that could make this work?
At least for the record-style routes supported by servant-* >= 0.14 (see here), if you want to work with another monad than Handler, you will want to look at AsServerT and genericServerT.
Applied to your example, this means siteServer should be defined as follows (not typechecked, but should be very close to correct).
siteServer :: Site (AsServerT AppM)
siteServer = Site
{ page = ... something in AppM ...
, home = ... something in AppM ...
}
-- turning that into a usual chain of :<|>-separated handlers
oldStyleServer :: ServerT API AppM
oldStyleServer = genericServerT siteServer
-- bringing it all back in Handler
oldStyleServerInHandler :: Pool Connection -> Server API -- same as ServerT API Handler
oldStyleServerInHandler conns = hoistServer (Proxy #API) appToHandler oldStyleServer
where appToHandler = liftIO . flip runReaderT conns
-- or something along those lines
-- serving it
app :: Pool Connection -> Application
app conns = serve (Proxy #API) (oldStyleServerInHandler conns)
Edit: Since you're using servant-* < 0.14 with servant-generic, you should replace genericServerT with toServant.
These days it's not uncommon to need to return a file (say, index.html) from the backend if the requested route doesn't match an existing API endpoint or another static asset. This is especially handy when using react-router and browserHistory.
I'm a bit stumped as to how I might approach this with Servant. I did wonder if intercepting 404's might be the way to go, but then of course sometimes the API will need to legitimately issue 404. Here's the kind of thing I've been using to experiment:
data Wombat = Wombat
{ id :: Int
, name :: String
} deriving (Eq, Show, Generic)
instance ToJSON Wombat
wombatStore :: [Wombat]
wombatStore =
[ Wombat 0 "Gertrude"
, Wombat 1 "Horace"
, Wombat 2 "Maisie"
, Wombat 3 "Julius"
]
wombats :: Handler [Wombat]
wombats = return wombatStore
wombat :: Int -> Handler Wombat
wombat wid = do
case find (\w -> Main.id w == wid) wombatStore of
Just x -> return x
Nothing -> throwE err404
type API =
"api" :> "wombats" :> Get '[JSON] [Wombat] :<|>
"api" :> "wombats" :> Capture "id" Int :> Get '[JSON] Wombat :<|>
Raw
api :: Proxy API
api = Proxy
server :: Server API
server = wombats
:<|> wombat
:<|> serveDirectory "static"
app :: Application
app = serve api server
main :: IO ()
main = run 3000 app
I'd love to see an example of how I could go about adding a 'default route' that sends an HTML response if the request doesn't match an API endpoint or anything in the static directory. Toy repo here.
You got it, basically. serveDirectory "static" can be replaced by any wai Application, so for instance, we could have:
...
{-# LANGUAGE OverloadedStrings #-}
...
import Network.Wai (responseLBS)
import Network.HTTP.Types (status200)
...
server :: Server API
server = wombats
:<|> wombat
:<|> hello
hello :: Application
hello req respond = respond $
responseLBS
status200 --
[("Content-Type", "text/plain")] -- headers
"Hello, World!" -- content
...
To a first approximation, wai applications are simply Request -> Response, but the docs tell a fuller story:
Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
So since you've got access to IO, you can check if the file exists and if so serve it, otherwise do whatever you like. In fact, wai defines type Middleware = Application -> Application, so you might think up a handy Middleware that wraps up hello (or any other Application!) in a file existence-checker-and-server.
Here is another route:
serveDirectory is defined as
serveDirectory = staticApp . defaultFileServerSettings . addTrailingPathSeparator
defaultFileServerSettings contains a field ssLookupFile which you can change to serve what you want if the file was not found. Perhaps:
import WaiAppStatic.Types
import WaiAppStatic.Storage.Filesystem
import Network.Wai.Application.Static
import System.FilePath
fileOrIndex root pieces = do
res <- ssLookupFile (defaultFileServerSettings root) pieces
case res of
LRNotFound -> undefined -- index.html here
_ -> return res
serveStatic root =
let root' = addTrailingPathSeparator root in
staticApp $ (defaultFileServerSettings root') {ssLookupFile = fileOrIndex root'}
What I'm trying to do is to create a somewhat smart reverse proxy server that should process some requests on its own and forward the others to the backend of choice. To make it challenging I'm trying hard to do it in Haskell, which I am a total newbie in.
Here's the code I've come up so far:
{-# LANGUAGE OverloadedStrings #-}
import Control.Applicative
import Data.ByteString
import Network.HTTP.ReverseProxy
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.RequestLogger
import qualified Network.HTTP.Client as HC
helloApp :: Application
helloApp req respond =
respond $ responseLBS status200 [("Content-Type", "text/plain")] "Hello"
proxyStubApp :: Application
proxyStubApp req respond =
respond $ responseLBS status200 [("Content-Type", "text/plain")] "You've hit the stub"
proxyApp :: IO Application
proxyApp = do
manager <- HC.newManager HC.defaultManagerSettings
return $ waiProxyTo (const $ return $ WPRProxyDest ProxyDest { pdHost = "localhost", pdPort = 9393 }) defaultOnExc manager
app :: Application
app req respond =
serve req respond
where serve = lookupServeFunction req
lookupServeFunction :: Request -> Application
lookupServeFunction req
| isInfixOf "sample_path" (rawPathInfo req) = proxyStubApp
| otherwise = helloApp
main = run 3011 =<< (logStdoutDev <$> return app)
It works fine, but when I exchange proxyStubApp for actual proxyApp I am forced to add IO all over the place. Particularly it gets added to app, consequently leaving me with the following compilation error message:
Couldn't match expected type ‘Request -> t5 -> t4’
with actual type ‘IO Application’
The equation(s) for ‘app’ have two arguments,
but its type ‘IO Application’ has none
I feel like I understand why it is happening, but I'm out of ideas of how to cope with it :( Or am I doing something totally wrong?
Thank you!
P.S. Here are the dependencies should you want to compile the thing on your own: wai warp http-types text bytestring wai-extra time http-reverse-proxy http-client
The IO in IO Application is kind-of redundant. Note that
type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
so, expanding proxyApp's arguments (what you already do in proxyStubApp), you get
proxyApp :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
proxyApp req continuation = do
manager <- HC.newManager HC.defaultManagerSettings
waiProxyTo (...) req respond
That works, because in either case
proxyApp :: IO Application
proxyApp = do
manager <- HC.newManager ...
...
and
proxyApp :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
proxyApp req continuation = do
manager <- HC.newManager ...
...
the IO action HC.newManager ... is "run within IO".
You may find it conceptually clearer to construct an Application in IO and hand it to some other place, and I won't argue with you. I want to note though, that you choose the Application based on the Request, so in a way you are in the hypothetical HTTP monad when choosing, so lookupServeFunction's signature Request -> Application makes more sense to me.
If you want to keep that type signature for proxyApp,
lookupServeFunction and app will have to be in IO as well and main will have to change accordingly, e.g.
myApp <- app
...
As haoformayor said, It is generally easier to work without the outer IO layer.
You might also like to simplify main.
fmap logStdoutDev (return app)
is the same as
return (logStdoutDev app)
and
run 3011 =<< return (logStdoutDev app)
is the same as
run 3011 (logStdoutDev app)
You might want to install hlint, which will help you spot these.