{-# 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
  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
    (TypeRep -> FilePath -> Text -> GenesisCmdError
GenesisCmdGenesisFileDecodeError (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> TypeRep) -> Proxy a -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) 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
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)
  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 -> StakeReference -> Address ShelleyAddr
ShelleyAddress Network
network Credential 'Payment
paymentCredential StakeReference
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
  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
  :: 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
  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 (LedgerEra era))
-> ExceptT ProtocolParamsError IO (PParams (LedgerEra 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 (LedgerEra era))
 -> ExceptT ProtocolParamsError IO (PParams (LedgerEra era)))
-> (Either FilePath (PParams (LedgerEra era))
    -> ExceptT FilePath IO (PParams (LedgerEra era)))
-> Either FilePath (PParams (LedgerEra era))
-> ExceptT ProtocolParamsError IO (PParams (LedgerEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either FilePath (PParams (LedgerEra era))
-> ExceptT FilePath IO (PParams (LedgerEra era))
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either FilePath (PParams (LedgerEra era))
 -> ExceptT ProtocolParamsError IO (PParams (LedgerEra era)))
-> Either FilePath (PParams (LedgerEra era))
-> ExceptT ProtocolParamsError IO (PParams (LedgerEra era))
forall a b. (a -> b) -> a -> b
$
    Era era
-> (EraCommonConstraints era =>
    Either FilePath (PParams (LedgerEra era)))
-> Either FilePath (PParams (LedgerEra era))
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints (forall era. IsEra era => Era era
Exp.useEra @era) ((EraCommonConstraints era =>
  Either FilePath (PParams (LedgerEra era)))
 -> Either FilePath (PParams (LedgerEra era)))
-> (EraCommonConstraints era =>
    Either FilePath (PParams (LedgerEra era)))
-> Either FilePath (PParams (LedgerEra era))
forall a b. (a -> b) -> a -> b
$
      ByteString -> Either FilePath (PParams (LedgerEra era))
forall a. FromJSON a => ByteString -> Either FilePath a
A.eitherDecode' ByteString
pparams