Generalize Raw combinator

doc/tutorial/Docs.lhs

@@ -18,6 +18,7 @@ import Data.ByteString.Lazy (ByteString)
 import Data.Proxy
 import Data.Text.Lazy.Encoding (encodeUtf8)
 import Data.Text.Lazy (pack)
+import Control.Monad.IO.Class
 import Network.HTTP.Types
 import Network.Wai
 import Servant.API
@@ -264,9 +265,9 @@ api :: Proxy DocsAPI
 api = Proxy
 
 server :: Server DocsAPI
-server = Server.server3 :<|> return serveDocs where
+server = Server.server3 :<|> serveDocs where
     serveDocs _ respond =
-        respond $ responseLBS ok200 [plain] docsBS
+        liftIO $ respond $ responseLBS ok200 [plain] docsBS
     plain = ("Content-Type", "text/plain")
 
 app :: Application

servant-client/test/Servant/ClientTestUtils.hs

@@ -25,6 +25,8 @@ import           Control.Concurrent
                  (ThreadId, forkIO, killThread)
 import           Control.Monad.Error.Class
                  (throwError)
+import           Control.Monad.IO.Class
+                 (liftIO)
 import           Data.Aeson
 import           Data.Char
                  (chr, isPrint)
@@ -159,13 +161,13 @@ server = serve api (
                    Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
   :<|> (\ names -> return (zipWith Person names [0..]))
   :<|> return
-  :<|> (return $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
-  :<|> (return $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))
-  :<|> (return $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
+  :<|> (\ _request respond -> liftIO $ respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
+  :<|> (\ request respond -> liftIO $ respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess")
+  :<|> (\ _request respond -> liftIO $ respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
   :<|> (\ a b c d -> return (a, b, c, d))
   :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
   :<|> return NoContent
-  :<|> (return $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
+  :<|> (\ _request respond -> liftIO $ respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
   :<|> emptyServer)
 
 type FailApi =
@@ -178,10 +180,10 @@ failApi = Proxy
 
 failServer :: Application
 failServer = serve failApi (
-       (return $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
-  :<|> (\ _capture -> return $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
-  :<|> (return $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
-  :<|> (return $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
+       (\ _request respond -> liftIO $ respond $ Wai.responseLBS HTTP.ok200 [] "")
+  :<|> (\ _capture -> \_request respond -> liftIO $ respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
+  :<|> (\_request respond -> liftIO $ respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
+  :<|> (\_request respond -> liftIO $ respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
  )
 
 -- * basic auth stuff

servant-http-streams/test/Servant/ClientSpec.hs

@@ -35,6 +35,8 @@ import           Control.Exception
                  (bracket, fromException, IOException)
 import           Control.Monad.Error.Class
                  (throwError)
+import           Control.Monad.IO.Class
+                 (liftIO)
 import           Data.Aeson
 import           Data.Char
                  (chr, isPrint)
@@ -186,12 +188,12 @@ server = serve api (
                    Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
   :<|> (\ names -> return (zipWith Person names [0..]))
   :<|> return
-  :<|> (return $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
-  :<|> (return $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
+  :<|> (\ _request respond -> liftIO $ respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
+  :<|> (\ _request respond -> liftIO $ respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
   :<|> (\ a b c d -> return (a, b, c, d))
   :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
   :<|> return NoContent
-  :<|> (return $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
+  :<|> (\ _request respond -> liftIO $ respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
   :<|> emptyServer)
 
 type FailApi =
@@ -203,9 +205,9 @@ failApi = Proxy
 
 failServer :: Application
 failServer = serve failApi (
-       (return $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
-  :<|> (\ _capture -> return $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
-  :<|> (return $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
+       (\ _request respond -> liftIO $ respond $ Wai.responseLBS HTTP.ok200 [] "")
+  :<|> (\ _capture -> \_request respond -> liftIO $ respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
+  :<|> (\_request respond -> liftIO $ respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
  )
 
 -- * basic auth stuff

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

@@ -64,7 +64,7 @@ import           Network.HTTP.Types                         hiding
 import           Network.Socket
                  (SockAddr)
 import           Network.Wai
-                 (Application, Request, httpVersion, isSecure, lazyRequestBody,
+                 (Response, ResponseReceived, Application, Request, httpVersion, isSecure, lazyRequestBody,
                  queryString, remoteHost, requestBody, requestHeaders,
                  requestMethod, responseLBS, responseStream, vault)
 import           Prelude ()
@@ -587,9 +587,9 @@ instance (KnownSymbol sym, HasServer api context)
 -- > server = serveDirectory "/var/www/images"
 instance HasServer Raw context where
 
-  type ServerT Raw m = m Application
+  type ServerT Raw m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
 
-  hoistServerWithContext _ _ nt s = nt s
+  hoistServerWithContext _ _ nt s = \ request respond -> nt $ s request respond
 
   route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
     -- note: a Raw application doesn't register any cleanup
@@ -600,10 +600,12 @@ instance HasServer Raw context where
 
     where go r request respond = case r of
             Route appH  -> do
-              r' <- runHandler appH
+              -- appH may return result with 'Right' _only_ by calling smth like @liftIO . respond@,
+              -- so in case of 'Left' we may suppose that 'respond' was never called.
+              r' <- runHandler $ appH request (respond . Route)
               case r' of
-                Left e    -> respond $ FailFatal e
-                Right app -> app request (respond . Route)
+                Left e  -> respond $ FailFatal e
+                Right x -> return x
             Fail a      -> respond $ Fail a
             FailFatal e -> respond $ FailFatal e
 

servant-server/test/Servant/ServerSpec.hs

@@ -19,6 +19,8 @@ import           Control.Monad
                  (forM_, unless, when)
 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
@@ -41,8 +43,8 @@ import           Network.HTTP.Types
                  methodDelete, methodGet, methodHead, methodPatch, methodPost,
                  methodPut, ok200, parseQuery)
 import           Network.Wai
-                 (Application, Middleware, Request, pathInfo, queryString,
-                 rawQueryString, requestHeaders, responseLBS)
+                 (Middleware, Request, Response, ResponseReceived,
+                 pathInfo, queryString, rawQueryString, requestHeaders, responseLBS)
 import           Network.Wai.Test
                  (defaultRequest, request, runSession, simpleBody,
                  simpleHeaders, simpleStatus)
@@ -62,7 +64,7 @@ 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
 
@@ -253,8 +255,8 @@ captureSpec = do
 
     with (return (serve
         (Proxy :: Proxy (Capture "captured" String :> Raw))
-        (\ "captured" -> return $ \request_ respond ->
-            respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
+        (\ "captured" -> \request_ respond ->
+            liftIO $ respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
       it "strips the captured path snippet from pathInfo" $ do
         get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
 
@@ -305,8 +307,8 @@ captureAllSpec = do
 
     with (return (serve
         (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
-        (\ _captured -> return $ \request_ respond ->
-            respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
+        (\ _captured -> \request_ respond ->
+            liftIO $ respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
       it "consumes everything from pathInfo" $ do
         get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
 
@@ -543,9 +545,9 @@ type RawApi = "foo" :> Raw
 rawApi :: Proxy RawApi
 rawApi = Proxy
 
-rawApplication :: (Show a, Monad m) => (Request -> a) -> m Application
-rawApplication f = return $ \request_ respond ->
-    respond $ responseLBS ok200 []
+rawApplication :: (Show a, Monad m, MonadIO m) => (Request -> a) -> Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
+rawApplication f = \request_ respond ->
+    liftIO $ respond $ responseLBS ok200 []
         (cs $ show $ f request_)
 
 rawSpec :: Spec
@@ -706,7 +708,7 @@ basicAuthApi = Proxy
 basicAuthServer :: Server BasicAuthAPI
 basicAuthServer =
   const (return jerry) :<|>
-  (return $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")
+  (\ _ respond -> liftIO $ respond $ responseLBS imATeapot418 [] "")
 
 basicAuthContext :: Context '[ BasicAuthCheck () ]
 basicAuthContext =
@@ -751,7 +753,7 @@ genAuthApi = Proxy
 
 genAuthServer :: Server GenAuthAPI
 genAuthServer = const (return tweety)
-           :<|> (return $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")
+           :<|> (\ _ respond -> liftIO $ respond $ responseLBS imATeapot418 [] "")
 
 type instance AuthServerData (AuthProtect "auth") = ()