{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- | TextEnvelope Serialisation
module Cardano.Api.Serialise.TextEnvelope.Internal
  ( HasTextEnvelope (..)
  , textEnvelopeTypeInEra
  , TextEnvelope (..)
  , TextEnvelopeType (..)
  , TextEnvelopeDescr (..)
  , textEnvelopeRawCBOR
  , TextEnvelopeError (..)
  , serialiseToTextEnvelope
  , deserialiseFromTextEnvelope
  , readFileTextEnvelope
  , writeFileTextEnvelope
  , writeFileTextEnvelopeWithOwnerPermissions
  , readTextEnvelopeFromFile
  , readTextEnvelopeOfTypeFromFile
  , textEnvelopeToJSON
  , serialiseTextEnvelope
  , legacyComparison
  , textEnvelopeTypeToEra

    -- * Reading one of several key types
  , FromSomeType (..)
  , deserialiseFromTextEnvelopeAnyOf
  , decodeTextEnvelopeJSON
  , deserialiseFromTextEnvelopeJSON
  , deserialiseFromTextEnvelopeJSONAnyOf
  , readFileTextEnvelopeAnyOf

    -- * Data family instances
  , AsType (..)
  )
where

import Cardano.Api.Era
import Cardano.Api.Error
import Cardano.Api.HasTypeProxy
import Cardano.Api.IO
import Cardano.Api.Internal.Orphans ()
import Cardano.Api.Pretty
import Cardano.Api.Serialise.Cbor

import Control.Monad (unless)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Control.Monad.Trans.Except.Extra (firstExceptT, hoistEither)
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder)
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.ByteString.Base16 qualified as Base16
import Data.ByteString.Lazy qualified as LBS
import Data.Data (Data)
import Data.List qualified as List
import Data.Maybe (fromMaybe)
import Data.String (IsString)
import Data.Text.Encoding qualified as Text

-- ----------------------------------------------------------------------------
-- Text envelopes
--

newtype TextEnvelopeType = TextEnvelopeType String
  deriving (Eq, Show, Data)
  deriving newtype (IsString, Semigroup, ToJSON, FromJSON)

newtype TextEnvelopeDescr = TextEnvelopeDescr String
  deriving (Eq, Show, Data)
  deriving newtype (IsString, Semigroup, ToJSON, FromJSON)

-- | A 'TextEnvelope' is a structured envelope for serialised binary values
-- with an external format with a semi-readable textual format.
--
-- It contains a \"type\" field, e.g. \"PublicKeyByron\" or \"TxSignedShelley\"
-- to indicate the type of the encoded data. This is used as a sanity check
-- and to help readers.
--
-- It also contains a \"title\" field which is free-form, and could be used
-- to indicate the role or purpose to a reader.
data TextEnvelope = TextEnvelope
  { teType :: !TextEnvelopeType
  , teDescription :: !TextEnvelopeDescr
  , teRawCBOR :: !ByteString
  }
  deriving (Eq, Show)

instance HasTypeProxy TextEnvelope where
  data AsType TextEnvelope = AsTextEnvelope
  proxyToAsType _ = AsTextEnvelope

instance ToJSON TextEnvelope where
  toJSON TextEnvelope{teType, teDescription, teRawCBOR} =
    object
      [ "type" .= teType
      , "description" .= teDescription
      , "cborHex" .= Text.decodeUtf8 (Base16.encode teRawCBOR)
      ]

instance FromJSON TextEnvelope where
  parseJSON = withObject "TextEnvelope" $ \v ->
    TextEnvelope
      <$> (v .: "type")
      <*> (v .: "description")
      <*> (parseJSONBase16 =<< v .: "cborHex")
   where
    parseJSONBase16 v =
      either fail return . Base16.decode . Text.encodeUtf8 =<< parseJSON v

textEnvelopeJsonConfig :: Config
textEnvelopeJsonConfig = defConfig{confCompare = textEnvelopeJsonKeyOrder}

textEnvelopeJsonKeyOrder :: Text -> Text -> Ordering
textEnvelopeJsonKeyOrder = keyOrder ["type", "description", "cborHex"]

textEnvelopeRawCBOR :: TextEnvelope -> ByteString
textEnvelopeRawCBOR = teRawCBOR

-- | The errors that the pure 'TextEnvelope' parsing\/decoding functions can return.
data TextEnvelopeError
  = -- | expected, actual
    TextEnvelopeTypeError ![TextEnvelopeType] !TextEnvelopeType
  | TextEnvelopeDecodeError !DecoderError
  | TextEnvelopeAesonDecodeError !String
  | TextEnvelopeUnknownKeyWitness !TextEnvelopeDescr
  | TextEnvelopeUnknownType !Text
  deriving (Eq, Show, Data)

instance Error TextEnvelopeError where
  prettyError = \case
    TextEnvelopeTypeError [TextEnvelopeType expType] (TextEnvelopeType actType) ->
      mconcat
        [ "TextEnvelope type error: "
        , " Expected: " <> pretty expType
        , " Actual: " <> pretty actType
        ]
    TextEnvelopeTypeError expTypes (TextEnvelopeType actType) ->
      mconcat
        [ "TextEnvelope type error: "
        , " Expected one of: "
        , mconcat $ List.intersperse ", " [pretty expType | TextEnvelopeType expType <- expTypes]
        , " Actual: " <> pretty actType
        ]
    TextEnvelopeAesonDecodeError decErr ->
      "TextEnvelope aeson decode error: " <> pretty decErr
    TextEnvelopeDecodeError decErr ->
      "TextEnvelope decode error: " <> pshow decErr
    TextEnvelopeUnknownKeyWitness desc ->
      "Unknown key witness specified: " <> pshow desc
    TextEnvelopeUnknownType unknownType ->
      "Unknown TextEnvelope type: " <> pretty unknownType

-- | Check that the \"type\" of the 'TextEnvelope' is as expected.
--
-- For example, one might check that the type is \"TxSignedShelley\".
expectTextEnvelopeOfType :: TextEnvelopeType -> TextEnvelope -> Either TextEnvelopeError ()
expectTextEnvelopeOfType expectedType TextEnvelope{teType = actualType} =
  unless (expectedType `legacyComparison` actualType) $
    Left (TextEnvelopeTypeError [expectedType] actualType)

-- | This is a backwards-compatibility patch to ensure that old envelopes
-- generated by 'serialiseTxLedgerCddl' can be deserialised after switching
-- to the 'serialiseToTextEnvelope'.
legacyComparison :: TextEnvelopeType -> TextEnvelopeType -> Bool
legacyComparison (TextEnvelopeType expectedType) (TextEnvelopeType actualType) =
  case (expectedType, actualType) of
    ("TxSignedShelley", "Witnessed Tx ShelleyEra") -> True
    ("Tx AllegraEra", "Witnessed Tx AllegraEra") -> True
    ("Tx MaryEra", "Witnessed Tx MaryEra") -> True
    ("Tx AlonzoEra", "Witnessed Tx AlonzoEra") -> True
    ("Tx BabbageEra", "Witnessed Tx BabbageEra") -> True
    ("Tx ConwayEra", "Witnessed Tx ConwayEra") -> True
    ("TxSignedShelley", "Unwitnessed Tx ShelleyEra") -> True
    ("Tx AllegraEra", "Unwitnessed Tx AllegraEra") -> True
    ("Tx MaryEra", "Unwitnessed Tx MaryEra") -> True
    ("Tx AlonzoEra", "Unwitnessed Tx AlonzoEra") -> True
    ("Tx BabbageEra", "Unwitnessed Tx BabbageEra") -> True
    ("Tx ConwayEra", "Unwitnessed Tx ConwayEra") -> True
    ("Certificate", "CertificateConway") -> True
    ("Certificate", "CertificateShelley") -> True
    (expectedOther, expectedActual) -> expectedOther == expectedActual

-- ----------------------------------------------------------------------------
-- Serialisation in text envelope format
--

class SerialiseAsCBOR a => HasTextEnvelope a where
  textEnvelopeType :: AsType a -> TextEnvelopeType

  textEnvelopeDefaultDescr :: a -> TextEnvelopeDescr
  textEnvelopeDefaultDescr _ = ""

textEnvelopeTypeInEra
  :: ()
  => HasTextEnvelope (f era)
  => CardanoEra era
  -> AsType (f era)
  -> TextEnvelopeType
textEnvelopeTypeInEra _ =
  textEnvelopeType

serialiseToTextEnvelope
  :: forall a
   . HasTextEnvelope a
  => Maybe TextEnvelopeDescr -> a -> TextEnvelope
serialiseToTextEnvelope mbDescr a =
  TextEnvelope
    { teType = textEnvelopeType ttoken
    , teDescription = fromMaybe (textEnvelopeDefaultDescr a) mbDescr
    , teRawCBOR = serialiseToCBOR a
    }
 where
  ttoken = asType :: AsType a

deserialiseFromTextEnvelope
  :: forall a
   . HasTextEnvelope a
  => TextEnvelope
  -> Either TextEnvelopeError a
deserialiseFromTextEnvelope te = do
  expectTextEnvelopeOfType (textEnvelopeType ttoken) te
  first TextEnvelopeDecodeError $
    deserialiseFromCBOR ttoken (teRawCBOR te) -- TODO: You have switched from CBOR to JSON
 where
  ttoken = asType :: AsType a

deserialiseFromTextEnvelopeAnyOf
  :: [FromSomeType HasTextEnvelope b]
  -> TextEnvelope
  -> Either TextEnvelopeError b
deserialiseFromTextEnvelopeAnyOf types te =
  case List.find matching types of
    Nothing ->
      Left (TextEnvelopeTypeError expectedTypes actualType)
    Just (FromSomeType ttoken f) ->
      first TextEnvelopeDecodeError $
        f <$> deserialiseFromCBOR ttoken (teRawCBOR te)
 where
  actualType = teType te
  expectedTypes =
    [ textEnvelopeType ttoken
    | FromSomeType ttoken _f <- types
    ]

  matching (FromSomeType ttoken _f) = textEnvelopeType ttoken `legacyComparison` actualType

-- | Decode a JSON-encoded 'TextEnvelope' from a strict 'ByteString' (UTF-8).
-- Returns 'TextEnvelopeAesonDecodeError' if the JSON parsing fails.
decodeTextEnvelopeJSON :: ByteString -> Either TextEnvelopeError TextEnvelope
decodeTextEnvelopeJSON bs =
  first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' bs

-- | Deserialise a value from a JSON-encoded text envelope 'ByteString' (UTF-8).
-- This performs no file I\/O. Returns 'TextEnvelopeAesonDecodeError' for JSON
-- parse failures, or downstream errors from 'deserialiseFromTextEnvelope' for
-- type mismatches and CBOR decoding failures.
deserialiseFromTextEnvelopeJSON
  :: HasTextEnvelope a
  => ByteString -> Either TextEnvelopeError a
deserialiseFromTextEnvelopeJSON bs =
  decodeTextEnvelopeJSON bs >>= deserialiseFromTextEnvelope

-- | Like 'deserialiseFromTextEnvelopeJSON' but accepts multiple target types.
-- This performs no file I\/O. Returns 'TextEnvelopeAesonDecodeError' for JSON
-- parse failures, or downstream errors from 'deserialiseFromTextEnvelopeAnyOf'
-- for type mismatches and CBOR decoding failures.
deserialiseFromTextEnvelopeJSONAnyOf
  :: [FromSomeType HasTextEnvelope b]
  -> ByteString
  -> Either TextEnvelopeError b
deserialiseFromTextEnvelopeJSONAnyOf types bs =
  decodeTextEnvelopeJSON bs >>= deserialiseFromTextEnvelopeAnyOf types

-- | Write a value to a file in the text envelope format.
--
-- Note that this does /not/ set conservative file permissions: the file is
-- created with the default permissions which should be restricted with `umask`. When writing sensitive data such as
-- signing keys, use 'writeFileTextEnvelopeWithOwnerPermissions' instead,
-- which tries to restrict access to the file owner where the platform
-- supports it (see its documentation for the exact guarantees).
writeFileTextEnvelope
  :: HasTextEnvelope a
  => File content Out
  -> Maybe TextEnvelopeDescr
  -> a
  -> IO (Either (FileError ()) ())
writeFileTextEnvelope outputFile mbDescr a =
  writeLazyByteStringFile outputFile (textEnvelopeToJSON mbDescr a)

-- | Like 'writeFileTextEnvelope', but the file is created so that only its
-- owner has access to it, to the extent the platform allows it:
--
-- * On POSIX systems, the file is created with @0600@ permissions (read
--   and write for the file owner only, further filtered by the process's
--   @umask@), and its ownership is set to the current (real) user. If the
--   file already exists, it is truncated, but its permission bits are
--   left unchanged.
--
-- * On Windows, the contents are written to a freshly created temporary
--   file which is then renamed to the target path. This guarantees the
--   file is owned by the current user, but no explicit ACL is set: the
--   file inherits the access control list of the target directory.
--
-- * On WASM, this is currently a no-op: no file is written at all.
--
-- Use this when writing sensitive data such as signing keys.
writeFileTextEnvelopeWithOwnerPermissions
  :: HasTextEnvelope a
  => File content Out
  -> Maybe TextEnvelopeDescr
  -> a
  -> IO (Either (FileError ()) ())
writeFileTextEnvelopeWithOwnerPermissions outputFile mbDescr a =
  writeLazyByteStringFileWithOwnerPermissions outputFile (textEnvelopeToJSON mbDescr a)

textEnvelopeToJSON :: HasTextEnvelope a => Maybe TextEnvelopeDescr -> a -> LBS.ByteString
textEnvelopeToJSON mbDescr a =
  serialiseTextEnvelope $ serialiseToTextEnvelope mbDescr a

-- | Serialise text envelope to pretty JSON
serialiseTextEnvelope :: TextEnvelope -> LBS.ByteString
serialiseTextEnvelope te = encodePretty' textEnvelopeJsonConfig te <> "\n"

readFileTextEnvelope
  :: HasTextEnvelope a
  => File content In
  -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope path =
  runExceptT $ do
    content <- fileIOExceptT (unFile path) readFileBlocking
    firstExceptT (FileError (unFile path)) $
      hoistEither $
        deserialiseFromTextEnvelopeJSON content

readFileTextEnvelopeAnyOf
  :: [FromSomeType HasTextEnvelope b]
  -> File content In
  -> IO (Either (FileError TextEnvelopeError) b)
readFileTextEnvelopeAnyOf types path =
  runExceptT $ do
    content <- fileIOExceptT (unFile path) readFileBlocking
    firstExceptT (FileError (unFile path)) $
      hoistEither $
        deserialiseFromTextEnvelopeJSONAnyOf types content

readTextEnvelopeFromFile
  :: FilePath
  -> IO (Either (FileError TextEnvelopeError) TextEnvelope)
readTextEnvelopeFromFile path =
  runExceptT $ do
    bs <- fileIOExceptT path readFileBlocking
    firstExceptT (FileError path . TextEnvelopeAesonDecodeError)
      . hoistEither
      $ Aeson.eitherDecodeStrict' bs

readTextEnvelopeOfTypeFromFile
  :: TextEnvelopeType
  -> FilePath
  -> IO (Either (FileError TextEnvelopeError) TextEnvelope)
readTextEnvelopeOfTypeFromFile expectedType path =
  runExceptT $ do
    te <- ExceptT (readTextEnvelopeFromFile path)
    firstExceptT (FileError path) $
      hoistEither $
        expectTextEnvelopeOfType expectedType te
    return te

textEnvelopeTypeToEra :: Text -> Either TextEnvelopeError AnyShelleyBasedEra
textEnvelopeTypeToEra =
  \case
    "TxSignedShelley" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley
    "Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra
    "Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary
    "Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
    "Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage
    "Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway
    "Witnessed Tx ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley
    "Witnessed Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra
    "Witnessed Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary
    "Witnessed Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
    "Witnessed Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage
    "Witnessed Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway
    "Unwitnessed Tx ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley
    "Unwitnessed Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra
    "Unwitnessed Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary
    "Unwitnessed Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
    "Unwitnessed Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage
    "Unwitnessed Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway
    "TxWitness ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley
    "TxWitness AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra
    "TxWitness MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary
    "TxWitness AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
    "TxWitness BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage
    "TxWitness ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway
    unknownCddlType -> Left $ TextEnvelopeUnknownType unknownCddlType
