nri-http (empty) → 0.1.0.0
raw patch · 8 files changed
+1024/−0 lines, 8 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, conduit, http-client, http-client-tls, http-types, mime-types, network-uri, nri-observability, nri-prelude, safe-exceptions, text, wai, warp
Files
- LICENSE +29/−0
- README.md +5/−0
- nri-http.cabal +116/−0
- src/Http.hs +356/−0
- src/Http/Internal.hs +73/−0
- src/Http/Mock.hs +166/−0
- test/Main.hs +230/−0
- test/golden-results/expected-http-span +49/−0
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2021, NoRedInk+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 the copyright holder nor the names of its+ 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 HOLDER 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.
+ README.md view
@@ -0,0 +1,5 @@+# Http++Making HTTP requests using an API inspired by Elm's [elm/http][].++[elm/http]: https://package.elm-lang.org/packages/elm/http/latest/
+ nri-http.cabal view
@@ -0,0 +1,116 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: nri-http+version: 0.1.0.0+synopsis: Make Elm style HTTP requests+description: Please see the README at <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-http#readme>.+category: Web+homepage: https://github.com/NoRedInk/haskell-libraries#readme+bug-reports: https://github.com/NoRedInk/haskell-libraries/issues+author: NoRedInk+maintainer: haskell-open-source@noredink.com+copyright: 2021 NoRedInk Corp.+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ LICENSE+ test/golden-results/expected-http-span++source-repository head+ type: git+ location: https://github.com/NoRedInk/haskell-libraries+ subdir: nri-http++library+ exposed-modules:+ Http+ Http.Mock+ other-modules:+ Http.Internal+ Paths_nri_http+ hs-source-dirs:+ src+ default-extensions:+ DataKinds+ DeriveGeneric+ FlexibleContexts+ FlexibleInstances+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedStrings+ PartialTypeSignatures+ ScopedTypeVariables+ Strict+ TypeOperators+ ExtendedDefaultRules+ NumericUnderscores+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin+ build-depends:+ aeson >=1.4.6.0 && <1.6+ , base >=4.12.0.0 && <4.16+ , bytestring >=0.10.8.2 && <0.12+ , conduit >=1.3.0 && <1.4+ , http-client >=0.6.0 && <0.8+ , http-client-tls >=0.3.0 && <0.4+ , http-types ==0.12.*+ , mime-types >=0.1.0.0 && <0.2+ , network-uri >=2.6.0.0 && <2.7+ , nri-observability >=0.1.0.0 && <0.2+ , nri-prelude >=0.1.0.0 && <0.7+ , safe-exceptions >=0.1.7.0 && <1.3+ , text >=1.2.3.1 && <1.3+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Http+ Http.Internal+ Http.Mock+ Paths_nri_http+ hs-source-dirs:+ src+ test+ default-extensions:+ DataKinds+ DeriveGeneric+ FlexibleContexts+ FlexibleInstances+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedStrings+ PartialTypeSignatures+ ScopedTypeVariables+ Strict+ TypeOperators+ ExtendedDefaultRules+ NumericUnderscores+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin -fno-warn-type-defaults+ build-depends:+ aeson >=1.4.6.0 && <1.6+ , base >=4.12.0.0 && <4.16+ , bytestring >=0.10.8.2 && <0.12+ , conduit >=1.3.0 && <1.4+ , http-client >=0.6.0 && <0.8+ , http-client-tls >=0.3.0 && <0.4+ , http-types ==0.12.*+ , mime-types >=0.1.0.0 && <0.2+ , network-uri >=2.6.0.0 && <2.7+ , nri-observability >=0.1.0.0 && <0.2+ , nri-prelude >=0.1.0.0 && <0.7+ , safe-exceptions >=0.1.7.0 && <1.3+ , text >=1.2.3.1 && <1.3+ , wai >=3.2.0 && <3.3+ , warp >=3.3.0 && <3.4+ default-language: Haskell2010
+ src/Http.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++-- | Making HTTP requests using an API inspired by Elm's elm/http.+module Http+ ( -- * Handlers+ Handler,+ handler,++ -- * Requests+ get,+ post,+ request,+ Internal.Request (..),+ Internal.Error (..),++ -- * Header,+ Internal.Header,+ header,++ -- * Body+ Internal.Body,+ emptyBody,+ stringBody,+ jsonBody,+ bytesBody,++ -- * Expect+ Expect,+ expectJson,+ expectText,+ expectWhatever,++ -- * Use with external libraries+ withThirdParty,+ withThirdPartyIO,+ )+where++import qualified Conduit+import qualified Control.Exception.Safe as Exception+import Control.Monad.IO.Class (liftIO)+import qualified Data.Aeson as Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy+import qualified Data.Dynamic as Dynamic+import Data.String (fromString)+import qualified Data.Text.Encoding+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Encoding+import Http.Internal (Body, Expect, Handler)+import qualified Http.Internal as Internal+import qualified Log.HttpRequest as HttpRequest+import qualified Maybe+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.Internal as HTTP.Internal+import qualified Network.HTTP.Client.TLS as TLS+import qualified Network.HTTP.Types.Status as Status+import qualified Network.URI+import qualified Platform+import qualified Task+import Prelude (Either (Left, Right), IO, fromIntegral, pure, show)++-- | Create a 'Handler' for making HTTP requests.+handler :: Conduit.Acquire Handler+handler = do+ doAnything <- liftIO Platform.doAnythingHandler+ manager <- TLS.newTlsManager+ pure+ <| Internal.Handler+ (_request doAnything manager)+ (_withThirdParty manager)+ (_withThirdPartyIO manager)++-- | Third party libraries that make HTTP requests often take a 'HTTP.Manager'.+-- This helper allows us to call such a library using a 'Handler'.+--+-- The benefit over using this over using a separate 'HTTP.Manager' for the+-- external library, is that 'withThirdParty' will ensure HTTP requests made+-- by the external library will get logged.+withThirdParty :: Handler -> (HTTP.Manager -> Task e a) -> Task e a+withThirdParty Internal.Handler {Internal.handlerWithThirdParty = wtp} library =+ wtp library++_withThirdParty :: HTTP.Manager -> (HTTP.Manager -> Task e a) -> Task e a+_withThirdParty manager library = do+ requestManager <- prepareManagerForRequest manager+ library requestManager++-- | Like `withThirdParty`, but runs in `IO`.+withThirdPartyIO :: Platform.LogHandler -> Handler -> (HTTP.Manager -> IO a) -> IO a+withThirdPartyIO log Internal.Handler {Internal.handlerWithThirdPartyIO = wtp} library =+ wtp log library++_withThirdPartyIO :: HTTP.Manager -> Platform.LogHandler -> (HTTP.Manager -> IO a) -> IO a+_withThirdPartyIO manager log library = do+ requestManager <- prepareManagerForRequest manager |> Task.perform log+ library requestManager++-- QUICKS++-- | Create a @GET@ request.+get :: Dynamic.Typeable a => Handler -> Text -> Expect a -> Task Error a+get handler' url expect =+ request+ handler'+ Internal.Request+ { Internal.method = "GET",+ Internal.headers = [],+ Internal.url = url,+ Internal.body = emptyBody,+ Internal.timeout = Nothing,+ Internal.expect = expect+ }++-- | Create a @POST@ request.+post :: Dynamic.Typeable a => Handler -> Text -> Body -> Expect a -> Task Error a+post handler' url body expect =+ request+ handler'+ Internal.Request+ { Internal.method = "POST",+ Internal.headers = [],+ Internal.url = url,+ Internal.body = body,+ Internal.timeout = Nothing,+ Internal.expect = expect+ }++-- REQUEST++-- | Create a 'Header'.+header :: Text -> Text -> Internal.Header+header key val =+ Internal.Header+ (fromString (Text.toList key), fromString (Text.toList val))++-- | Create an empty body for your Request. This is useful for GET requests and+-- POST requests where you are not sending any data.+emptyBody :: Body+emptyBody =+ Internal.Body+ { Internal.bodyContents = "",+ Internal.bodyContentType = Nothing+ }++-- | Put some string in the body of your Request.+--+-- The first argument is a MIME type of the body. Some servers are strict about+-- this!+stringBody :: Text -> Text -> Body+stringBody mimeType text =+ Internal.Body+ { Internal.bodyContents = Data.Text.Encoding.encodeUtf8 text |> Data.ByteString.Lazy.fromStrict,+ Internal.bodyContentType = Just (Data.Text.Encoding.encodeUtf8 mimeType)+ }++-- | Put some JSON value in the body of your Request. This will automatically+-- add the Content-Type: application/json header.+jsonBody :: Aeson.ToJSON body => body -> Body+jsonBody json =+ Internal.Body+ { Internal.bodyContents = Aeson.encode json,+ Internal.bodyContentType = Just "application/json"+ }++-- | Put some Bytes in the body of your Request. This allows you to use+-- ByteString to have full control over the binary representation of the data+-- you are sending.+--+-- The first argument is a MIME type of the body. In other scenarios you may+-- want to use MIME types like image/png or image/jpeg instead.+bytesBody :: Text -> ByteString -> Body+bytesBody mimeType bytes =+ Internal.Body+ { Internal.bodyContents = Data.ByteString.Lazy.fromStrict bytes,+ Internal.bodyContentType = Just (Data.Text.Encoding.encodeUtf8 mimeType)+ }++-- | Create a custom request.+request ::+ Dynamic.Typeable expect =>+ Handler ->+ Internal.Request expect ->+ Task Error expect+request Internal.Handler {Internal.handlerRequest} settings = handlerRequest settings++_request :: Platform.DoAnythingHandler -> HTTP.Manager -> Internal.Request expect -> Task Error expect+_request doAnythingHandler manager settings = do+ requestManager <- prepareManagerForRequest manager+ Platform.doAnything doAnythingHandler <| do+ response <-+ Exception.try <| do+ basicRequest <-+ HTTP.parseUrlThrow <| Text.toList (Internal.url settings)+ let finalRequest =+ basicRequest+ { HTTP.method = Data.Text.Encoding.encodeUtf8 (Internal.method settings),+ HTTP.requestHeaders = case Internal.bodyContentType (Internal.body settings) of+ Nothing ->+ Internal.headers settings+ |> List.map Internal.unHeader+ Just mimeType ->+ ("content-type", mimeType) :+ List.map Internal.unHeader (Internal.headers settings),+ HTTP.requestBody = HTTP.RequestBodyLBS <| Internal.bodyContents (Internal.body settings),+ HTTP.responseTimeout =+ Internal.timeout settings+ |> Maybe.withDefault (30 * 1000)+ |> (*) 1000+ |> fromIntegral+ |> HTTP.responseTimeoutMicro+ }+ HTTP.httpLbs finalRequest requestManager+ pure <| case response of+ Right okResponse ->+ case decode (Internal.expect settings) (HTTP.responseBody okResponse) of+ Ok decodedBody ->+ Ok decodedBody+ Err message ->+ Err (Internal.BadBody message)+ Left (HTTP.HttpExceptionRequest _ content) ->+ case content of+ HTTP.StatusCodeException res _ ->+ let statusCode = fromIntegral << Status.statusCode << HTTP.responseStatus+ in Err (Internal.BadStatus (statusCode res))+ HTTP.ResponseTimeout ->+ Err Internal.Timeout+ HTTP.ConnectionTimeout ->+ Err (Internal.NetworkError "ConnectionTimeout")+ HTTP.ConnectionFailure err ->+ Err (Internal.NetworkError (Text.fromList (Exception.displayException err)))+ err ->+ Err (Internal.NetworkError (Text.fromList (show err)))+ Left (HTTP.InvalidUrlException _ message) ->+ Err (Internal.BadUrl (Text.fromList message))++decode :: Expect a -> Data.ByteString.Lazy.ByteString -> Result Text a+decode Internal.ExpectJson bytes =+ case Aeson.eitherDecode bytes of+ Left err -> Err (Text.fromList err)+ Right x -> Ok x+decode Internal.ExpectText bytes = (Ok << Data.Text.Lazy.toStrict << Data.Text.Lazy.Encoding.decodeUtf8) bytes+decode Internal.ExpectWhatever _ = Ok ()++-- |+-- Expect the response body to be JSON.+expectJson :: Aeson.FromJSON a => Expect a+expectJson = Internal.ExpectJson++-- |+-- Expect the response body to be a `Text`.+expectText :: Expect Text+expectText = Internal.ExpectText++-- |+-- Expect the response body to be whatever. It does not matter. Ignore it!+expectWhatever :: Expect ()+expectWhatever = Internal.ExpectWhatever++-- |+type Error = Internal.Error++-- Our Task type carries around some context values which should influence in+-- minor ways the logic of sending a request. In this function we modify a+-- manager to apply these modifications (see the comments below for the exact+-- nature of the modifications).+--+-- We're changing settings on the manager that originally get set during the+-- creation of the manager. We cannot set these settings once during creation+-- because they will be different for each outgoing request, and for performance+-- reasons we're encouraged to reuse a manager as much as possible. Modifying a+-- manager in this way does require use of the `Network.HTTP.Client.Internal`+-- module, which on account of being an internal module increases the risk of+-- this code breaking in future versions of the `http-client` package. There's+-- an outstanding PR for motivating these Manager modification functions are+-- moved to the stable API: https://github.com/snoyberg/http-client/issues/426+prepareManagerForRequest :: HTTP.Manager -> Task e HTTP.Manager+prepareManagerForRequest manager = do+ log <- Platform.logHandler+ requestId <- Platform.requestId+ pure+ manager+ { -- To be able to correlate events and logs belonging to a single+ -- original user request we pass around a request ID on HTTP requests+ -- between services. Below we add this request ID to all outgoing HTTP+ -- requests.+ HTTP.Internal.mModifyRequest = \req ->+ HTTP.Internal.mModifyRequest manager req+ |> andThen (modifyRequest requestId),+ -- We trace outgoing HTTP requests. This comes down to measuring how+ -- long they take and passing that information to some dashboard. This+ -- dashboard can then draw nice graphs showing how the time responding+ -- to a request it divided between different activities, such as sending+ -- HTTP requests. We can use the `mWrapException` for this purpose,+ -- although in our case we're not wrapping because of exceptions.+ HTTP.Internal.mWrapException = \req io ->+ HTTP.Internal.mWrapException manager req io+ |> wrapException log req+ }+ where+ modifyRequest :: Text -> HTTP.Request -> IO HTTP.Request+ modifyRequest requestId req =+ case requestId of+ "" -> pure req+ _ ->+ pure+ req+ { HTTP.requestHeaders =+ ("x-request-id", Data.Text.Encoding.encodeUtf8 requestId) :+ HTTP.requestHeaders req+ }+ wrapException :: forall a. Platform.LogHandler -> HTTP.Request -> IO a -> IO a+ wrapException log req io =+ let uri = HTTP.getUri req+ host =+ Network.URI.uriScheme uri+ ++ ( Network.URI.uriAuthority uri+ |> Network.URI.uriAuthToString (\_ -> "*****")+ |> (\showS -> showS "")+ )+ |> Text.fromList+ method =+ HTTP.method req+ |> Data.Text.Encoding.decodeUtf8+ spanDetails =+ HttpRequest.Outgoing+ HttpRequest.emptyDetails+ { HttpRequest.host = Just host,+ HttpRequest.path =+ Network.URI.uriPath uri+ |> Text.fromList+ |> Just,+ HttpRequest.queryString =+ Network.URI.uriQuery uri+ |> Text.fromList+ |> Just,+ HttpRequest.method = Just method+ }+ uriStr =+ HTTP.getUri req+ |> Network.URI.uriToString (\_ -> "*****")+ |> (\showS -> Text.fromList (showS ""))+ in Platform.tracingSpanIO+ log+ "Outoing HTTP Request"+ ( \log' ->+ Exception.finally+ io+ ( do+ Platform.setTracingSpanDetailsIO log' spanDetails+ Platform.setTracingSpanSummaryIO+ log'+ (method ++ " " ++ uriStr)+ )+ )
+ src/Http/Internal.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++module Http.Internal where++import qualified Control.Exception.Safe as Exception+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy+import qualified Data.Dynamic as Dynamic+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Header as Header+import qualified Network.Mime as Mime+import qualified Platform+import Prelude (IO)++-- | A handler for making HTTP requests.+data Handler = Handler+ { handlerRequest :: forall expect. Dynamic.Typeable expect => Request expect -> Task Error expect,+ handlerWithThirdParty :: forall a e. (HTTP.Manager -> Task e a) -> Task e a,+ handlerWithThirdPartyIO :: forall a. Platform.LogHandler -> (HTTP.Manager -> IO a) -> IO a+ }++-- | A custom request.+data Request a = Request+ { -- | The request method, like @"GET"@ or @"PUT"@.+ method :: Text,+ -- | A list of request headers.+ headers :: [Header],+ -- | The url, like @"https://fishes.com/salmon"@.+ url :: Text,+ -- | The request body.+ body :: Body,+ -- | The amount of microseconds you're willing to wait before giving up.+ timeout :: Maybe Int,+ -- | The type of response you expect back from the request.+ expect :: Expect a+ }++-- | An HTTP header for configuration requests.+newtype Header = Header {unHeader :: Header.Header}+ deriving (Eq, Show)++-- | Represents the body of a Request.+data Body = Body+ { bodyContents :: Data.ByteString.Lazy.ByteString,+ bodyContentType :: Maybe Mime.MimeType+ }++-- |+-- Logic for interpreting a response body.+data Expect a where+ ExpectJson :: Aeson.FromJSON a => Expect a+ ExpectText :: Expect Text+ ExpectWhatever :: Expect ()++-- | A 'Request' can fail in a couple of ways:+--+-- - 'BadUrl' means you did not provide a valid URL.+-- - 'Timeout' means it took too long to get a response.+-- - 'NetworkError' means the user turned off their wifi, went in a cave, etc.+-- - 'BadStatus' means you got a response back, but the status code indicates failure.+-- - 'BadBody' means you got a response back with a nice status code, but the body of the response was something unexpected. The 'Text' in this cse is the debugging message that explains what went wrong with your JSONT decoder or whatever.+data Error+ = BadUrl Text+ | Timeout+ | NetworkError Text+ | BadStatus Int+ | BadBody Text+ deriving (Generic, Eq, Show)++instance Exception.Exception Error++instance Aeson.ToJSON Error
+ src/Http/Mock.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++-- | Stub out Http requests in tests.+module Http.Mock+ ( stub,+ Stub,+ mkStub,++ -- * Read request data+ getHeader,+ getTextBody,+ getJsonBody,+ getBytesBody,+ )+where++import qualified Data.Aeson as Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy+import qualified Data.Dynamic as Dynamic+import qualified Data.IORef+import Data.String (fromString)+import qualified Data.Text.Encoding+import qualified Debug+import qualified Expect+import qualified GHC.Stack as Stack+import qualified Http.Internal as Internal+import qualified Platform+import qualified Task+import qualified Type.Reflection+import qualified Prelude++-- | A stub for a single request type. If your test body can perform multiple+-- different kinds of http requests, you'll want one of these per request type.+data Stub a where+ Stub ::+ Dynamic.Typeable expect =>+ (Internal.Request expect -> Task Internal.Error (a, expect)) ->+ Stub a++-- | Create a 'Stub'.+mkStub ::+ Dynamic.Typeable expect =>+ (Internal.Request expect -> Task Internal.Error (a, expect)) ->+ Stub a+mkStub = Stub++-- | Stub out http requests in a bit of code. You can use this if you don't+-- want your tests to make real http requests, and to listen in on the http+-- requests it is attempting to make.+--+-- 'stub' takes a function that it calls instead of making a real http request.+-- That function should return the response string and a optionally some+-- information about the http request. You'll get back the information collected+-- for each outgoing http request so you can run assertions against it.+--+-- > test "Stubbed HTTP requests" <| \_ -> do+-- > urlsAccessed <-+-- > Http.Mock.stub+-- > [mkStub (\req -> Task.succeed (Http.url req, "Response!" :: Text))]+-- > ( \http ->+-- > Expect.succeeds <| do+-- > _ <- Http.get http "example.com/one" Http.expectText+-- > _ <- Http.get http "example.com/two" Http.expectText+-- > Task.succeed ()+-- > )+-- > urlsAccessed+-- > |> Expect.equal ["example.com/one", "example.com/two"]+stub ::+ ( Stack.HasCallStack,+ Dynamic.Typeable a+ ) =>+ (List (Stub a)) ->+ (Internal.Handler -> Expect.Expectation) ->+ Expect.Expectation' (List a)+stub responders stubbedTestBody = do+ logRef <- Expect.fromIO (Data.IORef.newIORef [])+ doAnything <- Expect.fromIO Platform.doAnythingHandler+ let mockHandler =+ Internal.Handler+ ( \req -> do+ (log, res) <-+ tryRespond+ responders+ ( Internal.NetworkError+ ( "Http request was made with expected return type "+ ++ printType req+ ++ ", but I don't how to create a mock response of this type. Please add a `mkStub` entry for this type in the test."+ )+ )+ req+ Data.IORef.modifyIORef' logRef (\prev -> log : prev)+ |> map Ok+ |> Platform.doAnything doAnything+ Prelude.pure res+ )+ (\_ -> Debug.todo "We don't mock third party HTTP calls yet")+ (\_ -> Debug.todo "We don't mock third party HTTP calls yet")+ Expect.around (\f -> f mockHandler) (Stack.withFrozenCallStack stubbedTestBody)+ Expect.fromIO (Data.IORef.readIORef logRef)+ |> map List.reverse++-- | Read the body of the request as text. Useful to check what data got+-- submitted inside a 'stub' function.+--+-- This will return 'Nothing' if the body cannot be parsed as UTF8 text.+getTextBody :: Internal.Request expect -> Maybe Text+getTextBody req =+ Data.Text.Encoding.decodeUtf8' (getBytesBody req)+ |> eitherToMaybe++-- | Read the body of the request as json. Useful to check what data got+-- submitted inside a 'stub' function.+--+-- This will return an error if parsing the JSON body fails.+getJsonBody :: Aeson.FromJSON a => Internal.Request expect -> Result Text a+getJsonBody req =+ case Aeson.eitherDecodeStrict (getBytesBody req) of+ Prelude.Left err -> Err (Text.fromList err)+ Prelude.Right decoded -> Ok decoded++-- | Read the body of the request as bytes. Useful to check what data got+-- submitted inside a 'stub' function.+getBytesBody :: Internal.Request expect -> ByteString+getBytesBody req =+ Internal.body req+ |> Internal.bodyContents+ |> Data.ByteString.Lazy.toStrict++-- | Read a header of the request. Useful to check what data got submitted+-- inside a 'stub' function.+--+-- This will return 'Nothing' if no header with that name was set on the+-- request.+getHeader :: Text -> Internal.Request expect -> Maybe Text+getHeader name req =+ Internal.headers req+ |> List.map Internal.unHeader+ |> Prelude.lookup (fromString (Text.toList name))+ |> Maybe.andThen (eitherToMaybe << Data.Text.Encoding.decodeUtf8')++eitherToMaybe :: Prelude.Either a b -> Maybe b+eitherToMaybe either =+ case either of+ Prelude.Left _ -> Nothing+ Prelude.Right x -> Just x++tryRespond ::+ ( Dynamic.Typeable expect,+ Dynamic.Typeable a+ ) =>+ List (Stub a) ->+ Internal.Error ->+ Internal.Request expect ->+ Task Internal.Error (a, expect)+tryRespond [] err _ = Task.fail err+tryRespond (Stub respond : rest) err req =+ Dynamic.dynApply (Dynamic.toDyn respond) (Dynamic.toDyn req)+ |> Maybe.andThen Dynamic.fromDynamic+ |> Maybe.withDefault (tryRespond rest err req)++printType :: Dynamic.Typeable expect => proxy expect -> Text+printType expect =+ Type.Reflection.someTypeRep expect+ |> Debug.toString
+ test/Main.hs view
@@ -0,0 +1,230 @@+module Main (main) where++import qualified Conduit+import qualified Control.Concurrent.MVar as MVar+import qualified Control.Exception.Safe as Exception+import qualified Data.ByteString.Lazy+import qualified Data.List+import qualified Debug+import qualified Expect+import qualified Http+import qualified Http.Mock+import qualified Log.HttpRequest as HttpRequest+import qualified Network.HTTP.Types.Status as Status+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import qualified Platform+import qualified Task+import Test (Test, describe, test)+import qualified Test+import qualified Prelude++main :: Prelude.IO ()+main = Test.run tests++tests :: Test+tests =+ describe+ "Http"+ [ test "Given a request made using `get` when the response has a 200 status code the task return succeeds" <| \() ->+ withServer+ (constant "" Status.ok200)+ ( \http url -> do+ Http.get http url Http.expectWhatever+ |> Expect.succeeds+ ),+ test "Given a request made using `get` when the response has a 400 status code the task fails with a BadStatus error" <| \() ->+ withServer+ (constant "" Status.badRequest400)+ ( \http url -> do+ err <-+ Http.get http url Http.expectWhatever+ |> Expect.fails+ err+ |> Expect.equal (Http.BadStatus 400)+ ),+ test "Given a request made using `get` that expects a JSON response when the response includes the right JSON it is returned decoded" <| \() ->+ withServer+ (constant "[1,2,3]" Status.ok200)+ ( \http url -> do+ response <-+ Http.get http url Http.expectJson+ |> Expect.succeeds+ response+ |> Expect.equal [1, 2, 3 :: Int]+ ),+ test "Given a request made using `get` that expects a JSON response when the JSON in the responses can not be decoded we fail with a BadBody error" <| \() ->+ withServer+ (constant "12" Status.ok200)+ ( \http url -> do+ err <-+ Http.get http url (Http.expectJson :: Http.Expect Text)+ |> Expect.fails+ err+ |> Expect.equal (Http.BadBody "Error in $: parsing Text failed, expected String, but encountered Number")+ ),+ test "When a request is made using `get` to an invalid URL we fail with a BadUrl error" <| \() ->+ withServer+ (constant "" Status.ok200)+ ( \http _ -> do+ err <-+ Http.get http "ceci n'est pas un URL" Http.expectWhatever+ |> Expect.fails+ err+ |> Expect.equal (Http.BadUrl "Invalid URL")+ ),+ test "When a request is made using `get` with a json body the `Content-Type` header is set to `application/json`" <| \() -> do+ request <-+ expectRequest+ ( \http url ->+ Http.post http url (Http.jsonBody ()) Http.expectWhatever+ )+ request+ |> Wai.requestHeaders+ |> Data.List.lookup "content-type"+ |> Expect.equal (Just "application/json"),+ test "When a request is made using `get` with a json body the JSON is encoded correctly" <| \() -> do+ request <-+ expectRequest+ ( \http url ->+ Http.post http url (Http.jsonBody [1, 2, 3 :: Int]) Http.expectWhatever+ )+ body <- Expect.fromIO (Wai.strictRequestBody request)+ Expect.equal "[1,2,3]" body,+ test "When a request is made using `get` with a string body the `Content-Type` header is set to provided mime type" <| \() -> do+ request <-+ expectRequest+ ( \http url ->+ Http.post http url (Http.stringBody "element/fire" "WOOSH") Http.expectWhatever+ )+ request+ |> Wai.requestHeaders+ |> Data.List.lookup "content-type"+ |> Expect.equal (Just "element/fire"),+ test "Http requests report the span data we expect" <| \_ ->+ withServer+ (constant "" Status.ok200)+ ( \http url -> do+ span <-+ Http.get http url Http.expectWhatever+ |> spanForTask+ Debug.toString span+ |> Expect.equalToContentsOf "test/golden-results/expected-http-span"+ ),+ test "Http.Mock.stub" <| \_ -> do+ urlsAccessed <-+ Http.Mock.stub+ [Http.Mock.mkStub (\req -> Task.succeed (Http.url req, "Response!" :: Text))]+ ( \http ->+ Expect.succeeds <| do+ _ <- Http.get http "example.com/one" Http.expectText+ _ <- Http.get http "example.com/two" Http.expectText+ Task.succeed ()+ )+ urlsAccessed+ |> Expect.equal ["example.com/one", "example.com/two"]+ ]++-- # Wai applications to test against+-- WAI NOT?++-- | A web application that returns the same response to every request.+constant :: Data.ByteString.Lazy.ByteString -> Status.Status -> Wai.Application+constant body status _ respond =+ Wai.responseLBS status [] body+ |> respond++-- | Run a temporary web application to send requests to.+withServer ::+ Wai.Application ->+ (Http.Handler -> Text -> Expect.Expectation) ->+ Expect.Expectation+withServer app run = do+ log <- Expect.succeeds Platform.logHandler+ doAnything <- Expect.fromIO Platform.doAnythingHandler+ Expect.around+ ( \runTask ->+ withServerIO log app (\http host -> runTask (http, host))+ |> Platform.doAnything doAnything+ )+ (\(http, host) -> run http host)++-- | Run a temporary web application to send requests to.+withServerIO ::+ Platform.LogHandler ->+ Wai.Application ->+ (Http.Handler -> Text -> Task e a) ->+ Prelude.IO (Result e a)+withServerIO log app run = do+ Conduit.withAcquire Http.handler <| \http ->+ Warp.testWithApplication+ (Prelude.pure app)+ ( \port ->+ run http ("http://localhost:" ++ Text.fromInt (Prelude.fromIntegral port))+ |> Task.attempt log+ )++-- | Run a temporary web application that handles a single request, and then+-- immediately returns that request so you can run expectations against it.+--+-- Useful if you want to check properties of requests you send.+expectRequest :: Show e => (Http.Handler -> Text -> Task e a) -> Expect.Expectation' Wai.Request+expectRequest run = do+ let app req _respond = Exception.throwIO (FirstRequest req)+ log <- Expect.succeeds Platform.logHandler+ either <- Expect.fromIO <| Exception.try (withServerIO log app run)+ Expect.succeeds+ <| case either of+ Prelude.Left (FirstRequest req) -> Task.succeed req+ Prelude.Right (Ok _) -> Task.fail "Expected a request, but none was received."+ Prelude.Right (Err err) -> Task.fail (Debug.toString err)++newtype FirstRequest = FirstRequest Wai.Request deriving (Show)++instance Exception.Exception FirstRequest++spanForTask :: Show e => Task e () -> Expect.Expectation' Platform.TracingSpan+spanForTask task = do+ spanVar <- Expect.fromIO MVar.newEmptyMVar+ res <-+ Expect.fromIO <| do+ Platform.rootTracingSpanIO+ "test-request"+ (MVar.putMVar spanVar)+ "test-root"+ (\log -> Task.attempt log task)+ Expect.ok res+ span <- Expect.fromIO (MVar.takeMVar spanVar)+ constantValuesForVariableFields span+ |> Task.succeed+ |> Expect.succeeds++-- | Timestamps recorded in spans would make each test result different from the+-- last. This helper sets all timestamps to zero to prevent this.+--+-- Similarly the host URI changes in each test, because `warp` pickes a random+-- free port to run a test webserver on. To prevent this from failing tests we+-- set the URI to a standard value.+constantValuesForVariableFields :: Platform.TracingSpan -> Platform.TracingSpan+constantValuesForVariableFields span =+ span+ { Platform.started = 0,+ Platform.finished = 0,+ Platform.details =+ Platform.details span+ |> andThen+ ( \details ->+ Platform.renderTracingSpanDetails+ [ Platform.Renderer+ ( \(HttpRequest.Outgoing httpDetails) ->+ httpDetails {HttpRequest.host = Just "mock-uri"}+ |> HttpRequest.Outgoing+ |> Platform.toTracingSpanDetails+ )+ ]+ details+ ),+ Platform.allocated = 0,+ Platform.summary = Just "mock-uri",+ Platform.children = map constantValuesForVariableFields (Platform.children span)+ }
+ test/golden-results/expected-http-span view
@@ -0,0 +1,49 @@+TracingSpan+ { name = "test-root"+ , started = MonotonicTime { inMicroseconds = 0 }+ , finished = MonotonicTime { inMicroseconds = 0 }+ , frame =+ Just+ ( "rootTracingSpanIO"+ , SrcLoc+ { srcLocPackage = "main"+ , srcLocModule = "Main"+ , srcLocFile = "test/Main.hs"+ , srcLocStartLine = 191+ , srcLocStartCol = 7+ , srcLocEndLine = 195+ , srcLocEndCol = 40+ }+ )+ , details = Nothing+ , summary = Just "mock-uri"+ , succeeded = Succeeded+ , allocated = 0+ , children =+ [ TracingSpan+ { name = "Outoing HTTP Request"+ , started = MonotonicTime { inMicroseconds = 0 }+ , finished = MonotonicTime { inMicroseconds = 0 }+ , frame =+ Just+ ( "tracingSpanIO"+ , SrcLoc+ { srcLocPackage = "main"+ , srcLocModule = "Http"+ , srcLocFile = "src/Http.hs"+ , srcLocStartLine = 344+ , srcLocStartCol = 11+ , srcLocEndLine = 356+ , srcLocEndCol = 14+ }+ )+ , details =+ Just+ "{\"method\":\"GET\",\"host\":\"mock-uri\",\"path\":\"/\",\"query string\":\"\",\"headers\":{}}"+ , summary = Just "mock-uri"+ , succeeded = Succeeded+ , allocated = 0+ , children = []+ }+ ]+ }