diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for dormouse + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` diff --git a/dormouse-client.cabal b/dormouse-client.cabal new file mode 100644 --- /dev/null +++ b/dormouse-client.cabal @@ -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 diff --git a/src/Dormouse/Client.hs b/src/Dormouse/Client.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client.hs @@ -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: +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 diff --git a/src/Dormouse/Client/Class.hs b/src/Dormouse/Client/Class.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/Class.hs @@ -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) diff --git a/src/Dormouse/Client/Data.hs b/src/Dormouse/Client/Data.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/Data.hs @@ -0,0 +1,5 @@ +module Dormouse.Client.Data + ( Empty(..) + ) where + +data Empty = Empty diff --git a/src/Dormouse/Client/Exception.hs b/src/Dormouse/Client/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/Exception.hs @@ -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 + + diff --git a/src/Dormouse/Client/Headers.hs b/src/Dormouse/Client/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/Headers.hs @@ -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 + diff --git a/src/Dormouse/Client/Headers/MediaType.hs b/src/Dormouse/Client/Headers/MediaType.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/Headers/MediaType.hs @@ -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) + + diff --git a/src/Dormouse/Client/Methods.hs b/src/Dormouse/Client/Methods.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/Methods.hs @@ -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 diff --git a/src/Dormouse/Client/MonadIOImpl.hs b/src/Dormouse/Client/MonadIOImpl.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/MonadIOImpl.hs @@ -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) diff --git a/src/Dormouse/Client/Payload.hs b/src/Dormouse/Client/Payload.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/Payload.hs @@ -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 diff --git a/src/Dormouse/Client/Status.hs b/src/Dormouse/Client/Status.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/Status.hs @@ -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) + + diff --git a/src/Dormouse/Client/Test/Class.hs b/src/Dormouse/Client/Test/Class.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/Test/Class.hs @@ -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 + diff --git a/src/Dormouse/Client/Types.hs b/src/Dormouse/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Dormouse/Client/Types.hs @@ -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 diff --git a/test/Dormouse/Client/Generators/Json.hs b/test/Dormouse/Client/Generators/Json.hs new file mode 100644 --- /dev/null +++ b/test/Dormouse/Client/Generators/Json.hs @@ -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] diff --git a/test/Dormouse/Client/Generators/UriComponents.hs b/test/Dormouse/Client/Generators/UriComponents.hs new file mode 100644 --- /dev/null +++ b/test/Dormouse/Client/Generators/UriComponents.hs @@ -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] + + diff --git a/test/Dormouse/Client/Headers/MediaTypeSpec.hs b/test/Dormouse/Client/Headers/MediaTypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dormouse/Client/Headers/MediaTypeSpec.hs @@ -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" + diff --git a/test/Dormouse/Client/StatusSpec.hs b/test/Dormouse/Client/StatusSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dormouse/Client/StatusSpec.hs @@ -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 diff --git a/test/Dormouse/Client/UrlReqSpec.hs b/test/Dormouse/Client/UrlReqSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dormouse/Client/UrlReqSpec.hs @@ -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" diff --git a/test/Dormouse/ClientSpec.hs b/test/Dormouse/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dormouse/ClientSpec.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}