nri-http-0.1.1.0: src/Http.hs
{-# 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,
-- * Elaborate Expectations
expectTextResponse,
expectBytesResponse,
Internal.Response (..),
Internal.Metadata (..),
-- * 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.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
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)
-- | 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 <| handleResponse (Internal.expect settings) response
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
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
-- |
-- 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
-- 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
"Outgoing HTTP Request"
( \log' ->
Exception.finally
io
( do
Platform.setTracingSpanDetailsIO log' spanDetails
Platform.setTracingSpanSummaryIO
log'
(method ++ " " ++ uriStr)
)
)