Merge pull request #667 from phadej/abstract-handler

Make Handler a newtype

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

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 ()

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") "" []
+                   Just n -> throwError $ ServantErr 400 (n ++ " not found") "" []
-                   Nothing -> throwE $ ServantErr 400 "missing parameter" "" [])
+                   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) =

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

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

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

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

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

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'

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

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

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)

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
+        Just _ -> throwError err403
-        Nothing -> throwE err401
+        Nothing -> throwError err401
   in mkAuthHandler authHandler :. EmptyContext
 
 genAuthSpec :: Spec