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

poking around in the code, but no luck yet...

Browse source
This commit is contained in:
Matthias Fischmann 2015-09-06 20:38:25 -07:00
parent a97dd8bc0e
commit 2b142796a4
1 changed files with 11 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -1,7 +1,9 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Servant.Server.Internal.RoutingApplication where module Servant.Server.Internal.RoutingApplication where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
@ -10,6 +12,7 @@ import Data.Monoid (Monoid, mappend, mempty)
#endif #endif
import Control.Monad.Trans.Either (EitherT, runEitherT) import Control.Monad.Trans.Either (EitherT, runEitherT)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, import Data.IORef (newIORef, readIORef,
writeIORef) writeIORef)
@ -41,6 +44,7 @@ newtype RouteResult a =
instance Monoid (RouteResult a) where instance Monoid (RouteResult a) where
mempty = RR $ Left mempty mempty = RR $ Left mempty
unrecoverable@(RR (Left (HttpError (statusCode -> s) _))) `mappend` RR (Right _) | s /= 404 = unrecoverable
RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y) RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
RR (Left _) `mappend` RR (Right y) = RR $ Right y RR (Left _) `mappend` RR (Right y) = RR $ Right y
r `mappend` _ = r r `mappend` _ = r
@ -119,7 +123,7 @@ runAction action respond k = do
e <- runEitherT a e <- runEitherT a
respond $ case e of respond $ case e of
Right x -> k x Right x -> k x
Left err -> succeedWith $ responseServantErr err Left err -> failWithServantError err
go (RR (Left err)) = respond $ failWith err go (RR (Left err)) = respond $ failWith err
feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b) feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)
@ -136,10 +140,15 @@ extractR (RR (Left err)) = RR (Left err)
failWith :: RouteMismatch -> RouteResult a failWith :: RouteMismatch -> RouteResult a
failWith = RR . Left failWith = RR . Left
-- FIXME: add headers field to HttpError constructor.
failWithServantError :: ServantErr -> RouteResult a
failWithServantError ServantErr{..} = failWith $ HttpError status {- errHeaders -} (Just errBody)
where
status = mkStatus errHTTPCode (BS.pack errReasonPhrase)
succeedWith :: a -> RouteResult a succeedWith :: a -> RouteResult a
succeedWith = RR . Right succeedWith = RR . Right
isMismatch :: RouteResult a -> Bool isMismatch :: RouteResult a -> Bool
isMismatch (RR (Left _)) = True isMismatch (RR (Left _)) = True
isMismatch _ = False isMismatch _ = False