@@ -17,8 +17,10 @@ import Prelude.Compat
1717
1818import Control.Monad
1919 (forM_, unless, when)
20+import Control.Monad.Reader (runReaderT, ask)
2021import Control.Monad.Error.Class
2122 (MonadError (..))
23+import Control.Monad.IO.Class (MonadIO(..))
2224import Data.Aeson
2325 (FromJSON, ToJSON, decode', encode)
2426import 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)
6062import 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)
6466import Servant.Test.ComprehensiveAPI
6567import qualified Servant.Types.SourceT as S
6668import Test.Hspec
6769 (Spec, context, describe, it, shouldBe, shouldContain)
6870import Test.Hspec.Wai
69− (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
71+ (get, matchHeaders, matchStatus, shouldRespondWith,
7072 with, (<:>))
7173import 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------------------------------------------------------------------------------
615658type AlternativeApi =