Skip to content

Commit ea87e97

Browse files
gdeestGaël Deest
gdeest
and
Gaël Deest
authored
Add RawM combinator (#1551)
Co-authored-by: Gaël Deest <[email protected]>
1 parent aee1917 commit ea87e97

File tree

6 files changed

+99
-9
lines changed

6 files changed

+99
-9
lines changed

‎servant-client-core/src/Servant/Client/Core/HasClient.hs

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -74,7 +74,7 @@ import Servant.API
7474
FromSourceIO (..), Header', Headers (..), HttpVersion,
7575
IsSecure, MimeRender (mimeRender),
7676
MimeUnrender (mimeUnrender), NoContent (NoContent),
77-
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
77+
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,
7878
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
7979
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
8080
Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
@@ -674,6 +674,16 @@ instance RunClient m => HasClient m Raw where
674674

675675
hoistClientMonad _ _ f cl = \meth -> f (cl meth)
676676

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+
677687
-- | If you use a 'ReqBody' in one of your endpoints in your API,
678688
-- the corresponding querying function will automatically take
679689
-- an additional argument of the type specified by your 'ReqBody'.

‎servant-server/src/Servant/Server/Internal.hs

Lines changed: 32 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
{-# LANGUAGE FlexibleContexts #-}
77
{-# LANGUAGE FlexibleInstances #-}
88
{-# LANGUAGE InstanceSigs #-}
9+
{-# LANGUAGE LambdaCase #-}
910
{-# LANGUAGE MultiParamTypeClasses #-}
1011
{-# LANGUAGE OverloadedStrings #-}
1112
{-# LANGUAGE PolyKinds #-}
@@ -65,7 +66,7 @@ import Network.HTTP.Types hiding
6566
import Network.Socket
6667
(SockAddr)
6768
import Network.Wai
68-
(Application, Request, httpVersion, isSecure, lazyRequestBody,
69+
(Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
6970
queryString, remoteHost, getRequestBodyChunk, requestHeaders,
7071
requestMethod, responseLBS, responseStream, vault)
7172
import Prelude ()
@@ -75,7 +76,7 @@ import Servant.API
7576
CaptureAll, Description, EmptyAPI, Fragment,
7677
FramingRender (..), FramingUnrender (..), FromSourceIO (..),
7778
Header', If, IsSecure (..), NoContentVerb, QueryFlag,
78-
QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
79+
QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
7980
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
8081
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
8182
WithNamedContext, WithResource, NamedRoutes)
@@ -652,6 +653,35 @@ instance HasServer Raw context where
652653
Fail a -> respond $ Fail a
653654
FailFatal e -> respond $ FailFatal e
654655

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+
655685
-- | If you use 'ReqBody' in one of the endpoints for your API,
656686
-- this automatically requires your server-side handler to be a function
657687
-- that takes an argument of the type specified by 'ReqBody'.

‎servant-server/test/Servant/ServerSpec.hs

Lines changed: 47 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -17,8 +17,10 @@ import Prelude.Compat
1717

1818
import Control.Monad
1919
(forM_, unless, when)
20+
import Control.Monad.Reader (runReaderT, ask)
2021
import Control.Monad.Error.Class
2122
(MonadError (..))
23+
import Control.Monad.IO.Class (MonadIO(..))
2224
import Data.Aeson
2325
(FromJSON, ToJSON, decode', encode)
2426
import Data.Acquire
@@ -54,19 +56,19 @@ import Servant.API
5456
Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
5557
Headers, HttpVersion, IsSecure (..), JSON, Lenient,
5658
NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
57-
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
59+
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,
5860
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
5961
UVerb, Union, Verb, WithStatus (..), addHeader)
6062
import Servant.Server
61-
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
62-
emptyServer, err401, err403, err404, respond, serve,
63+
(Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),
64+
emptyServer, err401, err403, err404, hoistServer, respond, serve,
6365
serveWithContext)
6466
import Servant.Test.ComprehensiveAPI
6567
import qualified Servant.Types.SourceT as S
6668
import Test.Hspec
6769
(Spec, context, describe, it, shouldBe, shouldContain)
6870
import Test.Hspec.Wai
69-
(get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
71+
(get, matchHeaders, matchStatus, shouldRespondWith,
7072
with, (<:>))
7173
import qualified Test.Hspec.Wai as THW
7274

@@ -102,6 +104,7 @@ spec = do
102104
reqBodySpec
103105
headerSpec
104106
rawSpec
107+
rawMSpec
105108
alternativeSpec
106109
responseHeadersSpec
107110
uverbResponseHeadersSpec
@@ -610,6 +613,46 @@ rawSpec = do
610613

611614
-- }}}
612615
------------------------------------------------------------------------------
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+
------------------------------------------------------------------------------
613656
-- * alternativeSpec {{{
614657
------------------------------------------------------------------------------
615658
type AlternativeApi =

‎servant/src/Servant/API.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -119,7 +119,7 @@ import Servant.API.NamedRoutes
119119
import Servant.API.QueryParam
120120
(QueryFlag, QueryParam, QueryParam', QueryParams)
121121
import Servant.API.Raw
122-
(Raw)
122+
(Raw, RawM)
123123
import Servant.API.RemoteHost
124124
(RemoteHost)
125125
import Servant.API.ReqBody

‎servant/src/Servant/API/Raw.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,3 +15,6 @@ import Data.Typeable
1515
-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>
1616
-- to serve static files stored in a particular directory on your filesystem
1717
data 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

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -175,7 +175,7 @@ import Servant.API.NamedRoutes
175175
import Servant.API.QueryParam
176176
(QueryFlag, QueryParam', QueryParams)
177177
import Servant.API.Raw
178-
(Raw)
178+
(Raw, RawM)
179179
import Servant.API.RemoteHost
180180
(RemoteHost)
181181
import Servant.API.ReqBody
@@ -589,6 +589,10 @@ instance HasLink Raw where
589589
type MkLink Raw a = a
590590
toLink toA _ = toA
591591

592+
instance HasLink RawM where
593+
type MkLink RawM a = a
594+
toLink toA _ = toA
595+
592596
instance HasLink (Stream m status fr ct a) where
593597
type MkLink (Stream m status fr ct a) r = r
594598
toLink toA _ = toA

0 commit comments

Comments
 (0)