{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.CLI.EraBased.Genesis.Internal.Common
  ( decodeShelleyGenesisFile
  , decodeAlonzoGenesisFile
  , decodeConwayGenesisFile
  , decodeDijkstraGenesisFile
  , genStuffedAddress
  , getCurrentTimePlus30
  , readRelays

    -- * Protocol Parameters
  , readProtocolParameters
  )
where

import Cardano.Api hiding (ConwayEra, HashAlgorithm)
import Cardano.Api.Experimental (obtainCommonConstraints)
import Cardano.Api.Experimental qualified as Exp
import Cardano.Api.Ledger (AlonzoGenesis, ConwayGenesis)
import Cardano.Api.Ledger qualified as L

import Cardano.CLI.Type.Common
import Cardano.CLI.Type.Error.GenesisCmdError
import Cardano.CLI.Type.Error.ProtocolParamsError
import Cardano.Crypto.Hash (HashAlgorithm)
import Cardano.Crypto.Hash qualified as Hash
import Cardano.Crypto.Random qualified as Crypto
import Cardano.Ledger.Dijkstra.Genesis (DijkstraGenesis (..))

import Data.Aeson qualified as A
import Data.Binary.Get qualified as Bin
import Data.ByteString (ByteString)
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Coerce (coerce)
import Data.Map.Strict (Map)
import Data.Text qualified as Text
import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
import Data.Typeable
import Data.Word (Word64)

import Crypto.Random (getRandomBytes)

decodeShelleyGenesisFile
  :: MonadIOTransError GenesisCmdError t m
  => FilePath
  -> t m ShelleyGenesis
decodeShelleyGenesisFile :: forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisCmdError t m =>
FilePath -> t m ShelleyGenesis
decodeShelleyGenesisFile = (ByteString -> Either FilePath ShelleyGenesis)
-> FilePath -> t m ShelleyGenesis
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(Typeable a, MonadIOTransError GenesisCmdError t m) =>
(ByteString -> Either FilePath a) -> FilePath -> t m a
readAndDecodeGenesisFileWith ByteString -> Either FilePath ShelleyGenesis
forall a. FromJSON a => ByteString -> Either FilePath a
A.eitherDecode

-- | Decode Alonzo Genesis file. See 'Cardano.Api.Genesis.decodeAlonzoGenesis' haddocks for details.
decodeAlonzoGenesisFile
  :: MonadIOTransError GenesisCmdError t m
  => FilePath
  -> t m AlonzoGenesis
decodeAlonzoGenesisFile :: forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisCmdError t m =>
FilePath -> t m AlonzoGenesis
decodeAlonzoGenesisFile = (ByteString -> Either FilePath AlonzoGenesis)
-> FilePath -> t m AlonzoGenesis
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(Typeable a, MonadIOTransError GenesisCmdError t m) =>
(ByteString -> Either FilePath a) -> FilePath -> t m a
readAndDecodeGenesisFileWith ByteString -> Either FilePath AlonzoGenesis
forall a. FromJSON a => ByteString -> Either FilePath a
A.eitherDecode

decodeConwayGenesisFile
  :: MonadIOTransError GenesisCmdError t m
  => FilePath
  -> t m ConwayGenesis
decodeConwayGenesisFile :: forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisCmdError t m =>
FilePath -> t m ConwayGenesis
decodeConwayGenesisFile = (ByteString -> Either FilePath ConwayGenesis)
-> FilePath -> t m ConwayGenesis
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(Typeable a, MonadIOTransError GenesisCmdError t m) =>
(ByteString -> Either FilePath a) -> FilePath -> t m a
readAndDecodeGenesisFileWith ByteString -> Either FilePath ConwayGenesis
forall a. FromJSON a => ByteString -> Either FilePath a
A.eitherDecode

decodeDijkstraGenesisFile
  :: MonadIOTransError GenesisCmdError t m
  => FilePath
  -> t m DijkstraGenesis
decodeDijkstraGenesisFile :: forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisCmdError t m =>
FilePath -> t m DijkstraGenesis
decodeDijkstraGenesisFile = (ByteString -> Either FilePath DijkstraGenesis)
-> FilePath -> t m DijkstraGenesis
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(Typeable a, MonadIOTransError GenesisCmdError t m) =>
(ByteString -> Either FilePath a) -> FilePath -> t m a
readAndDecodeGenesisFileWith ByteString -> Either FilePath DijkstraGenesis
forall a. FromJSON a => ByteString -> Either FilePath a
A.eitherDecode

readAndDecodeGenesisFileWith
  :: forall t m a
   . Typeable a
  => MonadIOTransError GenesisCmdError t m
  => (LBS.ByteString -> Either String a)
  -> FilePath
  -> t m a
readAndDecodeGenesisFileWith :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(Typeable a, MonadIOTransError GenesisCmdError t m) =>
(ByteString -> Either FilePath a) -> FilePath -> t m a
readAndDecodeGenesisFileWith ByteString -> Either FilePath a
decode' FilePath
fpath = do
  lbs <-
    (IOException -> GenesisCmdError) -> m ByteString -> t m ByteString
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
(MonadIOTransError e' t m, Exception e) =>
(e -> e') -> m a -> t m a
handleIOExceptionsLiftWith (FileError () -> GenesisCmdError
GenesisCmdGenesisFileError (FileError () -> GenesisCmdError)
-> (IOException -> FileError ()) -> IOException -> GenesisCmdError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOException -> FileError ()
forall e. FilePath -> IOException -> FileError e
FileIOError FilePath
fpath) (m ByteString -> t m ByteString)
-> (IO ByteString -> m ByteString)
-> IO ByteString
-> t m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> t m ByteString)
-> IO ByteString -> t m ByteString
forall a b. (a -> b) -> a -> b
$
      FilePath -> IO ByteString
LBS.readFile
        FilePath
fpath
  modifyError
    (GenesisCmdGenesisFileDecodeError (typeRep $ Proxy @a) fpath . Text.pack)
    . hoistEither
    $ decode' lbs

genStuffedAddress :: L.Network -> IO (AddressInEra ShelleyEra)
genStuffedAddress :: Network -> IO (AddressInEra ShelleyEra)
genStuffedAddress Network
network = do
  paymentCredential <-
    KeyHash 'Payment -> Credential 'Payment
forall (kr :: KeyRole). KeyHash kr -> Credential kr
L.KeyHashObj (KeyHash 'Payment -> Credential 'Payment)
-> (ByteString -> KeyHash 'Payment)
-> ByteString
-> Credential 'Payment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> KeyHash 'Payment
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash (Int -> KeyHash 'Payment)
-> (ByteString -> Int) -> ByteString -> KeyHash 'Payment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
read64BitInt (ByteString -> Credential 'Payment)
-> IO ByteString -> IO (Credential 'Payment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SecureRandom ByteString -> IO ByteString
forall a. SecureRandom a -> IO a
Crypto.runSecureRandom (Int -> SecureRandom ByteString
forall byteArray.
ByteArray byteArray =>
Int -> SecureRandom byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
8)
  pure . shelleyAddressInEra ShelleyBasedEraShelley $
    ShelleyAddress network paymentCredential L.StakeRefNull
 where
  read64BitInt :: ByteString -> Int
  read64BitInt :: ByteString -> Int
read64BitInt =
    (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word64 -> Int)
      (Word64 -> Int) -> (ByteString -> Word64) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get Word64 -> ByteString -> Word64
forall a. Get a -> ByteString -> a
Bin.runGet Get Word64
Bin.getWord64le
      (ByteString -> Word64)
-> (ByteString -> ByteString) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict

  mkDummyHash :: forall h a. HashAlgorithm h => Proxy h -> Int -> Hash.Hash h a
  mkDummyHash :: forall h a. HashAlgorithm h => Proxy h -> Int -> Hash h a
mkDummyHash Proxy h
_ = Hash h Int -> Hash h a
forall a b. Coercible a b => a -> b
coerce (Hash h Int -> Hash h a) -> (Int -> Hash h Int) -> Int -> Hash h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
L.hashWithSerialiser @h Int -> Encoding
forall a. ToCBOR a => a -> Encoding
L.toCBOR

  mkKeyHash :: forall discriminator. Int -> L.KeyHash discriminator
  mkKeyHash :: forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash = Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash discriminator
forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
L.KeyHash (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash discriminator)
-> (Int -> Hash ADDRHASH (VerKeyDSIGN DSIGN))
-> Int
-> KeyHash discriminator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy ADDRHASH -> Int -> Hash ADDRHASH (VerKeyDSIGN DSIGN)
forall h a. HashAlgorithm h => Proxy h -> Int -> Hash h a
mkDummyHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @L.ADDRHASH)

-- | Current UTCTime plus 30 seconds
getCurrentTimePlus30 :: MonadIO m => m UTCTime
getCurrentTimePlus30 :: forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTimePlus30 =
  UTCTime -> UTCTime
plus30sec (UTCTime -> UTCTime) -> m UTCTime -> m UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
 where
  plus30sec :: UTCTime -> UTCTime
  plus30sec :: UTCTime -> UTCTime
plus30sec = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
30 :: NominalDiffTime)

-- @readRelays fp@ reads the relays specification from a file
readRelays
  :: ()
  => MonadIO m
  => FilePath
  -- ^ The file to read from
  -> ExceptT GenesisCmdError m (Map Word [L.StakePoolRelay])
readRelays :: forall (m :: * -> *).
MonadIO m =>
FilePath -> ExceptT GenesisCmdError m (Map Word [StakePoolRelay])
readRelays FilePath
fp = do
  relaySpecJsonBs <-
    (IOException -> GenesisCmdError)
-> IO ByteString -> ExceptT GenesisCmdError m ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FilePath -> IOException -> GenesisCmdError
GenesisCmdStakePoolRelayFileError FilePath
fp) (FilePath -> IO ByteString
LBS.readFile FilePath
fp)
  firstExceptT (GenesisCmdStakePoolRelayJsonDecodeError fp)
    . hoistEither
    $ A.eitherDecode relaySpecJsonBs

-- TODO: eliminate this and get only the necessary params, and get them in a more
-- helpful way rather than requiring them as a local file.
readProtocolParameters
  :: forall era
   . Exp.IsEra era
  => ProtocolParamsFile
  -> ExceptT ProtocolParamsError IO (L.PParams (Exp.LedgerEra era))
readProtocolParameters :: forall era.
IsEra era =>
ProtocolParamsFile
-> ExceptT ProtocolParamsError IO (PParams (LedgerEra era))
readProtocolParameters (ProtocolParamsFile FilePath
fpath) = do
  pparams <- (IOException -> ProtocolParamsError)
-> IO ByteString -> ExceptT ProtocolParamsError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ProtocolParamsError
ProtocolParamsErrorFile (FileError () -> ProtocolParamsError)
-> (IOException -> FileError ())
-> IOException
-> ProtocolParamsError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOException -> FileError ()
forall e. FilePath -> IOException -> FileError e
FileIOError FilePath
fpath) (IO ByteString -> ExceptT ProtocolParamsError IO ByteString)
-> IO ByteString -> ExceptT ProtocolParamsError IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
LBS.readFile FilePath
fpath
  firstExceptT (ProtocolParamsErrorJSON fpath . Text.pack) . hoistEither $
    obtainCommonConstraints (Exp.useEra @era) $
      A.eitherDecode' pparams