diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## Hreq-Core 0.1.1.0 + +* Matching status codes with in response. + +One can specify that a certain status code is expected in the http response +and when its not received we throw an error. + ## Hreq-Core 0.1.0.0 * Initial public release diff --git a/hreq-core.cabal b/hreq-core.cabal --- a/hreq-core.cabal +++ b/hreq-core.cabal @@ -1,6 +1,6 @@ cabal-version: >= 2.0 name: hreq-core -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Core functionality for Hreq Http client library description: Core functionality for Hreq. A type dependent highlevel HTTP client library inspired by servant-client. category: Network, Web diff --git a/src/Hreq/Core/API/Response.hs b/src/Hreq/Core/API/Response.hs --- a/src/Hreq/Core/API/Response.hs +++ b/src/Hreq/Core/API/Response.hs @@ -5,13 +5,14 @@ import Data.Kind (Type) import Data.Singletons (Sing, SingI (..)) -import GHC.TypeLits (Symbol) +import GHC.TypeLits (Nat, Symbol) -- * Response type data ResContent a = ResBody a a | ResHeaders [(Symbol, a)] | ResStream a a + | ResStatus a Nat | Raw a -- * Response type synonyms @@ -19,12 +20,14 @@ type ResHeaders = 'ResHeaders type ResStream = 'ResStream type Raw = 'Raw () +type ResStatus = 'ResStatus () -- * Response as a Singleton GADT data SResContent (a :: ResContent Type) where SResBody :: forall ctyp a. Sing ctyp -> Sing a -> SResContent ('ResBody ctyp a) SResStream :: forall ctyp a. Sing ctyp -> Sing a -> SResContent ('ResStream ctyp a) SResHeaders :: forall (ts :: [(Symbol, Type)]). Sing ts -> SResContent ('ResHeaders ts) + SResStatus :: forall (a :: Type) (n :: Nat) . Sing a -> Sing n -> SResContent ('ResStatus a n) SRaw :: forall (a :: Type) . Sing a -> SResContent ('Raw a) type instance Sing = SResContent @@ -36,6 +39,9 @@ instance SingI ts => SingI ('ResHeaders ts :: ResContent Type) where sing = SResHeaders sing + +instance (SingI a, SingI n) => SingI ('ResStatus a n :: ResContent Type) where + sing = SResStatus sing sing instance SingI a => SingI ('Raw a :: ResContent Type) where sing = SRaw sing diff --git a/src/Hreq/Core/API/TypeLevel.hs b/src/Hreq/Core/API/TypeLevel.hs --- a/src/Hreq/Core/API/TypeLevel.hs +++ b/src/Hreq/Core/API/TypeLevel.hs @@ -3,7 +3,7 @@ module Hreq.Core.API.TypeLevel where import Data.Kind (Type, Constraint) -import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..), KnownSymbol) +import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..), KnownSymbol, KnownNat) import Network.HTTP.Types (Header) import Web.HttpApiData (ToHttpApiData) @@ -61,6 +61,7 @@ type family HttpRes (res :: [ ResContent Type ]) :: [ Type ] where HttpRes '[] = '[] HttpRes ('ResBody ctyp a ': ts) = a ': HttpRes ts + HttpRes ('ResStatus _a code ': ts) = HttpRes ts HttpRes ('ResHeaders (s ': hs) ': ts) = [Header] ': HttpRes ts HttpRes ('ResHeaders '[] ': ts) = HttpRes ts HttpRes ('Raw a ': ts) = HttpRes ts @@ -68,6 +69,7 @@ -- | Response content types Constraints. type family HttpResConstraints (res :: [ResContent Type]) :: Constraint where HttpResConstraints '[] = () + HttpResConstraints ('ResStatus _a code ': ts) = (KnownNat code, HttpResConstraints ts) HttpResConstraints ('ResBody ctyp a ': ts) = (HasMediaType ctyp, MediaDecode ctyp a, HttpResConstraints ts) HttpResConstraints ('ResStream ctyp a ': ts) = (HasMediaType ctyp, HttpResConstraints ts) diff --git a/src/Hreq/Core/Client/ClientError.hs b/src/Hreq/Core/Client/ClientError.hs --- a/src/Hreq/Core/Client/ClientError.hs +++ b/src/Hreq/Core/Client/ClientError.hs @@ -26,6 +26,8 @@ | UnsupportedContentType MediaType Response -- | The content-type header is invalid | InvalidContentTypeHeader Response + -- | The received status code didn't much the expected. + | InvalidStatusCode Response -- | There was a connection error, and no response was received | ConnectionError SomeException deriving (Show, Generic, Typeable) diff --git a/src/Hreq/Core/Client/HasRequest.hs b/src/Hreq/Core/Client/HasRequest.hs --- a/src/Hreq/Core/Client/HasRequest.hs +++ b/src/Hreq/Core/Client/HasRequest.hs @@ -69,6 +69,7 @@ SCons (SResBody sctyp _a) _rs -> Just $ mediaType sctyp SCons (SRaw _) rs -> getAcceptHeader rs SCons (SResHeaders _) rs -> getAcceptHeader rs + SCons (SResStatus _ _) rs -> getAcceptHeader rs SCons (SResStream sctyp _) _rs -> Just $ mediaType sctyp -- | Transform a 'Hlist' of inputs into a 'Request' diff --git a/src/Hreq/Core/Client/HasResponse.hs b/src/Hreq/Core/Client/HasResponse.hs --- a/src/Hreq/Core/Client/HasResponse.hs +++ b/src/Hreq/Core/Client/HasResponse.hs @@ -60,11 +60,44 @@ httpRes _ _ = error "GHC Error" +-- | Expected status code much match received code instance {-# OVERLAPPING #-} + ( MonadError ClientError m + , KnownNat n + ) + => HasResponse '[ ResStatus n ] m where + type HttpOutput '[ ResStatus n ] = Response + + httpRes _ res = do + let expectedCode = fromIntegral @Integer @Int $ natVal (Proxy @n) + rcode = resStatusCode res + when (expectedCode /= rcode) $ throwError (InvalidStatusCode res) + + return res + +-- | Expected status code much match received code in a response code list +instance {-# OVERLAPPING #-} + ( MonadError ClientError m + , KnownNat n + , SingI ('Res (r ': rs)) + , HttpResConstraints (r ': rs) + ) + => HasResponse (ResStatus n : r : rs) m where + type HttpOutput (ResStatus n : r : rs) = Hlist (HttpRes (r ': rs)) + + httpRes _ response = do + let expectedCode = fromIntegral @Integer @Int $ natVal (Proxy @n) + rcode = resStatusCode response + when (expectedCode /= rcode) $ throwError (InvalidStatusCode response) + + case sing @('Res (r ': rs)) of + SRes xs -> decodeAsHlist xs response + +instance {-# OVERLAPPING #-} ( MediaDecode ctyp a , MonadError ClientError m ) - => HasResponse '[ 'ResBody ctyp a ] m where + => HasResponse '[ 'ResBody ctyp a ] m where type HttpOutput '[ 'ResBody ctyp a ] = a httpRes _ = decodeAsBody (Proxy @ctyp) @@ -145,6 +178,14 @@ SCons (SResHeaders SNil) xs -> decodeAsHlist xs response + SCons (SResStatus _ snat) xs -> do + let rcode = resStatusCode response + expectedCode = withKnownNat snat (fromIntegral @Integer @Int $ natVal snat) + + when (rcode /= expectedCode) $ throwError (InvalidStatusCode response) + + decodeAsHlist xs response + -- Should never match because we have a class instance -- that triggers a type error when 'Raw' is in a non-singleton -- type level list