packages feed

hreq-core (empty) → 0.1.0.0

raw patch · 26 files changed

+1617/−0 lines, 26 filesdep +aesondep +attoparsecdep +basebuild-type:Customsetup-changed

Dependencies added: aeson, attoparsec, base, base-compat, bytestring, containers, doctest, exceptions, hreq-core, http-api-data, http-media, http-types, mtl, string-conversions, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## Hreq-Core 0.1.0.0++* Initial public release
+ LICENSE.md view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 Lukwago Allan++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,7 @@+# Hreq-core++[![Hackage](https://img.shields.io/hackage/v/hreq-core.svg?logo=haskell)](https://hackage.haskell.org/package/hreq-core)+[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE)+[![Build status](https://img.shields.io/travis/epicallan/hreq.svg?logo=travis)](https://travis-ci.org/epicallan/hreq)++Core functionality for Hreq Http client library. Please look at the repository [README.md](https://github.com/epicallan/hreq/blob/master/README.md) file for more.
+ Setup.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif++#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests"++#else++#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#warning You are configuring this package without cabal-doctest installed. \+         The doctests test-suite will not work as a result. \+         To fix this, install cabal-doctest before configuring.+#endif++import Distribution.Simple++main :: IO ()+main = defaultMain++#endif
+ hreq-core.cabal view
@@ -0,0 +1,94 @@+cabal-version: >= 2.0+name:           hreq-core+version:        0.1.0.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+homepage:       https://github.com/epicallan/hreq/blob/master/README.md+bug-reports:    https://github.com/epicallan/hreq.git/issues+author:         Lukwago Allan <epicallan.al@gmail>+maintainer:     Lukwago Allan <epicallan.al@gmail>+copyright:      2019 Lukwago Allan+license:        MIT+license-file:   LICENSE.md+extra-doc-files: CHANGELOG.md, README.md+tested-with:+   GHC  ==8.2.2+    ||  ==8.4.4+    ||  ==8.6.5+    ||  ==8.8.1+build-type: Custom++source-repository head+  type: git+  location: https://github.com/epicallan/hreq.git++custom-setup+ setup-depends:+   base >= 4 && <5,+   Cabal,+   cabal-doctest >= 1 && <1.1++library+  exposed-modules:+      Hreq.Core.Client+    , Hreq.Core.API+    , Hreq.Core.API.Internal+    , Hreq.Core.API.MediaType+    , Hreq.Core.API.Request+    , Hreq.Core.API.Response+    , Hreq.Core.API.TypeLevel+    , Hreq.Core.API.Streaming+    , Hreq.Core.API.Verb+    , Hreq.Core.Client.BaseUrl+    , Hreq.Core.Client.BasicAuth+    , Hreq.Core.Client.Internal+    , Hreq.Core.Client.HasRequest+    , Hreq.Core.Client.HasResponse+    , Hreq.Core.Client.ClientError+    , Hreq.Core.Client.Request+    , Hreq.Core.Client.Response+    , Hreq.Core.Client.RunClient+    , Data.Hlist+    , Data.Singletons++  default-extensions: LambdaCase DeriveGeneric FlexibleInstances FlexibleContexts ScopedTypeVariables TypeApplications TypeOperators MultiParamTypeClasses RecordWildCards TypeApplications TypeFamilies OverloadedStrings GADTs GeneralizedNewtypeDeriving FunctionalDependencies ConstraintKinds RankNTypes PolyKinds DataKinds KindSignatures ViewPatterns UndecidableInstances StrictData+  build-depends:+    base                 >= 4.10.1 && < 5,+    base-compat          >= 0.10.5 && < 0.13,+    aeson                >= 1.4.5 && < 1.5,+    attoparsec           >= 0.13.2.2 && < 0.14,+    bytestring           >= 0.10.8 && < 0.11,+    containers           >= 0.5.7.1 && < 0.7,+    exceptions           >= 0.10.0 && < 0.11,+    http-api-data        >= 0.4.1 && < 0.5,+    http-media           >= 0.8.0 && < 0.9,+    http-types           >= 0.12.3 && < 0.13,+    mtl                  >= 2.2.2 && < 3.0,+    text                 >= 1.2.4 && < 1.3,+    string-conversions   >= 0.4.0 && < 0.5+  ghc-options:+    -Wall+    -Wincomplete-uni-patterns+    -Wincomplete-record-updates+    -Wcompat+    -Widentities+    -Wredundant-constraints+    -fhide-source-paths+    -freverse-errors+    -Wpartial-fields++  hs-source-dirs: src+  default-language: Haskell2010++test-suite doctests+  type:             exitcode-stdio-1.0+  main-is:          DocTests.hs+  build-depends:+      base       >= 4.10.1 && < 5+    , doctest    >=0.15 && < 0.17+    , hreq-core++  ghc-options:      -Wall -threaded+  hs-source-dirs:   test+  default-language: Haskell2010
+ src/Data/Hlist.hs view
@@ -0,0 +1,21 @@+-- | This module provides a Heterogeneous list used to represent HTTP request inputs and outputs+-- for some API type definitions+module Data.Hlist where++import Data.Kind (Type)++infixr 7 :.++-- * Hlist+data Hlist (a :: [Type]) where+  Nil :: Hlist '[]+  (:.) :: x -> Hlist xs -> Hlist (x ': xs)++singleton :: a -> Hlist '[ a ]+singleton = (:. Nil)++instance Show (Hlist '[]) where+  show _ = "Nil"++instance (Show (Hlist ts), Show a) => Show (Hlist (a ': ts)) where+  show (x :. xs) =  show x ++  " :. " ++ show xs
+ src/Data/Singletons.hs view
@@ -0,0 +1,93 @@+{- |+    ==A small singleton core module++    A trimmed down core version of the singletons library made for my use case or more+    specifically Hreq but still general enough for similar use cases.++    ===Motivation++    The singleton library has pretty long compile times which can be hard to justify+    when you are using only a small portion of it.+    It is also not backward compatible with previous GHC releases.+    So if you want to support earlier GHC releases in a library that depends on singletons,+    you are pretty much left to the mercy of CPP hacks and careful Cabal dependency configurations.++    ===Attribution+    Some of the code in this module was directly borrowed from the Singletons library+-}+{-# LANGUAGE TypeInType #-}+module Data.Singletons where++import Data.Kind+import GHC.TypeLits+import Data.Typeable++-- * Sing Type family+type family Sing :: k -> Type++class SingI a where+  sing :: Sing a++--  TODO: Maybe add a SingKind class and SingKind instances++-- * Type-lits+-------------------++data SNat (n :: Nat) =  KnownNat n => SNat+type instance Sing = SNat++instance KnownNat a => SingI (a :: Nat) where+  sing = SNat++data SSymbol (n :: Symbol) = KnownSymbol n => SSym+type instance Sing = SSymbol++instance KnownSymbol a => SingI (a :: Symbol) where+  sing = SSym++-- | Given a singleton for @Nat@, call something requiring a+-- @KnownNat@ instance.+withKnownNat :: Sing n -> (KnownNat n => r) -> r+withKnownNat SNat f = f++-- | Given a singleton for @Symbol@, call something requiring+-- a @KnownSymbol@ instance.+withKnownSymbol :: Sing n -> (KnownSymbol n => r) -> r+withKnownSymbol SSym f = f++-- * Lists+----------------------++data SList :: [k] -> Type where+  SNil :: SList '[]+  SCons :: forall k (h :: k) (t :: [k]). Sing h -> SList t -> SList (h ': t)++type instance Sing = SList++instance SingI ('[] :: [k]) where+  sing = SNil++instance (SingI x, SingI xs) => SingI ( (x ': xs)  :: [k]) where+  sing = SCons sing sing++-- * Tuples+-------------------++data STuple2 (a :: (k1, k2)) where+  STuple2 :: Sing x -> Sing y -> STuple2 '(x, y)++instance (SingI x, SingI y) => SingI ( '(x, y) :: (k1, k2)) where+  sing = STuple2 sing sing++type instance Sing = STuple2++-- * TypeRep+----------------------------------++data STypeRep :: Type -> Type where+  STypeRep :: forall (t :: Type). Typeable t => STypeRep t++type instance Sing = STypeRep++instance Typeable a => SingI (a :: Type) where+  sing = STypeRep
+ src/Hreq/Core/API.hs view
@@ -0,0 +1,56 @@+-- | This module re-exports types and combinators required for type level+-- construction of API request components and expected type structure of an http request response.++module Hreq.Core.API+    ( -- * Request+      module Hreq.Core.API.Request+      -- * Response+    , module Hreq.Core.API.Response+      -- * API Types and Kinds+    , module Hreq.Core.API.Internal+      -- * MediaType+    , module Hreq.Core.API.MediaType+       -- * Streaming+    , module Hreq.Core.API.Streaming+      -- * TypeLevel+    , module Hreq.Core.API.TypeLevel+      -- * Verb+    , module Hreq.Core.API.Verb+      -- * API Type Synonyms+    , module Hreq.Core.API+      -- * Re-exports+    , ToHttpApiData (..)+    , Header+    , Status (..)+    , HeaderName+    ) where+import Data.Kind+import Hreq.Core.API.Internal+import Hreq.Core.API.MediaType+import Hreq.Core.API.Request+import Hreq.Core.API.Response+import Hreq.Core.API.Streaming+import Hreq.Core.API.TypeLevel+import Hreq.Core.API.Verb+import Network.HTTP.Types (Header, HeaderName, Status (..))+import Web.HttpApiData (ToHttpApiData (..))++type StatusCode = Int++type JsonBody (a :: Type) = ReqBody JSON a++-- | ==Response Type synonyms++type GetJson a = Get '[ ResBody JSON a]++type PostJson a = Post '[ResBody JSON a]++type PutJson a = Put '[ ResBody JSON a]++type PatchJson a = Patch '[ ResBody JSON a]++type DeleteJson a = Delete '[ResBody JSON a]++type RawResponse v = Verb v '[ Raw ]++type EmptyResponse v = Verb v ('[ ] :: [ ResContent Type ])
+ src/Hreq/Core/API/Internal.hs view
@@ -0,0 +1,54 @@+-- | Specification for an API endpoint as a composition of Request and Response components+-- at the Type level.+module Hreq.Core.API.Internal where++import Data.Kind (Type)+import Data.Singletons+import GHC.TypeLits++import Hreq.Core.API.Request+import Hreq.Core.API.Response++-- * API type+data Api a =+    Req [ ReqContent a]+  | Res [ ResContent a ]++-- * API GADT as a singleton.+data SApi (a :: Api Type)+  = forall b . a ~ 'Req b => SReq (Sing b)+  | forall b . a ~ 'Res b => SRes (Sing b)+type instance Sing = SApi++-- * SingI instance for API types+instance (SingI content) => SingI ('Res content :: Api Type) where+  sing = SRes sing++instance (SingI content) => SingI ('Req content :: Api Type) where+  sing = SReq sing++-- * API Type combinators+-- Used in concatenation of API types.+--+-- Examples+--+-- >>> PathQueryWithEmptyResponse = "hello" :> QueryFlag "young" :> Get '[]+-- >>> PathQueryWithResponse = "hello" :> QueryFlag "young" :> Get '[ ResBody JSON String, ResHeader [ "headerName" := String ]]+-- >>> JsonBodyAndResponse = "hello" :> JsonBody User :> GetJson User++infixr 7 :>++data (a :: k1) :> (b :: k2)++-- | For representing type level tuples where first value is a Symbol+infixr 1 :=++type (a :: Symbol) := (b :: k2) = '( a, b)++-- $setup+-- >>> import Hreq.Core.API+-- >>> import GHC.Generics+-- >>> import Data.Aeson+-- >>> data User = User deriving (Show)+-- >>> instance ToJSON User where toJSON = undefined+-- >>> instance FromJSON User where parseJSON = undefined
+ src/Hreq/Core/API/MediaType.hs view
@@ -0,0 +1,127 @@+-- | This module contains a collection of some of the Internet Media or Mime types+-- and class to serialize and deserialize them.+-- At the moment we only support a small set but its possible to write own custom+-- types and provide the required instances.+module Hreq.Core.API.MediaType+  ( module Hreq.Core.API.MediaType+  , MediaType+  , (//)+  , matches+  , parseAccept+  )where++import Prelude ()+import Prelude.Compat++import Control.Exception (Exception)+import Data.Aeson (FromJSON, ToJSON, encode, parseJSON)+import Data.Aeson.Parser (value)+import Data.Aeson.Types (parseEither)+import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, skipSpace, (<?>))+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List.NonEmpty as NE+import Data.String.Conversions (cs)+import Data.Text (Text)+import Data.Typeable (Typeable)+import Network.HTTP.Media (MediaType, matches, parseAccept, (//), (/:))+import Text.Read (readMaybe)+import Web.FormUrlEncoded (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm)++-- * Provided Content types+data JSON deriving Typeable+data PlainText deriving Typeable+data OctetStream deriving Typeable+data FormUrlEncoded deriving Typeable++newtype DecodeError = DecodeError { unDecodeError :: Text }+  deriving (Show, Eq)++instance Exception DecodeError++-- | Instances of 'HasMediaType' are useful for matching against the @Accept@ HTTP header+-- of the request and setting @Content-Type@ header of the response+class HasMediaType ctyp where+  mediaType :: sing ctyp -> MediaType+  mediaType = NE.head . mediaTypes++  mediaTypes :: sing ctyp -> NE.NonEmpty MediaType+  mediaTypes = (NE.:| []) . mediaType++  {-# MINIMAL mediaType | mediaTypes #-}++instance HasMediaType JSON where+  mediaTypes _ =+    "application" // "json" /: ("charset", "utf-8") NE.:|+    [ "application" // "json" ]++instance HasMediaType PlainText where+  mediaType _ = "text" // "plain" /: ("charset", "utf-8")++instance HasMediaType FormUrlEncoded where+  mediaType _ = "application" // "x-www-form-urlencoded"++instance HasMediaType OctetStream where+  mediaType _ = "application" // "octet-stream"++class HasMediaType ctyp => MediaDecode ctyp a where+  mediaDecode :: sing ctyp -> LBS.ByteString -> Either DecodeError a++class HasMediaType ctyp => MediaEncode ctyp a where+  mediaEncode :: sing ctyp -> a -> LBS.ByteString++instance FromJSON a => MediaDecode JSON a where+  mediaDecode _ = first (DecodeError . cs) . eitherDecodeLenient++instance ToJSON a => MediaEncode JSON a where+  mediaEncode _ = cs . encode++instance MediaDecode OctetStream ByteString where+  mediaDecode _ = Right . cs++instance MediaDecode OctetStream LBS.ByteString where+  mediaDecode _ = Right . id++instance MediaEncode OctetStream ByteString where+  mediaEncode _ = cs++instance MediaEncode OctetStream LBS.ByteString where+  mediaEncode _ = id++instance MediaDecode PlainText Text where+  mediaDecode _ = Right . cs++instance Read a => MediaDecode PlainText a where+  mediaDecode _ bs =+    maybe (Left $ DecodeError $ "Failed to decode: " <> cs bs) Right . readMaybe $ cs bs++instance Show a => MediaEncode PlainText a where+  mediaEncode _ = cs . show++instance ToForm a => MediaEncode FormUrlEncoded a where+  mediaEncode _ = cs . urlEncodeAsForm++instance FromForm a => MediaDecode FormUrlEncoded a where+  mediaDecode _ = first DecodeError . urlDecodeAsForm . cs++-- * Helper functions++-- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just+-- objects and arrays. This function is borrowed from @servant@+--+-- Will handle trailing whitespace, but not trailing junk. ie.+--+-- >>> eitherDecodeLenient "1 " :: Either String Int+-- Right 1+--+-- >>> eitherDecodeLenient "1 junk" :: Either String Int+-- Left "trailing junk after valid JSON: endOfInput"+eitherDecodeLenient :: FromJSON a => LBS.ByteString -> Either String a+eitherDecodeLenient input =+    parseOnly parser (cs input) >>= parseEither parseJSON+  where+    parser = skipSpace+          *> Data.Aeson.Parser.value+          <* skipSpace+          <* (endOfInput <?> "trailing junk after valid JSON")
+ src/Hreq/Core/API/Request.hs view
@@ -0,0 +1,75 @@+-- | Specification for valid Request component types used at the Kind and Type level for+-- creating an API structure.+--+module Hreq.Core.API.Request where++import Data.Kind (Type)+import Data.Singletons (Sing, SingI(..))+import GHC.TypeLits (Symbol)++-- * Request Type+data ReqContent a =+      Path a Symbol+    | Params [(Symbol, a)]+    | QueryFlags a [Symbol]+    | Captures [a]+    | BasicAuth a Symbol+    | CaptureAll a+    | ReqBody a a+    | StreamBody a a+    | ReqHeaders [(Symbol, a)]++-- * Request Type Synonyms+type Captures = 'Captures+type QueryFlags = 'QueryFlags ()+type Params = 'Params+type ReqBody = 'ReqBody+type StreamBody = 'StreamBody+type ReqHeaders = 'ReqHeaders+type CaptureAll = 'CaptureAll+type BasicAuth = 'BasicAuth ()+type Path = 'Path ()+type QueryFlag (s :: Symbol) = QueryFlags '[ s ]+type Param s t = Params '[ '( s,  t ) ]+type Capture t = Captures '[ t ]++-- * Request as a Singleton GADT+data SReqContent (a :: ReqContent Type)+  = forall t s . a ~ 'Path t s => SPath (Sing t) (Sing s)+  | forall ts (b :: Type) . a ~ 'QueryFlags b ts => SQueryFlags (Sing b) (Sing ts)+  | forall b . a ~ 'CaptureAll b => SCaptureAll (Sing b)+  | forall ts . a ~ 'Captures ts => SCaptures (Sing ts)+  | forall ctyp b . a ~ 'ReqBody ctyp b => SReqBody (Sing ctyp) (Sing b)+  | forall ctyp b . a ~ 'StreamBody ctyp b => SStreamBody (Sing ctyp) (Sing b)+  | forall ts . a ~ ReqHeaders ts => SReqHeaders (Sing ts)+  | forall ts . a ~ Params ts => SParams (Sing ts)+  | forall b s . a ~ 'BasicAuth b s => SBasicAuth (Sing b) (Sing s)++type instance Sing = SReqContent++instance (SingI a, SingI s) => SingI ('BasicAuth a s :: ReqContent Type) where+  sing = SBasicAuth sing sing++instance (SingI a, SingI s) => SingI ('Path a s :: ReqContent Type) where+  sing = SPath sing sing++instance SingI ts => SingI ('Params ts :: ReqContent Type) where+  sing = SParams sing++instance (SingI a, SingI ts) => SingI ('QueryFlags a ts :: ReqContent Type) where+  sing = SQueryFlags sing sing++instance SingI ts => SingI ('Captures ts :: ReqContent Type) where+  sing = SCaptures sing++instance (SingI a) => SingI ('CaptureAll a :: ReqContent Type) where+  sing = SCaptureAll sing++instance (SingI a, SingI ctyp) => SingI ('ReqBody ctyp a :: ReqContent Type) where+  sing = SReqBody sing sing++instance (SingI a, SingI ctyp) => SingI ('StreamBody ctyp a :: ReqContent Type) where+  sing = SStreamBody sing sing++instance SingI a => SingI ('ReqHeaders a :: ReqContent Type) where+  sing = SReqHeaders sing
+ src/Hreq/Core/API/Response.hs view
@@ -0,0 +1,41 @@+-- | Specification for valid Response component types used at the Kind and Type level+-- for creating an API structure.+--+module Hreq.Core.API.Response where++import Data.Kind (Type)+import Data.Singletons (Sing, SingI (..))+import GHC.TypeLits (Symbol)++-- * Response type+data ResContent a =+    ResBody a a+  | ResHeaders [(Symbol, a)]+  | ResStream a a+  | Raw a++-- * Response type synonyms+type ResBody = 'ResBody+type ResHeaders = 'ResHeaders+type ResStream = 'ResStream+type Raw = 'Raw ()++-- * 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)+  SRaw :: forall (a :: Type) . Sing a -> SResContent ('Raw a)+type instance Sing = SResContent++instance (SingI a, SingI ctyp) => SingI ('ResStream ctyp a :: ResContent Type) where+  sing = SResStream sing sing++instance (SingI ctyp, SingI a) => SingI ('ResBody ctyp a :: ResContent Type) where+  sing = SResBody sing sing++instance SingI ts => SingI ('ResHeaders ts :: ResContent Type) where+  sing = SResHeaders sing++instance SingI a => SingI ('Raw a :: ResContent Type) where+  sing = SRaw sing
+ src/Hreq/Core/API/Streaming.hs view
@@ -0,0 +1,41 @@+-- | This module provides classes that one has to implement in order to+-- use a streaming library such as Conduit for streaming.+module Hreq.Core.API.Streaming where++import Data.ByteString (ByteString)+import Hreq.Core.API.MediaType+import Hreq.Core.API.Response+import Hreq.Core.API.Verb++-- * Client Streaming++-- | A StreamVerb endpoint receives a stream of encoded values+-- with the OctetStream content type.+type StreamVerb method = Verb method '[ 'ResStream OctetStream () ]++-- * Stream synonyms+type StreamGet = StreamVerb GET+type StreamPost = StreamVerb POST+type StreamPut = StreamVerb PUT++-- * Request Body streaming++-- | A function which generates successive chunks of a request body,+-- provider a single empty bytestring when no more data is available.+type Pooper = IO ByteString++-- | A function which must be provided with a Popper.+type NeedsPooper a = Pooper -> IO a++-- | A datatype containing a function which will provide a 'Pooper' to a 'NeedsPooper'. .+newtype GivesPooper a+  = GivesPooper { runGivesPooper ::  NeedsPooper a -> IO a }++instance Show (GivesPooper a) where+  show _ = "GivesPooper <IO>"++instance Eq (GivesPooper a) where+  _ == _ = False++class HasStreamBody a where+  givePopper :: a -> GivesPooper ()
+ src/Hreq/Core/API/TypeLevel.hs view
@@ -0,0 +1,144 @@+-- | Type level functions over 'ReqContent' and 'ResContent'+--+module Hreq.Core.API.TypeLevel where++import Data.Kind (Type, Constraint)+import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..), KnownSymbol)+import Network.HTTP.Types (Header)+import Web.HttpApiData (ToHttpApiData)++import Hreq.Core.Client.BasicAuth (BasicAuthData)+import Hreq.Core.API.Request (ReqContent(..))+import Hreq.Core.API.Response (ResContent (..))+import Hreq.Core.API.Internal ((:>))+import Hreq.Core.API.MediaType (MediaDecode, MediaEncode, HasMediaType)+import Hreq.Core.API.Streaming (HasStreamBody)+import Hreq.Core.API.Verb (Verb)++-- | 'ApiToReq' transforms an API type into a type level list of+-- Request component content types.+-- The resulting list is used by the 'Hreq.Core.API.HasRequest.HasRequest' class.+type family ApiToReq (a :: api) :: [ ReqContent Type]  where+  ApiToReq (Verb m ts) =  '[ ]+  ApiToReq ( (path :: Symbol) :> ts) = 'Path () path ': ApiToReq ts+  ApiToReq ( (x :: ReqContent Type) :> ts) = x ': ApiToReq ts++-- | Given an API type, 'GetVerb' retrieves the Verb type component which+-- is used by the 'Hreq.Core.Client.HasResponse.HasResponse' class.+type family GetVerb (a :: api) :: Type  where+  GetVerb (Verb m ts) =  Verb m ts+  GetVerb (api :> sub) = GetVerb sub++-- | 'HttpReq' interprets a 'ReqContent' list as a 'Type' level list+-- used in the 'Hreq.Core.Client.HasRequest.HasRequest' class for representing+-- request component inputs+type family HttpReq (ts :: [ReqContent Type]) :: [  Type ] where+  HttpReq '[] = '[]++  HttpReq ('Path _ _ ': ts) = HttpReq ts++  HttpReq ('ReqBody ctyp a ': ts) = a ': HttpReq ts++  HttpReq ('StreamBody ctyp a ': ts) = a ': HttpReq ts++  HttpReq ('BasicAuth _ _ : ts) = BasicAuthData ': HttpReq ts++  HttpReq ('QueryFlags _ _ ': ts) = HttpReq ts++  HttpReq ('Params ( '(s, a) ': ps ) ': ts) = a ': HttpReq ('Params ps ': ts)+  HttpReq ('Params '[] : ts) = HttpReq ts++  HttpReq ('CaptureAll a ': ts) = [a] ': HttpReq ts++  HttpReq ('Captures ( a : cs ) ': ts) = a ': HttpReq ('Captures cs ': ts)+  HttpReq ('Captures '[] : ts) = HttpReq ts++  HttpReq ('ReqHeaders ( '(s, a) ': hs ) ': ts) = a ': HttpReq ('ReqHeaders hs ': ts)+  HttpReq ('ReqHeaders '[] : ts) = HttpReq ts++-- | 'HttpRes' interprets a 'ResContent' list as a Type level list for+-- used 'Hreq.Core.Client.HasResponse.HasResponse' class to represent responses+type family HttpRes (res :: [ ResContent Type ]) :: [ Type ] where+  HttpRes '[] = '[]+  HttpRes ('ResBody ctyp a ': ts) = a ': HttpRes ts+  HttpRes ('ResHeaders (s ': hs) ': ts) = [Header] ': HttpRes ts+  HttpRes ('ResHeaders '[]  ': ts) = HttpRes ts+  HttpRes ('Raw a ': ts) = HttpRes ts++-- | Response content types Constraints.+type family HttpResConstraints (res :: [ResContent Type]) :: Constraint where+  HttpResConstraints '[] = ()+  HttpResConstraints  ('ResBody ctyp a ': ts) =+     (HasMediaType ctyp, MediaDecode ctyp a, HttpResConstraints ts)+  HttpResConstraints  ('ResStream ctyp a ': ts) = (HasMediaType ctyp, HttpResConstraints ts)+  HttpResConstraints ('ResHeaders hs ': ts) = (HttpSymbolTypePair hs, HttpResConstraints ts)+  HttpResConstraints ('Raw a ': ts) = HttpResConstraints ts++-- | Request content types Constraints.+type family HttpReqConstraints (req :: [ReqContent Type]) :: Constraint where+  HttpReqConstraints '[] = ()++  HttpReqConstraints ('Path _ path ': ts) = (KnownSymbol path, HttpReqConstraints ts)++  HttpReqConstraints ('BasicAuth _ _ ': ts) = HttpReqConstraints ts++  HttpReqConstraints ('ReqBody ctyp a ': ts ) =+    (HasMediaType ctyp, MediaEncode ctyp a, HttpReqConstraints ts)++  HttpReqConstraints ('StreamBody ctyp a ': ts ) =+    (HasMediaType ctyp, HasStreamBody a, HttpReqConstraints ts)+++  HttpReqConstraints ('QueryFlags _a fs ': ts) = (All KnownSymbol fs, HttpReqConstraints ts)++  HttpReqConstraints ('Params ( '(s, a) ': ps) ': ts) =+    (KnownSymbol s, ToHttpApiData a,  HttpReqConstraints ('Params ps ': ts))+  HttpReqConstraints ('Params '[] ': ts) =  HttpReqConstraints ts++  HttpReqConstraints ('Captures ( a : cs) ': ts) =+    (ToHttpApiData a,  HttpReqConstraints ('Captures cs ': ts))+  HttpReqConstraints ('Captures '[] ': ts) =  HttpReqConstraints ts++  HttpReqConstraints ('CaptureAll a ': ts) = (ToHttpApiData a, HttpReqConstraints ts)++  HttpReqConstraints ('ReqHeaders ('(s, a) ': hs) ': ts) =+     (KnownSymbol s, ToHttpApiData a, HttpReqConstraints ('ReqHeaders hs ': ts))+  HttpReqConstraints ('ReqHeaders '[] ': ts) = HttpReqConstraints ts++-- | For a given HTTP API data 'Symbol' 'Type' tuple list generate Constraints for all the members.+type family HttpSymbolTypePair (ts :: [(Symbol, Type)]) :: Constraint where+  HttpSymbolTypePair ts =  (All KnownSymbol (AllFsts ts), All ToHttpApiData (AllSnds ts))++-- | Cross check that there are no repeated instance of an item+-- with in a type level list. For instance we want to have only+-- one 'ResBody' with in a Response type level list+type family UniqMembers (ts :: [k]) (label :: Symbol) :: Constraint  where+  UniqMembers '[] label = ()+  UniqMembers (a ': ts) label = (UniqMember a ts label, UniqMembers ts label)++type family UniqMember (a :: k) (ts :: [k]) (label :: Symbol) :: Constraint where+   UniqMember a '[] label = ()+   UniqMember a (a ': ts) label = TypeError ( 'Text "Type "+                                              ':<>: 'ShowType a+                                              ':<>: 'Text "Should be unique with in the "+                                              ':<>: 'Text label+                                              ':<>: 'Text " type level list"+                                             )+   UniqMember a (b ': ts ) label = UniqMember b ts label+++{-------------------------------------------------------------------------------+  Helper type families+-------------------------------------------------------------------------------}++type family All (a :: k -> Constraint) (ts :: [k]) :: Constraint where+  All c '[] = ()+  All c (t ': ts) = (c t, All c ts)++type family AllFsts (a :: [(k1, k2)]) :: [k1] where+  AllFsts '[] = '[]+  AllFsts ('(f, s) ': ts) = f ': AllFsts ts++type family AllSnds (a :: [(k1, k2)]) :: [k2] where+  AllSnds '[] = '[]+  AllSnds ('(f, s) ': ts) = s ': AllSnds ts
+ src/Hreq/Core/API/Verb.hs view
@@ -0,0 +1,78 @@+-- | Module for working with HTTP methods and the resulting content at the type level.+--+module Hreq.Core.API.Verb+  ( module Hreq.Core.API.Verb+    -- * Re-exports+  , StdMethod (..)+  , Method+  ) where++import Data.Proxy (Proxy)+import Data.Typeable (Typeable)+import Network.HTTP.Types.Method (Method, StdMethod (..), methodConnect, methodDelete, methodGet,+                                  methodHead, methodOptions, methodPatch, methodPost, methodPut,+                                  methodTrace)++-- | @Verb@ is a type for representing the results of an HTTP client+-- request call represented as content list and the HTTP method+-- associated with it. Type synonyms for common verbs are provided but you+-- free to define your own+--+-- >>> type Trace = Verb 'TRACE+--+-- Verb with contents example:+--+-- >>> type GetRaw = Verb 'GET '[ Raw ]+--+data Verb (method :: k1) (contents:: [k2])+  deriving (Typeable)++type GET = 'GET+type Get = Verb GET++type POST = 'POST+type Post = Verb 'POST++type PUT = 'PUT+type Put = Verb PUT++type DELETE = 'DELETE+type Delete = Verb 'DELETE++type PATCH = 'PATCH+type Patch = Verb 'PATCH++-- | @ReflectMethod@ class provides us with a way to obtain the 'Method' data+-- associated with a promoted HTTP Verb.+class ReflectMethod a where+    reflectMethod :: Proxy a -> Method++instance ReflectMethod 'GET where+    reflectMethod _ = methodGet++instance ReflectMethod 'POST where+    reflectMethod _ = methodPost++instance ReflectMethod 'PUT where+    reflectMethod _ = methodPut++instance ReflectMethod 'DELETE where+    reflectMethod _ = methodDelete++instance ReflectMethod 'PATCH where+    reflectMethod _ = methodPatch++instance ReflectMethod 'HEAD where+    reflectMethod _ = methodHead++instance ReflectMethod 'OPTIONS where+    reflectMethod _ = methodOptions++instance ReflectMethod 'TRACE where+    reflectMethod _ = methodTrace++instance ReflectMethod 'CONNECT where+    reflectMethod _ = methodConnect++-- $setup+-- >>> data Raw
+ src/Hreq/Core/Client.hs view
@@ -0,0 +1,36 @@+-- | This module re-exports data types and functionality required+-- in creation of Request and Response objects for an HTTP client.+module Hreq.Core.Client+  ( -- * BaseUrl+    module Hreq.Core.Client.BaseUrl+    -- * Request+  , module Hreq.Core.Client.Request+    -- * Response+  , module Hreq.Core.Client.Response+    -- * HasRequest+  , module Hreq.Core.Client.HasRequest+    -- * HasResponse+  , module Hreq.Core.Client.HasResponse+    -- * Internal+  , module Hreq.Core.Client.Internal+    -- * RunClient+  , module Hreq.Core.Client.RunClient+    -- * ClientError+  , module Hreq.Core.Client.ClientError+    -- * BasicAuth+  , module Hreq.Core.Client.BasicAuth+      -- * Hlist+  , module Data.Hlist+  ) where++import Data.Hlist++import Hreq.Core.Client.BaseUrl+import Hreq.Core.Client.BasicAuth+import Hreq.Core.Client.ClientError+import Hreq.Core.Client.HasRequest+import Hreq.Core.Client.HasResponse+import Hreq.Core.Client.Internal+import Hreq.Core.Client.Request+import Hreq.Core.Client.Response+import Hreq.Core.Client.RunClient
+ src/Hreq/Core/Client/BaseUrl.hs view
@@ -0,0 +1,54 @@+-- | This module provides a safe way to construct API endpoint base URLs+{-# LANGUAGE PatternSynonyms #-}+module Hreq.Core.Client.BaseUrl where++import Prelude ()+import Prelude.Compat++import Data.String.Conversions (cs)+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Natural (Natural)++data Scheme =+    Http+  | Https+  deriving (Show, Eq, Ord)++-- | Simple data type to represent the target of HTTP requests+data BaseUrl = BaseUrl+  { baseUrlScheme :: Scheme   -- ^ URI scheme to use+  , baseUrlHost   :: Text     -- ^ host (eg "haskell.org")+  , baseUrlPort   :: Natural  -- ^ port (eg 80)+  , baseUrlPath   :: Text     -- ^ path (eg "/a/b/c")+  } deriving (Show, Eq, Ord)++pattern HttpDomain :: Text -> BaseUrl+pattern HttpDomain host = BaseUrl Http host 80 ""++pattern HttpUrl :: Text -> Text -> BaseUrl+pattern HttpUrl host path = BaseUrl Http host 80 path++pattern HttpsDomain :: Text -> BaseUrl+pattern HttpsDomain host = BaseUrl Https host 443 ""++pattern HttpsUrl :: Text -> Text -> BaseUrl+pattern HttpsUrl host path = BaseUrl Https host 443 path++showBaseUrl :: BaseUrl -> Text+showBaseUrl (BaseUrl urlscheme host port path) =+  schemeString <> "//" <> host <> (portString </> path)+    where+      (</>) :: Text -> Text -> Text+      a </> b = if "/" `T.isPrefixOf` b || T.null b then a <> b else a <> ("/" <> b)++      schemeString :: Text+      schemeString = case urlscheme of+        Http  -> "http:"+        Https -> "https:"++      portString :: Text+      portString = case (urlscheme, port) of+        (Http, 80)   -> ""+        (Https, 443) -> ""+        _            -> cs $ ":" <> show port
+ src/Hreq/Core/Client/BasicAuth.hs view
@@ -0,0 +1,20 @@+-- | Provides Basic Authentication support+module Hreq.Core.Client.BasicAuth where++import Prelude ()+import Prelude.Compat++import Data.Text+import Hreq.Core.Client.Request++-- | Required data for Basic Authentication+data BasicAuthData = BasicAuthData+  { baUser     :: Text+  , baPassword :: Text+  }++-- | Authenticate a request using Basic Authentication+basicAuthReq :: BasicAuthData -> Request -> Request+basicAuthReq (BasicAuthData user pass) req =+  let authText = "Basic " <> user <> ":" <> pass+  in addHeader "Authorization" authText req
+ src/Hreq/Core/Client/ClientError.hs view
@@ -0,0 +1,43 @@+-- | This module provides 'ClientError' constructors and type.+--+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+module Hreq.Core.Client.ClientError where++import Control.Exception (Exception, SomeException (..))+import Data.Text (Text)+import Data.Typeable (Typeable, typeOf)+import GHC.Generics (Generic)+import Network.HTTP.Media (MediaType)++import Hreq.Core.Client.Request+import Hreq.Core.Client.Response++-- | A type representing possible errors in a request+-- This type and the Eq instance is largely borrowed from servant-client+--+data ClientError =+  -- | The server returned an error response including the+  -- failing request. 'reqPath' includes the 'Hreq.Core.Client.BaseUrl.BaseUrl' and the+  -- path of the request.+    FailureResponse Request Response+  -- | The body could not be decoded at the expected type+  | DecodeFailure Text Response+  -- | The content-type of the response is not supported+  | UnsupportedContentType MediaType Response+  -- | The content-type header is invalid+  | InvalidContentTypeHeader Response+  -- | There was a connection error, and no response was received+  | ConnectionError SomeException+  deriving (Show, Generic, Typeable)++instance Eq ClientError where+  FailureResponse req res     == FailureResponse req' res'     = req == req' && res == res'+  DecodeFailure t r           == DecodeFailure t' r'           = t == t' && r == r'+  UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'+  InvalidContentTypeHeader r  == InvalidContentTypeHeader r'   = r == r'+  ConnectionError exc         == ConnectionError exc'          = eqSomeException exc exc'+    where+      -- returns true, if type of exception is the same+      eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b++instance Exception ClientError
+ src/Hreq/Core/Client/HasRequest.hs view
@@ -0,0 +1,162 @@+-- | This module provides a 'HasRequest' class that Interprets+-- a 'ReqContent' type level list into 'Request' data+--+{-# LANGUAGE PatternSynonyms      #-}+module Hreq.Core.Client.HasRequest where++import Prelude ()+import Prelude.Compat++import Data.Kind+import Data.Hlist+import Data.Proxy+import Data.Singletons+import GHC.TypeLits+import Data.String (fromString)+import Data.String.Conversions (cs)+import Data.List (intersperse)+import qualified Data.Text as T (concat)++import Hreq.Core.API+import Hreq.Core.Client.Request+import Hreq.Core.Client.BasicAuth+import Network.HTTP.Types (QueryItem)++pattern Empty :: Hlist '[]+pattern Empty = Nil++-- | 'HasRequest' is used to create a Request from a 'ReqContent' type level list+-- and a 'Verb'.+--+-- @verb@ is requited for obtaining Request method and 'MediaType' value+--+-- @reqComponents@ is a usually a 'ReqContent Type' type level list.+-- It can be something else.+class HasRequest (reqComponents :: k) (verb :: Type) where+   type HttpInput reqComponents :: Type++   httpReq+     :: Proxy verb+     -> Proxy reqComponents+     -> HttpInput reqComponents+     -> Request+     -> Request++instance+   ( HttpReqConstraints ts+   , ReflectMethod method+   , SingI ('Req ts)+   , SingI ('Res rs)+   , HttpResConstraints rs+  )+  => HasRequest (ts :: [ReqContent Type]) (Verb method rs) where+  type HttpInput ts = Hlist (HttpReq ts)++  httpReq _ _ input req =+    let method'      = reflectMethod (Proxy @method)+        acceptHeader = case sing @('Res rs) of+                         SRes ys -> getAcceptHeader ys+        req'         = case sing @('Req ts) of+                         SReq xs -> encodeHlistAsReq xs input req++    in appendMethod method' $ req' { reqAccept = acceptHeader }++getAcceptHeader+  :: forall (rs :: [ResContent Type]) . HttpResConstraints rs+  => Sing rs -> Maybe MediaType+getAcceptHeader = \case+  SNil -> Nothing+  SCons (SResBody sctyp _a) _rs -> Just $ mediaType sctyp+  SCons (SRaw _) rs -> getAcceptHeader rs+  SCons (SResHeaders _) rs -> getAcceptHeader rs+  SCons (SResStream sctyp _) _rs -> Just $ mediaType sctyp++-- | Transform a 'Hlist' of inputs into a 'Request'+encodeHlistAsReq+  :: forall (ts :: [ReqContent Type]). (HttpReqConstraints ts)+  => Sing ts+  -> Hlist (HttpReq ts)+  -> Request+  -> Request+encodeHlistAsReq xs input req = case (xs, input) of+  (SNil, _)                                                    ->+    req++  (SCons (SPath _ spath) sxs, ys) ->+    let path = withKnownSymbol spath (cs . symbolVal $ spath)+        req' = appendToPath path req+    in encodeHlistAsReq sxs ys req'++  (SCons (SBasicAuth _ _) sxs, y :. ys)                        ->+    let req' = basicAuthReq y req+    in encodeHlistAsReq sxs ys req'++  (SCons (SReqHeaders (SCons (STuple2 s _x) hs)) sxs, y :. ys) ->+    let headerName = fromString $ withKnownSymbol s (symbolVal s)+        req' = addHeader headerName y req+    in encodeHlistAsReq (SCons (SReqHeaders hs) sxs) ys req'++  (SCons (SReqHeaders SNil) sxs, ys)                           ->+    encodeHlistAsReq sxs ys req++  (SCons (SCaptureAll _a) sxs, captureList :. ys)              ->+    let captureFragments =+           T.concat $ intersperse "/" $ toUrlPiece <$> captureList++        req' = appendToPath captureFragments req+    in encodeHlistAsReq sxs ys req'++  (SCons (SCaptures SNil) sxs, ys)                             ->+    encodeHlistAsReq sxs ys req++  (SCons (SCaptures (SCons _z zs)) sxs, y :. ys)  ->+    let req' = appendToPath (cs $ toUrlPiece y) req+    in encodeHlistAsReq (SCons (SCaptures zs) sxs) ys req'++  (SCons (SParams SNil) sxs, ys)                               ->+    encodeHlistAsReq sxs ys req++  (SCons (SParams (SCons (STuple2 s _x) ps)) sxs, y :. ys)     ->+    let req' = appendToQueryString (createParam s y) req+    in encodeHlistAsReq (SCons (SParams ps) sxs) ys req'++  (SCons (SQueryFlags _a sflags) SNil, _)                      ->+    appendQueryFlags (toQueryFlags sflags) req++  (SCons (SQueryFlags _a sflags) sxs, ys)                      ->+     encodeHlistAsReq sxs ys+       $ appendQueryFlags (toQueryFlags sflags) req++  (SCons (SReqBody sctyp _sa) sxs, y :. ys)                    ->+     let body = RequestBodyLBS $ mediaEncode sctyp y+         req' = setReqBody body (mediaType sctyp) req+     in encodeHlistAsReq sxs ys req'++  (SCons (SStreamBody sctyp _sa) sxs, y :. ys)                 ->+     let body = RequestBodyStream $ givePopper y+         req' = setReqBody body (mediaType sctyp) req+     in encodeHlistAsReq sxs ys req'++{-------------------------------------------------------------------------------+  Helper functions+-------------------------------------------------------------------------------}++createParam+  :: (KnownSymbol p, ToHttpApiData a) => Sing p -> a -> QueryItem+createParam sname val =+  let pname = withKnownSymbol sname (symbolVal sname)+      value = toQueryParam val+  in (cs pname, Just $ cs value)++appendQueryFlags :: [String] -> Request -> Request+appendQueryFlags xs req =+  let queryflags = (\ x -> (cs x, Nothing)) <$> xs+  in foldr appendToQueryString req queryflags++toQueryFlags+  :: forall (fs :: [Symbol]) . All KnownSymbol fs+  => Sing fs+  -> [String]+toQueryFlags  = \case+  SNil -> []+  SCons x xs -> withKnownSymbol x (symbolVal x) : toQueryFlags xs
+ src/Hreq/Core/Client/HasResponse.hs view
@@ -0,0 +1,156 @@+-- | This module provides a 'HasResponse' class that Interprets+-- 'Verb' content into a particular api endpoint query result.+--+-- For instance @Verb GET '[]@ gets interpreted as an empty response of type Unit i.e @()@+--+module Hreq.Core.Client.HasResponse where++import Control.Monad.Except+import Data.Kind+import Data.Hlist+import Data.Proxy+import Data.Singletons+import qualified Data.List.NonEmpty as NE+import GHC.TypeLits+import Network.HTTP.Types (hContentType)++import Hreq.Core.API+import Hreq.Core.Client.ClientError+import Hreq.Core.Client.Response++class MonadError ClientError m => HasResponse (a :: k) m where+   type HttpOutput a :: Type++   httpRes :: sing a -> Response -> m (HttpOutput a)++instance+  ( UniqMembers rs "Response"+  , HasResponse rs m+  )+  => HasResponse (Verb method rs ) m where++  type HttpOutput (Verb method rs) = HttpOutput rs++  httpRes _ = httpRes (Proxy @rs)++instance (MonadError ClientError m) => HasResponse '[] m where+  type HttpOutput '[] = ()++  httpRes _ _ = return ()++instance {-# OVERLAPPING #-} (MonadError ClientError m)+  => HasResponse '[ 'Raw a ] m where+  type HttpOutput '[ 'Raw a ] = Response++  httpRes _ = return++instance MonadError ClientError m => HasResponse ('ResStream ': rs) m where++  type HttpOutput ('ResStream ': rs) =+    TypeError ('Text "ResStream shouldn't be an instance of HasResponse class")++  httpRes _ _ =  error "GHC Error"++instance {-# OVERLAPPING #-}+  MonadError ClientError m+  => HasResponse ('Raw a : r : rs) m where++  type HttpOutput ('Raw a : r : rs) =+    TypeError ('Text "Raw should be used only in a singleton list")++  httpRes _ _ =  error "GHC Error"++instance {-# OVERLAPPING #-}+  ( MediaDecode ctyp a+  , MonadError ClientError m+  )+  => HasResponse '[ 'ResBody  ctyp a ] m where+  type HttpOutput '[ 'ResBody ctyp a ] = a++  httpRes _ = decodeAsBody (Proxy @ctyp)++-- | The following type instance is overly restrictive to avoid+-- overlapping type family instance error.+instance {-# OVERLAPPING #-}+  ( MediaDecode ctyp a+  , MonadError ClientError m+  , SingI ('Res (r ': rs))+  , HttpResConstraints (r ': rs)+  ) => HasResponse ( 'ResBody ctyp a ': r ': rs ) m where+  type HttpOutput  ( 'ResBody ctyp a ': r ': rs) = Hlist ( a ': HttpRes (r ': rs))+  httpRes _ response = case sing @('Res (r ': rs)) of+    SRes xs -> do+      body <- decodeAsBody (Proxy @ctyp) response+      reset <- decodeAsHlist xs response+      return $ body :. reset+++instance {-# OVERLAPPING #-}+  ( MonadError ClientError m+  , SingI ('Res ('ResHeaders hs ': rs))+  , HttpResConstraints ('ResHeaders hs ': rs)+  ) => HasResponse ('ResHeaders hs ': rs) m where+  type HttpOutput ('ResHeaders hs : rs) = Hlist (HttpRes ('ResHeaders hs ': rs))++  httpRes _ response = case sing @('Res ('ResHeaders hs ': rs)) of+    SRes xs -> decodeAsHlist xs response++decodeAsBody+  :: forall ctyp a m sing+  . (MonadError ClientError m, MediaDecode ctyp a)+  => sing ctyp+  -> Response+  -> m a+decodeAsBody _ response = do+  responseContentType <- checkContentType++  unless (any (responseContentType `matches`) accepts)+    . throwError $ UnsupportedContentType (NE.head accepts) response++  case mediaDecode ctypProxy (resBody response) of+     Left err -> throwError $ DecodeFailure (unDecodeError err) response+     Right val -> pure val+  where+    ctypProxy :: Proxy ctyp+    ctypProxy = Proxy++    accepts :: NE.NonEmpty MediaType+    accepts = mediaTypes ctypProxy++    checkContentType :: m MediaType+    checkContentType  = case lookup hContentType $ resHeaders response of+      Nothing -> return $ mediaType (Proxy @PlainText) -- fall back to plain text+      Just t  -> maybe (throwError $ InvalidContentTypeHeader response) return $ parseAccept t++-- | Turn a Response into a 'Hlist' of outputs+decodeAsHlist+  :: (MonadError ClientError m, HttpResConstraints rs)+  => Sing rs+  -> Response+  -> m (Hlist (HttpRes rs))+decodeAsHlist srs response = case srs of+  SNil -> return Nil++  SCons (SResBody ctyp _a) xs -> do+    body <- decodeAsBody ctyp response+    rest <- decodeAsHlist xs response+    return $ body :. rest++  SCons (SResHeaders (SCons _h _hs)) xs -> do+    let headers = resHeaders response++    rest <- decodeAsHlist xs response+    return $ headers :. rest++  SCons (SResHeaders SNil) xs ->+    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+  (SCons (SRaw _) _xs)-> error "GHC Error"++  -- Should never match because we have a class instance+  -- that triggers a type error when 'ResStream' is in a instance of+  -- HasResponse class+  (SCons (SResStream _ _) _xs)-> error "GHC Error"
+ src/Hreq/Core/Client/Internal.hs view
@@ -0,0 +1,96 @@+-- | This module provides functions that take API endpoint types and transform them into+-- HTTP Response outputs.+--+{-# LANGUAGE AllowAmbiguousTypes #-}+module Hreq.Core.Client.Internal where++import Control.Monad.Except+import Data.Proxy++import Hreq.Core.API+import Hreq.Core.Client.ClientError+import Hreq.Core.Client.HasRequest+import Hreq.Core.Client.HasResponse+import Hreq.Core.Client.Request+import Hreq.Core.Client.RunClient++-- | 'HasClient' represent constraints required to interpret a type level API into an actual+-- HTTP network request.+--+-- @ts ~@ 'ApiToReq' @api@ : Turns API description into a list of Request Content types+--+-- @v ~ 'GetVerb' api@     : Retrieves the verb component of an API definition+--+-- 'HasRequest' @ts v@     : Interprets type level list 'ReqContent' and 'Verb' components to obtain 'Request' Data+--+-- 'HasResponse' @v n@     : Interprets 'Verb' component to obtain type level specified Response+--+-- 'MonadError' 'ClientError' @n@ : @MonadError ClientError n@ is used by the 'httpRes' function+--+-- 'RunClient' @m@         : Provides capability to make an actual Http client network request+--+type HasClient api ts v n m =+  ( ts ~ ApiToReq api+  , v  ~ GetVerb api+  , HasRequest ts v+  , HasResponse v n+  , MonadError ClientError n+  , RunClient m+  )++-- | Used to make generic HTTP requests+--+hreq'+  :: forall api ts v m. HasClient api ts v (Either ClientError) m+  => Proxy api+  -> HttpInput ts+  -> m (HttpOutput v)+hreq' _ reqInput = do+  let req = httpReq (Proxy @v) (Proxy @ts) reqInput defaultRequest++  clientResponse <- runClient $! req++  lift' $ httpRes (Proxy @v) clientResponse+  where+    lift' = either throwHttpError pure++-- | Used to make HTTP requests. Uses visible type-applications for API type specification.+-- Example+--+-- > hreq @(Capture "age" Int :> GetJson Value) (25 :. Empty)+--+hreq+  :: forall api ts v m. HasClient api ts v (Either ClientError) m+  => HttpInput ts+  -> m (HttpOutput v)+hreq = hreq' (Proxy @api)++-- | 'HasStreamingClient' type constraint is represents constraints required for streaming HTTP responses.+--+-- @ts ~@ 'ApiToReq' @api@ :  Turns API description into a list of Request Content types+--+-- @v  ~@ 'GetVerb' @api@  :  Retrieves the verb component of an API definition+--+-- 'HasRequest' @ts v@     :  Interprets type level list 'ReqContent' and 'Verb' components to obtain+--+-- 'RunStreamingClient' @m a@: Provides capability to create an HTTP request with response streaming.+--+type HasStreamingClient api a ts v m =+  ( ts ~ ApiToReq api+  , v  ~ GetVerb api+  , HasRequest ts v+  , RunStreamingClient m a+  )++-- | Helper function for working with an HTTP response streaming client.+--+hreqStream+  :: forall api a ts v m r. (HasStreamingClient api a ts v m)+  => Proxy api+  -> HttpInput ts+  -> (a -> IO r)+  -> m r+hreqStream _ reqInput f = do+  let req = httpReq (Proxy @v) (Proxy @ts) reqInput defaultRequest++  withStreamingClient req (liftIO . f)
+ src/Hreq/Core/Client/Request.hs view
@@ -0,0 +1,78 @@+-- | This module provides a 'Request' data type which contains components required for+-- creation of an HTTP Request.+--+-- 'Request' data is built from type level API endpoints and the 'Hreq.Core.Client.BaseUrl.BaseUrl'+-- with in the 'Hreq.Core.API.HasRequest.HasRequest' class instance.+--+{-# LANGUAGE DeriveFunctor #-}+module Hreq.Core.Client.Request where++import Prelude ()+import Prelude.Compat++import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Sequence as Seq+import Data.Text+import Network.HTTP.Media (MediaType)+import Network.HTTP.Types (Header, HeaderName, HttpVersion (..), Method, QueryItem, http11,+                           methodGet)+import Web.HttpApiData (ToHttpApiData (..))++import Hreq.Core.API.Streaming (GivesPooper)++-- * Request+data RequestF body = Request+  { reqPath        :: Text+  , reqMethod      :: Method+  , reqBody        :: Maybe (body, MediaType)+  , reqQueryString :: Seq.Seq QueryItem+  , reqHttpVersion :: HttpVersion+  , reqAccept      :: Maybe MediaType+  , reqHeaders     :: Seq.Seq Header+  } deriving (Show, Eq, Functor)+++-- | The Request body replica of the @http-client@ @RequestBody@.+data RequestBody =+    RequestBodyLBS LBS.ByteString+  | RequestBodyBS ByteString+  | RequestBodyStream (GivesPooper ())+  deriving (Show, Eq)+++type Request = RequestF RequestBody++-- * Default Request+defaultRequest :: Request+defaultRequest = Request+  { reqPath = ""+  , reqMethod = methodGet+  , reqBody = Nothing+  , reqQueryString = Seq.empty+  , reqHttpVersion = http11+  , reqAccept = Nothing+  , reqHeaders = Seq.empty+  }++-- * Request helper functions+appendMethod :: Method -> Request -> Request+appendMethod method req = req { reqMethod = method }++appendToPath :: Text -> Request -> Request+appendToPath p req = req { reqPath = reqPath req <> "/" <> p }++appendToQueryString+  :: QueryItem+  -> Request+  -> Request+appendToQueryString queryItem req =+  req { reqQueryString =  reqQueryString req Seq.|> queryItem }++addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request+addHeader name val req =+  req {reqHeaders = reqHeaders req Seq.|> (name, toHeader val) }++setReqBody :: RequestBody -> MediaType -> Request -> Request+setReqBody body mediaType req =+  req { reqBody = Just (body, mediaType) }
+ src/Hreq/Core/Client/Response.hs view
@@ -0,0 +1,20 @@+-- | This module provides the 'Response' type which is the result of an HTTP request.+--+{-# LANGUAGE DeriveFunctor #-}+module Hreq.Core.Client.Response where++import Data.ByteString.Lazy as LBS+import Network.HTTP.Types (Header, HttpVersion (..))++import Data.Text (Text)++-- * Response+data ResponseF a = Response+  { resStatusCode  :: Int+  , resStatusMsg   :: Text+  , resHeaders     :: [Header]+  , resBody        :: a+  , resHttpVersion :: HttpVersion+  } deriving (Eq, Show, Functor)++type Response = ResponseF LBS.ByteString
+ src/Hreq/Core/Client/RunClient.hs view
@@ -0,0 +1,50 @@+-- | The 'RunClient' module provides a class which any client must instantiate in order to+-- run HTTP requests.+--+{-# LANGUAGE DeriveFunctor #-}+module Hreq.Core.Client.RunClient where++import Hreq.Core.Client.ClientError+import Hreq.Core.Client.Request+import Hreq.Core.Client.Response++-- | Provides the capability to run a request and get a response.+class Monad m => RunClient m where+  runClient :: Request -> m Response++  throwHttpError :: ClientError -> m a++  checkResponse :: Request -> Response -> m (Maybe ClientError)++class Monad m => RunStreamingClient m a where+  withStreamingClient+      :: forall r. Request+      -> (a -> IO r)+      -> m r++-- * Pure client++-- | A pure HTTP client monad useful for testing.+data ClientPure (state :: k) a+    = RunClient Request a+    | Throw ClientError+  deriving (Functor, Show, Eq)++instance Monad (ClientPure state)  where+  return = pure++  m >>= f = case m of+    RunClient r x -> setHttpRequest r $ f x+    Throw e     -> Throw e++instance Applicative (ClientPure state) where+  pure = RunClient defaultRequest++  f <*> x = case x of+    Throw e     -> Throw e+    RunClient r y -> setHttpRequest r $ fmap ( $ y) f++setHttpRequest :: Request -> ClientPure state a -> ClientPure state a+setHttpRequest r h = case h of+  RunClient _ rs -> RunClient r rs+  Throw e      -> Throw e
+ test/DocTests.hs view
@@ -0,0 +1,14 @@+module Main where++import Build_doctests (flags, module_sources, pkgs)+import Data.Foldable (traverse_)+import System.Environment (unsetEnv)+import Test.DocTest (doctest)++main :: IO ()+main = do+    traverse_ putStrLn args -- optionally print arguments+    unsetEnv "GHC_ENVIRONMENT" -- see 'Notes'; you may not need this+    doctest args+  where+    args = flags ++ pkgs ++ module_sources