From 5168157757adaada652ca7706d4bb3ae5b55eacd Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 16 Jan 2017 11:44:25 +0200 Subject: [PATCH] Make Handler a newtype --- servant-client/servant-client.cabal | 7 ++-- servant-client/src/Servant/Common/Req.hs | 5 --- servant-client/test/Servant/ClientSpec.hs | 10 ++--- servant-server/CHANGELOG.md | 3 ++ servant-server/servant-server.cabal | 4 ++ servant-server/src/Servant/Server.hs | 3 +- .../src/Servant/Server/Experimental/Auth.hs | 5 +-- servant-server/src/Servant/Server/Internal.hs | 2 + .../src/Servant/Server/Internal/Handler.hs | 41 +++++++++++++++++++ .../Server/Internal/RoutingApplication.hs | 4 +- .../src/Servant/Server/Internal/ServantErr.hs | 3 -- .../test/Servant/Server/ErrorSpec.hs | 5 +-- servant-server/test/Servant/ServerSpec.hs | 10 ++--- 13 files changed, 72 insertions(+), 30 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/Handler.hs diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index dabef6b3..452e4d35 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -75,10 +75,8 @@ test-suite spec , Servant.Common.BaseUrlSpec build-depends: base == 4.* - , base-compat - , transformers - , transformers-compat , aeson + , base-compat , bytestring , deepseq , hspec == 2.* @@ -87,11 +85,14 @@ test-suite spec , http-media , http-types , HUnit + , mtl , network >= 2.6 , QuickCheck >= 2.7 , servant == 0.9.* , servant-client , servant-server == 0.9.* , text + , transformers + , transformers-compat , wai , warp diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 90cc3ddf..3fb8c5aa 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -17,14 +17,9 @@ import Control.Monad import Control.Monad.Catch (MonadThrow, MonadCatch) import Data.Foldable (toList) -#if MIN_VERSION_mtl(2,2,0) -import Control.Monad.Except (MonadError(..)) -#else import Control.Monad.Error.Class (MonadError(..)) -#endif import Control.Monad.Trans.Except - import GHC.Generics import Control.Monad.Base (MonadBase (..)) import Control.Monad.IO.Class () diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 7833cd4e..783876dd 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -29,7 +29,7 @@ module Servant.ClientSpec where import Control.Arrow (left) import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Exception (bracket) -import Control.Monad.Trans.Except (throwE ) +import Control.Monad.Error.Class (throwError ) import Data.Aeson import qualified Data.ByteString.Lazy as BS import Data.Char (chr, isPrint) @@ -150,8 +150,8 @@ server = serve api ( :<|> return :<|> (\ name -> case name of Just "alice" -> return alice - Just n -> throwE $ ServantErr 400 (n ++ " not found") "" [] - Nothing -> throwE $ ServantErr 400 "missing parameter" "" []) + Just n -> throwError $ ServantErr 400 (n ++ " not found") "" [] + Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") @@ -212,7 +212,7 @@ type instance AuthClientData (AuthProtect "auth-tag") = () genAuthHandler :: AuthHandler Request () genAuthHandler = let handler req = case lookup "AuthHeader" (requestHeaders req) of - Nothing -> throwE (err401 { errBody = "Missing auth header" }) + Nothing -> throwError (err401 { errBody = "Missing auth header" }) Just _ -> return () in mkAuthHandler handler @@ -298,7 +298,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do wrappedApiSpec :: Spec wrappedApiSpec = describe "error status codes" $ do - let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" [] + let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" [] context "are correctly handled by the client" $ let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 355a0ff9..411b4af4 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -4,6 +4,9 @@ * Add `err422` Unprocessable Entity ([#646](https://github.com/haskell-servant/servant/pull/646)) +* `Handler` is not abstract datatype. Migration hint: change `throwE` to `throwError`. + ([#641](https://github.com/haskell-servant/servant/issues/641)) + 0.7.1 ------ diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index c8e7e6df..fc07f74a 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -43,6 +43,7 @@ library Servant.Server.Internal Servant.Server.Internal.BasicAuth Servant.Server.Internal.Context + Servant.Server.Internal.Handler Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServantErr @@ -55,9 +56,11 @@ library , base64-bytestring >= 1.0 && < 1.1 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 + , exceptions >= 0.8 && < 0.9 , http-api-data >= 0.3 && < 0.4 , http-types >= 0.8 && < 0.10 , network-uri >= 2.6 && < 2.7 + , monad-control >= 1.0.0.4 && < 1.1 , mtl >= 2 && < 2.3 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 @@ -68,6 +71,7 @@ library , filepath >= 1 && < 1.5 , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 + , transformers-base >= 0.4.4 && < 0.5 , transformers-compat>= 0.4 && < 0.6 , wai >= 3.0 && < 3.3 , wai-app-static >= 3.1 && < 3.2 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index cc29ff84..0e786ea6 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -17,7 +17,8 @@ module Servant.Server , -- * Handlers for all standard combinators HasServer(..) , Server - , Handler + , Handler (..) + , runHandler -- * Debugging the server layout , layout diff --git a/servant-server/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs index fd38ff1e..a6dfd52f 100644 --- a/servant-server/src/Servant/Server/Experimental/Auth.hs +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -13,7 +13,6 @@ module Servant.Server.Experimental.Auth where import Control.Monad.Trans (liftIO) -import Control.Monad.Trans.Except (runExceptT) import Data.Proxy (Proxy (Proxy)) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -29,7 +28,7 @@ import Servant.Server.Internal.RoutingApplication (addAuthCheck, delayedFailFatal, DelayedIO, withRequest) -import Servant.Server.Internal.ServantErr (Handler) +import Servant.Server.Internal.Handler (Handler, runHandler) -- * General Auth @@ -65,4 +64,4 @@ instance ( HasServer api context authHandler :: Request -> Handler (AuthServerData (AuthProtect tag)) authHandler = unAuthHandler (getContextEntry context) authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag)) - authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler + authCheck = (>>= either delayedFailFatal return) . liftIO . runHandler . authHandler diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index fc91267b..7c89b8f5 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -17,6 +17,7 @@ module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.Context , module Servant.Server.Internal.BasicAuth + , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr @@ -63,6 +64,7 @@ import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, import Servant.Server.Internal.Context import Servant.Server.Internal.BasicAuth +import Servant.Server.Internal.Handler import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr diff --git a/servant-server/src/Servant/Server/Internal/Handler.hs b/servant-server/src/Servant/Server/Internal/Handler.hs new file mode 100644 index 00000000..d5c41a5c --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Handler.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Server.Internal.Handler where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Error.Class (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import GHC.Generics (Generic) +import Servant.Server.Internal.ServantErr (ServantErr) + +newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a } + deriving + ( Functor, Applicative, Monad, MonadIO, Generic + , MonadError ServantErr + , MonadThrow, MonadCatch + ) + +instance MonadBase IO Handler where + liftBase = Handler . liftBase + +instance MonadBaseControl IO Handler where + type StM Handler a = Either ServantErr a + + -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a + liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler'))) + + -- restoreM :: StM Handler a -> Handler a + restoreM st = Handler (restoreM st) + +runHandler :: Handler a -> IO (Either ServantErr a) +runHandler = runExceptT . runHandler' diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 5f78d0bb..85fb04dc 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -10,12 +10,12 @@ module Servant.Server.Internal.RoutingApplication where import Control.Monad (ap, liftM) import Control.Monad.Trans (MonadIO(..)) -import Control.Monad.Trans.Except (runExceptT) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () import Prelude.Compat import Servant.Server.Internal.ServantErr +import Servant.Server.Internal.Handler type RoutingApplication = Request -- ^ the request, the field 'pathInfo' may be modified by url routing @@ -264,7 +264,7 @@ runAction action env req respond k = go (Fail e) = return $ Fail e go (FailFatal e) = return $ FailFatal e go (Route a) = do - e <- runExceptT a + e <- runHandler a case e of Left err -> return . Route $ responseServantErr err Right x -> return $! k x diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index 1d617dc8..82a5ccb0 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -4,7 +4,6 @@ module Servant.Server.Internal.ServantErr where import Control.Exception (Exception) -import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import Data.Typeable (Typeable) @@ -19,8 +18,6 @@ data ServantErr = ServantErr { errHTTPCode :: Int instance Exception ServantErr -type Handler = ExceptT ServantErr IO - responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody where diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 516719d2..18c49461 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -6,7 +6,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.ErrorSpec (spec) where -import Control.Monad.Trans.Except (throwE) import Data.Aeson (encode) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BCL @@ -51,7 +50,7 @@ errorOrderApi :: Proxy ErrorOrderApi errorOrderApi = Proxy errorOrderServer :: Server ErrorOrderApi -errorOrderServer = \_ _ _ -> throwE err402 +errorOrderServer = \_ _ _ -> throwError err402 -- On error priorities: -- @@ -187,7 +186,7 @@ errorRetryApi = Proxy errorRetryServer :: Server ErrorRetryApi errorRetryServer - = (\_ -> throwE err402) + = (\_ -> throwError err402) :<|> (\_ -> return 1) :<|> (\_ -> return 2) :<|> (\_ -> return 3) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index ade5a7b3..eaf25de3 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -14,7 +14,7 @@ module Servant.ServerSpec where import Control.Monad (forM_, when, unless) -import Control.Monad.Trans.Except (throwE) +import Control.Monad.Error.Class (MonadError (..)) import Data.Aeson (FromJSON, ToJSON, decode', encode) import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper) @@ -194,7 +194,7 @@ captureServer :: Integer -> Handler Animal captureServer legs = case legs of 4 -> return jerry 2 -> return tweety - _ -> throwE err404 + _ -> throwError err404 captureSpec :: Spec captureSpec = do @@ -228,7 +228,7 @@ captureAllServer legs = case sum legs of 4 -> return jerry 2 -> return tweety 0 -> return beholder - _ -> throwE err404 + _ -> throwError err404 captureAllSpec :: Spec captureAllSpec = do @@ -642,8 +642,8 @@ genAuthContext :: Context '[AuthHandler Request ()] genAuthContext = let authHandler = \req -> case lookup "Auth" (requestHeaders req) of Just "secret" -> return () - Just _ -> throwE err403 - Nothing -> throwE err401 + Just _ -> throwError err403 + Nothing -> throwError err401 in mkAuthHandler authHandler :. EmptyContext genAuthSpec :: Spec