dormouse-client (empty) → 0.1.0.0

raw patch · 23 files changed

+1876/−0 lines, 23 filesdep +aesondep +attoparsecdep +base

Dependencies added: aeson, attoparsec, base, bytestring, case-insensitive, containers, dormouse-uri, hedgehog, hspec, hspec-discover, hspec-hedgehog, http-api-data, http-client, http-client-tls, http-types, mtl, safe-exceptions, scientific, streamly, streamly-bytestring, template-haskell, text, vector

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +162/−0
• dormouse-client.cabal +134/−0
• src/Dormouse/Client.hs +180/−0
• src/Dormouse/Client/Class.hs +27/−0
• src/Dormouse/Client/Data.hs +5/−0
• src/Dormouse/Client/Exception.hs +58/−0
• src/Dormouse/Client/Headers.hs +20/−0
• src/Dormouse/Client/Headers/MediaType.hs +145/−0
• src/Dormouse/Client/Methods.hs +67/−0
• src/Dormouse/Client/MonadIOImpl.hs +96/−0
• src/Dormouse/Client/Payload.hs +154/−0
• src/Dormouse/Client/Status.hs +145/−0
• src/Dormouse/Client/Test/Class.hs +58/−0
• src/Dormouse/Client/Types.hs +64/−0
• test/Dormouse/Client/Generators/Json.hs +52/−0
• test/Dormouse/Client/Generators/UriComponents.hs +246/−0
• test/Dormouse/Client/Headers/MediaTypeSpec.hs +29/−0
• test/Dormouse/Client/StatusSpec.hs +22/−0
• test/Dormouse/Client/UrlReqSpec.hs +60/−0
• test/Dormouse/ClientSpec.hs +118/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,3 @@+# Changelog for dormouse++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Phil Curzon (c) 2020-2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Phil Curzon nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,162 @@+# Dormouse-Client++Dormouse is an HTTP client that will help you REST.++It was designed with the following objectives in mind:+       +  - HTTP requests and responses should be modelled by a simple, immutable Haskell Record.+  - Real HTTP calls should be made via an abstraction layer (`MonadDormouseClient`) so testing and mocking is painless.+  - Illegal requests should be unrepresentable, such as HTTP GET requests with a content body.+  - It should be possible to enforce a protocol (e.g. https) at the type level.+  - It should be possible to handle large request and response bodies via constant memory streaming.++Example use:++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++import Control.Monad.IO.Class+import Data.Aeson.TH +import Dormouse.Client+import GHC.Generics (Generic)+import Dormouse.Url.QQ++data UserDetails = UserDetails +  { name :: String+  , nickname :: String+  , email :: String+  } deriving (Eq, Show, Generic)++deriveJSON defaultOptions ''UserDetails++data EchoedJson a = EchoedJson +  { echoedjson :: a+  } deriving (Eq, Show, Generic)++deriveJSON defaultOptions {fieldLabelModifier = drop 6} ''EchoedJson++main :: IO ()+main = do+  manager <- newManager tlsManagerSettings+  runDormouseClient (DormouseClientConfig { clientManager = manager }) $ do+    let +      userDetails = UserDetails +        { name = "James T. Kirk"+        , nickname = "Jim"+        , email = "james.t.kirk@starfleet.com"+        }+      req = accept json $ supplyBody json userDetails $ post [https|https://postman-echo.com/post|]+    response :: HttpResponse (EchoedJson UserDetails) <- expect req+    liftIO $ print response+    return ()+```++## Building requests++### GET requests++Building a GET request is simple using a `Url` (Please see the [Dormouse-Uri](../dormouse-uri/README.md) documentation for more details of how to safely create and construct `Url`s).++```haskell+postmanEchoGetUrl :: Url "http"+postmanEchoGetUrl = [http|http://postman-echo.com/get?foo1=bar1&foo2=bar2/|]++postmanEchoGetReq :: HttpRequest (Url "http") "GET" Empty EmptyPayload acceptTag+postmanEchoGetReq = get postmanEchoGetUrl+```++It is often useful to tell Dormouse about the expected `Content-Type` of the response in advance so that the correct `Accept` headers can be sent:++```haskell+postmanEchoGetReq' :: HttpRequest (Url "http") "GET" Empty EmptyPayload acceptTag+postmanEchoGetReq' = accept json $ get postmanEchoGetUrl+```++### POST requests++You can build POST requests in the same way++```haskell+postmanEchoPostUrl :: Url "https"+postmanEchoPostUrl = [https|https://postman-echo.com/post|]++postmanEchoPostReq :: HttpRequest (Url "https") "POST" Empty EmptyPayload JsonPayload+postmanEchoPostReq = accept json $ post postmanEchoPostUrl+```++## Expecting a response++Since we're expecting json, we also need data types and `FromJSON` instances to interpret the response with.  Let's start with an example to handle the GET request.++```haskell+{-# LANGUAGE DeriveGeneric #-}+```++```haskell+data Args = Args +  { foo1 :: String+  , foo2 :: String+  } deriving (Eq, Show, Generic)++data PostmanEchoResponse = PostmanEchoResponse+  { args :: Args+  } deriving (Eq, Show, Generic)+```+++Once the request has been built, you can send it and expect a response of a particular type in any `MonadDormouseClient m`.++```haskell+sendPostmanEchoGetReq :: MonadDormouseClient m => m PostmanEchoResponse+sendPostmanEchoGetReq = do+  (resp :: HttpResponse PostmanEchoResponse) <- expect postmanEchoGetReq'+  return $ responseBody resp+```++## Running Dormouse++Dormouse is not opinionated about how you run it.  ++You can use a concrete type.++```haskell+main :: IO ()+main = do+  manager <- newManager tlsManagerSettings+  postmanResponse <- runDormouseClient (DormouseClientConfig { clientManager = manager }) sendPostmanEchoGetReq+  print postmanResponse+```++You can integrate the `DormouseClientT` Monad Transformer into your transformer stack.++```haskell+main :: IO ()+main = do+  manager <- newManager tlsManagerSettings+  postmanResponse <- runDormouseClientT (DormouseClientConfig { clientManager = manager }) sendPostmanEchoGetReq+  print postmanResponse+```++You can also integrate into your own Application monad using the `sendHttp` function from `Dormouse.Client.MonadIOImpl` and by providing an instance of `HasDormouseConfig` for your application environment.++```haskell+data MyEnv = MyEnv +  { dormouseEnv :: DormouseClientConfig+  }++instance HasDormouseClientConfigMyEnv where+  getDormouseClientConfig = dormouseEnv++newtype AppM a = AppM+  { unAppM :: ReaderT Env IO a +  } deriving (Functor, Applicative, Monad, MonadReader Env, MonadIO, MonadThrow)++instance MonadDormouseClient (AppM) where+  send = IOImpl.sendHttp++runAppM :: Env -> AppM a -> IO a+runAppM deps app = flip runReaderT deps $ unAppM app+```

@@ -0,0 +1,134 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: ba447e997d78582de45b1d7a4371396f5daed044c73681fa6b1a1e5f06f57aa9++name:           dormouse-client+version:        0.1.0.0+synopsis:       Simple, type-safe and testable HTTP client+description:    An HTTP client designed to be productive, easy to use, easy to test, flexible and safe!+                .+                It was designed with the following objectives in mind:+                .+                  - HTTP requests and responses should be modelled by a simple, immutable Haskell Record.+                  - Actual HTTP calls should be made via an abstraction layer (`MonadDormouseClient`) so testing and mocking is painless.+                  - Illegal requests should be unrepresentable, such as HTTP GET requests with a content body.+                  - It should be possible to enforce a protocol (e.g. https) at the type level.+                  - It should be possible to handle large request and response bodies via constant memory streaming.+                .+                Please see https://dormouse.io for full documentation.+category:       Web+homepage:       https://dormouse.io/client.html+bug-reports:    https://github.com/theinnerlight/dormouse/issues+author:         Phil Curzon+maintainer:     phil@novelfs.org+copyright:      2020-2021 Phil Curzon+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md+extra-doc-files:+    README.md++source-repository head+  type: git+  location: https://github.com/theinnerlight/dormouse++library+  exposed-modules:+      Dormouse.Client+      Dormouse.Client.Headers+      Dormouse.Client.Headers.MediaType+      Dormouse.Client.MonadIOImpl+      Dormouse.Client.Status+      Dormouse.Client.Test.Class+  other-modules:+      Dormouse.Client.Class+      Dormouse.Client.Data+      Dormouse.Client.Exception+      Dormouse.Client.Methods+      Dormouse.Client.Payload+      Dormouse.Client.Types+      Paths_dormouse_client+  hs-source-dirs:+      src+  default-extensions: OverloadedStrings MultiParamTypeClasses ScopedTypeVariables FlexibleContexts+  ghc-options: -Wall+  build-depends:+      aeson >=1.4.2 && <2.0.0+    , attoparsec >=0.13.2.4 && <0.14+    , base >=4.7 && <5+    , bytestring >=0.10.8 && <0.11.0+    , case-insensitive >=1.2.1.0 && <2.0.0+    , containers >=0.6.2.1 && <0.7+    , dormouse-uri+    , http-api-data >=0.4.1.1 && <0.5+    , http-client >=0.6.4.1 && <0.7.0+    , http-client-tls >=0.3.5.3 && <0.4+    , http-types >=0.12.3 && <0.13+    , mtl >=2.2.2 && <3+    , safe-exceptions >=0.1.7 && <0.2.0+    , streamly >=0.7.2 && <0.8+    , streamly-bytestring >=0.1.2 && <0.2+    , template-haskell >=2.15.0 && <3.0.0+    , text >=1.2.3 && <2.0.0+  default-language: Haskell2010++test-suite dormouse-client-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Dormouse.Client+      Dormouse.Client.Class+      Dormouse.Client.Data+      Dormouse.Client.Exception+      Dormouse.Client.Headers+      Dormouse.Client.Headers.MediaType+      Dormouse.Client.Methods+      Dormouse.Client.MonadIOImpl+      Dormouse.Client.Payload+      Dormouse.Client.Status+      Dormouse.Client.Test.Class+      Dormouse.Client.Types+      Dormouse.Client.Generators.Json+      Dormouse.Client.Generators.UriComponents+      Dormouse.Client.Headers.MediaTypeSpec+      Dormouse.Client.StatusSpec+      Dormouse.Client.UrlReqSpec+      Dormouse.ClientSpec+      Paths_dormouse_client+  hs-source-dirs:+      src+      test+  default-extensions: OverloadedStrings MultiParamTypeClasses ScopedTypeVariables FlexibleContexts+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      aeson >=1.4.2 && <2.0.0+    , attoparsec >=0.13.2.4 && <0.14+    , base >=4.7 && <5+    , bytestring >=0.10.8 && <0.11.0+    , case-insensitive >=1.2.1.0 && <2.0.0+    , containers >=0.6.2.1 && <0.7+    , dormouse-uri+    , hedgehog >=1.0.1 && <2+    , hspec >=2.0.0 && <3+    , hspec-discover >=2.0.0 && <3+    , hspec-hedgehog >=0.0.1.2 && <0.1+    , http-api-data >=0.4.1.1 && <0.5+    , http-client >=0.6.4.1 && <0.7.0+    , http-client-tls >=0.3.5.3 && <0.4+    , http-types >=0.12.3 && <0.13+    , mtl >=2.2.2 && <3+    , safe-exceptions >=0.1.7 && <0.2.0+    , scientific >=0.3.6.2 && <0.4+    , streamly >=0.7.2 && <0.8+    , streamly-bytestring >=0.1.2 && <0.2+    , template-haskell >=2.15.0 && <3.0.0+    , text >=1.2.3 && <2.0.0+    , vector >=0.12.0.3 && <0.13+  default-language: Haskell2010

@@ -0,0 +1,180 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}++-- | The "Client" module is the primary module you will need to import to perform HTTP requests with this library.+--+--  For a comprehensive documentation, please see: <https://dormouse.io/client.html>+module Dormouse.Client+  ( -- * Request / Response Types+    HttpRequest(..)+  , HttpResponse(..)+  -- * Request building+  , delete+  , get+  , Dormouse.Client.head+  , patch+  , post+  , put+  , supplyBody+  , accept+  , expectAs+  , expect+  -- * Dormouse Client Monad and Transformer+  , DormouseClientT+  , DormouseClient+  , runDormouseClientT+  , runDormouseClient+  -- * Dormouse Client Class+  , MonadDormouseClient(..)+  -- * Dormouse Client Config+  , C.newManager+  , TLS.tlsManagerSettings+  , HasDormouseClientConfig(..)+  , DormouseClientConfig(..)+  -- * Headers+  , HeaderName+  , HasHeaders(..)+  , HasMediaType(..)+  -- * Methods+  , HttpMethod(..)+  , AllowedBody+  , methodAsByteString+  -- * Payloads+  , RawRequestPayload(..)+  , RequestPayload(..)+  , ResponsePayload(..)+  , EmptyPayload+  , HtmlPayload+  , JsonPayload+  , UrlFormPayload+  , Empty+  , json+  , urlForm+  , noPayload+  , html+  -- * Exceptions+  , SomeDormouseException(..)+  , DecodingException(..)+  , MediaTypeException(..)+  , UnexpectedStatusCodeException(..)+  , UriException(..)+  , UrlException(..)+  -- * Uri+  , Uri+  , parseUri+  -- * Url+  , Url+  , AnyUrl(..)+  , IsUrl(..)+  , ensureHttp+  , ensureHttps+  , parseUrl+  , parseHttpUrl+  , parseHttpsUrl+  ) where++import Control.Exception.Safe (MonadThrow)+import Control.Monad.IO.Class+import Control.Monad.Reader+import qualified Data.Map.Strict as Map+import qualified Data.ByteString as B+import Data.Proxy+import Dormouse.Client.Class+import Dormouse.Client.Data+import Dormouse.Client.Exception+import Dormouse.Client.Headers+import Dormouse.Client.Headers.MediaType+import Dormouse.Client.Payload+import Dormouse.Client.Methods+import Dormouse.Client.Types+import Dormouse.Uri+import Dormouse.Url+import qualified Dormouse.Client.MonadIOImpl as IOImpl+import qualified Network.HTTP.Client as C+import qualified Network.HTTP.Client.TLS as TLS++-- | Create an HTTP request with the supplied URI and supplied method, containing no body and no headers+makeRequest :: IsUrl url => HttpMethod method -> url -> HttpRequest url method Empty EmptyPayload acceptTag+makeRequest method url = HttpRequest +  { requestMethod = method+  , requestUrl = url+  , requestHeaders = Map.empty+  , requestBody = Empty+  }++-- | Create an HTTP DELETE request with the supplied URI, containing no body and no headers+delete :: IsUrl url => url -> HttpRequest url "DELETE" Empty EmptyPayload acceptTag+delete = makeRequest DELETE++-- | Create an HTTP GET request with the supplied URI, containing no body and no headers+get :: IsUrl url => url  -> HttpRequest url "GET" Empty EmptyPayload acceptTag+get = makeRequest GET++-- | Create an HTTP HEAD request with the supplied URI, containing no body and no headers+head :: IsUrl url => url  -> HttpRequest url "HEAD" Empty EmptyPayload acceptTag+head = makeRequest HEAD++-- | Create an HTTP PATCH request with the supplied URI, containing no body and no headers+patch :: IsUrl url => url  -> HttpRequest url "PATCH" Empty EmptyPayload acceptTag+patch = makeRequest PATCH++-- | Create an HTTP POST request with the supplied URI, containing no body and no headers+post :: IsUrl url => url  -> HttpRequest url "POST" Empty EmptyPayload acceptTag+post = makeRequest POST++-- | Create an HTTP PUT request with the supplied URI, containing no body and no headers+put :: IsUrl url => url  -> HttpRequest url "PUT" Empty EmptyPayload acceptTag+put = makeRequest PUT++-- | Supply a body to an HTTP request using the supplied tag to indicate how the request should be encoded+supplyBody :: (AllowedBody method b, RequestPayload b contentTag) => Proxy contentTag -> b -> HttpRequest url method b' contentTag' acceptTag -> HttpRequest url method b contentTag acceptTag+supplyBody prox b HttpRequest { requestHeaders = headers, requestBody = _, ..} =+  HttpRequest +    { requestHeaders = foldMap (\v -> Map.insert ("Content-Type" :: HeaderName) v headers) . fmap encodeMediaType $ mediaType prox+    , requestBody = b+    , ..+    }++-- | Supply a header to an HTTP request+supplyHeader :: (HeaderName, B.ByteString) -> HttpRequest url method b contentTag acceptTag -> HttpRequest url method b contentTag acceptTag+supplyHeader (k, v) r = r { requestHeaders = Map.insert k v $ requestHeaders r }++-- | Apply an accept header derived from the supplied tag proxy and add a type hint to the request, indicating how the response should be decodable+accept :: HasMediaType acceptTag => Proxy acceptTag -> HttpRequest url method b contentTag acceptTag -> HttpRequest url method b contentTag acceptTag+accept prox r = maybe r (\v -> supplyHeader ("Accept", v) r) . fmap encodeMediaType $ mediaType prox++-- | Make the supplied HTTP request, expecting an HTTP response with body type `b' to be delivered in some 'MonadDormouseClient m'+expect :: (MonadDormouseClient m, RequestPayload b contentTag, ResponsePayload b' acceptTag, IsUrl url) => HttpRequest url method b contentTag acceptTag -> m (HttpResponse b')+expect r = expectAs (proxyOfReq r) r+  where +    proxyOfReq :: HttpRequest url method b contentTag acceptTag -> Proxy acceptTag+    proxyOfReq _ = Proxy++-- | Make the supplied HTTP request, expecting an HTTP response in the supplied format with body type `b' to be delivered in some 'MonadDormouseClient m'+expectAs :: (MonadDormouseClient m, RequestPayload b contentTag, ResponsePayload b' acceptTag, IsUrl url) => Proxy acceptTag -> HttpRequest url method b contentTag acceptTag -> m (HttpResponse b')+expectAs tag r = do+  let r' = serialiseRequest (contentTypeProx r) r+  send r' $ deserialiseRequest tag+  where +    contentTypeProx :: HttpRequest url method b contentTag acceptTag -> Proxy contentTag+    contentTypeProx _ = Proxy++-- | The DormouseClientT Monad Transformer+newtype DormouseClientT m a = DormouseClientT +  { unDormouseClientT :: ReaderT DormouseClientConfig m a +  } deriving (Functor, Applicative, Monad, MonadReader DormouseClientConfig, MonadIO, MonadThrow, MonadTrans)++instance (MonadIO m, MonadThrow m) => MonadDormouseClient (DormouseClientT m) where+  send = IOImpl.sendHttp++-- | A simple monad that allows you to run DormouseClient+type DormouseClient a = DormouseClientT IO a++-- | Run a 'DormouseClientT' using the supplied 'DormouseClientConfig' to generate a result in the underlying monad @m@+runDormouseClientT :: DormouseClientConfig -> DormouseClientT m a -> m a+runDormouseClientT config dormouseClientT = runReaderT (unDormouseClientT dormouseClientT) config++-- | Run a 'DormouseClient' using the supplied 'DormouseClientConfig' to generate a result in 'IO'+runDormouseClient :: DormouseClientConfig -> DormouseClient a -> IO a+runDormouseClient = runDormouseClientT

@@ -0,0 +1,27 @@+module Dormouse.Client.Class+  ( MonadDormouseClient(..)+  , HasDormouseClientConfig(..)+  , DormouseClientConfig(..)+  ) where++import Data.Word ( Word8 )+import Dormouse.Client.Payload ( RawRequestPayload(..) )+import Dormouse.Client.Types ( HttpRequest(..), HttpResponse(..) )+import Dormouse.Url ( IsUrl )+import Network.HTTP.Client ( Manager )+import Streamly ( SerialT )++-- | The configuration options required to run Dormouse+newtype DormouseClientConfig = DormouseClientConfig { clientManager :: Manager }++-- | Describes the capability to retrieve a Dormouse Config+class HasDormouseClientConfig a where+  getDormouseClientConfig :: a -> DormouseClientConfig++instance HasDormouseClientConfig DormouseClientConfig where+  getDormouseClientConfig = id++-- | MonadDormouseClient describes the capability to send HTTP requests and receive an HTTP response+class Monad m => MonadDormouseClient m where+  -- | Sends a supplied HTTP request and retrieves a response within the supplied monad @m@+  send :: IsUrl url => HttpRequest url method RawRequestPayload contentTag acceptTag -> (HttpResponse (SerialT IO Word8) -> IO (HttpResponse b)) -> m (HttpResponse b)

@@ -0,0 +1,5 @@+module Dormouse.Client.Data +  ( Empty(..)+  ) where++data Empty = Empty

@@ -0,0 +1,58 @@+{-# LANGUAGE ExistentialQuantification #-}++module Dormouse.Client.Exception +  ( SomeDormouseException(..)+  , DecodingException(..)+  , UnexpectedStatusCodeException(..)+  , MediaTypeException(..)+  , UriException(..)+  , UrlException(..)+  ) where++  +import Control.Exception.Safe (Exception(..))+import Dormouse.Uri.Exception (UriException(..))+import Dormouse.Url.Exception (UrlException(..))+import qualified Data.Text as T+import Data.Typeable (cast)++data SomeDormouseException = forall e . Exception e => SomeDormouseException e++instance Show SomeDormouseException where+    show (SomeDormouseException e) = show e++instance Exception SomeDormouseException++-- | 'UnexpectedStatusCodeException' is used to indicate that the remote server returned an unexpected status code value, for instance an unsuccessful (non-2XX) status code.+newtype UnexpectedStatusCodeException = UnexpectedStatusCodeException { uscStatusCode :: Int }++instance Show UnexpectedStatusCodeException where+  show UnexpectedStatusCodeException { uscStatusCode = statusCode } = "Server returned unexpected status code: " <> show statusCode++instance Exception UnexpectedStatusCodeException where+  toException     = toException . SomeDormouseException+  fromException x = do+    SomeDormouseException a <- fromException x+    cast a++-- | 'DecodingException' is used to when something has gone wrong decoding an http response into the expected representation, e.g. json was expected but the response json was invalid.+newtype DecodingException = DecodingException { decodingExceptionMessage :: T.Text }++instance Show DecodingException where+  show DecodingException { decodingExceptionMessage = msg } = "Decoding payload failed: " <> T.unpack msg++instance Exception DecodingException++-- | 'MediaTypeException' is used to indicate an error parsing a MediaType header such as "Content-Type" into a valid 'MediaType'+newtype MediaTypeException = MediaTypeException  { mediaTypeExceptionMessage :: T.Text }++instance Show MediaTypeException where+  show MediaTypeException { mediaTypeExceptionMessage = msg } = "Failed to parse media type: " <> show msg++instance Exception MediaTypeException where+  toException     = toException . SomeDormouseException+  fromException x = do+    SomeDormouseException a <- fromException x+    cast a++

@@ -0,0 +1,20 @@++module Dormouse.Client.Headers+  ( HeaderName+  , HasHeaders(..)+  ) where++import qualified Data.ByteString  as SB+import Data.CaseInsensitive  (CI)+import qualified Data.Map.Strict as Map++-- | The name of an HTTP Header.  Header names are case insensitive.+type HeaderName = CI SB.ByteString++-- | Describes something which has headers+class HasHeaders a where+  -- | Retrieve all of the headers which @a@ has.+  getHeaders :: a -> Map.Map HeaderName SB.ByteString+  -- | Try to retrieve a specific header from @a@ with the supplied `HeaderName`+  getHeaderValue :: HeaderName -> a -> Maybe SB.ByteString+

@@ -0,0 +1,145 @@+module Dormouse.Client.Headers.MediaType +  ( MediaType(..)+  , ContentType(..)+  , MediaTypeException+  , parseMediaType+  , encodeMediaType+  , applicationJson+  , applicationXWWWFormUrlEncoded+  , textHtml+  ) where++import Control.Exception.Safe (MonadThrow, throw)+import Control.Applicative ((<|>))+import qualified Data.ByteString as B+import qualified Data.Attoparsec.ByteString.Char8 as A+import Data.CaseInsensitive  (CI, mk, foldedCase)+import Dormouse.Client.Exception (MediaTypeException(..))+import qualified Data.Char as C+import qualified Data.Text as T+import qualified Data.Map.Strict as Map++-- | A Media Type indicates the format of content which can be transferred over the wire+data MediaType = MediaType +  { mainType :: ContentType -- ^ The general category of data associated with this Media Type+  , subType :: CI B.ByteString -- ^ The subtype indicates the exact subtype of data associated with this Media Type+  , suffixes :: [CI B.ByteString] -- ^ The suffixes specify additional information on the structure of this Media Type+  , parameters :: Map.Map (CI B.ByteString) B.ByteString -- ^ Parameters serve to modify the content subtype specifying additional information, e.g. the @charset@+  } deriving (Eq, Show)++data ContentType+  = Text+  | Image+  | Audio+  | Video+  | Application+  | Multipart+  | Other (CI B.ByteString)+  deriving (Eq, Show)++-- | Encode a Media Type as an ASCII ByteString+encodeMediaType :: MediaType -> B.ByteString+encodeMediaType mediaType =+  let mainTypeBs = foldedCase . mainTypeAsByteString $ mainType mediaType+      subTypeBs = foldedCase $ subType mediaType+      suffixesBs = fmap (\x -> "+" <> foldedCase x) $ suffixes mediaType+      paramsBs = Map.foldlWithKey' (\acc k v -> acc <> "; " <> foldedCase k <> "=" <> v) "" $ parameters mediaType+  in mainTypeBs <> "/" <> subTypeBs <> B.concat suffixesBs <> paramsBs+  where +    mainTypeAsByteString Text        = "text"+    mainTypeAsByteString Image       = "image"+    mainTypeAsByteString Audio       = "audio"+    mainTypeAsByteString Video       = "video"+    mainTypeAsByteString Application = "application"+    mainTypeAsByteString Multipart   = "multipart"+    mainTypeAsByteString (Other x)   = x++-- | Parse a Media Type from an ASCII ByteString+parseMediaType :: MonadThrow m => B.ByteString -> m MediaType+parseMediaType bs = either (throw . MediaTypeException . T.pack) return $ A.parseOnly pMediaType bs++-- | The @application/json@ Media Type+applicationJson :: MediaType+applicationJson = MediaType +  { mainType = Application+  , subType = mk "json"+  , suffixes = []+  , parameters = Map.empty+  }++-- | The @application/x-www-form-urlencoded@ Media Type+applicationXWWWFormUrlEncoded :: MediaType+applicationXWWWFormUrlEncoded = MediaType +  { mainType = Application+  , subType = mk "x-www-form-urlencoded"+  , suffixes = []+  , parameters = Map.empty+  }++-- | The @text/html@ Media Type+textHtml :: MediaType+textHtml = MediaType +  { mainType = Text+  , subType = mk "html"+  , suffixes = []+  , parameters = Map.empty+  }++pContentType :: A.Parser ContentType+pContentType = +  fmap (convertContentType . mk) $ A.takeWhile1 isAsciiAlpha+  where +    convertContentType :: CI B.ByteString -> ContentType+    convertContentType "text"        = Text+    convertContentType "image"       = Image+    convertContentType "audio"       = Audio+    convertContentType "video"       = Video+    convertContentType "application" = Application+    convertContentType "multipart"   = Multipart+    convertContentType x             = Other x++pSubType :: A.Parser (CI B.ByteString)+pSubType = fmap mk $ A.takeWhile1 isSubtypeChar++pSuffix :: A.Parser (CI B.ByteString)+pSuffix = fmap mk $ A.takeWhile1 isAsciiAlpha++pMediaType :: A.Parser MediaType+pMediaType = do+  mainType' <- pContentType+  _ <- A.char '/'+  subType' <- pSubType+  suffixes' <- pSuffix `A.sepBy` A.char '+'+  parameters' <- A.many' (A.char ';' *> A.skipSpace *> pParam)+  return $ MediaType { mainType = mainType', subType = subType', suffixes = suffixes', parameters = Map.fromList parameters'}++-- | Checks whether a char is ascii & alpha+isAsciiAlpha :: Char -> Bool+isAsciiAlpha c = C.isAlpha c && C.isAscii c++isSpecial :: Char -> Bool+isSpecial c = c == '(' || c == ')' || c == '<' || c == '>' || c == '@' || c == ',' || c == ':' || c == ';' || c == '\\' || c == '"' || c == '/' || c == '[' || c == ']' || c == '?' || c == '='++isTokenChar :: Char -> Bool+isTokenChar c = (not $ isSpecial c) && (not $ C.isSpace c) && C.isAscii c && (not $ C.isControl c)++isQuotedChar :: Char -> Bool+isQuotedChar c = C.isAscii c && (not $ C.isControl c)++isSubtypeChar :: Char -> Bool+isSubtypeChar c = (isTokenChar c) && (c /= '+')++pTokens :: A.Parser B.ByteString+pTokens = A.takeWhile1 isTokenChar++pQuotedString :: A.Parser B.ByteString+pQuotedString = A.char '"' *> A.takeWhile isQuotedChar <* A.char '"'++pParam :: A.Parser (CI B.ByteString, B.ByteString)+pParam = do+  attribute <- pTokens+  _ <- A.char '='+  value <- pTokens <|> pQuotedString+  return (mk attribute, value)++

@@ -0,0 +1,67 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}++module Dormouse.Client.Methods+  ( HttpMethod(..)+  , AllowedBody+  , methodAsByteString+  ) where++import qualified Data.ByteString as SB+import qualified Data.ByteString.Char8 as C8SB+import Data.Kind (Constraint)+import Data.Proxy ( Proxy )+import Dormouse.Client.Data ( Empty )+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )++data HttpMethod (a :: Symbol) where +  CONNECT :: HttpMethod "CONNECT"+  DELETE :: HttpMethod "DELETE"+  HEAD :: HttpMethod "HEAD"+  GET :: HttpMethod "GET"+  OPTIONS :: HttpMethod "OPTIONS"+  PATCH :: HttpMethod "PATCH"+  POST :: HttpMethod "POST"+  PUT :: HttpMethod "PUT"+  TRACE :: HttpMethod "TRACE"+  CUSTOM :: KnownSymbol a => Proxy a -> HttpMethod a++instance Show (HttpMethod a) where+  show CONNECT    = "CONNECT"+  show DELETE     = "DELETE"+  show HEAD       = "HEAD"+  show GET        = "GET"+  show OPTIONS    = "OPTIONS"+  show PATCH      = "PATCH"+  show POST       = "POST"+  show PUT        = "PUT"+  show TRACE      = "TRACE"+  show (CUSTOM p)   = show . symbolVal $ p++instance Eq (HttpMethod a) where+  (==) _ _ = True++type family AllowedBody (a :: Symbol) b :: Constraint+type instance AllowedBody "CONNECT" b = (b ~ Empty)+type instance AllowedBody "DELETE" b = ()+type instance AllowedBody "GET" b = (b ~ Empty)+type instance AllowedBody "HEAD" b = (b ~ Empty)+type instance AllowedBody "OPTIONS" b = (b ~ Empty)+type instance AllowedBody "PATCH" b = ()+type instance AllowedBody "POST" b = ()+type instance AllowedBody "PUT" b = ()+type instance AllowedBody "TRACE" b = (b ~ Empty)++methodAsByteString :: HttpMethod a -> SB.ByteString+methodAsByteString CONNECT    = "CONNECT"+methodAsByteString DELETE     = "DELETE"+methodAsByteString HEAD       = "HEAD"+methodAsByteString GET        = "GET"+methodAsByteString OPTIONS    = "OPTIONS"+methodAsByteString PATCH      = "PATCH"+methodAsByteString POST       = "POST"+methodAsByteString PUT        = "PUT"+methodAsByteString TRACE      = "TRACE"+methodAsByteString (CUSTOM p) = C8SB.pack . symbolVal $ p

@@ -0,0 +1,96 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Dormouse.Client.MonadIOImpl+  ( sendHttp+  , genClientRequestFromUrlComponents+  ) where++import Control.Exception.Safe (MonadThrow, throw)+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Function ((&))+import Data.Functor (($>))+import Data.IORef+import Data.Maybe (fromMaybe)+import qualified Data.Map.Strict as Map+import Data.Text.Encoding (encodeUtf8)+import Data.Word (Word8)+import Data.ByteString as B+import Dormouse.Client.Class+import Dormouse.Client.Exception (UnexpectedStatusCodeException(..))+import Dormouse.Client.Methods+import Dormouse.Client.Payload+import Dormouse.Client.Status+import Dormouse.Client.Types+import Dormouse.Uri+import Dormouse.Uri.Encode+import Dormouse.Url+import qualified Network.HTTP.Client as C+import qualified Network.HTTP.Types as T+import qualified Network.HTTP.Types.Status as NC+import Streamly+import qualified Streamly.Prelude as S+import qualified Streamly.External.ByteString as SEB+import qualified Streamly.Internal.Memory.ArrayStream as SIMA++givesPopper :: SerialT IO Word8 -> C.GivesPopper ()+givesPopper rawStream k = do+  let initialStream = SIMA.arraysOf 32768 rawStream+  streamState <- newIORef initialStream+  let popper = do+        stream <- readIORef streamState+        test <- S.uncons stream+        case test of+          Just (elems, stream') -> writeIORef streamState stream' $> SEB.fromArray elems+          Nothing               -> return B.empty+  k popper++translateRequestBody :: RawRequestPayload -> C.RequestBody+translateRequestBody (DefinedContentLength size stream) = C.RequestBodyStream (fromIntegral size) (givesPopper stream)+translateRequestBody (ChunkedTransfer stream)           = C.RequestBodyStreamChunked (givesPopper stream)++genClientRequestFromUrlComponents :: AnyUrl -> C.Request+genClientRequestFromUrlComponents url =+  let (scheme, comps) = case url of+        AnyUrl (HttpUrl uc)  -> (HttpScheme, uc)+        AnyUrl (HttpsUrl uc) -> (HttpsScheme, uc)+      authority = urlAuthority comps+      path = urlPath comps+      queryParams = urlQuery comps+      host = T.urlEncode False . encodeUtf8 . unHost . authorityHost $ authority+      (isSecure, port) = case scheme of+        HttpScheme -> (False, fromMaybe 80 $ authorityPort authority)+        HttpsScheme -> (True, fromMaybe 443 $  authorityPort authority)+      queryText = fromMaybe "" queryParams in+  C.defaultRequest+    { C.host = host+    , C.path = encodePath path+    , C.secure = isSecure+    , C.port = fromIntegral port+    , C.queryString = encodeQuery queryText+    }++responseStream :: C.Response C.BodyReader -> SerialT IO Word8+responseStream resp = +    S.repeatM (C.brRead $ C.responseBody resp)+  & S.takeWhile (not . B.null)+  & S.concatMap (S.unfold SEB.read)++sendHttp :: (HasDormouseClientConfig env, MonadReader env m, MonadIO m, MonadThrow m, IsUrl url) => HttpRequest url method RawRequestPayload contentTag acceptTag -> (HttpResponse (SerialT IO Word8) -> IO (HttpResponse b)) -> m (HttpResponse b)+sendHttp HttpRequest { requestMethod = method, requestUrl = url, requestBody = reqBody, requestHeaders = reqHeaders} deserialiseResp = do+  manager <- clientManager <$> reader getDormouseClientConfig+  let initialRequest = genClientRequestFromUrlComponents $ asAnyUrl url+  let request = initialRequest { C.method = methodAsByteString method, C.requestBody = translateRequestBody reqBody, C.requestHeaders = Map.toList reqHeaders }+  response <- liftIO $ C.withResponse request manager (\resp -> do+      let respHeaders = Map.fromList $ C.responseHeaders resp+      let statusCode = NC.statusCode . C.responseStatus $ resp+      deserialiseResp $ HttpResponse +        { responseStatusCode = statusCode+        , responseHeaders = respHeaders+        , responseBody = responseStream resp+        }+      ) +  case responseStatusCode response of+    Successful -> return response+    _          -> throw $ UnexpectedStatusCodeException (responseStatusCode response)

@@ -0,0 +1,154 @@+{-# LANGUAGE FlexibleInstances #-}++module Dormouse.Client.Payload+  ( HasMediaType(..)+  , EmptyPayload+  , RequestPayload(..)+  , ResponsePayload(..)+  , JsonPayload+  , UrlFormPayload+  , HtmlPayload+  , RawRequestPayload(..)+  , json+  , urlForm+  , noPayload+  , html+  ) where++import Control.Exception.Safe (MonadThrow, throw)+import Control.Monad.IO.Class+import Data.Aeson (FromJSON, ToJSON, encode, eitherDecodeStrict)+import qualified Data.CaseInsensitive as CI+import Data.Proxy+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Word (Word8, Word64)+import Dormouse.Client.Data+import Dormouse.Client.Types+import Dormouse.Client.Exception (DecodingException(..))+import Dormouse.Client.Headers+import Dormouse.Client.Headers.MediaType+import qualified Dormouse.Client.Headers.MediaType as MTH+import qualified Data.ByteString.Lazy as LB+import qualified Data.Map.Strict as Map+import qualified Web.FormUrlEncoded as W+import Streamly+import qualified Streamly.Prelude as S+import qualified Streamly.External.ByteString as SEB+import qualified Streamly.External.ByteString.Lazy as SEBL++-- | Describes an association between a type @tag@ and a specific Media Type+class HasMediaType tag where+  mediaType :: Proxy tag -> Maybe MediaType++-- | A raw HTTP Request payload consisting of a stream of bytes with either a defined Content Length or using Chunked Transfer Encoding+data RawRequestPayload+  -- | DefinedContentLength represents a payload where the size of the message is known in advance and the content length header can be computed+  = DefinedContentLength Word64 (SerialT IO Word8)+  -- | ChunkedTransfer represents a payload with indertiminate length, to be sent using chunked transfer encoding+  | ChunkedTransfer (SerialT IO Word8)++-- | RequestPayload relates a type of content and a payload tag used to describe that type to its byte stream representation and the constraints required to encode it+class HasMediaType contentTag => RequestPayload body contentTag where+  -- | Generates a the byte stream representation from the supplied content+  serialiseRequest :: Proxy contentTag -> HttpRequest url method body contentTag acceptTag  -> HttpRequest url method RawRequestPayload contentTag acceptTag ++-- | ResponsePayload relates a type of content and a payload tag used to describe that type  to its byte stream representation and the constraints required to decode it+class HasMediaType tag => ResponsePayload body tag where+  -- | Decodes the high level representation from the supplied byte stream+  deserialiseRequest :: Proxy tag -> HttpResponse (SerialT IO Word8) -> IO (HttpResponse body)++data JsonPayload = JsonPayload++instance HasMediaType JsonPayload where+  mediaType _ = Just applicationJson++instance (ToJSON body) => RequestPayload body JsonPayload where+  serialiseRequest _ r = +    let b = requestBody r+        lbs = encode b+    in r { requestBody = DefinedContentLength (fromIntegral . LB.length $ lbs) (S.unfold SEBL.read lbs) }++instance (FromJSON body) => ResponsePayload body JsonPayload where+  deserialiseRequest _ resp = do+    let stream = responseBody resp+    bs <- S.fold SEB.write stream+    body <- either (throw . DecodingException . T.pack) return . eitherDecodeStrict $ bs+    return $ resp { responseBody = body }++-- | A type tag used to indicate that a request\/response should be encoded\/decoded as @application/json@ data+json :: Proxy JsonPayload+json = Proxy :: Proxy JsonPayload++data UrlFormPayload = UrlFormPayload++instance HasMediaType UrlFormPayload where+  mediaType _ = Just applicationXWWWFormUrlEncoded++instance (W.ToForm body) => RequestPayload body UrlFormPayload where+  serialiseRequest _ r =+    let b = requestBody r+        lbs = W.urlEncodeAsForm b+    in r { requestBody = DefinedContentLength (fromIntegral . LB.length $ lbs) (S.unfold SEBL.read lbs) }++instance (W.FromForm body) => ResponsePayload body UrlFormPayload where+  deserialiseRequest _ resp = do+    let stream = responseBody resp+    bs <- S.fold SEB.write $ stream+    body <- either (throw . DecodingException) return . W.urlDecodeAsForm $ LB.fromStrict bs+    return $ resp { responseBody = body }++-- | A type tag used to indicate that a request\/response should be encoded\/decoded as @application/x-www-form-urlencoded@ data+urlForm :: Proxy UrlFormPayload+urlForm = Proxy :: Proxy UrlFormPayload++data EmptyPayload = EmptyPayload++instance HasMediaType EmptyPayload where+  mediaType _ = Nothing++instance RequestPayload Empty EmptyPayload where+  serialiseRequest _ r = r { requestBody = DefinedContentLength 0 S.nil }++instance ResponsePayload Empty EmptyPayload where+  deserialiseRequest _ resp = do+    let stream = responseBody resp+    body <- Empty <$ S.drain stream+    return $ resp { responseBody = body }++-- | A type tag used to indicate that a request\/response has no payload+noPayload :: Proxy EmptyPayload+noPayload = Proxy :: Proxy EmptyPayload++decodeTextContent :: (MonadThrow m, MonadIO m) => HttpResponse (SerialT m Word8) -> m (HttpResponse T.Text)+decodeTextContent resp = do+  let contentTypeHV = getHeaderValue "Content-Type" resp+  mediaType' <- traverse MTH.parseMediaType contentTypeHV+  let maybeCharset = mediaType' >>= Map.lookup "charset" . MTH.parameters+  let stream = responseBody resp+  bs <- S.fold SEB.write $ stream+  return $ resp { responseBody = decodeContent maybeCharset bs }+    where+      decodeContent maybeCharset bs' = +        case fmap CI.mk maybeCharset of+          Just("utf8")       -> TE.decodeUtf8 bs'+          Just("iso-8859-1") -> TE.decodeLatin1 bs'+          _                  -> TE.decodeUtf8 bs'++data HtmlPayload = HtmlPayload++instance HasMediaType HtmlPayload where+  mediaType _ = Just textHtml++instance RequestPayload T.Text HtmlPayload where+  serialiseRequest _ r =+    let b = requestBody r+        lbs = LB.fromStrict $ TE.encodeUtf8 b +    in r { requestBody = DefinedContentLength (fromIntegral . LB.length $ lbs) (S.unfold SEBL.read lbs) }++instance ResponsePayload T.Text HtmlPayload where+  deserialiseRequest _ resp = decodeTextContent resp++-- | A type tag used to indicate that a request\/response should be encoded\/decoded as @text/html@ data+html :: Proxy HtmlPayload+html = Proxy :: Proxy HtmlPayload

@@ -0,0 +1,145 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++module Dormouse.Client.Status+  ( ok+  , created+  , accepted+  , nonAuthoritativeInformation+  , noContent+  , resetContent+  , partialContent+  , badRequest+  , notFound+  , internalServerError+  , pattern Informational+  , pattern Successful+  , pattern Redirect+  , pattern ClientError+  , pattern ServerError+  , pattern Ok+  , pattern Created+  , pattern Accepted+  , pattern NonAuthoritativeInformation+  , pattern NoContent+  , pattern ResetContent+  , pattern PartialContent+  , pattern BadRequest+  , pattern NotFound+  , pattern InternalServerError+  ) where++-- | Checks whether the status code is in the range of Informational (1xx) status codes+isInformational :: Int -> Bool+isInformational x = x >= 100 && x < 200++-- | Checks whether the status code is in the range of Successful (2xx) status codes+isSuccessful :: Int -> Bool+isSuccessful x = x >= 200 && x < 300++-- | Checks whether the status code is in the range of Redirect (3xx) status codes+isRedirect :: Int -> Bool+isRedirect x = x >= 300 && x < 400++-- | Checks whether the status code is in the range of Client Error (4xx) status codes+isClientError :: Int -> Bool+isClientError x = x >= 400 && x < 500++-- | Checks whether the status code is in the range of Server Error (5xx) status codes+isServerError :: Int -> Bool+isServerError x = x >= 500 && x < 600++ok :: Int+ok = 200++created :: Int+created = 201++accepted :: Int+accepted = 202++nonAuthoritativeInformation :: Int+nonAuthoritativeInformation = 203++noContent :: Int+noContent = 204++resetContent :: Int+resetContent = 205++partialContent :: Int+partialContent  = 206++badRequest :: Int+badRequest = 400++notFound :: Int+notFound = 404++internalServerError :: Int+internalServerError = 500++-- | Matches for 1XX http status codes+pattern Informational :: Int+pattern Informational <- (isInformational -> True)++-- | Matches for 2XX http status codes+pattern Successful :: Int+pattern Successful <- (isSuccessful -> True)++-- | Matches for 3XX http status codes+pattern Redirect :: Int+pattern Redirect <- (isRedirect -> True)++-- | Matches for 4XX http status codes+pattern ClientError :: Int+pattern ClientError <- (isClientError -> True)++-- | Matches for 5XX http status codes+pattern ServerError :: Int+pattern ServerError <- (isServerError -> True)++-- | Matches the 200 Ok status code+pattern Ok :: Int+pattern Ok <- ((==) ok -> True)++-- | Matches the 201 Created status code+pattern Created :: Int+pattern Created <- ((==) created -> True)++-- | Matches the 202 Accepted status code+pattern Accepted :: Int+pattern Accepted <- ((==) accepted -> True)++-- | Matches the 203 Non-Authoritative Information status code+pattern NonAuthoritativeInformation :: Int+pattern NonAuthoritativeInformation <- ((==) nonAuthoritativeInformation -> True)++-- | Matches the 204 No Content status code+pattern NoContent :: Int+pattern NoContent <- ((==) noContent -> True)++-- | Matches the 205 Reset Content status code+pattern ResetContent :: Int+pattern ResetContent <- ((==) resetContent -> True)++-- | Matches the 206 Partial Content status code+pattern PartialContent :: Int+pattern PartialContent <- ((==) partialContent -> True)++-- | Matches the 400 Bad Request status code+pattern BadRequest :: Int+pattern BadRequest <- ((==) badRequest -> True)++-- | Matches the 404 Not Found status code+pattern NotFound :: Int+pattern NotFound <- ((==) notFound -> True)++-- | Matches the 500 Internal Server Error status code+pattern InternalServerError :: Int+pattern InternalServerError <- ((==) internalServerError -> True)++

@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- | +-- This module is useful for testing by providing a concrete ByteString typed version of 'MonadDormouseClient' called `MonadDormouseTestClient`.  +--+-- The assumption is that, in most test cases, you probably want to verify the byte payload of the request (which you simply extract+-- from the request here as a @ByteString@) and provide a byte payload (also as a @ByteString@) in the response so that you can verify +-- your repsonse payload can be decoded directly.+--+-- An implementation of `MonadDormouseTestClient` can be written in terms of either Strict or Lazy Bytestrings at your convenient and the other +-- will be automatically provided for you.+--+-- The machinery in here uses orphan instances of 'MonadDormouseClient' so you should use this carefully and restrict this module to test +-- cases only.+module Dormouse.Client.Test.Class+  ( MonadDormouseTestClient(..)+  ) where++import Control.Monad.IO.Class ( MonadIO(..) )+import qualified Data.ByteString  as SB+import qualified Data.ByteString.Lazy  as LB+import Data.Word ( Word8 )+import Dormouse.Client.Class ( MonadDormouseClient(..) )+import Dormouse.Client.Payload ( RawRequestPayload(..) )+import Dormouse.Client.Types ( HttpRequest(..), HttpResponse(..) )+import Streamly ( SerialT )+import qualified Streamly.Prelude as S+import qualified Streamly.External.ByteString as SEB+import qualified Streamly.External.ByteString.Lazy as SEBL++-- | MonadDormouseTestClient describes the capability to send and receive specifically ByteString typed HTTP Requests and Responses+class Monad m => MonadDormouseTestClient m where+  -- | Make the supplied HTTP request, expecting an HTTP response with a Lazy ByteString body to be delivered in some @MonadDormouseTest m@+  expectLbs :: HttpRequest scheme method LB.ByteString contentTag acceptTag -> m (HttpResponse LB.ByteString)+  expectLbs req = do+    resp <- expectBs $ req {requestBody = LB.toStrict $ requestBody req}+    return $ resp {responseBody = LB.fromStrict $ responseBody resp}+  -- | Make the supplied HTTP request, expecting an HTTP response with a Strict ByteString body to be delivered in some @MonadDormouseTest m@+  expectBs :: HttpRequest scheme method SB.ByteString contentTag acceptTag -> m (HttpResponse SB.ByteString)+  expectBs req = do+    resp <- expectLbs $ req {requestBody = LB.fromStrict $ requestBody req}+    return $ resp {responseBody = LB.toStrict $ responseBody resp}+  {-# MINIMAL expectLbs | expectBs #-}++instance (Monad m, MonadIO m, MonadDormouseTestClient m) => MonadDormouseClient m where+  send req deserialiseResp = do+    reqBody <- liftIO . S.fold SEB.write . extricateRequestStream . requestBody $ req+    let reqBs = req {requestBody = reqBody}+    respBs <- expectBs reqBs+    let respStream = S.unfold SEBL.read . LB.fromStrict $ responseBody respBs+    liftIO $ deserialiseResp $ respBs { responseBody = respStream }+    where +      extricateRequestStream :: RawRequestPayload -> SerialT IO Word8+      extricateRequestStream (DefinedContentLength _ s) = s+      extricateRequestStream (ChunkedTransfer s) = s+

@@ -0,0 +1,64 @@++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}++module Dormouse.Client.Types+  ( HttpRequest(..)+  , HttpResponse(..)+  ) where++import Dormouse.Client.Headers+import Dormouse.Client.Methods+import qualified Data.ByteString as SB+import qualified Data.Map.Strict as Map++-- | Model of an HTTP request with type parameters: @scheme@ describing the uri scheme, @body@ describing the type of the content body, @contentTag@ describing the type, @method@+-- describing the HTTP verb associated with the request, @contentTag@ describing the type of content being sen and @acceptTag@ describing the type of content desired+data HttpRequest url method body contentTag acceptTag = HttpRequest +  { requestMethod :: !(HttpMethod method)+  , requestUrl :: !url+  , requestHeaders :: Map.Map HeaderName SB.ByteString+  , requestBody :: body+  }++instance (Eq body, Eq url) => Eq (HttpRequest url method body contentTag acceptTag) where+  (==) (HttpRequest { requestMethod = rm1, requestUrl = ru1, requestHeaders = rh1, requestBody = rb1 }) (HttpRequest { requestMethod = rm2, requestUrl = ru2, requestHeaders = rh2, requestBody = rb2 }) =+    rm1 == rm2 && ru1 == ru2 && rh1 == rh2 && rb1 == rb2++instance (Show body, Show url) => Show (HttpRequest url method body contentTag acceptTag) where+  show (HttpRequest { requestMethod = rm, requestUrl = ru, requestHeaders = rh, requestBody = rb }) = +    unlines+        [ "HttpRequest"+        , "{ requestMethod  = " ++ show rm+        , ", requestUri     = " ++ show ru+        , ", requestHeaders = " ++ show rh+        , ", requestBody    = " ++ show rb+        , "}"+        ]++instance HasHeaders (HttpRequest url method body contentTag acceptTag) where+  getHeaders = requestHeaders+  getHeaderValue key = Map.lookup key . requestHeaders++-- | Model of an HTTP response with the type parameter @body@ describing the type of the content body.+data HttpResponse body = HttpResponse+  { responseStatusCode :: !Int+  , responseHeaders :: Map.Map HeaderName SB.ByteString+  , responseBody :: body+  } deriving (Eq)++instance Show body => Show (HttpResponse body) where+  show (HttpResponse { responseStatusCode = rsc, responseHeaders = rh, responseBody = rb }) = +    unlines+        [ "HttpResponse"+        , "{ responseStatusCode = " ++ show rsc+        , ", responseHeaders    = " ++ show rh+        , ", responseBody       = " ++ show rb+        , "}"+        ]++instance HasHeaders (HttpResponse b) where+  getHeaders = responseHeaders+  getHeaderValue key = Map.lookup key . responseHeaders

@@ -0,0 +1,52 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Dormouse.Client.Generators.Json +  ( genJsonValue+  , JsonGenRanges(..)+  )+  where++import qualified Data.Aeson as A+import qualified Data.Scientific as S+import qualified Data.Vector as V+import Hedgehog+import qualified Hedgehog.Gen as Gen++data JsonGenRanges = JsonGenRanges +  { stringRanges :: Range Int+  , doubleRanges :: Range Double+  , arrayLenRanges :: Range Int+  }++genJsonNull :: Gen A.Value+genJsonNull = pure A.Null++genJsonString :: Range Int -> Gen A.Value+genJsonString sr = fmap A.String $ Gen.text sr Gen.unicode++genJsonBool :: Gen A.Value+genJsonBool = fmap A.Bool Gen.bool++genJsonNumber :: Range Double -> Gen A.Value+genJsonNumber r = fmap (A.Number . S.fromFloatDigits) $ Gen.double r++genJsonArray :: JsonGenRanges -> Gen A.Value+genJsonArray ranges = fmap (A.Array . V.fromList) $ Gen.list ar gen+  where+    gen = Gen.recursive Gen.choice [genJsonBool, genJsonNumber nr, genJsonString sr] [genJsonValue ranges, genJsonObject ranges]+    nr = doubleRanges ranges+    sr = stringRanges ranges+    ar = arrayLenRanges ranges++genJsonObject :: JsonGenRanges -> Gen A.Value+genJsonObject ranges =  fmap A.object $ Gen.list ar genNameValue+  where+    genNameValue = do+      name <- Gen.text sr Gen.unicode+      value <- genJsonValue ranges+      return (name, value)+    sr = stringRanges ranges+    ar = arrayLenRanges ranges++genJsonValue :: JsonGenRanges -> Gen A.Value+genJsonValue ranges = Gen.choice [genJsonNull, genJsonString (stringRanges ranges), genJsonBool, genJsonNumber (doubleRanges ranges), genJsonArray ranges, genJsonObject ranges]

@@ -0,0 +1,246 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Dormouse.Client.Generators.UriComponents +  ( genValidScheme+  , genInvalidScheme+  , genValidUsername+  , genInvalidUsername+  , genValidPassword+  , genInvalidPassword+  , genValidUserInfo+  , genInvalidUserInfo+  , genValidIPv4+  , genValidRegName+  , genValidHost+  , genValidPort+  , genValidAuthority+  , genValidPathAbsAuth+  , genValidPathAbsNoAuth+  , genValidPathRel+  , genValidQuery+  , genValidFragment+  , genValidAbsoluteUri+  )+  where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.Char as C+import qualified Data.Text as T+import Dormouse.Uri.Encode+import Dormouse.Uri.RFC3986+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++genPercentEncoded :: Gen B.ByteString+genPercentEncoded = do+  char <- Gen.filter C.isPrint Gen.unicode+  let t = T.pack $ [char]+  let percentEncoded = encodeUnless (const False) t+  return $ percentEncoded++genValidScheme :: Gen B.ByteString+genValidScheme = do+  first <- Gen.filter isAsciiAlpha Gen.ascii+  bs <- Gen.list (Range.constant 0 10) (Gen.filter isSchemeChar Gen.ascii)+  return . B8.pack $ (first : bs ++ [':'])++data SchemeFailureMode +  = NonAsciiFirstChar+  | InvalidSchemeChar+  | NoTrailingSemicolon++schemeFailureMode :: Int -> SchemeFailureMode+schemeFailureMode 1 = NonAsciiFirstChar+schemeFailureMode 2 = InvalidSchemeChar+schemeFailureMode 3 = NoTrailingSemicolon+schemeFailureMode _ = undefined++genInvalidScheme :: Gen B.ByteString+genInvalidScheme = do+  failureMode <- fmap schemeFailureMode $ Gen.element [1..3]+  first <- case failureMode of+    NonAsciiFirstChar -> Gen.filter (not . isAsciiAlpha) Gen.ascii+    _                 -> Gen.filter isAsciiAlpha Gen.ascii+  remainder <- case failureMode of+    InvalidSchemeChar -> do+      let c = Gen.filter (\x -> (not $ isSchemeChar x) && x /= ':') Gen.ascii+      Gen.list (Range.constant 1 10) c+    _ -> do+      let c = Gen.filter isSchemeChar Gen.ascii+      Gen.list (Range.constant 0 10) c+  let finalBs = case failureMode of+        NoTrailingSemicolon -> first : remainder+        _                   -> first : remainder ++ [':']+  return $ B8.pack finalBs++genUsernameChar :: Gen B.ByteString+genUsernameChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isUsernameChar Gen.ascii)]++genValidUsername :: Gen B.ByteString+genValidUsername = do+  list <- Gen.list (Range.constant 1 20) genUsernameChar+  return $ B.intercalate "" list++genInvalidUsername :: Gen B.ByteString+genInvalidUsername = do+  invalids <- Gen.list (Range.constant 1 5) genInvalidUsernameChar+  valids <- Gen.list (Range.constant 0 15) genUsernameChar+  fmap (B.intercalate "") $ Gen.shuffle $ invalids ++ valids+  where+    genInvalidUsernameChar = fmap (B8.pack . return) $ Gen.filter (\x -> (not $ isUsernameChar x) && x /= '%'  && C.isPrint x) Gen.ascii++genPasswordChar :: Gen B.ByteString+genPasswordChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isPasswordChar Gen.ascii)]++genValidPassword :: Gen B.ByteString+genValidPassword = do+  list <- Gen.list (Range.constant 1 20) genPasswordChar+  return $ B.intercalate "" list++genInvalidPassword :: Gen B.ByteString+genInvalidPassword = do+  invalids <- Gen.list (Range.constant 1 5) genInvalidPasswordChar+  valids <- Gen.list (Range.constant 0 15) genPasswordChar+  fmap (B.intercalate "") $ Gen.shuffle $ invalids ++ valids+  where+    genInvalidPasswordChar = fmap (B8.pack . return) $ Gen.filter (\x -> (not $ isPasswordChar x) && x /= '%' && C.isPrint x) Gen.ascii++genValidUserInfo :: Gen B.ByteString+genValidUserInfo = do+  username <- genValidUsername+  maybePassword <- Gen.maybe genValidPassword+  let passwordSuffix = maybe B.empty (B.cons $ c2w ':') maybePassword+  return $ B.append (B.append username passwordSuffix) "@"++data UserInfoFailureMode +  = InvalidUsername+  | InvalidPassword+  | MissingAtSuffix++userInfoFailureMode :: Int -> UserInfoFailureMode+userInfoFailureMode 1 = InvalidUsername+userInfoFailureMode 2 = InvalidPassword+userInfoFailureMode 3 = MissingAtSuffix+userInfoFailureMode _ = undefined++genInvalidUserInfo :: Gen B.ByteString+genInvalidUserInfo = do+  failureMode <- fmap userInfoFailureMode $ Gen.element [1..3]+  username <- case failureMode of+    InvalidUsername -> Gen.filter (B.all (\x -> w2c x /= ':')) genInvalidUsername -- if the username is supposed to be invalid, ensure that ':' is not present, otherwise the user info could be interpreted as valid if valid chars precede the ':'+    _               -> genValidUsername+  maybePassword <- case failureMode of +    InvalidPassword -> fmap Just genInvalidPassword+    _               -> Gen.maybe $ genValidPassword+  let passwordSuffix = maybe B.empty (B.cons $ c2w ':') maybePassword+  let complete = case failureMode of+        MissingAtSuffix -> B.append (B.append username passwordSuffix) "#"+        _               -> B.append (B.append username passwordSuffix) "@"+  return complete++genValidIPv4 :: Gen B.ByteString+genValidIPv4 = do+  ipChars <- (\a b c d -> show a <> "." <> show b <> "." <> show c <> "." <> show d) <$> genOctet <*> genOctet <*> genOctet <*> genOctet+  return $ B8.pack ipChars+  where+    genOctet = Gen.word8 Range.constantBounded++genValidRegName :: Gen B.ByteString+genValidRegName = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isRegNameChar Gen.ascii)]++genValidHost :: Gen B.ByteString+genValidHost = Gen.choice [genValidIPv4, genValidRegName]++genValidPort :: Gen B.ByteString+genValidPort = fmap (B.append ":" . B8.pack . show) $ Gen.word16 Range.constantBounded++genValidAuthority :: Gen B.ByteString+genValidAuthority = do+  maybeUserInfo <- Gen.maybe genValidUserInfo+  let userInfoPrefix = maybe B.empty id maybeUserInfo+  host <- genValidHost+  maybePort <- Gen.maybe genValidPort+  let portSuffix = maybe B.empty id maybePort+  return . B.append "//" . B.append userInfoPrefix $ B.append host portSuffix++genPathChar :: Gen B.ByteString+genPathChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isPathChar Gen.ascii)]++genPathSegment :: Gen B.ByteString+genPathSegment = fmap (B.intercalate "") $ Gen.list (Range.constant 0 20) genPathChar++genPathSegmentNz :: Gen B.ByteString+genPathSegmentNz = fmap (B.intercalate "") $ Gen.list (Range.constant 1 20) genPathChar++genPathCharNc :: Gen B.ByteString+genPathCharNc = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isPathCharNoColon Gen.ascii)]++genPathSegmentNzNc :: Gen B.ByteString+genPathSegmentNzNc = fmap (B.intercalate "") $ Gen.list (Range.constant 1 20) genPathCharNc++genPathsAbEmpty :: Gen B.ByteString+genPathsAbEmpty = do+  components <- Gen.list (Range.constant 1 10) genPathSegment+  return . B.append "/" $ B.intercalate "/" components++genPathsAbsolute :: Gen B.ByteString+genPathsAbsolute = do+  first <- genPathSegmentNz+  components <- Gen.list (Range.constant 0 10) genPathSegment+  return . B.append "/" . B.append first $ B.intercalate "/" components++genPathsNoScheme :: Gen B.ByteString+genPathsNoScheme = do+  first <- genPathSegmentNzNc+  components <- Gen.list (Range.constant 0 10) genPathSegment+  return . B.append first . B.append "/" $ B.intercalate "/" components++genPathsRootless :: Gen B.ByteString+genPathsRootless = do+  first <- genPathSegmentNz+  components <- Gen.list (Range.constant 0 10) genPathSegment+  return . B.append first . B.append "/" $ B.intercalate "/" components++genValidPathsEmpty :: Gen B.ByteString+genValidPathsEmpty = return B.empty++genValidPathAbsAuth :: Gen B.ByteString+genValidPathAbsAuth = Gen.choice [genPathsAbEmpty, genPathsAbsolute, genValidPathsEmpty]++genValidPathAbsNoAuth :: Gen B.ByteString+genValidPathAbsNoAuth = Gen.choice [genPathsAbsolute, genPathsRootless, genValidPathsEmpty]++genValidPathRel :: Gen B.ByteString+genValidPathRel = Gen.choice [genPathsAbsolute, genPathsNoScheme, genValidPathsEmpty]++genQueryChar :: Gen B.ByteString+genQueryChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isQueryChar Gen.ascii)]++genValidQuery :: Gen B.ByteString+genValidQuery = do+  list <- Gen.list (Range.constant 1 50) genQueryChar+  return $ B.append "?" $ B.intercalate "" list++genFragmentChar :: Gen B.ByteString+genFragmentChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isFragmentChar Gen.ascii)]++genValidFragment :: Gen B.ByteString+genValidFragment = do+  list <- Gen.list (Range.constant 1 50) genFragmentChar+  return $ B.append "#" $ B.intercalate "" list++genValidAbsoluteUri :: Gen B.ByteString+genValidAbsoluteUri = do+  scheme <- genValidScheme+  authority <- Gen.maybe genValidAuthority+  path <- case authority of+    Just _  -> genValidPathAbsAuth+    Nothing -> genValidPathAbsNoAuth+  query <- Gen.maybe genValidQuery+  fragment <- Gen.maybe genValidFragment+  return . B.intercalate "" $ [scheme, maybe B.empty id authority, path, maybe B.empty id query, maybe B.empty id fragment]++

@@ -0,0 +1,29 @@+module Dormouse.Client.Headers.MediaTypeSpec+  ( spec+  ) where++import Data.CaseInsensitive (mk)+import qualified Data.Map.Strict as Map+import Dormouse.Client.Headers.MediaType+import Test.Hspec++spec :: Spec+spec = do+  describe "parseMediaType" $ do+    it "parses application/json media type correctly" $ do+      mediaType <- parseMediaType "application/json"+      mediaType `shouldBe` applicationJson+    it "parses application/x-www-form-urlencoded" $ do+      mediaType <- parseMediaType "application/x-www-form-urlencoded"+      mediaType `shouldBe` applicationXWWWFormUrlEncoded+    it "parses text/html" $ do+      mediaType <- parseMediaType "text/html"+      mediaType `shouldBe` textHtml+  describe "mediaTypeAsByteString" $ do+    it "creates correct ByteString for applicationJson" $ do+      encodeMediaType applicationJson `shouldBe` "application/json"+    it "creates correct ByteString for applicationXWWWFormUrlEncoded" $ do+      encodeMediaType applicationXWWWFormUrlEncoded `shouldBe` "application/x-www-form-urlencoded"+    it "creates correct ByteString for textHtml" $ do+      encodeMediaType textHtml `shouldBe` "text/html"+  

@@ -0,0 +1,22 @@+module Dormouse.Client.StatusSpec+  ( spec+  ) where++import Test.Hspec+import Dormouse.Client.Status++spec :: Spec+spec = do+  describe "Successful" $ do+    it "matches a status code of 200" $+      let wasSuccess = +            case 200 of+              Successful -> True+              _ -> False in+      wasSuccess `shouldBe` True+    it "does not match a status code of 400" $+      let wasSuccess = +            case 400 of+              Successful -> True+              _ -> False in+      wasSuccess `shouldBe` False

@@ -0,0 +1,60 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}++module Dormouse.Client.UrlReqSpec+  ( spec+  ) where++import Test.Hspec+import Dormouse.Url+import Dormouse.Url.QQ+import Dormouse.Client.MonadIOImpl+import qualified Network.HTTP.Client as C++spec :: Spec+spec = do+  describe "genClientRequestFromUrlComponents" $ do+    it "generates a non-secure request for an http uri" $ do+      let anyUrl = asAnyUrl [http|http://google.com|]+          req = genClientRequestFromUrlComponents anyUrl+      C.secure req `shouldBe` False+    it "generates a secure request for an https uri" $ do+      let anyUrl = asAnyUrl [https|https://google.com|]+          req = genClientRequestFromUrlComponents anyUrl+      C.secure req `shouldBe` True+    it "generates a non-secure request with the correct host" $ do+      let anyUrl = asAnyUrl [http|http://google.com|]+          req = genClientRequestFromUrlComponents anyUrl+      C.host req `shouldBe` "google.com"+    it "generates a request on port 80 for an http uri with no provided port" $ do+      let anyUrl = asAnyUrl [http|http://google.com|]+          req = genClientRequestFromUrlComponents anyUrl+      C.port req `shouldBe` 80+    it "generates a request on the supplied port for an http uri with a provided port" $ do+      let anyUrl = asAnyUrl [http|http://google.com:8080|]+          req = genClientRequestFromUrlComponents anyUrl+      C.port req `shouldBe` 8080+    it "generates a request on port 443 for an https uri with no provided port" $ do+      let anyUrl = asAnyUrl [https|https://google.com|]+          req = genClientRequestFromUrlComponents anyUrl+      C.port req `shouldBe` 443+    it "generates a request on the supplied port for an https uri with a provided port" $ do+      let anyUrl = asAnyUrl [https|https://google.com:8443|]+          req = genClientRequestFromUrlComponents anyUrl+      C.port req `shouldBe` 8443+    it "generates a request with the correct path (simple)" $ do+      let anyUrl = asAnyUrl [https|https://google.com/my/path/is/great|]+          req = genClientRequestFromUrlComponents anyUrl+      C.path req `shouldBe` "/my/path/is/great"+    it "generates a request with the correct path (unicode)" $ do+      let anyUrl = asAnyUrl [https|https://google.com/my/path/is/great%F0%9F%98%88|]+          req = genClientRequestFromUrlComponents anyUrl+      C.path req `shouldBe` "/my/path/is/great%F0%9F%98%88"+    it "generates a request with the correct query params (simple)" $ do+      let anyUrl = asAnyUrl [https|https://google.com?test=abc|]+          req = genClientRequestFromUrlComponents anyUrl+      C.queryString req `shouldBe` "?test=abc"+    it "generates a request with the correct query params (unicode)" $ do+      let anyUrl = asAnyUrl [https|https://google.com?test=%F0%9F%98%80|]+          req = genClientRequestFromUrlComponents anyUrl+      C.queryString req `shouldBe` "?test=%F0%9F%98%80"

@@ -0,0 +1,118 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Dormouse.ClientSpec +  ( spec+  ) where++import Control.Concurrent.MVar+import Control.Exception.Safe (MonadThrow)+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Aeson (encode, Value)+import qualified Data.Map.Strict as Map+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Dormouse.Client+import Dormouse.Client.Test.Class+import Dormouse.Url.QQ+import Dormouse.Client.Generators.Json+import Test.Hspec+import Test.Hspec.Hedgehog++import qualified Hedgehog.Range as Range++data TestEnv = TestEnv +  { sentJson :: MVar (Maybe (LB.ByteString))+  , sentContentType :: MVar (Maybe B.ByteString)+  , sentAcceptHeader :: MVar (Maybe B.ByteString)+  , returnJson :: MVar (Maybe (LB.ByteString))+  }++newtype TestM a = TestM { unTestM :: ReaderT TestEnv IO a } deriving (Functor, Applicative, Monad, MonadReader TestEnv, MonadIO, MonadThrow)++runTestM :: TestEnv -> TestM a -> IO a+runTestM deps app = flip runReaderT deps $ unTestM app++instance MonadDormouseTestClient TestM where+  expectLbs req = do+    testEnv <- ask+    _ <- liftIO . swapMVar (sentJson testEnv) . Just $ requestBody req+    _ <- liftIO . swapMVar (sentContentType testEnv) . getHeaderValue "Content-Type" $ req+    _ <- liftIO . swapMVar (sentAcceptHeader testEnv) . getHeaderValue "Accept" $ req+    maybeResponseJson <- liftIO . readMVar $ returnJson testEnv+    let respBs = maybe (encode ()) id $ maybeResponseJson+    pure HttpResponse+      { responseStatusCode = 200+      , responseHeaders = Map.empty+      , responseBody = respBs+      }++spec :: Spec+spec = before setup $ do+  describe "expect" $ do+    it "submits the correct json body, content-type and accept header for a json request" $ \(sentJson', sentContentType', sentAcceptHeader', _, testEnv, jsonGenRanges) -> do+      hedgehog $ do+        arbJson <- forAll . genJsonValue $ jsonGenRanges+        let req = accept noPayload $ supplyBody json arbJson $ post [https|https://testing123.com|]+        _ :: HttpResponse Empty <- liftIO $ runTestM testEnv $ expect req+        lbs <- liftIO $ readMVar sentJson'+        actualContentType <- liftIO $ readMVar sentContentType'+        actualAcceptHeader <- liftIO $ readMVar sentAcceptHeader'+        let expected = encode arbJson+        lbs === (Just expected)+        actualContentType === Just "application/json"+        actualAcceptHeader === Nothing+    it "submits the correct accept header and gets the correct json body for a json response" $ \(_, _, sentAcceptHeader', returnJson', testEnv, jsonGenRanges) -> do+      hedgehog $ do+        arbJson <- forAll . genJsonValue $ jsonGenRanges+        _ <- liftIO $ swapMVar returnJson' $ Just (encode arbJson)+        let req = accept json $ supplyBody json () $ post [https|https://testing123.com|]+        r :: HttpResponse Value <- liftIO $ runTestM testEnv $ expect req+        actualAcceptHeader <- liftIO $ readMVar sentAcceptHeader'+        let actualJson = responseBody r+        actualJson === arbJson+        actualAcceptHeader === Just "application/json"+  describe "expectAs" $ do+    it "submits the correct json body, content-type and accept header for a json request" $ \(sentJson', sentContentType', sentAcceptHeader', _, testEnv, jsonGenRanges) -> do+      hedgehog $ do+        arbJson <- forAll . genJsonValue $ jsonGenRanges+        let req = supplyBody json arbJson $ post [https|https://testing123.com|]+        _ :: HttpResponse Empty <- liftIO $ runTestM testEnv $ expectAs noPayload req+        lbs <- liftIO $ readMVar sentJson'+        actualContentType <- liftIO $ readMVar sentContentType'+        actualAcceptHeader <- liftIO $ readMVar sentAcceptHeader'+        let expected = encode arbJson+        lbs === (Just expected)+        actualContentType === (Just "application/json")+        actualAcceptHeader === Nothing+    it "submits the correct accept header and gets the correct json body for a json response" $ \(_, _, sentAcceptHeader', returnJson', testEnv, jsonGenRanges) -> do+      hedgehog $ do+        arbJson <- forAll . genJsonValue $ jsonGenRanges+        _ <- liftIO $ swapMVar returnJson' $ Just (encode arbJson)+        let req = supplyBody json () $ post [https|https://testing123.com|]+        r :: HttpResponse Value <- liftIO $ runTestM testEnv $ expectAs json req+        actualAcceptHeader <- liftIO $ readMVar sentAcceptHeader'+        let actualJson = responseBody r+        actualJson === arbJson+        actualAcceptHeader === Nothing+  where +    setup = do+      sentJson' <- newMVar Nothing+      sentContentType' <- newMVar Nothing+      sentAcceptHeader' <- newMVar Nothing+      returnJson' <- newMVar Nothing+      let testEnv = TestEnv +            { sentJson = sentJson'+            , sentContentType = sentContentType'+            , sentAcceptHeader = sentAcceptHeader'+            , returnJson = returnJson'+            }+      let jsonGenRanges = JsonGenRanges +            { stringRanges = Range.constant 0 15+            , doubleRanges = Range.constant (-100000) (1000000)+            , arrayLenRanges = Range.constant 0 7+            }+      return (sentJson', sentContentType', sentAcceptHeader', returnJson', testEnv, jsonGenRanges)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}