{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_HADDOCK prune #-}

module Data.UTxO.Transaction.Cardano.Byron
    (
    -- * Initialization
      mkInit
    , mainnetMagic
    , testnetMagic

    -- * Constructing Primitives
    , mkInput
    , mkOutput
    , mkSignKey

    -- * Converting From Bases
    , fromBase16
    , fromBase58
    , fromBase64

    -- Internal
    , Byron
    , encodeCoinSel
    , decodeCoinSel
    , encodeTx
    , decodeTx
    ) where

import Cardano.Binary
    ( FromCBOR (..), ToCBOR (..) )
import Cardano.Chain.Common
    ( mkAttributes, mkLovelace )
import Cardano.Chain.UTxO
    ( TxIn (..), TxInWitness (..), TxOut (..), TxSigData (..), mkTxAux )
import Cardano.Crypto.Hashing
    ( AbstractHash (..), hash )
import Cardano.Crypto.ProtocolMagic
    ( ProtocolMagicId (..) )
import Cardano.Crypto.Signing
    ( SignTag (..), Signature, SigningKey (..), VerificationKey (..) )
import Cardano.Crypto.Wallet
    ( toXPub, xprv )
import Codec.CBOR.Read
    ( deserialiseFromBytes )
import Crypto.Error
    ( eitherCryptoError )
import Crypto.Hash
    ( Blake2b_256, digestFromByteString )
import Data.ByteArray.Encoding
    ( Base (..), convertFromBase )
import Data.ByteString
    ( ByteString )
import Data.ByteString.Base58
    ( bitcoinAlphabet, decodeBase58 )
import Data.Either.Extra
    ( eitherToMaybe )
import Data.List.NonEmpty
    ( NonEmpty, nonEmpty )
import Data.Text
    ( Text )
import Data.UTxO.Transaction
    ( ErrMkPayment (..), MkPayment (..) )
import Data.Word
    ( Word32 )
import GHC.Exts
    ( IsList (fromList) )
import Numeric.Natural
    ( Natural )

import qualified Cardano.Chain.UTxO as CC
import qualified Cardano.Crypto.Signing as CC
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Write as CBOR
import qualified Crypto.ECC.Edwards25519 as Ed25519
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

-- | Construct a payment 'Init' for /Byron/ from primitive types.
--
-- __examples__:
--
-- >>> mkInit 764824073 == mainnetMagic
-- True
--
-- >>> mkInit 1097911063 == testnetMagic
-- True
--
-- @since 1.0.0
mkInit
    :: Word32
        -- ^ A protocol magic id
    -> Init Byron
mkInit =
    ProtocolMagicId

-- | Pre-defined 'Init' magic for /Byron/ MainNet.
--
-- @since 1.0.0
mainnetMagic :: Init Byron
mainnetMagic = mkInit 764824073

-- | Pre-defined 'Init' magic for /Byron/ TestNet.
--
-- @since 1.0.0
testnetMagic :: Init Byron
testnetMagic = mkInit 1097911063

-- | Construct a payment 'Input' for /Byron/ from primitive types.
--
-- __example__:
--
-- >>> mkInput 14 =<< fromBase16 "3b402651...aad1c0b7"
-- Just (Input ...)
--
-- @since 1.0.0
mkInput
    :: Word32
        -- ^ Input index.
    -> ByteString
        -- ^ Input transaction id. See also: 'fromBase16'.
    -> Maybe (Input Byron)
mkInput ix bytes =
    case digestFromByteString @Blake2b_256 bytes of
        Just txId -> Just $ TxInUtxo (AbstractHash txId) ix
        Nothing -> Nothing

-- | Construct a payment 'Output' for /Byron/ from primitive types.
--
-- __example__:
--
-- >>> mkOutput 42 =<< fromBase58 "Ae2tdPwU...DnXy319f"
-- Just (Output ...)
--
-- @since 1.0.0
mkOutput
    :: Natural
        -- ^ Output value, in Lovelace (1 Ada = 1e6 Lovelace).
    -> ByteString
        -- ^ Output Address. See also: 'fromBase58'.
    -> Maybe (Output Byron)
mkOutput n bytes =
    case (fromCBOR' bytes, mkLovelace (fromIntegral n)) of
        (Right addr, Right coin) -> Just $ TxOut addr coin
        _ -> Nothing
  where
    fromCBOR' = fmap snd . deserialiseFromBytes fromCBOR .  BL.fromStrict

-- | Construct a 'SignKey' for /Byron/ from primitive types.
--
-- __example__:
--
-- >>> mkSignKey =<< fromBase16 "3b402651...aad1c0b7"
-- Just (SignKey ...)
--
-- @since 1.0.0
mkSignKey
    :: ByteString
        -- ^ A extended address private key and its chain code.
        -- The key __must be 96 bytes__ long, internally made of two concatenated parts:
        --
        -- @
        -- BYTES = PRV | CC
        -- PRV   = 64OCTET  # a 64 bytes Ed25519 extended private key
        -- CC    = 32OCTET  # a 32 bytes chain code
        -- @
        --
        -- See also: 'fromBase16'.
    -> Maybe (SignKey Byron)
mkSignKey bytes
    | BS.length bytes /= 96 = Nothing
    | otherwise = do
        let (prv, cc) = BS.splitAt 64 bytes
        pub <- ed25519ScalarMult (BS.take 32 prv)
        fmap SigningKey $ eitherToMaybe $ xprv $ prv <> pub <> cc
  where
    ed25519ScalarMult :: ByteString -> Maybe ByteString
    ed25519ScalarMult bs = do
        scalar <- eitherToMaybe $ eitherCryptoError $ Ed25519.scalarDecodeLong bs
        pure $ Ed25519.pointEncode $ Ed25519.toPoint scalar

--
-- ByteString Decoding
--

-- | Convert a base16 encoded 'Text' into a raw 'ByteString'
--
-- @since 1.0.0
fromBase16 :: Text -> Maybe ByteString
fromBase16 = eitherToMaybe . convertFromBase Base16 . T.encodeUtf8

-- | Convert a base58 encoded 'Text' into a raw 'ByteString'
--
-- @since 1.0.0
fromBase58 :: Text -> Maybe ByteString
fromBase58 = decodeBase58 bitcoinAlphabet . T.encodeUtf8


-- | Convert a base64 encoded 'Text' into a raw 'ByteString'
--
-- @since 1.0.0
fromBase64 :: Text -> Maybe ByteString
fromBase64 = eitherToMaybe . convertFromBase Base64 . T.encodeUtf8

--
-- MkPayment instance
--

-- Type-level constructor capturing types for 'Byron'.
data Byron

instance MkPayment Byron where
    type Init Byron = ProtocolMagicId

    type Input   Byron = TxIn
    type Output  Byron = TxOut
    type SignKey Byron = SigningKey

    type CoinSel Byron =
        (ProtocolMagicId, [TxIn], [TxOut])

    type Tx Byron = Either
        ErrMkPayment
        (ProtocolMagicId, NonEmpty TxIn, NonEmpty TxOut, TxSigData, [TxInWitness])

    empty :: ProtocolMagicId -> CoinSel Byron
    empty pm = (pm, mempty, mempty)

    addInput :: TxIn -> CoinSel Byron -> CoinSel Byron
    addInput inp (pm, inps, outs) = (pm, inp : inps, outs)

    addOutput :: TxOut -> CoinSel Byron -> CoinSel Byron
    addOutput out (pm, inps, outs) = (pm, inps, out : outs)

    lock :: CoinSel Byron -> Tx Byron
    lock (_pm, [], _outs) = Left MissingInput
    lock (_pm, _inps, []) = Left MissingOutput
    lock (pm, inps, outs) =
        Right (pm, neInps, neOuts, sigData, mempty)
      where
        sigData = TxSigData $ hash $ CC.UnsafeTx neInps neOuts (mkAttributes ())
        neInps  = NE.fromList $ reverse inps
        neOuts  = NE.fromList $ reverse outs

    signWith :: SigningKey -> Tx Byron -> Tx Byron
    signWith _ (Left e) = Left e
    signWith (SigningKey prv) (Right (pm, inps, outs, sigData, wits)) =
        Right (pm, inps, outs, sigData, VKWitness vk sig : wits)
      where
        vk :: VerificationKey
        vk = VerificationKey (toXPub prv)

        sig :: Signature TxSigData
        sig = CC.sign pm SignTx (SigningKey prv) sigData

    serialize :: Tx Byron -> Either ErrMkPayment ByteString
    serialize (Left e) = Left e
    serialize (Right (_pm, inps, outs, _sigData, wits))
        | NE.length inps /= length wits = Left MissingSignature
        | otherwise = Right $ CBOR.toStrictByteString $ toCBOR $ mkTxAux
            (CC.UnsafeTx inps outs (mkAttributes ()))
            (fromList $ reverse wits)


-- Internal
--
-- For running the Payment DSL as a command-line, we need to be able to produce
-- a text output representing the internal state.
--
-- There's no point about obfuscating this more than necessary; this should
-- remain mainly invisible to users if used properly through pipes. Yet, it can
-- be useful to have a human-friendly representation that is base16 or base64
-- encoded. Three possible obvious choice:
--
-- - CBOR, since most data above can already be serialized to CBOR
-- - JSON, instances exists on most type and are derived generically from CBOR
-- - Show, although here most types don't have a corresponding 'Read' instance.
--
-- Since we also need to decode an encoded state, CBOR will be path of least
-- resistance.

-- __Internal__: Encode a 'CoinSel Byron' to CBOR.
encodeCoinSel :: CoinSel Byron -> CBOR.Encoding
encodeCoinSel (pm, inps, outs) = mconcat
    [ toCBOR pm
    , CBOR.encodeListLenIndef
    , mconcat (toCBOR <$> inps)
    , CBOR.encodeBreak
    , CBOR.encodeListLenIndef
    , mconcat (toCBOR <$> outs)
    , CBOR.encodeBreak
    ]

-- __Internal__: Decode a 'CoinSel Byron' from CBOR.
decodeCoinSel :: CBOR.Decoder s (CoinSel Byron)
decodeCoinSel = (,,)
    <$> fromCBOR
    <*> decodeListIndef fromCBOR
    <*> decodeListIndef fromCBOR

-- __Internal__: Encode a 'Tx Byron' to CBOR.
encodeTx :: Tx Byron -> CBOR.Encoding
encodeTx (Left e) = mconcat
    [ CBOR.encodeWord8 0
    , CBOR.encodeString $ T.pack $ show e
    ]
encodeTx (Right (pm, inps, outs, sigData, wits)) = mconcat
    [ CBOR.encodeWord8 1
    , encodeCoinSel (pm, NE.toList inps, NE.toList outs)
    , toCBOR sigData
    , CBOR.encodeListLenIndef
    , mconcat (toCBOR <$> wits)
    , CBOR.encodeBreak
    ]

-- __Internal__: Decode a 'Tx Byron' from CBOR.
decodeTx :: CBOR.Decoder s (Tx Byron)
decodeTx = do
    CBOR.decodeWord8 >>= \case
        0 -> fmap T.unpack CBOR.decodeString >>= \case
            str | str == show MissingInput     -> pure $ Left MissingInput
            str | str == show MissingOutput    -> pure $ Left MissingOutput
            str | str == show MissingSignature -> pure $ Left MissingSignature
            _ -> fail $
                "Invalid error constructor found in 'Tx Byron'. Constructor must \
                \be one of: " <> unwords (show <$>
                    [ MissingInput, MissingOutput, MissingSignature])
        1 -> do
            (pm, inps, outs) <- decodeCoinSel
            sigData <- fromCBOR
            wits <- decodeListIndef fromCBOR
            case (nonEmpty inps, nonEmpty outs) of
                (Nothing, _) -> fail
                    "Empty list of inputs found in 'Tx Byron'. This is impossible \
                    \unless the data has been modified by hand."
                (_, Nothing) -> fail
                    "Empty list of outputs found in 'Tx Byron'. This is impossible \
                    \unless the data has been modified by hand."
                (Just neInps, Just neOuts) ->
                    pure $ Right (pm, neInps, neOuts, sigData, wits)

        _ -> fail
            "'Tx Byron' has been modified  with and is now invalid. The first \
            \byte must be either 0 or 1, followed by respectively an error \
            \constructor or constituants of the intermediate transaction."

-- __Internal__ Decode an arbitrary long list 'sandwiched' by markers.
decodeListIndef :: forall s a. CBOR.Decoder s a -> CBOR.Decoder s [a]
decodeListIndef decodeOne = do
    _ <- CBOR.decodeListLenIndef
    CBOR.decodeSequenceLenIndef (flip (:)) [] reverse decodeOne