5168157 · typeable/servant

git.iko.soy/typeable/servant

Make Handler a newtype

commit5168157757adaada652ca7706d4bb3ae5b55eacd authorOleg Grenrus <oleg.grenrus@iki.fi> dateMon 16 Jan 2017, 11:44 (10 years ago) parent48014f4

13 files changed+72−30

compare with master

unifiedsplit

servant-client/servant-client.cabal+4−3 servant-client/src/Servant/Common/Req.hs−5 servant-client/test/Servant/ClientSpec.hs+5−5 servant-server/CHANGELOG.md+3 servant-server/servant-server.cabal+4 servant-server/src/Servant/Server.hs+2−1 servant-server/src/Servant/Server/Experimental/Auth.hs+2−3 servant-server/src/Servant/Server/Internal.hs+2 servant-server/src/Servant/Server/Internal/Handler.hs+41 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+2−2 servant-server/src/Servant/Server/Internal/ServantErr.hs−3 servant-server/test/Servant/Server/ErrorSpec.hs+2−3 servant-server/test/Servant/ServerSpec.hs+5−5

servant-client/servant-client.cabal+4−3

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

@@ -17,14 +17,9 @@ import Control.Monad

1717import Control.Monad.Catch (MonadThrow, MonadCatch)

1818import Data.Foldable (toList)

1919

20−#if MIN_VERSION_mtl(2,2,0)

21−import Control.Monad.Except (MonadError(..))

22−#else

2320import Control.Monad.Error.Class (MonadError(..))

24−#endif

2521import Control.Monad.Trans.Except

2622

27−

2823import GHC.Generics

2924import Control.Monad.Base (MonadBase (..))

3025import Control.Monad.IO.Class ()

servant-client/test/Servant/ClientSpec.hs+5−5

@@ -29,7 +29,7 @@ module Servant.ClientSpec where

2929import Control.Arrow (left)

3030import Control.Concurrent (forkIO, killThread, ThreadId)

3131import Control.Exception (bracket)

32−import Control.Monad.Trans.Except (throwE )

32+import Control.Monad.Error.Class (throwError )

3333import Data.Aeson

3434import qualified Data.ByteString.Lazy as BS

3535import 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") = ()

212212genAuthHandler :: AuthHandler Request ()

213213genAuthHandler =

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

299299wrappedApiSpec :: Spec

300300wrappedApiSpec = 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+3

@@ -4,6 +4,9 @@

44* Add `err422` Unprocessable Entity

55 ([#646](https://github.com/haskell-servant/servant/pull/646))

7+* `Handler` is not abstract datatype. Migration hint: change `throwE` to `throwError`.

8+ ([#641](https://github.com/haskell-servant/servant/issues/641))

7100.7.1

811------

912

servant-server/servant-server.cabal+4

@@ -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+2−1

@@ -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+2−3

@@ -13,7 +13,6 @@

1313module Servant.Server.Experimental.Auth where

1414

1515import Control.Monad.Trans (liftIO)

16−import Control.Monad.Trans.Except (runExceptT)

1716import Data.Proxy (Proxy (Proxy))

1817import Data.Typeable (Typeable)

1918import 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+2

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

6465import Servant.Server.Internal.Context

6566import Servant.Server.Internal.BasicAuth

67+import Servant.Server.Internal.Handler

6668import Servant.Server.Internal.Router

6769import Servant.Server.Internal.RoutingApplication

6870import Servant.Server.Internal.ServantErr

servant-server/src/Servant/Server/Internal/Handler.hsnew file+41

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

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+2−2

@@ -10,12 +10,12 @@ module Servant.Server.Internal.RoutingApplication where

1010

1111import Control.Monad (ap, liftM)

1212import Control.Monad.Trans (MonadIO(..))

13−import Control.Monad.Trans.Except (runExceptT)

1413import Network.Wai (Application, Request,

1514 Response, ResponseReceived)

1615import Prelude ()

1716import Prelude.Compat

1817import Servant.Server.Internal.ServantErr

18+import Servant.Server.Internal.Handler

1919

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

servant-server/src/Servant/Server/Internal/ServantErr.hs−3

@@ -4,7 +4,6 @@

44module Servant.Server.Internal.ServantErr where

66import Control.Exception (Exception)

7−import Control.Monad.Trans.Except (ExceptT)

87import qualified Data.ByteString.Char8 as BS

98import qualified Data.ByteString.Lazy as LBS

109import Data.Typeable (Typeable)

@@ -19,8 +18,6 @@ data ServantErr = ServantErr { errHTTPCode :: Int

1918

2019instance Exception ServantErr

2120

22−type Handler = ExceptT ServantErr IO

23−

2421responseServantErr :: ServantErr -> Response

2522responseServantErr ServantErr{..} = responseLBS status errHeaders errBody

2623 where

servant-server/test/Servant/Server/ErrorSpec.hs+2−3

@@ -6,7 +6,6 @@

66{-# OPTIONS_GHC -fno-warn-orphans #-}

77module Servant.Server.ErrorSpec (spec) where

9−import Control.Monad.Trans.Except (throwE)

109import Data.Aeson (encode)

1110import qualified Data.ByteString.Char8 as BC

1211import qualified Data.ByteString.Lazy.Char8 as BCL

@@ -51,7 +50,7 @@ errorOrderApi :: Proxy ErrorOrderApi

5150errorOrderApi = Proxy

5251

5352errorOrderServer :: Server ErrorOrderApi

54−errorOrderServer = \_ _ _ -> throwE err402

53+errorOrderServer = \_ _ _ -> throwError err402

5554

5655-- On error priorities:

5756--

@@ -187,7 +186,7 @@ errorRetryApi = Proxy

187186

188187errorRetryServer :: Server ErrorRetryApi

189188errorRetryServer

190− = (\_ -> throwE err402)

189+ = (\_ -> throwError err402)

191190 :<|> (\_ -> return 1)

192191 :<|> (\_ -> return 2)

193192 :<|> (\_ -> return 3)

servant-server/test/Servant/ServerSpec.hs+5−5

@@ -14,7 +14,7 @@

1414module Servant.ServerSpec where

1515

1616import Control.Monad (forM_, when, unless)

17−import Control.Monad.Trans.Except (throwE)

17+import Control.Monad.Error.Class (MonadError (..))

1818import Data.Aeson (FromJSON, ToJSON, decode', encode)

1919import qualified Data.ByteString.Base64 as Base64

2020import Data.Char (toUpper)

@@ -194,7 +194,7 @@ captureServer :: Integer -> Handler Animal

194194captureServer legs = case legs of

195195 4 -> return jerry

196196 2 -> return tweety

197− _ -> throwE err404

197+ _ -> throwError err404

198198

199199captureSpec :: Spec

200200captureSpec = do

@@ -228,7 +228,7 @@ captureAllServer legs = case sum legs of

228228 4 -> return jerry

229229 2 -> return tweety

230230 0 -> return beholder

231− _ -> throwE err404

231+ _ -> throwError err404

232232

233233captureAllSpec :: Spec

234234captureAllSpec = do

@@ -642,8 +642,8 @@ genAuthContext :: Context '[AuthHandler Request ()]

642642genAuthContext =

643643 let authHandler = \req -> case lookup "Auth" (requestHeaders req) of

644644 Just "secret" -> return ()

645− Just _ -> throwE err403

646− Nothing -> throwE err401

645+ Just _ -> throwError err403

646+ Nothing -> throwError err401

647647 in mkAuthHandler authHandler :. EmptyContext

648648

649649genAuthSpec :: Spec