Add RawM combinator (#1551)

Co-authored-by: Gaël Deest <gael.deest@tweag.io>

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

@@ -74,7 +74,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, WithResource, WithStatus (..), contentType, getHeadersHList,
@@ -674,6 +674,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'.

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

@@ -6,6 +6,7 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE InstanceSigs          #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PolyKinds             #-}
@@ -65,7 +66,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 ()
@@ -75,7 +76,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, WithResource, NamedRoutes)
@@ -652,6 +653,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'.

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           Data.Acquire
@@ -54,19 +56,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
 
@@ -102,6 +104,7 @@ spec = do
   reqBodySpec
   headerSpec
   rawSpec
+  rawMSpec
   alternativeSpec
   responseHeadersSpec
   uverbResponseHeadersSpec
@@ -610,6 +613,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 =

servant/src/Servant/API.hs

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

servant/src/Servant/API/Raw.hs

@@ -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

servant/src/Servant/Links.hs

@@ -175,7 +175,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
@@ -589,6 +589,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