Custom errors for HasClient, HasServer

This commit is contained in:
Gaël Deest 2021-11-18 11:49:28 +01:00
parent c388c5e82c
commit aab7e0d5dd
2 changed files with 31 additions and 31 deletions

View file

@ -65,7 +65,7 @@ import Data.Text
import Data.Proxy import Data.Proxy
(Proxy (Proxy)) (Proxy (Proxy))
import GHC.TypeLits import GHC.TypeLits
(KnownNat, KnownSymbol, symbolVal) (KnownNat, KnownSymbol, TypeError, symbolVal)
import Network.HTTP.Types import Network.HTTP.Types
(Status) (Status)
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
@ -91,6 +91,7 @@ import Servant.API.Status
import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment) import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
import Servant.API.Modifiers import Servant.API.Modifiers
(FoldRequired, RequiredArgument, foldRequiredArgument) (FoldRequired, RequiredArgument, foldRequiredArgument)
import Servant.API.TypeErrors
import Servant.API.UVerb import Servant.API.UVerb
(HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion) (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
@ -979,3 +980,19 @@ decodedAs response ct = do
Right val -> return val Right val -> return val
where where
accept = toList $ contentTypes ct accept = toList $ contentTypes ct
-------------------------------------------------------------------------------
-- Custom type errors
-------------------------------------------------------------------------------
-- Erroring instance for HasClient' when a combinator is not fully applied
instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
where
type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
clientWithRoute _ _ _ = error "unreachable"
hoistClientMonad _ _ _ _ = error "unreachable"
-- Erroring instances for 'HasClient' for unknown API combinators
instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api

View file

@ -56,7 +56,7 @@ import qualified Data.Text as T
import Data.Typeable import Data.Typeable
import GHC.Generics import GHC.Generics
import GHC.TypeLits import GHC.TypeLits
(KnownNat, KnownSymbol, symbolVal) (KnownNat, KnownSymbol, TypeError, symbolVal)
import qualified Network.HTTP.Media as NHM import qualified Network.HTTP.Media as NHM
import Network.HTTP.Types hiding import Network.HTTP.Types hiding
(Header, ResponseHeaders) (Header, ResponseHeaders)
@ -90,6 +90,7 @@ import Servant.API.ResponseHeaders
import Servant.API.Status import Servant.API.Status
(statusFromNat) (statusFromNat)
import qualified Servant.Types.SourceT as S import qualified Servant.Types.SourceT as S
import Servant.API.TypeErrors
import Web.HttpApiData import Web.HttpApiData
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
parseUrlPieces) parseUrlPieces)
@ -814,38 +815,15 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- TypeError helpers -- Custom type errors
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | This instance catches mistakes when there are non-saturated -- Erroring instance for 'HasServer' when a combinator is not fully applied
-- type applications on LHS of ':>'. instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
--
-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
-- ...
-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
-- ...Maybe you haven't applied enough arguments to
-- ...Capture' '[] "foo"
-- ...
--
-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
-- ...
-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
-- ...Maybe you haven't applied enough arguments to
-- ...Capture' '[] "foo"
-- ...
--
instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
where where
type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr) type ServerT (arr :> sub) _ = TypeError (PartialApplication HasServer arr)
-- it doesn't really matter what sub route we peak route = error "unreachable"
route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)" hoistServerWithContext _ _ _ _ = error "unreachable"
hoistServerWithContext _ _ _ = id
-- Cannot have TypeError here, otherwise use of this symbol will error :)
type HasServerArrowKindError arr =
'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
':$$: 'Text "Maybe you haven't applied enough arguments to"
':$$: 'ShowType arr
-- | This instance prevents from accidentally using '->' instead of ':>' -- | This instance prevents from accidentally using '->' instead of ':>'
-- --
@ -880,6 +858,11 @@ type HasServerArrowTypeError a b =
':$$: 'Text "and" ':$$: 'Text "and"
':$$: 'ShowType b ':$$: 'ShowType b
-- Erroring instances for 'HasServer' for unknown API combinators
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
-- | Ignore @'Fragment'@ in server handlers. -- | Ignore @'Fragment'@ in server handlers.
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details. -- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
-- --