diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 9b26c089..8d6dc522 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -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'. diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index e2df2c4a..c4aa7330 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -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'. diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 39e75cd4..713a31bc 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -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 = diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index de4b805c..f6f30d2a 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -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 diff --git a/servant/src/Servant/API/Raw.hs b/servant/src/Servant/API/Raw.hs index 4ece3845..6f27c9b9 100644 --- a/servant/src/Servant/API/Raw.hs +++ b/servant/src/Servant/API/Raw.hs @@ -15,3 +15,6 @@ import Data.Typeable -- -- 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 diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index ce07e22d..6e4c75d2 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -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