bd9151b9de
Trying to use `NamedRoutes` with `servant-auth-server` currently results
in hideous error messages such as:
```
app/Main.hs:50:7: error:
• No instance for (Servant.Auth.Server.Internal.AddSetCookie.AddSetCookies
('Servant.Auth.Server.Internal.AddSetCookie.S
('Servant.Auth.Server.Internal.AddSetCookie.S
'Servant.Auth.Server.Internal.AddSetCookie.Z))
(AdminRoutes (Servant.Server.Internal.AsServerT Handler))
(ServerT
(Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi
(Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi
(NamedRoutes AdminRoutes)))
Handler))
arising from a use of 'serveWithContext'
• In the expression: serveWithContext (Proxy @API) ctx RootAPI {..}
```
This is because we didn't teach it how to recurse along `NamedRoutes`
trees and sprinkle headers at the tip of each branch.
This commit adds a test case and fixes the issue. In the process, it
also implements `ThrowAll` for `NamedRoutes`, which was necessary for
the test to run, and should also prove convenient for users.
59 lines
2.0 KiB
Haskell
59 lines
2.0 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
module Servant.Auth.Server.Internal.ThrowAll where
|
|
|
|
#if !MIN_VERSION_servant_server(0,16,0)
|
|
#define ServerError ServantErr
|
|
#endif
|
|
|
|
import Control.Monad.Error.Class
|
|
import Data.Tagged (Tagged (..))
|
|
import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..))
|
|
import Servant.API.Generic
|
|
import Servant.Server.Generic
|
|
import Servant.Server
|
|
import Network.HTTP.Types
|
|
import Network.Wai
|
|
|
|
import qualified Data.ByteString.Char8 as BS
|
|
|
|
class ThrowAll a where
|
|
-- | 'throwAll' is a convenience function to throw errors across an entire
|
|
-- sub-API
|
|
--
|
|
--
|
|
-- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
|
|
-- > == throwError err400 :<|> throwError err400 :<|> err400
|
|
throwAll :: ServerError -> a
|
|
|
|
instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where
|
|
throwAll e = throwAll e :<|> throwAll e
|
|
|
|
instance
|
|
( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) =>
|
|
ThrowAll (api (AsServerT m)) where
|
|
|
|
throwAll = fromServant . throwAll
|
|
|
|
-- Really this shouldn't be necessary - ((->) a) should be an instance of
|
|
-- MonadError, no?
|
|
instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where
|
|
throwAll e = const $ throwAll e
|
|
|
|
instance {-# OVERLAPPABLE #-} (MonadError ServerError m) => ThrowAll (m a) where
|
|
throwAll = throwError
|
|
|
|
-- | for @servant <0.11@
|
|
instance {-# OVERLAPPING #-} ThrowAll Application where
|
|
throwAll e _req respond
|
|
= respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))
|
|
(errHeaders e)
|
|
(errBody e)
|
|
|
|
-- | for @servant >=0.11@
|
|
instance {-# OVERLAPPING #-} MonadError ServerError m => ThrowAll (Tagged m Application) where
|
|
throwAll e = Tagged $ \_req respond ->
|
|
respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))
|
|
(errHeaders e)
|
|
(errBody e)
|