ea87e97 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Add RawM combinator (#1551)

ea87e97Gaël Deest4 years ago

servant-client-core/src/Servant/Client/Core/HasClient.hs+11−1

compare with master

unifiedsplit

@@ -74,7 +74,7 @@ import Servant.API

74 FromSourceIO (..), Header', Headers (..), HttpVersion,

75 IsSecure, MimeRender (mimeRender),

76 MimeUnrender (mimeUnrender), NoContent (NoContent),

77− NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,

77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,

78 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,

79 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,

80 Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,

@@ -674,6 +674,16 @@ instance RunClient m => HasClient m Raw where

674

675 hoistClientMonad _ _ f cl = \meth -> f (cl meth)

676

677+instance RunClient m => HasClient m RawM where

678+ type Client m RawM

679+ = H.Method -> m Response

680+

681+ clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM

682+ clientWithRoute _pm Proxy req httpMethod = do

683+ runRequest req { requestMethod = httpMethod }

684+

685+ hoistClientMonad _ _ f cl = \meth -> f (cl meth)

686+

677-- | If you use a 'ReqBody' in one of your endpoints in your API,

687-- | If you use a 'ReqBody' in one of your endpoints in your API,

678-- the corresponding querying function will automatically take

688-- the corresponding querying function will automatically take

679-- an additional argument of the type specified by your 'ReqBody'.

689-- an additional argument of the type specified by your 'ReqBody'.

servant-server/src/Servant/Server/Internal.hs+32−2

@@ -6,6 +6,7 @@

6{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE InstanceSigs #-}

9+{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE OverloadedStrings #-}

11{-# LANGUAGE OverloadedStrings #-}

11{-# LANGUAGE PolyKinds #-}

12{-# LANGUAGE PolyKinds #-}

@@ -65,7 +66,7 @@ import Network.HTTP.Types hiding

65import Network.Socket

66import Network.Socket

66 (SockAddr)

67 (SockAddr)

67import Network.Wai

68import Network.Wai

68− (Application, Request, httpVersion, isSecure, lazyRequestBody,

69+ (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,

69 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

70 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

70 requestMethod, responseLBS, responseStream, vault)

71 requestMethod, responseLBS, responseStream, vault)

71import Prelude ()

72import Prelude ()

@@ -75,7 +76,7 @@ import Servant.API

75 CaptureAll, Description, EmptyAPI, Fragment,

76 CaptureAll, Description, EmptyAPI, Fragment,

76 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

77 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

77 Header', If, IsSecure (..), NoContentVerb, QueryFlag,

78 Header', If, IsSecure (..), NoContentVerb, QueryFlag,

78− QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

79+ QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),

79 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

80 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

80 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

81 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

81 WithNamedContext, WithResource, NamedRoutes)

82 WithNamedContext, WithResource, NamedRoutes)

@@ -652,6 +653,35 @@ instance HasServer Raw context where

652 Fail a -> respond $ Fail a

653 Fail a -> respond $ Fail a

653 FailFatal e -> respond $ FailFatal e

654 FailFatal e -> respond $ FailFatal e

654

655

656+-- | Just pass the request to the underlying application and serve its response.

657+--

658+-- Example:

659+--

660+-- > type MyApi = "images" :> Raw

661+-- >

662+-- > server :: Server MyApi

663+-- > server = serveDirectory "/var/www/images"

664+instance HasServer RawM context where

665+ type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived

666+

667+ route

668+ :: Proxy RawM

669+ -> Context context

670+ -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env

671+ route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do

672+ routeResult <- runDelayed handleDelayed env request

673+ let respond' = liftIO . respond

674+ liftIO $ case routeResult of

675+ Route handler -> runHandler (handler request (respond . Route)) >>=

676+ \case

677+ Left e -> respond' $ FailFatal e

678+ Right a -> pure a

679+ Fail e -> respond' $ Fail e

680+ FailFatal e -> respond' $ FailFatal e

681+

682+ hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)

683+

684+

655-- | If you use 'ReqBody' in one of the endpoints for your API,

685-- | If you use 'ReqBody' in one of the endpoints for your API,

656-- this automatically requires your server-side handler to be a function

686-- this automatically requires your server-side handler to be a function

657-- that takes an argument of the type specified by 'ReqBody'.

687-- that takes an argument of the type specified by 'ReqBody'.

servant-server/test/Servant/ServerSpec.hs+47−4

@@ -17,8 +17,10 @@ import Prelude.Compat

18import Control.Monad

19 (forM_, unless, when)

20+import Control.Monad.Reader (runReaderT, ask)

20import Control.Monad.Error.Class

21import Control.Monad.Error.Class

21 (MonadError (..))

22 (MonadError (..))

23+import Control.Monad.IO.Class (MonadIO(..))

22import Data.Aeson

24import Data.Aeson

23 (FromJSON, ToJSON, decode', encode)

25 (FromJSON, ToJSON, decode', encode)

24import Data.Acquire

26import Data.Acquire

@@ -54,19 +56,19 @@ import Servant.API

54 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,

56 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,

55 Headers, HttpVersion, IsSecure (..), JSON, Lenient,

57 Headers, HttpVersion, IsSecure (..), JSON, Lenient,

56 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

58 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

57− PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,

59+ PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,

58 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

60 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

59 UVerb, Union, Verb, WithStatus (..), addHeader)

61 UVerb, Union, Verb, WithStatus (..), addHeader)

60import Servant.Server

62import Servant.Server

61− (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

63+ (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),

62− emptyServer, err401, err403, err404, respond, serve,

64+ emptyServer, err401, err403, err404, hoistServer, respond, serve,

63 serveWithContext)

65 serveWithContext)

64import Servant.Test.ComprehensiveAPI

66import Servant.Test.ComprehensiveAPI

65import qualified Servant.Types.SourceT as S

67import qualified Servant.Types.SourceT as S

66import Test.Hspec

68import Test.Hspec

67 (Spec, context, describe, it, shouldBe, shouldContain)

69 (Spec, context, describe, it, shouldBe, shouldContain)

68import Test.Hspec.Wai

70import Test.Hspec.Wai

69− (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,

71+ (get, matchHeaders, matchStatus, shouldRespondWith,

70 with, (<:>))

72 with, (<:>))

71import qualified Test.Hspec.Wai as THW

73import qualified Test.Hspec.Wai as THW

@@ -102,6 +104,7 @@ spec = do

102 reqBodySpec

104 reqBodySpec

103 headerSpec

105 headerSpec

104 rawSpec

106 rawSpec

107+ rawMSpec

105 alternativeSpec

108 alternativeSpec

106 responseHeadersSpec

109 responseHeadersSpec

107 uverbResponseHeadersSpec

110 uverbResponseHeadersSpec

@@ -610,6 +613,46 @@ rawSpec = do

610

613

611-- }}}

614-- }}}

612------------------------------------------------------------------------------

615------------------------------------------------------------------------------

616+-- * rawMSpec {{{

617+------------------------------------------------------------------------------

618+

619+type RawMApi = "foo" :> RawM

620+

621+rawMApi :: Proxy RawMApi

622+rawMApi = Proxy

623+

624+rawMServer :: (Monad m, MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m

625+rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . cs . show =<< f req

626+

627+rawMSpec :: Spec

628+rawMSpec = do

629+ describe "Servant.API.RawM" $ do

630+ it "gives access to monadic context" $ do

631+ flip runSession (serve rawMApi

632+ (hoistServer rawMApi (flip runReaderT (42 :: Integer)) (rawMServer (const ask)))) $ do

633+ response <- Network.Wai.Test.request defaultRequest{

634+ pathInfo = ["foo"]

635+ }

636+ liftIO $ do

637+ simpleBody response `shouldBe` "42"

638+

639+ it "lets users throw servant errors" $ do

640+ flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do

641+ response <- Network.Wai.Test.request defaultRequest{

642+ pathInfo = ["foo"]

643+ }

644+ liftIO $ do

645+ statusCode (simpleStatus response) `shouldBe` 404

646+

647+ it "gets the pathInfo modified" $ do

648+ flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do

649+ response <- Network.Wai.Test.request defaultRequest{

650+ pathInfo = ["foo", "bar"]

651+ }

652+ liftIO $ do

653+ simpleBody response `shouldBe` cs (show ["bar" :: String])

654+-- }}}

655+------------------------------------------------------------------------------

613-- * alternativeSpec {{{

656-- * alternativeSpec {{{

614------------------------------------------------------------------------------

657------------------------------------------------------------------------------

615type AlternativeApi =

658type AlternativeApi =

servant/src/Servant/API.hs+1−1

@@ -119,7 +119,7 @@ import Servant.API.NamedRoutes

119import Servant.API.QueryParam

120 (QueryFlag, QueryParam, QueryParam', QueryParams)

121import Servant.API.Raw

122− (Raw)

122+ (Raw, RawM)

123import Servant.API.RemoteHost

124 (RemoteHost)

125import Servant.API.ReqBody

servant/src/Servant/API/Raw.hs+3

@@ -15,3 +15,6 @@ import Data.Typeable

15-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>

16-- to serve static files stored in a particular directory on your filesystem

17data Raw deriving Typeable

18+

19+-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request.

20+data RawM deriving Typeable

servant/src/Servant/Links.hs+5−1

@@ -175,7 +175,7 @@ import Servant.API.NamedRoutes

175import Servant.API.QueryParam

176 (QueryFlag, QueryParam', QueryParams)

177import Servant.API.Raw

178− (Raw)

178+ (Raw, RawM)

179import Servant.API.RemoteHost

180 (RemoteHost)

181import Servant.API.ReqBody

@@ -589,6 +589,10 @@ instance HasLink Raw where

589 type MkLink Raw a = a

590 toLink toA _ = toA

591

592+instance HasLink RawM where

593+ type MkLink RawM a = a

594+ toLink toA _ = toA

595+

592instance HasLink (Stream m status fr ct a) where

596instance HasLink (Stream m status fr ct a) where

593 type MkLink (Stream m status fr ct a) r = r

597 type MkLink (Stream m status fr ct a) r = r

594 toLink toA _ = toA

598 toLink toA _ = toA