{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  OpenTelemetry.Resource
-- Copyright   :  (c) Ian Duncan, 2021
-- License     :  BSD-3
-- Description :  Facilities for attaching metadata attributes to all spans in a trace
-- Maintainer  :  Ian Duncan
-- Stability   :  experimental
-- Portability :  non-portable (GHC extensions)
--
-- A Resource is an immutable representation of the entity producing
-- telemetry. For example, a process producing telemetry that is running in
-- a container on Kubernetes has a Pod name, it is in a namespace and
-- possibly is part of a Deployment which also has a name. All three of
-- these attributes can be included in the Resource.
--
-----------------------------------------------------------------------------
module OpenTelemetry.Resource where
import Data.Text (Text)
import Data.Int
import GHC.TypeLits
import Control.Monad.IO.Class
import System.Environment
import OpenTelemetry.Baggage (decodeBaggageHeader)
import qualified Data.ByteString.Char8 as B
import qualified OpenTelemetry.Baggage as Baggage
import qualified Data.HashMap.Strict as H
import Data.Text.Encoding (decodeUtf8)
import Data.Maybe (catMaybes)

data AttributeLimits = AttributeLimits
  { attributeCountLimit :: Maybe Int
  , attributeLengthLimit :: Maybe Int
  }

class ToPrimitiveAttribute a where
  toPrimitiveAttribute :: a -> PrimitiveAttribute

data Attribute
  = AttributeValue PrimitiveAttribute
  | AttributeArray [PrimitiveAttribute]
  deriving (Show)

data PrimitiveAttribute
  = TextAttribute Text
  | BoolAttribute Bool
  | DoubleAttribute Double
  | IntAttribute Int64
  deriving (Show)

class ToAttribute a where
  toAttribute :: a -> Attribute
  default toAttribute :: ToPrimitiveAttribute a => a -> Attribute
  toAttribute = AttributeValue . toPrimitiveAttribute

instance ToAttribute PrimitiveAttribute where
  toAttribute = AttributeValue

instance ToPrimitiveAttribute Text where
  toPrimitiveAttribute = TextAttribute
instance ToAttribute Text

instance ToPrimitiveAttribute Bool where
  toPrimitiveAttribute = BoolAttribute
instance ToAttribute Bool

instance ToPrimitiveAttribute Double where
  toPrimitiveAttribute = DoubleAttribute
instance ToAttribute Double

instance ToPrimitiveAttribute Int64 where
  toPrimitiveAttribute = IntAttribute
instance ToAttribute Int64

instance ToPrimitiveAttribute Int where
  toPrimitiveAttribute = IntAttribute . fromIntegral
instance ToAttribute Int

instance ToPrimitiveAttribute a => ToAttribute [a] where
  toAttribute = AttributeArray . map toPrimitiveAttribute

newtype Resource (schema :: Maybe Symbol) = Resource [(Text, Attribute)]

resourceAttributes :: Resource s -> [(Text, Attribute)]
resourceAttributes (Resource attrs) = attrs

-- Utility function to create a resource from a list
-- of fields and attributes. See the '.=' and '.=?' functions.
--
-- @since 0.0.1.0
mkResource :: [Maybe (Text, Attribute)] -> Resource r
mkResource = Resource . catMaybes

-- | Utility function to convert a required resource attribute
-- into the format needed for 'mkResource'.
(.=) :: ToAttribute a => Text -> a -> Maybe (Text, Attribute)
k .= v = Just (k, toAttribute v)

-- | Utility function to convert an optional resource attribute
-- into the format needed for 'mkResource'.
(.=?) :: ToAttribute a => Text -> Maybe a -> Maybe (Text, Attribute)
k .=? mv = (\k' v -> (k', toAttribute v)) k <$> mv
instance (s ~ ResourceMerge s s) => Semigroup (Resource s) where
  (<>) = mergeResources

instance (s ~ ResourceMerge s s) => Monoid (Resource s) where
  mempty = Resource []

data ResourceCreationParameters = ResourceCreationParameters
  {
  }

-- | Create a resource from list of attributes.
createResource :: [(Text, Attribute)] -> ResourceCreationParameters -> Resource s
createResource attrs _params = Resource attrs

-- | Static checks to prevent invalid resources from being merged.
--
-- According to the OpenTelemetry specification:
--
-- The interface MUST provide a way for an old resource and an
-- updating resource to be merged into a new resource.
--
-- Note: This is intended to be utilized for merging of resources whose attributes
-- come from different sources,
-- such as environment variables, or metadata extracted from the host or container.
--
-- The resulting resource MUST have all attributes that are on any of the two input resources.
-- If a key exists on both the old and updating resource, the value of the updating
-- resource MUST be picked (even if the updated value is empty).
--
-- The resulting resource will have the Schema URL calculated as follows:
--
-- - If the old resource's Schema URL is empty then the resulting resource's Schema
--   URL will be set to the Schema URL of the updating resource,
-- - Else if the updating resource's Schema URL is empty then the resulting
--   resource's Schema URL will be set to the Schema URL of the old resource,
-- - Else if the Schema URLs of the old and updating resources are the same then
--   that will be the Schema URL of the resulting resource,
-- - Else this is a merging error (this is the case when the Schema URL of the old
--   and updating resources are not empty and are different). The resulting resource is
--   undefined, and its contents are implementation-specific.
--
-- Required parameters:
--
-- - the old resource
-- - the updating resource whose attributes take precedence
type family ResourceMerge schemaLeft schemaRight :: Maybe Symbol where
  ResourceMerge 'Nothing 'Nothing = 'Nothing
  ResourceMerge 'Nothing ('Just s) = 'Just s
  ResourceMerge ('Just s) 'Nothing = 'Just s
  ResourceMerge ('Just s) ('Just s) = 'Just s

mergeResources :: Resource l -> Resource r -> Resource (ResourceMerge l r)
mergeResources (Resource l) (Resource r) = Resource (l <> r)

class ToResource a where
  type ResourceSchema a :: Maybe Symbol
  toResource :: a -> Resource (ResourceSchema a)

-- baggage format environment variables
getEnvVarResourceAttributes :: MonadIO m => m (Resource 'Nothing)
getEnvVarResourceAttributes = do
  mEnv <- liftIO $ lookupEnv "OTEL_RESOURCE_ATTRIBUTES"
  case mEnv of
    Nothing -> pure $ Resource []
    Just envVar -> case decodeBaggageHeader $ B.pack envVar of
      Left err -> do
        -- TODO logError
        liftIO $ putStrLn err
        pure $ Resource []
      Right ok ->
        pure
          $ Resource
          $ map (\(k, v) -> (decodeUtf8 $ Baggage.tokenValue k, toAttribute $ Baggage.value v))
          $ H.toList
          $ Baggage.values ok