diff --git a/nri-http.cabal b/nri-http.cabal --- a/nri-http.cabal +++ b/nri-http.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: nri-http -version: 0.1.0.4 +version: 0.1.1.0 synopsis: Make Elm style HTTP requests description: Please see the README at . category: Web @@ -57,6 +57,7 @@ aeson >=1.4.6.0 && <2.1 , base >=4.12.0.0 && <4.17 , bytestring >=0.10.8.2 && <0.12 + , case-insensitive >=1.1 && <2.0 , conduit >=1.3.0 && <1.4 , http-client >=0.6.0 && <0.8 , http-client-tls >=0.3.0 && <0.4 @@ -101,6 +102,7 @@ aeson >=1.4.6.0 && <2.1 , base >=4.12.0.0 && <4.17 , bytestring >=0.10.8.2 && <0.12 + , case-insensitive >=1.1 && <2.0 , conduit >=1.3.0 && <1.4 , http-client >=0.6.0 && <0.8 , http-client-tls >=0.3.0 && <0.4 diff --git a/src/Http.hs b/src/Http.hs --- a/src/Http.hs +++ b/src/Http.hs @@ -31,6 +31,12 @@ expectText, expectWhatever, + -- * Elaborate Expectations + expectTextResponse, + expectBytesResponse, + Internal.Response (..), + Internal.Metadata (..), + -- * Use with external libraries withThirdParty, withThirdPartyIO, @@ -43,11 +49,13 @@ import qualified Data.Aeson as Aeson import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy +import qualified Data.CaseInsensitive as CI 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 qualified Dict import Http.Internal (Body, Expect, Handler) import qualified Http.Internal as Internal import qualified Log.HttpRequest as HttpRequest @@ -59,7 +67,7 @@ import qualified Network.URI import qualified Platform import qualified Task -import Prelude (Either (Left, Right), IO, fromIntegral, pure, show) +import Prelude (Either (Left, Right), IO, fromIntegral, pure) -- | Create a 'Handler' for making HTTP requests. handler :: Conduit.Acquire Handler @@ -100,7 +108,7 @@ -- QUICKS -- | Create a @GET@ request. -get :: Dynamic.Typeable a => Handler -> Text -> Expect a -> Task Error a +get :: (Dynamic.Typeable a) => Handler -> Text -> Expect a -> Task Error a get handler' url expect = request handler' @@ -114,7 +122,7 @@ } -- | Create a @POST@ request. -post :: Dynamic.Typeable a => Handler -> Text -> Body -> Expect a -> Task Error a +post :: (Dynamic.Typeable a) => Handler -> Text -> Body -> Expect a -> Task Error a post handler' url body expect = request handler' @@ -179,7 +187,7 @@ -- | Create a custom request. request :: - Dynamic.Typeable expect => + (Dynamic.Typeable expect) => Handler -> Internal.Request expect -> Task Error expect @@ -212,37 +220,103 @@ |> 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)) + pure <| handleResponse (Internal.expect settings) response -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 () +handleResponse :: Expect a -> Either HTTP.HttpException (HTTP.Response Data.ByteString.Lazy.ByteString) -> Result Error a +handleResponse expect response = + case response of + Right okResponse -> + let bytes = HTTP.responseBody okResponse + bodyAsText = Data.Text.Lazy.toStrict <| Data.Text.Lazy.Encoding.decodeUtf8 bytes + in case expect of + Internal.ExpectJson -> + case Aeson.eitherDecode bytes of + Left err -> Err (Internal.BadBody (Text.fromList err)) + Right x -> Ok x + Internal.ExpectText -> Ok bodyAsText + Internal.ExpectWhatever -> Ok () + Internal.ExpectTextResponse mkResult -> mkResult (Internal.GoodStatus_ (mkMetadata okResponse) bodyAsText) + Internal.ExpectBytesResponse mkResult -> mkResult (Internal.GoodStatus_ (mkMetadata okResponse) (Data.ByteString.Lazy.toStrict bytes)) + Left exception -> + case expect of + Internal.ExpectTextResponse mkResult -> + exception + |> exceptionToResponse Data.Text.Encoding.decodeUtf8 + |> mkResult + Internal.ExpectBytesResponse mkResult -> + exception + |> exceptionToResponse identity + |> mkResult + _ -> + Err (exceptionToError exception) +exceptionToError :: HTTP.HttpException -> Error +exceptionToError exception = + case exception of + HTTP.InvalidUrlException _ message -> + Internal.BadUrl (Text.fromList message) + HTTP.HttpExceptionRequest _ content -> + case content of + HTTP.StatusCodeException res _ -> + res + |> HTTP.responseStatus + |> Status.statusCode + |> fromIntegral + |> Internal.BadStatus + HTTP.ResponseTimeout -> + Internal.Timeout + HTTP.ConnectionTimeout -> + Internal.NetworkError "ConnectionTimeout" + HTTP.ConnectionFailure err -> + Exception.displayException err + |> Text.fromList + |> Internal.NetworkError + err -> + Internal.NetworkError (Debug.toString err) + +exceptionToResponse :: (ByteString -> a) -> HTTP.HttpException -> Internal.Response a +exceptionToResponse toBody exception = + case exception of + HTTP.InvalidUrlException _ message -> + Internal.BadUrl_ (Text.fromList message) + HTTP.HttpExceptionRequest _ content -> + case content of + HTTP.StatusCodeException res bytes -> + Internal.BadStatus_ (mkMetadata res) (toBody bytes) + HTTP.ResponseTimeout -> + Internal.Timeout_ + HTTP.ConnectionTimeout -> + Internal.NetworkError_ "ConnectionTimeout" + HTTP.ConnectionFailure err -> + Internal.NetworkError_ (Text.fromList (Exception.displayException err)) + err -> + Internal.NetworkError_ (Debug.toString err) + +mkMetadata :: HTTP.Response a -> Internal.Metadata +mkMetadata response = + let status = HTTP.responseStatus response + in Internal.Metadata + { Internal.metadataStatusCode = fromIntegral <| Status.statusCode status, + Internal.metadataStatusText = + status + |> Status.statusMessage + |> Data.Text.Encoding.decodeUtf8, + Internal.metadataHeaders = + List.foldl + ( \(name, valueBS) -> + let value = Data.Text.Encoding.decodeUtf8 valueBS + in Dict.update + (Data.Text.Encoding.decodeUtf8 <| CI.original name) + ( \current -> + Just <| case current of + Just current_ -> current_ ++ ", " ++ value + Nothing -> value + ) + ) + Dict.empty + (HTTP.responseHeaders response) + } + -- | -- Expect the response body to be JSON. expectJson :: Aeson.FromJSON a => Expect a @@ -259,6 +333,16 @@ expectWhatever = Internal.ExpectWhatever -- | +-- Expect a `Response` with a `Text` body. +expectTextResponse :: (Internal.Response Text -> Result Error a) -> Expect a +expectTextResponse = Internal.ExpectTextResponse + +-- | +-- Expect a `Response` with a `ByteString` body +expectBytesResponse :: (Internal.Response ByteString -> Result Error a) -> Expect a +expectBytesResponse = Internal.ExpectBytesResponse + +-- | type Error = Internal.Error -- Our Task type carries around some context values which should influence in @@ -343,7 +427,7 @@ |> (\showS -> Text.fromList (showS "")) in Platform.tracingSpanIO log - "Outoing HTTP Request" + "Outgoing HTTP Request" ( \log' -> Exception.finally io diff --git a/src/Http/Internal.hs b/src/Http/Internal.hs --- a/src/Http/Internal.hs +++ b/src/Http/Internal.hs @@ -5,8 +5,10 @@ import qualified Control.Exception.Safe as Exception import qualified Data.Aeson as Aeson +import qualified Data.ByteString import qualified Data.ByteString.Lazy import qualified Data.Dynamic as Dynamic +import Dict (Dict) import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Types.Header as Header import qualified Network.Mime as Mime @@ -52,6 +54,8 @@ ExpectJson :: Aeson.FromJSON a => Expect a ExpectText :: Expect Text ExpectWhatever :: Expect () + ExpectTextResponse :: (Response Text -> Result Error a) -> Expect a + ExpectBytesResponse :: (Response Data.ByteString.ByteString -> Result Error a) -> Expect a -- | A 'Request' can fail in a couple of ways: -- @@ -71,3 +75,38 @@ instance Exception.Exception Error instance Aeson.ToJSON Error + +-- | A 'Response' can come back a couple different ways: +-- +-- - 'BadUrl_' — you did not provide a valid URL. +-- - 'Timeout_' — it took too long to get a response. +-- - 'NetworkError_' — the user turned off their wifi, went in a cave, etc. +-- - 'BadStatus_' — a response arrived, but the status code indicates failure. +-- - 'GoodStatus_' — a response arrived with a nice status code! +-- - The type of the body depends on whether you use expectStringResponse or expectBytesResponse. +data Response body + = BadUrl_ Text + | Timeout_ + | NetworkError_ Text + | BadStatus_ Metadata body + | GoodStatus_ Metadata body + deriving (Generic, Eq, Show) + +instance (Dynamic.Typeable body, Show body) => Exception.Exception (Response body) + +instance (Aeson.ToJSON body) => Aeson.ToJSON (Response body) + +-- Extra information about the response: +-- +-- Note: It is possible for a response to have the same header multiple times. In that case, all the values end up in a single entry in the headers dictionary. The values are separated by commas, following the rules outlined [here](https://stackoverflow.com/questions/4371328/are-duplicate-http-response-headers-acceptable). +data Metadata = Metadata + { -- statusCode like 200 or 404 + metadataStatusCode :: Int, + -- statusText describing what the statusCode means a little + metadataStatusText :: Text, + -- headers like Content-Length and Expires + metadataHeaders :: Dict Text Text + } + deriving (Generic, Eq, Show) + +instance Aeson.ToJSON Metadata diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -122,7 +122,37 @@ Task.succeed () ) urlsAccessed - |> Expect.equal ["example.com/one", "example.com/two"] + |> Expect.equal ["example.com/one", "example.com/two"], + test "Using expectTextResponse, metadata returns the correct status" <| \() -> + withServer + (constant "Some text" Status.ok200) + ( \http url -> do + res <- + Http.get http url (Http.expectTextResponse Ok) + |> Expect.succeeds + case res of + Http.GoodStatus_ metadata body -> do + Expect.equal 200 (Http.metadataStatusCode metadata) + Expect.equal "OK" (Http.metadataStatusText metadata) + Expect.equal "Some text" body + other -> + Expect.fail <| "Unexpected response: " ++ (Text.fromList <| Prelude.show other) + ), + test "Using expectBytesResponse, we can read the body when the request is not successful" <| \() -> + withServer + (constant "This is a bad request" Status.badRequest400) + ( \http url -> do + res <- + Http.get http url (Http.expectBytesResponse Ok) + |> Expect.succeeds + case res of + Http.BadStatus_ metadata body -> do + Expect.equal 400 (Http.metadataStatusCode metadata) + Expect.equal "Bad Request" (Http.metadataStatusText metadata) + Expect.equal "This is a bad request" body + other -> + Expect.fail <| "Unexpected response: " ++ (Text.fromList <| Prelude.show other) + ) ] -- # Wai applications to test against diff --git a/test/golden-results/expected-http-span b/test/golden-results/expected-http-span --- a/test/golden-results/expected-http-span +++ b/test/golden-results/expected-http-span @@ -9,9 +9,9 @@ { srcLocPackage = "main" , srcLocModule = "Main" , srcLocFile = "test/Main.hs" - , srcLocStartLine = 191 + , srcLocStartLine = 221 , srcLocStartCol = 7 - , srcLocEndLine = 195 + , srcLocEndLine = 225 , srcLocEndCol = 40 } ) @@ -21,7 +21,7 @@ , allocated = 0 , children = [ TracingSpan - { name = "Outoing HTTP Request" + { name = "Outgoing HTTP Request" , started = MonotonicTime { inMicroseconds = 0 } , finished = MonotonicTime { inMicroseconds = 0 } , frame = @@ -31,9 +31,9 @@ { srcLocPackage = "main" , srcLocModule = "Http" , srcLocFile = "src/Http.hs" - , srcLocStartLine = 344 + , srcLocStartLine = 428 , srcLocStartCol = 11 - , srcLocEndLine = 356 + , srcLocEndLine = 440 , srcLocEndCol = 14 } )