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.
Related
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
In my attempt to write an authenticated Servant API where handlers use the RIO monad instead of Servant's own Handler monad, I am stuck on authenticated routes that return no content; i.e., Servant's NoContent type. When I try to hoist the RIO server into the Handler using hoistServerWithContext, I get a type error that I don't grok.
Here is the simplified API and server setup:
import qualified Servant as SV
import qualified Servant.Auth.Server as AS
-- A login endpoint that sets authentication and XSRF cookies upon success.
-- Login is a credentials record.
type LoginEndpoint
= "login" :> SV.ReqBody '[SV.JSON] Login :> SV.Verb 'SV.POST 204 '[SV.JSON] CookieHeader
loginServer
:: AS.CookieSettings -> AS.JWTSettings -> SV.ServerT LoginEndpoint (RIO m)
loginServer = ... -- Perform credential check here.
-- A protected endpoint that requires cookie authentication
-- The no-content handler is causing the problem described below.
type ProtectedEndpoint = "api" :> SV.Get '[SV.JSON] Text :<|> SV.DeleteNoContent
protectedServer (AS.Authenticated _) =
return "Authenticated" :<|> return SV.NoContent
protectedServer _ = throwIO SV.err401 :<|> throwIO SV.err401
-- The overall API, with cookie authentication on the protected endpoint
type Api
= LoginEndpoint :<|> (AS.Auth '[AS.Cookie] User :> ProtectedEndpoint)
-- | The overall server for all endpoints.
server :: AS.CookieSettings -> AS.JWTSettings -> SV.ServerT Api (RIO m)
server cs jwt = loginServer cs jwt :<|> protectedServer
Where User is a record type that can be serialized as JWT as part of a cookie. To hoist the server, I follow the example here:
apiProxy :: Proxy Api
apiProxy = Proxy
contextProxy :: Proxy '[AS.CookieSettings, AS.JWTSettings]
contextProxy = Proxy
newtype Env = Env
{ config :: Text }
-- Helper function to hoist our RIO handler into a Servant Handler.
hoistAppServer :: AS.CookieSettings -> AS.JWTSettings -> Env -> SV.Server Api
hoistAppServer cookieSettings jwtSettings env = SV.hoistServerWithContext
apiProxy
contextProxy
(nt env)
(server cookieSettings jwtSettings)
where
-- Natural transformation to map the RIO monad stack to Servant's Handler.
nt :: Env -> RIO Env a -> SV.Handler a
nt e m = SV.Handler $ ExceptT $ try $ runRIO e m
main :: IO ()
main = do
myKey <- AS.generateKey -- Key for encrypting the JWT.
let jwtCfg = AS.defaultJWTSettings myKey
cfg = cookieConf :. jwtCfg :. SV.EmptyContext -- cookieConf sets XSRF handling
env = Env { config = "Some configuration string" }
Warp.run 8081 $ SV.serveWithContext apiProxy cfg $ hoistAppServer cookieConf jwtCfg env
The above hoisting works fine for endpoints that return some content. However, when :<|> SV.DeleteNoContent is present in the ProtectedEndpoint (and the corresponding parts in the server), I get the following type error:
No instance for (HasServer
(Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi
(Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi
(NoContentVerb 'DELETE)))
'[CookieSettings, JWTSettings])
arising from a use of ‘hoistServerWithContext’
The problem does not arise on an endpoint without authentication; e.g., UnprotectedEndpoint instead of (AS.Auth '[AS.Cookie] User :> ProtectedEndpoint) in the API type definition.
hoistServerWithContext is a function of the HasServer type class, but I'm not sure which instance is of concern here. If I let GHC infer the type, I get
hoistServerWithContext :: forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
To me, the type error (plus my experiments adding and removing the no-content handler) indicate that the protectedServer derived by Servant's type machinery is not a member of the HasServer type class. But my Haskell type-level programming skills are not up to the task, it seems. Where exactly is the problem? Am I missing a type annotation? A language extension?
The type error seems to result because servant currently does not allow adding headers to a NoContentVerb because the corresponding type instance is missing. See the Servant-Auth issue here.
Even though I don't fully understand the details, the following workaround from the above issue comment avoids the type error:
type instance ASC.AddSetCookieApi (SV.NoContentVerb 'SV.DELETE)
= SV.Verb 'SV.DELETE 204 '[SV.JSON] (ASC.AddSetCookieApiVerb SV.NoContent)
I have been searching for examples, however most examples do a RouteSomething -> PathSegment "firstpath" $ unitEncoder mempty and not a single nested route.
There are some examples that use Cat.id to pass the whole URI as a Text such Characher-Sheet:
backendRouteEncoder = mkFullRouteEncoder
(FullRoute_Backend BackendRoute_Missing :/ ())
(\case
BackendRoute_API -> PathSegment "api" $ Cat.id
BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty
)
and then on the backend parse the whole route:
server sql (BackendRoute_API :=> Identity _) = dir "api" $
route [ ("spelllist/", runReaderT spellListHandler sql)
, ("featlist/", runReaderT featListHandler sql)
]
however, this feels odd since I would have thought all routing would have been defined in Common.Route with Obelisk.Route as per the skeleton of ob init and other examples defining routes exclusively there. I would appreciate the safety of exhaustiveness check of the LambdaCase over the datatype codifying routes and not having to add BackendRoute_Missing equivalent on all possible backend/frontend subroutes.
data FrontendRoute :: * -> * where
FrontendRoute_Sub :: FrontendRoute (R SubRoute)
data SubRoute :: * -> * where
SubRoute_Foo :: SubRoute ()
Then replace unitEncoder with pathComponentEncoder $ \case ...
See obelisk-oauth for another example.
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'}
I am writing a Happstack server and I have a MongoDB database to connect to. For that, I made a function to create a connection pool
type MongoPool = Pool IOError Pipe
withMongo :: (MongoPool -> IO a) -> IO ()
withMongo f = do
pool <- dbPool
f pool
killAll pool
And then a function to run an Action with a created pool:
runDB :: (MonadIO m) => MongoPool -> Action IO a -> m (Either Failure a)
runDB pool f = liftIO $ do
pipe <- runIOE $ aResource pool
access pipe master dbName f
It's obvious this requires to carry the pool in all the routes as a parameter. I would like to wrap it into a ReaderT, so that runDB can have a type like Action IO a -> ServerPart (Either Failure a) or even better, Action IO a -> ServerPart a in which a failure will result in an HTTP Error 500 automatically.
I have a trouble wrapping my head around how that can be achieved and I'd love for some hints from people who've more experience with Haskell monads and happstack.
Thanks.
Through this question I found another with a very good hint, and I have built this. It seems to work fine and I thought I'd share it:
type MongoPool = Pool IOError Pipe
type DBServerPart a = ReaderT MongoPool (ServerPartT IO) a
hostName = "127.0.0.1"
dbName = "test"
defaultPoolSize = 10
runDB :: Action IO a -> DBServerPart (Either Failure a)
runDB f = do
pool <- ask
liftIO $ do
pipe <- runIOE $ aResource pool
access pipe master dbName f
withMongo :: DBServerPart a -> ServerPart a
withMongo f = do
pool <- liftIO $ dbPool
a <- runReaderT f pool
liftIO $ killAll pool
return a
dbPool = newPool fac defaultPoolSize
where fac = Factory {
newResource = connect $ host hostName,
killResource = close,
isExpired = isClosed
}