ID.hs

module Effectful.OpenTelemetry.Tracing.Span.ID where

import Data.Aeson.Types (FromJSON (..), ToJSON (..), withText)
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Data.ByteString.Base16 qualified as Base16
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import System.Random.Extra (uniformIO)
import GHC.Generics (Generic)
import Proto3.Wire.Encode.Class qualified as Proto
import System.Random (Random (..), Uniform)
import System.Random.Stateful (Uniform (..), uniformByteStringM)
import Prelude hiding (length)

-- | A globally unique identifier of a span.
newtype ID = ID ByteString
    deriving stock (Generic)
    deriving newtype (Eq, Show)

length :: Int
length = 8

-- | Generate a random 'ID'.
new :: IO ID
new = uniformIO

-- | Encode an 'ID' to base-16.
-- The result is always 16 characters long.
toHex :: ID -> Text
toHex (ID bs) = Text.justifyRight (length * 2) '0' . Text.decodeUtf8 . Base16.encode $ bs

toBytes :: ID -> ByteString
toBytes (ID bs) = bs

fromBytes :: ByteString -> Either String ID
fromBytes bs
    | ByteString.length bs /= length = Left $ "Span ID must have exactly " <> show length <> " bytes"
    | ByteString.all (== 0) bs = Left "Span ID must not be all zero"
    | otherwise = Right $ ID bs

instance Uniform ID where
    uniformM g = do
        bs <- uniformByteStringM length g
        either (const $ uniformM g) pure $ fromBytes bs

instance Random ID where
    randomR _ = random

instance FromJSON ID where
    parseJSON = withText "ID" $ either fail pure . fromHex
      where
        fromHex :: Text -> Either String ID
        fromHex t = Base16.decode (Text.encodeUtf8 t) >>= fromBytes

instance ToJSON ID where
    toJSON = toJSON . toHex

instance {-# OVERLAPPING #-} Proto.EncodeField ID where
    encodeField n = Proto.byteString n . toBytes