Skip to content

Commit 5168157

Browse files
phadejphadej
committed
Make Handler a newtype
1 parent 48014f4 commit 5168157

File tree

13 files changed

+72
-30
lines changed

13 files changed

+72
-30
lines changed

‎servant-client/servant-client.cabal

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -75,10 +75,8 @@ test-suite spec
7575
, Servant.Common.BaseUrlSpec
7676
build-depends:
7777
base == 4.*
78-
, base-compat
79-
, transformers
80-
, transformers-compat
8178
, aeson
79+
, base-compat
8280
, bytestring
8381
, deepseq
8482
, hspec == 2.*
@@ -87,11 +85,14 @@ test-suite spec
8785
, http-media
8886
, http-types
8987
, HUnit
88+
, mtl
9089
, network >= 2.6
9190
, QuickCheck >= 2.7
9291
, servant == 0.9.*
9392
, servant-client
9493
, servant-server == 0.9.*
9594
, text
95+
, transformers
96+
, transformers-compat
9697
, wai
9798
, warp

‎servant-client/src/Servant/Common/Req.hs

Lines changed: 0 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -17,14 +17,9 @@ import Control.Monad
1717
import Control.Monad.Catch (MonadThrow, MonadCatch)
1818
import Data.Foldable (toList)
1919

20-
#if MIN_VERSION_mtl(2,2,0)
21-
import Control.Monad.Except (MonadError(..))
22-
#else
2320
import Control.Monad.Error.Class (MonadError(..))
24-
#endif
2521
import Control.Monad.Trans.Except
2622

27-
2823
import GHC.Generics
2924
import Control.Monad.Base (MonadBase (..))
3025
import Control.Monad.IO.Class ()

‎servant-client/test/Servant/ClientSpec.hs

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,7 @@ module Servant.ClientSpec where
2929
import Control.Arrow (left)
3030
import Control.Concurrent (forkIO, killThread, ThreadId)
3131
import Control.Exception (bracket)
32-
import Control.Monad.Trans.Except (throwE )
32+
import Control.Monad.Error.Class (throwError )
3333
import Data.Aeson
3434
import qualified Data.ByteString.Lazy as BS
3535
import Data.Char (chr, isPrint)
@@ -150,8 +150,8 @@ server = serve api (
150150
:<|> return
151151
:<|> (\ name -> case name of
152152
Just "alice" -> return alice
153-
Just n -> throwE $ ServantErr 400 (n ++ " not found") "" []
154-
Nothing -> throwE $ ServantErr 400 "missing parameter" "" [])
153+
Just n -> throwError $ ServantErr 400 (n ++ " not found") "" []
154+
Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
155155
:<|> (\ names -> return (zipWith Person names [0..]))
156156
:<|> return
157157
:<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")
@@ -212,7 +212,7 @@ type instance AuthClientData (AuthProtect "auth-tag") = ()
212212
genAuthHandler :: AuthHandler Request ()
213213
genAuthHandler =
214214
let handler req = case lookup "AuthHeader" (requestHeaders req) of
215-
Nothing -> throwE (err401 { errBody = "Missing auth header" })
215+
Nothing -> throwError (err401 { errBody = "Missing auth header" })
216216
Just _ -> return ()
217217
in mkAuthHandler handler
218218

@@ -298,7 +298,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
298298

299299
wrappedApiSpec :: Spec
300300
wrappedApiSpec = describe "error status codes" $ do
301-
let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
301+
let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" []
302302
context "are correctly handled by the client" $
303303
let test :: (WrappedApi, String) -> Spec
304304
test (WrappedApi api, desc) =

‎servant-server/CHANGELOG.md

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,9 @@
44
* Add `err422` Unprocessable Entity
55
([#646](https://github.com/haskell-servant/servant/pull/646))
66

7+
* `Handler` is not abstract datatype. Migration hint: change `throwE` to `throwError`.
8+
([#641](https://github.com/haskell-servant/servant/issues/641))
9+
710
0.7.1
811
------
912

‎servant-server/servant-server.cabal

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ library
4343
Servant.Server.Internal
4444
Servant.Server.Internal.BasicAuth
4545
Servant.Server.Internal.Context
46+
Servant.Server.Internal.Handler
4647
Servant.Server.Internal.Router
4748
Servant.Server.Internal.RoutingApplication
4849
Servant.Server.Internal.ServantErr
@@ -55,9 +56,11 @@ library
5556
, base64-bytestring >= 1.0 && < 1.1
5657
, bytestring >= 0.10 && < 0.11
5758
, containers >= 0.5 && < 0.6
59+
, exceptions >= 0.8 && < 0.9
5860
, http-api-data >= 0.3 && < 0.4
5961
, http-types >= 0.8 && < 0.10
6062
, network-uri >= 2.6 && < 2.7
63+
, monad-control >= 1.0.0.4 && < 1.1
6164
, mtl >= 2 && < 2.3
6265
, network >= 2.6 && < 2.7
6366
, safe >= 0.3 && < 0.4
@@ -68,6 +71,7 @@ library
6871
, filepath >= 1 && < 1.5
6972
, text >= 1.2 && < 1.3
7073
, transformers >= 0.3 && < 0.6
74+
, transformers-base >= 0.4.4 && < 0.5
7175
, transformers-compat>= 0.4 && < 0.6
7276
, wai >= 3.0 && < 3.3
7377
, wai-app-static >= 3.1 && < 3.2

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

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,8 @@ module Servant.Server
1717
, -- * Handlers for all standard combinators
1818
HasServer(..)
1919
, Server
20-
, Handler
20+
, Handler (..)
21+
, runHandler
2122

2223
-- * Debugging the server layout
2324
, layout

‎servant-server/src/Servant/Server/Experimental/Auth.hs

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@
1313
module Servant.Server.Experimental.Auth where
1414

1515
import Control.Monad.Trans (liftIO)
16-
import Control.Monad.Trans.Except (runExceptT)
1716
import Data.Proxy (Proxy (Proxy))
1817
import Data.Typeable (Typeable)
1918
import GHC.Generics (Generic)
@@ -29,7 +28,7 @@ import Servant.Server.Internal.RoutingApplication (addAuthCheck,
2928
delayedFailFatal,
3029
DelayedIO,
3130
withRequest)
32-
import Servant.Server.Internal.ServantErr (Handler)
31+
import Servant.Server.Internal.Handler (Handler, runHandler)
3332

3433
-- * General Auth
3534

@@ -65,4 +64,4 @@ instance ( HasServer api context
6564
authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))
6665
authHandler = unAuthHandler (getContextEntry context)
6766
authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))
68-
authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler
67+
authCheck = (>>= either delayedFailFatal return) . liftIO . runHandler . authHandler

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ module Servant.Server.Internal
1717
( module Servant.Server.Internal
1818
, module Servant.Server.Internal.Context
1919
, module Servant.Server.Internal.BasicAuth
20+
, module Servant.Server.Internal.Handler
2021
, module Servant.Server.Internal.Router
2122
, module Servant.Server.Internal.RoutingApplication
2223
, module Servant.Server.Internal.ServantErr
@@ -63,6 +64,7 @@ import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
6364

6465
import Servant.Server.Internal.Context
6566
import Servant.Server.Internal.BasicAuth
67+
import Servant.Server.Internal.Handler
6668
import Servant.Server.Internal.Router
6769
import Servant.Server.Internal.RoutingApplication
6870
import Servant.Server.Internal.ServantErr

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

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DeriveDataTypeable #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+
{-# LANGUAGE MultiParamTypeClasses #-}
6+
{-# LANGUAGE TypeFamilies #-}
7+
module Servant.Server.Internal.Handler where
8+
9+
import Prelude ()
10+
import Prelude.Compat
11+
12+
import Control.Monad.Base (MonadBase (..))
13+
import Control.Monad.Catch (MonadCatch, MonadThrow)
14+
import Control.Monad.Error.Class (MonadError)
15+
import Control.Monad.IO.Class (MonadIO)
16+
import Control.Monad.Trans.Control (MonadBaseControl (..))
17+
import Control.Monad.Trans.Except (ExceptT, runExceptT)
18+
import GHC.Generics (Generic)
19+
import Servant.Server.Internal.ServantErr (ServantErr)
20+
21+
newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a }
22+
deriving
23+
( Functor, Applicative, Monad, MonadIO, Generic
24+
, MonadError ServantErr
25+
, MonadThrow, MonadCatch
26+
)
27+
28+
instance MonadBase IO Handler where
29+
liftBase = Handler . liftBase
30+
31+
instance MonadBaseControl IO Handler where
32+
type StM Handler a = Either ServantErr a
33+
34+
-- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a
35+
liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler')))
36+
37+
-- restoreM :: StM Handler a -> Handler a
38+
restoreM st = Handler (restoreM st)
39+
40+
runHandler :: Handler a -> IO (Either ServantErr a)
41+
runHandler = runExceptT . runHandler'

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,12 +10,12 @@ module Servant.Server.Internal.RoutingApplication where
1010

1111
import Control.Monad (ap, liftM)
1212
import Control.Monad.Trans (MonadIO(..))
13-
import Control.Monad.Trans.Except (runExceptT)
1413
import Network.Wai (Application, Request,
1514
Response, ResponseReceived)
1615
import Prelude ()
1716
import Prelude.Compat
1817
import Servant.Server.Internal.ServantErr
18+
import Servant.Server.Internal.Handler
1919

2020
type RoutingApplication =
2121
Request -- ^ the request, the field 'pathInfo' may be modified by url routing
@@ -264,7 +264,7 @@ runAction action env req respond k =
264264
go (Fail e) = return $ Fail e
265265
go (FailFatal e) = return $ FailFatal e
266266
go (Route a) = do
267-
e <- runExceptT a
267+
e <- runHandler a
268268
case e of
269269
Left err -> return . Route $ responseServantErr err
270270
Right x -> return $! k x

0 commit comments

Comments
 (0)