eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Add RawM combinator

Browse source 
The 'RawM' combinator is a variant of 'Raw' that lets users access the monadic context of the server.
This commit is contained in:
Gaël Deest 2022-03-04 10:23:41 +01:00
parent cedab6572d
commit e871e1eb85
6 changed files with 99 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
servant-client-core/src/Servant/Client/Core/HasClient.hs
View file

@ -76,7 +76,7 @@ import Servant.API
FromSourceIO (..), Header', Headers (..), HttpVersion,
IsSecure, MimeRender (mimeRender),
MimeUnrender (mimeUnrender), NoContent (NoContent),
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
@ -679,6 +679,16 @@ instance RunClient m => HasClient m Raw where
hoistClientMonad _ _ f cl = \meth -> f (cl meth)
instance RunClient m => HasClient m RawM where
type Client m RawM
= H.Method -> m Response
clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM
clientWithRoute _pm Proxy req httpMethod = do
runRequest req { requestMethod = httpMethod }
hoistClientMonad _ _ f cl = \meth -> f (cl meth)
-- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'ReqBody'.

34
servant-server/src/Servant/Server/Internal.hs
View file

@ -5,6 +5,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
@ -63,7 +64,7 @@ import Network.HTTP.Types hiding
import Network.Socket
(SockAddr)
import Network.Wai
(Application, Request, httpVersion, isSecure, lazyRequestBody,
(Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
queryString, remoteHost, getRequestBodyChunk, requestHeaders,
requestMethod, responseLBS, responseStream, vault)
import Prelude ()
@ -73,7 +74,7 @@ import Servant.API
CaptureAll, Description, EmptyAPI, Fragment,
FramingRender (..), FramingUnrender (..), FromSourceIO (..),
Header', If, IsSecure (..), NoContentVerb, QueryFlag,
QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
WithNamedContext, NamedRoutes)
@ -606,6 +607,35 @@ instance HasServer Raw context where
Fail a -> respond $ Fail a
FailFatal e -> respond $ FailFatal e
-- | Just pass the request to the underlying application and serve its response.
--
-- Example:
--
-- > type MyApi = "images" :> Raw
-- >
-- > server :: Server MyApi
-- > server = serveDirectory "/var/www/images"
instance HasServer RawM context where
type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
route
:: Proxy RawM
-> Context context
-> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env
route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do
routeResult <- runDelayed handleDelayed env request
let respond' = liftIO . respond
liftIO $ case routeResult of
Route handler -> runHandler (handler request (respond . Route)) >>=
\case
Left e -> respond' $ FailFatal e
Right a -> pure a
Fail e -> respond' $ Fail e
FailFatal e -> respond' $ FailFatal e
hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)
-- | If you use 'ReqBody' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by 'ReqBody'.

51
servant-server/test/Servant/ServerSpec.hs
View file

@ -17,8 +17,10 @@ import Prelude.Compat
import Control.Monad
(forM_, unless, when)
import Control.Monad.Reader (runReaderT, ask)
import Control.Monad.Error.Class
(MonadError (..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Aeson
(FromJSON, ToJSON, decode', encode)
import qualified Data.ByteString as BS
@ -52,19 +54,19 @@ import Servant.API
Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
Headers, HttpVersion, IsSecure (..), JSON, Lenient,
NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
UVerb, Union, Verb, WithStatus (..), addHeader)
import Servant.Server
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
emptyServer, err401, err403, err404, respond, serve,
(Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),
emptyServer, err401, err403, err404, hoistServer, respond, serve,
serveWithContext)
import Servant.Test.ComprehensiveAPI
import qualified Servant.Types.SourceT as S
import Test.Hspec
(Spec, context, describe, it, shouldBe, shouldContain)
import Test.Hspec.Wai
(get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
(get, matchHeaders, matchStatus, shouldRespondWith,
with, (<:>))
import qualified Test.Hspec.Wai as THW
@ -97,6 +99,7 @@ spec = do
reqBodySpec
headerSpec
rawSpec
rawMSpec
alternativeSpec
responseHeadersSpec
uverbResponseHeadersSpec
@ -605,6 +608,46 @@ rawSpec = do
-- }}}
------------------------------------------------------------------------------
-- * rawMSpec {{{
------------------------------------------------------------------------------
type RawMApi = "foo" :> RawM
rawMApi :: Proxy RawMApi
rawMApi = Proxy
rawMServer :: (Monad m, MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m
rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . cs . show =<< f req
rawMSpec :: Spec
rawMSpec = do
describe "Servant.API.RawM" $ do
it "gives access to monadic context" $ do
flip runSession (serve rawMApi
(hoistServer rawMApi (flip runReaderT (42 :: Integer)) (rawMServer (const ask)))) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo"]
}
liftIO $ do
simpleBody response `shouldBe` "42"
it "lets users throw servant errors" $ do
flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo"]
}
liftIO $ do
statusCode (simpleStatus response) `shouldBe` 404
it "gets the pathInfo modified" $ do
flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo", "bar"]
}
liftIO $ do
simpleBody response `shouldBe` cs (show ["bar" :: String])
-- }}}
------------------------------------------------------------------------------
-- * alternativeSpec {{{
------------------------------------------------------------------------------
type AlternativeApi =

2
servant/src/Servant/API.hs
View file

@ -111,7 +111,7 @@ import Servant.API.Modifiers
import Servant.API.QueryParam
(QueryFlag, QueryParam, QueryParam', QueryParams)
import Servant.API.Raw
(Raw)
(Raw, RawM)
import Servant.API.RemoteHost
(RemoteHost)
import Servant.API.ReqBody

3
servant/src/Servant/API/Raw.hs
View file

@ -15,3 +15,6 @@ import Data.Typeable
-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>
-- to serve static files stored in a particular directory on your filesystem
data Raw deriving Typeable
-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request.
data RawM deriving Typeable

6
servant/src/Servant/Links.hs
View file

@ -174,7 +174,7 @@ import Servant.API.NamedRoutes
import Servant.API.QueryParam
(QueryFlag, QueryParam', QueryParams)
import Servant.API.Raw
(Raw)
(Raw, RawM)
import Servant.API.RemoteHost
(RemoteHost)
import Servant.API.ReqBody
@ -580,6 +580,10 @@ instance HasLink Raw where
type MkLink Raw a = a
toLink toA _ = toA
instance HasLink RawM where
type MkLink RawM a = a
toLink toA _ = toA
instance HasLink (Stream m status fr ct a) where
type MkLink (Stream m status fr ct a) r = r
toLink toA _ = toA