Skip to content

309 handle application exceptions with 500 errors #954

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 9 commits into
base: master
Choose a base branch
from
Open

309 handle application exceptions with 500 errors #954

Show file tree
Hide file tree
Changes from 6 commits
Commits
Show all changes
9 commits
Select commit Hold shift + click to select a range
ff4e2af
Remove duplicate import
Apr 26, 2018
547adab
Add NFData instance
Apr 26, 2018
a90b671
Fix all errors
Apr 26, 2018
4d46e98
Remove hardcoded param in serveWithContext
Apr 27, 2018
3d9a151
Add helper functions
Apr 27, 2018
64686f3
Merge branch 'master' into 309-handle-application-exceptions-with-500…
Jun 10, 2018
5b13ff4
Merge branch 'master' into 309-handle-application-exceptions-with-500…
Jul 5, 2018
465e0b8
Make everyting compile again
Jul 6, 2018
a786dc4
Use Evaluate instead of Bool
Jul 9, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions servant-server/servant-server.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -84,6 +84,7 @@ library
, base-compat >= 0.9.3 && < 0.11
, attoparsec >= 0.13.2.0 && < 0.14
, base64-bytestring >= 1.0.0.1 && < 1.1
, deepseq >= 1.4.3.0 && < 1.5
, exceptions >= 0.8.3 && < 0.11
, http-api-data >= 0.3.7.1 && < 0.4
, http-media >= 0.7.1.1 && < 0.8
Expand Down
21 changes: 17 additions & 4 deletions servant-server/src/Servant/Server.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,8 @@ module Servant.Server
( -- * Run a wai application from an API
serve
, serveWithContext
, fullyEvalResponse
, noEvalResponse

, -- * Construct a wai Application from an API
toApplication
Expand Down Expand Up @@ -122,13 +124,24 @@ import Servant.Server.Internal
-- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app
--
serve :: (HasServer api '[]) => Proxy api -> Server api -> Application
serve p = serveWithContext p EmptyContext

serveWithContext :: (HasServer api context)
serve :: (HasServer api '[Bool]) => Proxy api -> Server api -> Application
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm against of using Context to guide whether to eval or not eval. IMHO single global choice should be enough for now.

Something #309 (comment) is good.

Context won't work for subapis anyway, as we give only single Context to serveWithContext. And if we use combinators to alter the context, we could be more direct and alter "whether to eval or not".

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The comment suggests both a global setting & a Context. Are you requesting both, or just the global?

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Just global I think.

serve p = serveWithContext p noEvalResponse

serveWithContext :: (HasServer api context, HasContextEntry context Bool)
=> Proxy api -> Context context -> Server api -> Application
serveWithContext p context server =
toApplication (runRouter (route p context (emptyDelayed (Route server))))
toApplication
((getContextEntry context :: Bool) || False)
-- ^ determins if we should fully evaluate response
-- defaults to False
(runRouter (route p context (emptyDelayed (Route server))))

fullyEvalResponse :: Context '[Bool]
fullyEvalResponse = True :. EmptyContext

noEvalResponse :: Context '[Bool]
noEvalResponse = False :. EmptyContext

-- | Hoist server implementation.
--
Expand Down
22 changes: 15 additions & 7 deletions servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@
{-# LANGUAGE UndecidableInstances #-}
module Servant.Server.Internal.RoutingApplication where

import Control.DeepSeq (force)
import Control.Monad (ap, liftM)
import Control.Monad.Base (MonadBase (..))
import Control.Monad.Catch (MonadThrow (..))
Expand Down Expand Up @@ -84,13 +85,20 @@ instance MonadTransControl RouteResultT where
instance MonadThrow m => MonadThrow (RouteResultT m) where
throwM = lift . throwM

toApplication :: RoutingApplication -> Application
toApplication ra request respond = ra request routingRespond
where
routingRespond :: RouteResult Response -> IO ResponseReceived
routingRespond (Fail err) = respond $ responseServantErr err
routingRespond (FailFatal err) = respond $ responseServantErr err
routingRespond (Route v) = respond v
toApplication :: Bool -> RoutingApplication -> Application
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Last nitpick: let's have

data Evaluate = Force | Lazy deriving (Show)

so we won't be Bool-blind.

toApplication fullyEvaluate ra request respond =
ra request (maybeEval routingRespond)
where
maybeEval :: (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
maybeEval resp =
if fullyEvaluate
then force resp
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

http://hackage.haskell.org/package/deepseq-1.4.3.0/docs/src/Control.DeepSeq.html#line-482 - NFData (a - > b) probably doesn't do what you expect.

else resp
routingRespond :: RouteResult Response -> IO ResponseReceived
routingRespond (Fail err) = respond $ responseServantErr err
routingRespond (FailFatal err) = respond $ responseServantErr err
routingRespond (Route v) = respond v

-- | A 'Delayed' is a representation of a handler with scheduled
-- delayed checks that can trigger errors.
Expand Down
10 changes: 7 additions & 3 deletions servant-server/src/Servant/Server/Internal/ServantErr.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,20 +1,24 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
module Servant.Server.Internal.ServantErr where

import Control.DeepSeq (NFData)
import Control.Exception (Exception)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Typeable (Typeable)
import qualified Network.HTTP.Types as HTTP
import Network.Wai (Response, responseLBS)
import GHC.Generics (Generic)

data ServantErr = ServantErr { errHTTPCode :: Int
, errReasonPhrase :: String
, errBody :: LBS.ByteString
, errHeaders :: [HTTP.Header]
} deriving (Show, Eq, Read, Typeable)
} deriving (Show, Eq, Read, Typeable, Generic, NFData)

instance Exception ServantErr

Expand Down