{-# LANGUAGE FlexibleContexts #-}
module Network.AWS.XRayClient.TraceId
( amazonTraceIdHeaderName
,
XRayTraceId(..)
, generateXRayTraceId
, makeXRayTraceId
, XRaySegmentId(..)
, generateXRaySegmentId
, XRayTraceIdHeaderData(..)
, xrayTraceIdHeaderData
, parseXRayTraceIdHeaderData
, makeXRayTraceIdHeaderValue
) where
import Prelude
import Control.DeepSeq (NFData)
import Data.Aeson
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import Data.Char (intToDigit)
import Data.IORef
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Clock.POSIX (getPOSIXTime)
import GHC.Generics
import Network.HTTP.Types.Header
import Numeric (showHex)
import System.Random
import System.Random.XRayCustom
amazonTraceIdHeaderName :: HeaderName
= HeaderName
"X-Amzn-Trace-Id"
newtype XRayTraceId = XRayTraceId { XRayTraceId -> Text
unXRayTraceId :: Text }
deriving (Int -> XRayTraceId -> ShowS
[XRayTraceId] -> ShowS
XRayTraceId -> String
(Int -> XRayTraceId -> ShowS)
-> (XRayTraceId -> String)
-> ([XRayTraceId] -> ShowS)
-> Show XRayTraceId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XRayTraceId] -> ShowS
$cshowList :: [XRayTraceId] -> ShowS
show :: XRayTraceId -> String
$cshow :: XRayTraceId -> String
showsPrec :: Int -> XRayTraceId -> ShowS
$cshowsPrec :: Int -> XRayTraceId -> ShowS
Show, XRayTraceId -> XRayTraceId -> Bool
(XRayTraceId -> XRayTraceId -> Bool)
-> (XRayTraceId -> XRayTraceId -> Bool) -> Eq XRayTraceId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XRayTraceId -> XRayTraceId -> Bool
$c/= :: XRayTraceId -> XRayTraceId -> Bool
== :: XRayTraceId -> XRayTraceId -> Bool
$c== :: XRayTraceId -> XRayTraceId -> Bool
Eq)
deriving newtype (Value -> Parser [XRayTraceId]
Value -> Parser XRayTraceId
(Value -> Parser XRayTraceId)
-> (Value -> Parser [XRayTraceId]) -> FromJSON XRayTraceId
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [XRayTraceId]
$cparseJSONList :: Value -> Parser [XRayTraceId]
parseJSON :: Value -> Parser XRayTraceId
$cparseJSON :: Value -> Parser XRayTraceId
FromJSON, [XRayTraceId] -> Encoding
[XRayTraceId] -> Value
XRayTraceId -> Encoding
XRayTraceId -> Value
(XRayTraceId -> Value)
-> (XRayTraceId -> Encoding)
-> ([XRayTraceId] -> Value)
-> ([XRayTraceId] -> Encoding)
-> ToJSON XRayTraceId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [XRayTraceId] -> Encoding
$ctoEncodingList :: [XRayTraceId] -> Encoding
toJSONList :: [XRayTraceId] -> Value
$ctoJSONList :: [XRayTraceId] -> Value
toEncoding :: XRayTraceId -> Encoding
$ctoEncoding :: XRayTraceId -> Encoding
toJSON :: XRayTraceId -> Value
$ctoJSON :: XRayTraceId -> Value
ToJSON, XRayTraceId -> ()
(XRayTraceId -> ()) -> NFData XRayTraceId
forall a. (a -> ()) -> NFData a
rnf :: XRayTraceId -> ()
$crnf :: XRayTraceId -> ()
NFData)
generateXRayTraceId :: IORef StdGen -> IO XRayTraceId
generateXRayTraceId :: IORef StdGen -> IO XRayTraceId
generateXRayTraceId IORef StdGen
ioRef = do
Int
timeInSeconds <- POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> IO POSIXTime -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
IORef StdGen -> (StdGen -> (XRayTraceId, StdGen)) -> IO XRayTraceId
forall g a. RandomGen g => IORef g -> (g -> (a, g)) -> IO a
withRandomGenIORef IORef StdGen
ioRef ((StdGen -> (XRayTraceId, StdGen)) -> IO XRayTraceId)
-> (StdGen -> (XRayTraceId, StdGen)) -> IO XRayTraceId
forall a b. (a -> b) -> a -> b
$ Int -> StdGen -> (XRayTraceId, StdGen)
makeXRayTraceId Int
timeInSeconds
makeXRayTraceId :: Int -> StdGen -> (XRayTraceId, StdGen)
makeXRayTraceId :: Int -> StdGen -> (XRayTraceId, StdGen)
makeXRayTraceId Int
timeInSeconds StdGen
gen = (String -> XRayTraceId)
-> (String, StdGen) -> (XRayTraceId, StdGen)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> XRayTraceId
make ((String, StdGen) -> (XRayTraceId, StdGen))
-> (String, StdGen) -> (XRayTraceId, StdGen)
forall a b. (a -> b) -> a -> b
$ Int -> StdGen -> (String, StdGen)
randomHexString Int
24 StdGen
gen
where
make :: String -> XRayTraceId
make String
hexString =
Text -> XRayTraceId
XRayTraceId (Text -> XRayTraceId) -> Text -> XRayTraceId
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"1-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex Int
timeInSeconds String
"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hexString
randomHexString :: Int -> StdGen -> (String, StdGen)
randomHexString :: Int -> StdGen -> (String, StdGen)
randomHexString Int
n StdGen
gen =
Int -> StdGen -> (StdGen -> (Char, StdGen)) -> (String, StdGen)
forall g a. RandomGen g => Int -> g -> (g -> (a, g)) -> ([a], g)
replicateRandom Int
n StdGen
gen ((StdGen -> (Char, StdGen)) -> (String, StdGen))
-> (StdGen -> (Char, StdGen)) -> (String, StdGen)
forall a b. (a -> b) -> a -> b
$ (Int -> Char) -> (Int, StdGen) -> (Char, StdGen)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Char
intToDigit ((Int, StdGen) -> (Char, StdGen))
-> (StdGen -> (Int, StdGen)) -> StdGen -> (Char, StdGen)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Int
15)
newtype XRaySegmentId = XRaySegmentId { XRaySegmentId -> Text
unXRaySegmentId :: Text }
deriving (Int -> XRaySegmentId -> ShowS
[XRaySegmentId] -> ShowS
XRaySegmentId -> String
(Int -> XRaySegmentId -> ShowS)
-> (XRaySegmentId -> String)
-> ([XRaySegmentId] -> ShowS)
-> Show XRaySegmentId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XRaySegmentId] -> ShowS
$cshowList :: [XRaySegmentId] -> ShowS
show :: XRaySegmentId -> String
$cshow :: XRaySegmentId -> String
showsPrec :: Int -> XRaySegmentId -> ShowS
$cshowsPrec :: Int -> XRaySegmentId -> ShowS
Show, XRaySegmentId -> XRaySegmentId -> Bool
(XRaySegmentId -> XRaySegmentId -> Bool)
-> (XRaySegmentId -> XRaySegmentId -> Bool) -> Eq XRaySegmentId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XRaySegmentId -> XRaySegmentId -> Bool
$c/= :: XRaySegmentId -> XRaySegmentId -> Bool
== :: XRaySegmentId -> XRaySegmentId -> Bool
$c== :: XRaySegmentId -> XRaySegmentId -> Bool
Eq)
deriving newtype (Value -> Parser [XRaySegmentId]
Value -> Parser XRaySegmentId
(Value -> Parser XRaySegmentId)
-> (Value -> Parser [XRaySegmentId]) -> FromJSON XRaySegmentId
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [XRaySegmentId]
$cparseJSONList :: Value -> Parser [XRaySegmentId]
parseJSON :: Value -> Parser XRaySegmentId
$cparseJSON :: Value -> Parser XRaySegmentId
FromJSON, [XRaySegmentId] -> Encoding
[XRaySegmentId] -> Value
XRaySegmentId -> Encoding
XRaySegmentId -> Value
(XRaySegmentId -> Value)
-> (XRaySegmentId -> Encoding)
-> ([XRaySegmentId] -> Value)
-> ([XRaySegmentId] -> Encoding)
-> ToJSON XRaySegmentId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [XRaySegmentId] -> Encoding
$ctoEncodingList :: [XRaySegmentId] -> Encoding
toJSONList :: [XRaySegmentId] -> Value
$ctoJSONList :: [XRaySegmentId] -> Value
toEncoding :: XRaySegmentId -> Encoding
$ctoEncoding :: XRaySegmentId -> Encoding
toJSON :: XRaySegmentId -> Value
$ctoJSON :: XRaySegmentId -> Value
ToJSON, XRaySegmentId -> ()
(XRaySegmentId -> ()) -> NFData XRaySegmentId
forall a. (a -> ()) -> NFData a
rnf :: XRaySegmentId -> ()
$crnf :: XRaySegmentId -> ()
NFData)
generateXRaySegmentId :: StdGen -> (XRaySegmentId, StdGen)
generateXRaySegmentId :: StdGen -> (XRaySegmentId, StdGen)
generateXRaySegmentId = (String -> XRaySegmentId)
-> (String, StdGen) -> (XRaySegmentId, StdGen)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> XRaySegmentId
XRaySegmentId (Text -> XRaySegmentId)
-> (String -> Text) -> String -> XRaySegmentId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) ((String, StdGen) -> (XRaySegmentId, StdGen))
-> (StdGen -> (String, StdGen))
-> StdGen
-> (XRaySegmentId, StdGen)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> StdGen -> (String, StdGen)
randomHexString Int
16
data =
{ :: !XRayTraceId
, :: !(Maybe XRaySegmentId)
, :: !(Maybe Bool)
}
deriving (Int -> XRayTraceIdHeaderData -> ShowS
[XRayTraceIdHeaderData] -> ShowS
XRayTraceIdHeaderData -> String
(Int -> XRayTraceIdHeaderData -> ShowS)
-> (XRayTraceIdHeaderData -> String)
-> ([XRayTraceIdHeaderData] -> ShowS)
-> Show XRayTraceIdHeaderData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XRayTraceIdHeaderData] -> ShowS
$cshowList :: [XRayTraceIdHeaderData] -> ShowS
show :: XRayTraceIdHeaderData -> String
$cshow :: XRayTraceIdHeaderData -> String
showsPrec :: Int -> XRayTraceIdHeaderData -> ShowS
$cshowsPrec :: Int -> XRayTraceIdHeaderData -> ShowS
Show, XRayTraceIdHeaderData -> XRayTraceIdHeaderData -> Bool
(XRayTraceIdHeaderData -> XRayTraceIdHeaderData -> Bool)
-> (XRayTraceIdHeaderData -> XRayTraceIdHeaderData -> Bool)
-> Eq XRayTraceIdHeaderData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XRayTraceIdHeaderData -> XRayTraceIdHeaderData -> Bool
$c/= :: XRayTraceIdHeaderData -> XRayTraceIdHeaderData -> Bool
== :: XRayTraceIdHeaderData -> XRayTraceIdHeaderData -> Bool
$c== :: XRayTraceIdHeaderData -> XRayTraceIdHeaderData -> Bool
Eq, (forall x. XRayTraceIdHeaderData -> Rep XRayTraceIdHeaderData x)
-> (forall x. Rep XRayTraceIdHeaderData x -> XRayTraceIdHeaderData)
-> Generic XRayTraceIdHeaderData
forall x. Rep XRayTraceIdHeaderData x -> XRayTraceIdHeaderData
forall x. XRayTraceIdHeaderData -> Rep XRayTraceIdHeaderData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep XRayTraceIdHeaderData x -> XRayTraceIdHeaderData
$cfrom :: forall x. XRayTraceIdHeaderData -> Rep XRayTraceIdHeaderData x
Generic)
xrayTraceIdHeaderData :: XRayTraceId -> XRayTraceIdHeaderData
XRayTraceId
traceId = XRayTraceIdHeaderData :: XRayTraceId
-> Maybe XRaySegmentId -> Maybe Bool -> XRayTraceIdHeaderData
XRayTraceIdHeaderData
{ xrayTraceIdHeaderDataRootTraceId :: XRayTraceId
xrayTraceIdHeaderDataRootTraceId = XRayTraceId
traceId
, xrayTraceIdHeaderDataParentId :: Maybe XRaySegmentId
xrayTraceIdHeaderDataParentId = Maybe XRaySegmentId
forall a. Maybe a
Nothing
, xrayTraceIdHeaderDataSampled :: Maybe Bool
xrayTraceIdHeaderDataSampled = Maybe Bool
forall a. Maybe a
Nothing
}
parseXRayTraceIdHeaderData :: ByteString -> Maybe XRayTraceIdHeaderData
ByteString
rawHeader = do
[(ByteString, ByteString)]
components <- (ByteString -> Maybe (ByteString, ByteString))
-> [ByteString] -> Maybe [(ByteString, ByteString)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ByteString -> Maybe (ByteString, ByteString)
parseHeaderComponent ([ByteString] -> Maybe [(ByteString, ByteString)])
-> [ByteString] -> Maybe [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
BS8.split Char
';' ByteString
rawHeader
ByteString
traceId <- ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"Root" [(ByteString, ByteString)]
components
XRayTraceIdHeaderData -> Maybe XRayTraceIdHeaderData
forall (f :: * -> *) a. Applicative f => a -> f a
pure XRayTraceIdHeaderData :: XRayTraceId
-> Maybe XRaySegmentId -> Maybe Bool -> XRayTraceIdHeaderData
XRayTraceIdHeaderData
{ xrayTraceIdHeaderDataRootTraceId :: XRayTraceId
xrayTraceIdHeaderDataRootTraceId = Text -> XRayTraceId
XRayTraceId (ByteString -> Text
T.decodeUtf8 ByteString
traceId)
, xrayTraceIdHeaderDataParentId :: Maybe XRaySegmentId
xrayTraceIdHeaderDataParentId =
Text -> XRaySegmentId
XRaySegmentId (Text -> XRaySegmentId)
-> (ByteString -> Text) -> ByteString -> XRaySegmentId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> XRaySegmentId)
-> Maybe ByteString -> Maybe XRaySegmentId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"Parent" [(ByteString, ByteString)]
components
, xrayTraceIdHeaderDataSampled :: Maybe Bool
xrayTraceIdHeaderDataSampled = ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"Sampled" [(ByteString, ByteString)]
components Maybe ByteString -> (ByteString -> Maybe Bool) -> Maybe Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe Bool
readSampled
}
where
readSampled :: ByteString -> Maybe Bool
readSampled :: ByteString -> Maybe Bool
readSampled ByteString
"0" = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
readSampled ByteString
"1" = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
readSampled ByteString
_ = Maybe Bool
forall a. Maybe a
Nothing
makeXRayTraceIdHeaderValue :: XRayTraceIdHeaderData -> ByteString
XRayTraceIdHeaderData {Maybe Bool
Maybe XRaySegmentId
XRayTraceId
xrayTraceIdHeaderDataSampled :: Maybe Bool
xrayTraceIdHeaderDataParentId :: Maybe XRaySegmentId
xrayTraceIdHeaderDataRootTraceId :: XRayTraceId
xrayTraceIdHeaderDataSampled :: XRayTraceIdHeaderData -> Maybe Bool
xrayTraceIdHeaderDataParentId :: XRayTraceIdHeaderData -> Maybe XRaySegmentId
xrayTraceIdHeaderDataRootTraceId :: XRayTraceIdHeaderData -> XRayTraceId
..} =
ByteString
traceIdPart ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
parentPart ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sampledPart
where
traceIdPart :: ByteString
traceIdPart =
ByteString
"Root=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
T.encodeUtf8 (XRayTraceId -> Text
unXRayTraceId XRayTraceId
xrayTraceIdHeaderDataRootTraceId)
parentPart :: ByteString
parentPart = ByteString
-> (XRaySegmentId -> ByteString)
-> Maybe XRaySegmentId
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
ByteString
""
((ByteString
";Parent=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString)
-> (XRaySegmentId -> ByteString) -> XRaySegmentId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString)
-> (XRaySegmentId -> Text) -> XRaySegmentId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRaySegmentId -> Text
unXRaySegmentId)
Maybe XRaySegmentId
xrayTraceIdHeaderDataParentId
sampledPart :: ByteString
sampledPart = ByteString -> (Bool -> ByteString) -> Maybe Bool -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
ByteString
""
((ByteString
";Sampled=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString)
-> (Bool -> ByteString) -> Bool -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS8.pack (String -> ByteString) -> (Bool -> String) -> Bool -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Bool -> Int) -> Bool -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum)
Maybe Bool
xrayTraceIdHeaderDataSampled
parseHeaderComponent :: ByteString -> Maybe (ByteString, ByteString)
ByteString
rawComponent = case Char -> ByteString -> [ByteString]
BS8.split Char
'=' ByteString
rawComponent of
[ByteString
name, ByteString
value] -> (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
name, ByteString
value)
[ByteString]
_ -> Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing