eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Make Handler a newtype

Browse source
This commit is contained in:
Oleg Grenrus 2017-01-16 11:44:25 +02:00
parent 48014f4a66
commit 5168157757
13 changed files with 72 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
servant-client/servant-client.cabal
View file

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

5
servant-client/src/Servant/Common/Req.hs
View file

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

10
servant-client/test/Servant/ClientSpec.hs
View file

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

3
servant-server/CHANGELOG.md
View file

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

4
servant-server/servant-server.cabal
View file

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

3
servant-server/src/Servant/Server.hs
View file

@ -17,7 +17,8 @@ module Servant.Server
, -- * Handlers for all standard combinators
HasServer(..)
, Server
, Handler
, Handler (..)
, runHandler
-- * Debugging the server layout
, layout

5
servant-server/src/Servant/Server/Experimental/Auth.hs
View file

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

2
servant-server/src/Servant/Server/Internal.hs
View file

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

41
servant-server/src/Servant/Server/Internal/Handler.hs Normal file
View file

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

4
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

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

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

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

5
servant-server/test/Servant/Server/ErrorSpec.hs
View file

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

10
servant-server/test/Servant/ServerSpec.hs
View file

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