hreq-core 0.1.0.0 → 0.1.1.0

raw patch · 7 files changed

+63/−4 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• hreq-core.cabal +1/−1
• src/Hreq/Core/API/Response.hs +7/−1
• src/Hreq/Core/API/TypeLevel.hs +3/−1
• src/Hreq/Core/Client/ClientError.hs +2/−0
• src/Hreq/Core/Client/HasRequest.hs +1/−0
• src/Hreq/Core/Client/HasResponse.hs +42/−1

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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'

@@ -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