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

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

    -- * Protocol Parameters
  , readProtocolParameters
  )
where

import           Cardano.Api hiding (ConwayEra)
import           Cardano.Api.Ledger (AlonzoGenesis, ConwayGenesis, StandardCrypto)
import qualified Cardano.Api.Ledger as L
import           Cardano.Api.Shelley (ShelleyGenesis, ShelleyLedgerEra, decodeAlonzoGenesis)

import           Cardano.CLI.Types.Common
import           Cardano.CLI.Types.Errors.GenesisCmdError
import           Cardano.CLI.Types.Errors.ProtocolParamsError
import           Cardano.Crypto.Hash (HashAlgorithm)
import qualified Cardano.Crypto.Hash as Hash
import qualified Cardano.Crypto.Random as Crypto

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

import           Crypto.Random (getRandomBytes)

decodeShelleyGenesisFile
  :: MonadIOTransError GenesisCmdError t m
  => FilePath
  -> t m (ShelleyGenesis StandardCrypto)
decodeShelleyGenesisFile :: forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisCmdError t m =>
FilePath -> t m (ShelleyGenesis StandardCrypto)
decodeShelleyGenesisFile = (ByteString -> Either FilePath (ShelleyGenesis StandardCrypto))
-> FilePath -> t m (ShelleyGenesis StandardCrypto)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIOTransError GenesisCmdError t m =>
(ByteString -> Either FilePath a) -> FilePath -> t m a
readAndDecodeGenesisFileWith ByteString -> Either FilePath (ShelleyGenesis StandardCrypto)
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
  => Maybe (CardanoEra era)
  -- ^ Optional era in which we're decoding alonzo genesis.
  -> FilePath
  -> t m AlonzoGenesis
decodeAlonzoGenesisFile :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) era.
MonadIOTransError GenesisCmdError t m =>
Maybe (CardanoEra era) -> FilePath -> t m AlonzoGenesis
decodeAlonzoGenesisFile Maybe (CardanoEra era)
mEra = (ByteString -> Either FilePath AlonzoGenesis)
-> FilePath -> t m AlonzoGenesis
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIOTransError GenesisCmdError t m =>
(ByteString -> Either FilePath a) -> FilePath -> t m a
readAndDecodeGenesisFileWith (Except FilePath AlonzoGenesis -> Either FilePath AlonzoGenesis
forall e a. Except e a -> Either e a
runExcept (Except FilePath AlonzoGenesis -> Either FilePath AlonzoGenesis)
-> (ByteString -> Except FilePath AlonzoGenesis)
-> ByteString
-> Either FilePath AlonzoGenesis
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (CardanoEra era)
-> ByteString -> Except FilePath AlonzoGenesis
forall era (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadTransError FilePath t m =>
Maybe (CardanoEra era) -> ByteString -> t m AlonzoGenesis
decodeAlonzoGenesis Maybe (CardanoEra era)
mEra)

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

readAndDecodeGenesisFileWith
  :: MonadIOTransError GenesisCmdError t m
  => (LBS.ByteString -> Either String a)
  -> FilePath
  -> t m a
readAndDecodeGenesisFileWith :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIOTransError GenesisCmdError t m =>
(ByteString -> Either FilePath a) -> FilePath -> t m a
readAndDecodeGenesisFileWith ByteString -> Either FilePath a
decode' FilePath
fpath = do
  ByteString
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
  (FilePath -> GenesisCmdError) -> ExceptT FilePath m a -> t m a
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError (FilePath -> Text -> GenesisCmdError
GenesisCmdGenesisFileDecodeError FilePath
fpath (Text -> GenesisCmdError)
-> (FilePath -> Text) -> FilePath -> GenesisCmdError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack)
    (ExceptT FilePath m a -> t m a)
-> (Either FilePath a -> ExceptT FilePath m a)
-> Either FilePath a
-> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either FilePath a -> ExceptT FilePath m a
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither
    (Either FilePath a -> t m a) -> Either FilePath a -> t m a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath a
decode' ByteString
lbs

genStuffedAddress :: L.Network -> IO (AddressInEra ShelleyEra)
genStuffedAddress :: Network -> IO (AddressInEra ShelleyEra)
genStuffedAddress Network
network = do
  Credential 'Payment StandardCrypto
paymentCredential <-
    KeyHash 'Payment StandardCrypto
-> Credential 'Payment StandardCrypto
forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
L.KeyHashObj (KeyHash 'Payment StandardCrypto
 -> Credential 'Payment StandardCrypto)
-> (ByteString -> KeyHash 'Payment StandardCrypto)
-> ByteString
-> Credential 'Payment StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> KeyHash 'Payment StandardCrypto
forall c (discriminator :: KeyRole).
Crypto c =>
Int -> KeyHash discriminator c
mkKeyHash (Int -> KeyHash 'Payment StandardCrypto)
-> (ByteString -> Int)
-> ByteString
-> KeyHash 'Payment StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
read64BitInt (ByteString -> Credential 'Payment StandardCrypto)
-> IO ByteString -> IO (Credential 'Payment StandardCrypto)
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)
  AddressInEra ShelleyEra -> IO (AddressInEra ShelleyEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AddressInEra ShelleyEra -> IO (AddressInEra ShelleyEra))
-> (Address ShelleyAddr -> AddressInEra ShelleyEra)
-> Address ShelleyAddr
-> IO (AddressInEra ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra ShelleyEra
-> Address ShelleyAddr -> AddressInEra ShelleyEra
forall era.
ShelleyBasedEra era -> Address ShelleyAddr -> AddressInEra era
shelleyAddressInEra ShelleyBasedEra ShelleyEra
ShelleyBasedEraShelley (Address ShelleyAddr -> IO (AddressInEra ShelleyEra))
-> Address ShelleyAddr -> IO (AddressInEra ShelleyEra)
forall a b. (a -> b) -> a -> b
$
    Network
-> Credential 'Payment StandardCrypto
-> StakeReference StandardCrypto
-> Address ShelleyAddr
ShelleyAddress Network
network Credential 'Payment StandardCrypto
paymentCredential StakeReference StandardCrypto
forall c. StakeReference c
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 c discriminator. L.Crypto c => Int -> L.KeyHash discriminator c
  mkKeyHash :: forall c (discriminator :: KeyRole).
Crypto c =>
Int -> KeyHash discriminator c
mkKeyHash = Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
-> KeyHash discriminator c
forall (discriminator :: KeyRole) c.
Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
-> KeyHash discriminator c
L.KeyHash (Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
 -> KeyHash discriminator c)
-> (Int -> Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c)))
-> Int
-> KeyHash discriminator c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (ADDRHASH c)
-> Int -> Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
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 c))

-- | 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
  ByteString
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)
  (FilePath -> GenesisCmdError)
-> ExceptT FilePath m (Map Word [StakePoolRelay])
-> ExceptT GenesisCmdError m (Map Word [StakePoolRelay])
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (FilePath -> FilePath -> GenesisCmdError
GenesisCmdStakePoolRelayJsonDecodeError FilePath
fp)
    (ExceptT FilePath m (Map Word [StakePoolRelay])
 -> ExceptT GenesisCmdError m (Map Word [StakePoolRelay]))
-> (Either FilePath (Map Word [StakePoolRelay])
    -> ExceptT FilePath m (Map Word [StakePoolRelay]))
-> Either FilePath (Map Word [StakePoolRelay])
-> ExceptT GenesisCmdError m (Map Word [StakePoolRelay])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either FilePath (Map Word [StakePoolRelay])
-> ExceptT FilePath m (Map Word [StakePoolRelay])
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither
    (Either FilePath (Map Word [StakePoolRelay])
 -> ExceptT GenesisCmdError m (Map Word [StakePoolRelay]))
-> Either FilePath (Map Word [StakePoolRelay])
-> ExceptT GenesisCmdError m (Map Word [StakePoolRelay])
forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath (Map Word [StakePoolRelay])
forall a. FromJSON a => ByteString -> Either FilePath a
A.eitherDecode ByteString
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
  :: ()
  => ShelleyBasedEra era
  -> ProtocolParamsFile
  -> ExceptT ProtocolParamsError IO (L.PParams (ShelleyLedgerEra era))
readProtocolParameters :: forall era.
ShelleyBasedEra era
-> ProtocolParamsFile
-> ExceptT ProtocolParamsError IO (PParams (ShelleyLedgerEra era))
readProtocolParameters ShelleyBasedEra era
sbe (ProtocolParamsFile FilePath
fpath) = do
  ByteString
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
  (FilePath -> ProtocolParamsError)
-> ExceptT FilePath IO (PParams (ShelleyLedgerEra era))
-> ExceptT ProtocolParamsError IO (PParams (ShelleyLedgerEra era))
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (FilePath -> Text -> ProtocolParamsError
ProtocolParamsErrorJSON FilePath
fpath (Text -> ProtocolParamsError)
-> (FilePath -> Text) -> FilePath -> ProtocolParamsError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack) (ExceptT FilePath IO (PParams (ShelleyLedgerEra era))
 -> ExceptT ProtocolParamsError IO (PParams (ShelleyLedgerEra era)))
-> (Either FilePath (PParams (ShelleyLedgerEra era))
    -> ExceptT FilePath IO (PParams (ShelleyLedgerEra era)))
-> Either FilePath (PParams (ShelleyLedgerEra era))
-> ExceptT ProtocolParamsError IO (PParams (ShelleyLedgerEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either FilePath (PParams (ShelleyLedgerEra era))
-> ExceptT FilePath IO (PParams (ShelleyLedgerEra era))
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either FilePath (PParams (ShelleyLedgerEra era))
 -> ExceptT ProtocolParamsError IO (PParams (ShelleyLedgerEra era)))
-> Either FilePath (PParams (ShelleyLedgerEra era))
-> ExceptT ProtocolParamsError IO (PParams (ShelleyLedgerEra era))
forall a b. (a -> b) -> a -> b
$
    ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era =>
    Either FilePath (PParams (ShelleyLedgerEra era)))
-> Either FilePath (PParams (ShelleyLedgerEra era))
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era =>
  Either FilePath (PParams (ShelleyLedgerEra era)))
 -> Either FilePath (PParams (ShelleyLedgerEra era)))
-> (ShelleyBasedEraConstraints era =>
    Either FilePath (PParams (ShelleyLedgerEra era)))
-> Either FilePath (PParams (ShelleyLedgerEra era))
forall a b. (a -> b) -> a -> b
$
      ByteString -> Either FilePath (PParams (ShelleyLedgerEra era))
forall a. FromJSON a => ByteString -> Either FilePath a
A.eitherDecode' ByteString
pparams