module Freckle.App.OpenTelemetry.Http
  ( httpSpanName
  , httpSpanArguments
  , httpAttributes
  , httpResponseAttributes
  ) where

import Freckle.App.Prelude

import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Freckle.App.OpenTelemetry
  ( SpanArguments (..)
  , byteStringToAttribute
  , clientSpanArguments
  )
import Network.HTTP.Client (Request, Response)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Types.Status (statusCode)
import OpenTelemetry.Attributes (Attribute, ToAttribute (..))

httpSpanName :: Request -> Text
httpSpanName :: Request -> Text
httpSpanName Request
req =
  OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.method Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
HTTP.path Request
req

httpSpanArguments :: Request -> SpanArguments
httpSpanArguments :: Request -> SpanArguments
httpSpanArguments Request
req = SpanArguments
clientSpanArguments {attributes = httpAttributes req}

httpAttributes :: Request -> HashMap Text Attribute
httpAttributes :: Request -> HashMap Text Attribute
httpAttributes Request
req =
  [(Text, Attribute)] -> HashMap Text Attribute
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
    [ (Text
"service.name", ByteString -> Attribute
byteStringToAttribute (ByteString -> Attribute) -> ByteString -> Attribute
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.host Request
req)
    , (Text
"resource.name", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Request -> Text
httpSpanName Request
req)
    , (Text
"http.host", ByteString -> Attribute
byteStringToAttribute (ByteString -> Attribute) -> ByteString -> Attribute
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.host Request
req)
    , (Text
"http.method", ByteString -> Attribute
byteStringToAttribute (ByteString -> Attribute) -> ByteString -> Attribute
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.method Request
req)
    , (Text
"http.path", ByteString -> Attribute
byteStringToAttribute (ByteString -> Attribute) -> ByteString -> Attribute
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.path Request
req)
    , (Text
"http.query", ByteString -> Attribute
byteStringToAttribute (ByteString -> Attribute) -> ByteString -> Attribute
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.queryString Request
req)
    ]

httpResponseAttributes :: Response body -> HashMap Text Attribute
httpResponseAttributes :: forall body. Response body -> HashMap Text Attribute
httpResponseAttributes Response body
resp = HashMap Text Attribute
statusAttr HashMap Text Attribute
-> HashMap Text Attribute -> HashMap Text Attribute
forall a. Semigroup a => a -> a -> a
<> ((CI ByteString, ByteString) -> HashMap Text Attribute)
-> [(CI ByteString, ByteString)] -> HashMap Text Attribute
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((CI ByteString -> ByteString -> HashMap Text Attribute)
-> (CI ByteString, ByteString) -> HashMap Text Attribute
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CI ByteString -> ByteString -> HashMap Text Attribute
headerAttr) (Response body -> [(CI ByteString, ByteString)]
forall body. Response body -> [(CI ByteString, ByteString)]
HTTP.responseHeaders Response body
resp)
 where
  statusAttr :: HashMap Text Attribute
statusAttr =
    Text -> Attribute -> HashMap Text Attribute
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Text
"http.status_code"
      (Attribute -> HashMap Text Attribute)
-> (Status -> Attribute) -> Status -> HashMap Text Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute
      (Int -> Attribute) -> (Status -> Int) -> Status -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode
      (Status -> HashMap Text Attribute)
-> Status -> HashMap Text Attribute
forall a b. (a -> b) -> a -> b
$ Response body -> Status
forall body. Response body -> Status
HTTP.responseStatus Response body
resp

  headerAttr :: CI ByteString -> ByteString -> HashMap Text Attribute
headerAttr CI ByteString
k = Text -> Attribute -> HashMap Text Attribute
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton (CI ByteString -> Text
headerAttrKey CI ByteString
k) (Attribute -> HashMap Text Attribute)
-> (ByteString -> Attribute)
-> ByteString
-> HashMap Text Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Attribute
byteStringToAttribute

  headerAttrKey :: CI ByteString -> Text
headerAttrKey =
    (Text
"http.response.headers." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
      (Text -> Text) -> (CI ByteString -> Text) -> CI ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower
      (Text -> Text) -> (CI ByteString -> Text) -> CI ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode
      (ByteString -> Text)
-> (CI ByteString -> ByteString) -> CI ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString
forall s. CI s -> s
CI.original