{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}

#if !defined(mingw32_HOST_OS)
#define UNIX
#endif

module Bcc.CLI.Cole.Genesis
  ( ColeGenesisError(..)
  , GenesisParameters(..)
  , NewDirectory(..)
  , dumpGenesis
  , mkGenesis
  , readGenesis
  , renderColeGenesisError
  )
where

import           Bcc.Prelude hiding (option, show, trace)
import           Prelude (String)

import           Control.Monad.Trans.Except.Extra (firstExceptT, left, right)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LB
import qualified Data.Map.Strict as Map
import           Data.Text.Lazy.Builder (toLazyText)
import           Data.Time (UTCTime)
import           Formatting.Buildable
import           Text.Printf (printf)

import           System.Directory (createDirectory, doesPathExist)
import           System.FilePath ((</>))
#ifdef UNIX
import           System.Posix.Files (ownerReadMode, setFileMode)
#else
import           System.Directory (emptyPermissions, readable, setPermissions)
#endif
import           Bcc.Api (Key (..), NetworkId)
import           Bcc.Api.Cole (ColeKey, SerialiseAsRawBytes (..), SigningKey (..),
                     toColeRequiresNetworkMagic)

import qualified Bcc.Chain.Common as Common
import           Bcc.Chain.Delegation hiding (Map, epoch)
import           Bcc.Chain.Genesis (GeneratedSecrets (..))
import qualified Bcc.Chain.Genesis as Genesis
import qualified Bcc.Chain.UTxO as UTxO

import qualified Bcc.Crypto as Crypto

import           Bcc.CLI.Cole.Delegation
import           Bcc.CLI.Cole.Key
import           Bcc.CLI.Helpers (textShow)
import           Bcc.CLI.Types (GenesisFile (..))

data ColeGenesisError
  = ColeDelegationCertSerializationError !ColeDelegationError
  | ColeDelegationKeySerializationError ColeDelegationError
  | GenesisGenerationError !Genesis.GenesisDataGenerationError
  | GenesisOutputDirAlreadyExists FilePath
  | GenesisReadError !FilePath !Genesis.GenesisDataError
  | GenesisSpecError !Text
  | MakeGenesisDelegationError !Genesis.GenesisDelegationError
  | NoGenesisDelegationForKey !Text
  | ProtocolParametersParseFailed !FilePath !Text
  | PoorKeyFailure !ColeKeyFailure

  deriving Int -> ColeGenesisError -> ShowS
[ColeGenesisError] -> ShowS
ColeGenesisError -> String
(Int -> ColeGenesisError -> ShowS)
-> (ColeGenesisError -> String)
-> ([ColeGenesisError] -> ShowS)
-> Show ColeGenesisError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColeGenesisError] -> ShowS
$cshowList :: [ColeGenesisError] -> ShowS
show :: ColeGenesisError -> String
$cshow :: ColeGenesisError -> String
showsPrec :: Int -> ColeGenesisError -> ShowS
$cshowsPrec :: Int -> ColeGenesisError -> ShowS
Show

renderColeGenesisError :: ColeGenesisError -> Text
renderColeGenesisError :: ColeGenesisError -> Text
renderColeGenesisError ColeGenesisError
err =
  case ColeGenesisError
err of
    ProtocolParametersParseFailed String
pParamFp Text
parseError ->
      Text
"Protocol parameters parse failed at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
textShow String
pParamFp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
parseError
    ColeDelegationCertSerializationError ColeDelegationError
bDelegSerErr ->
      Text
"Error while serializing the delegation certificate: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ColeDelegationError -> Text
forall a. Show a => a -> Text
textShow ColeDelegationError
bDelegSerErr
    ColeDelegationKeySerializationError ColeDelegationError
bKeySerErr ->
      Text
"Error while serializing the delegation key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ColeDelegationError -> Text
forall a. Show a => a -> Text
textShow ColeDelegationError
bKeySerErr
    PoorKeyFailure ColeKeyFailure
bKeyFailure ->
      Text
"Error creating poor keys: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ColeKeyFailure -> Text
forall a. Show a => a -> Text
textShow ColeKeyFailure
bKeyFailure
    MakeGenesisDelegationError GenesisDelegationError
genDelegError ->
      Text
"Error creating genesis delegation: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GenesisDelegationError -> Text
forall a. Show a => a -> Text
textShow GenesisDelegationError
genDelegError
    GenesisGenerationError GenesisDataGenerationError
genDataGenError ->
      Text
"Error generating genesis: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GenesisDataGenerationError -> Text
forall a. Show a => a -> Text
textShow GenesisDataGenerationError
genDataGenError
    GenesisOutputDirAlreadyExists String
genOutDir ->
      Text
"Genesis output directory already exists: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
textShow String
genOutDir
    GenesisReadError String
genFp GenesisDataError
genDataError ->
      Text
"Error while reading genesis file at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
textShow String
genFp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GenesisDataError -> Text
forall a. Show a => a -> Text
textShow GenesisDataError
genDataError
    GenesisSpecError Text
genSpecError ->
      Text
"Error while creating genesis spec" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
textShow Text
genSpecError
    NoGenesisDelegationForKey Text
verKey ->
      Text
"Error while creating genesis, no delegation certificate for this verification key:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
textShow Text
verKey

newtype NewDirectory =
  NewDirectory FilePath
  deriving (NewDirectory -> NewDirectory -> Bool
(NewDirectory -> NewDirectory -> Bool)
-> (NewDirectory -> NewDirectory -> Bool) -> Eq NewDirectory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NewDirectory -> NewDirectory -> Bool
$c/= :: NewDirectory -> NewDirectory -> Bool
== :: NewDirectory -> NewDirectory -> Bool
$c== :: NewDirectory -> NewDirectory -> Bool
Eq, Eq NewDirectory
Eq NewDirectory
-> (NewDirectory -> NewDirectory -> Ordering)
-> (NewDirectory -> NewDirectory -> Bool)
-> (NewDirectory -> NewDirectory -> Bool)
-> (NewDirectory -> NewDirectory -> Bool)
-> (NewDirectory -> NewDirectory -> Bool)
-> (NewDirectory -> NewDirectory -> NewDirectory)
-> (NewDirectory -> NewDirectory -> NewDirectory)
-> Ord NewDirectory
NewDirectory -> NewDirectory -> Bool
NewDirectory -> NewDirectory -> Ordering
NewDirectory -> NewDirectory -> NewDirectory
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NewDirectory -> NewDirectory -> NewDirectory
$cmin :: NewDirectory -> NewDirectory -> NewDirectory
max :: NewDirectory -> NewDirectory -> NewDirectory
$cmax :: NewDirectory -> NewDirectory -> NewDirectory
>= :: NewDirectory -> NewDirectory -> Bool
$c>= :: NewDirectory -> NewDirectory -> Bool
> :: NewDirectory -> NewDirectory -> Bool
$c> :: NewDirectory -> NewDirectory -> Bool
<= :: NewDirectory -> NewDirectory -> Bool
$c<= :: NewDirectory -> NewDirectory -> Bool
< :: NewDirectory -> NewDirectory -> Bool
$c< :: NewDirectory -> NewDirectory -> Bool
compare :: NewDirectory -> NewDirectory -> Ordering
$ccompare :: NewDirectory -> NewDirectory -> Ordering
$cp1Ord :: Eq NewDirectory
Ord, Int -> NewDirectory -> ShowS
[NewDirectory] -> ShowS
NewDirectory -> String
(Int -> NewDirectory -> ShowS)
-> (NewDirectory -> String)
-> ([NewDirectory] -> ShowS)
-> Show NewDirectory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NewDirectory] -> ShowS
$cshowList :: [NewDirectory] -> ShowS
show :: NewDirectory -> String
$cshow :: NewDirectory -> String
showsPrec :: Int -> NewDirectory -> ShowS
$cshowsPrec :: Int -> NewDirectory -> ShowS
Show, String -> NewDirectory
(String -> NewDirectory) -> IsString NewDirectory
forall a. (String -> a) -> IsString a
fromString :: String -> NewDirectory
$cfromString :: String -> NewDirectory
IsString)

-- | Parameters required for generation of new genesis.
data GenesisParameters = GenesisParameters
  { GenesisParameters -> UTCTime
gpStartTime :: !UTCTime
  , GenesisParameters -> String
gpProtocolParamsFile :: !FilePath
  , GenesisParameters -> BlockCount
gpK :: !Common.BlockCount
  , GenesisParameters -> ProtocolMagic
gpProtocolMagic :: !Crypto.ProtocolMagic
  , GenesisParameters -> TestnetBalanceOptions
gpTestnetBalance :: !Genesis.TestnetBalanceOptions
  , GenesisParameters -> FakeAvvmOptions
gpFakeAvvmOptions :: !Genesis.FakeAvvmOptions
  , GenesisParameters -> EntropicPortion
gpAvvmBalanceFactor :: !Common.EntropicPortion
  , GenesisParameters -> Maybe Integer
gpSeed :: !(Maybe Integer)
  } deriving Int -> GenesisParameters -> ShowS
[GenesisParameters] -> ShowS
GenesisParameters -> String
(Int -> GenesisParameters -> ShowS)
-> (GenesisParameters -> String)
-> ([GenesisParameters] -> ShowS)
-> Show GenesisParameters
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenesisParameters] -> ShowS
$cshowList :: [GenesisParameters] -> ShowS
show :: GenesisParameters -> String
$cshow :: GenesisParameters -> String
showsPrec :: Int -> GenesisParameters -> ShowS
$cshowsPrec :: Int -> GenesisParameters -> ShowS
Show


mkGenesisSpec :: GenesisParameters -> ExceptT ColeGenesisError IO Genesis.GenesisSpec
mkGenesisSpec :: GenesisParameters -> ExceptT ColeGenesisError IO GenesisSpec
mkGenesisSpec GenesisParameters
gp = do
  ByteString
protoParamsRaw <- IO ByteString -> ExceptT ColeGenesisError IO ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ByteString -> ExceptT ColeGenesisError IO ByteString)
-> (String -> IO ByteString)
-> String
-> ExceptT ColeGenesisError IO ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IO ByteString
LB.readFile (String -> ExceptT ColeGenesisError IO ByteString)
-> String -> ExceptT ColeGenesisError IO ByteString
forall a b. (a -> b) -> a -> b
$ GenesisParameters -> String
gpProtocolParamsFile GenesisParameters
gp

  ProtocolParameters
protocolParameters <- (Text -> ColeGenesisError)
-> ExceptT Text IO ProtocolParameters
-> ExceptT ColeGenesisError IO ProtocolParameters
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT
    (String -> Text -> ColeGenesisError
ProtocolParametersParseFailed (GenesisParameters -> String
gpProtocolParamsFile GenesisParameters
gp)) (ExceptT Text IO ProtocolParameters
 -> ExceptT ColeGenesisError IO ProtocolParameters)
-> ExceptT Text IO ProtocolParameters
-> ExceptT ColeGenesisError IO ProtocolParameters
forall a b. (a -> b) -> a -> b
$
    IO (Either Text ProtocolParameters)
-> ExceptT Text IO ProtocolParameters
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text ProtocolParameters)
 -> ExceptT Text IO ProtocolParameters)
-> (Either Text ProtocolParameters
    -> IO (Either Text ProtocolParameters))
-> Either Text ProtocolParameters
-> ExceptT Text IO ProtocolParameters
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Either Text ProtocolParameters
-> IO (Either Text ProtocolParameters)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text ProtocolParameters
 -> ExceptT Text IO ProtocolParameters)
-> Either Text ProtocolParameters
-> ExceptT Text IO ProtocolParameters
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text ProtocolParameters
forall a.
FromJSON (Either SchemaError) a =>
ByteString -> Either Text a
canonicalDecodePretty ByteString
protoParamsRaw

  -- We're relying on the generator to fake AVVM and delegation.
  GenesisDelegation
genesisDelegation <- (GenesisDelegationError -> ColeGenesisError)
-> ExceptT GenesisDelegationError IO GenesisDelegation
-> ExceptT ColeGenesisError IO GenesisDelegation
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GenesisDelegationError -> ColeGenesisError
MakeGenesisDelegationError (ExceptT GenesisDelegationError IO GenesisDelegation
 -> ExceptT ColeGenesisError IO GenesisDelegation)
-> ExceptT GenesisDelegationError IO GenesisDelegation
-> ExceptT ColeGenesisError IO GenesisDelegation
forall a b. (a -> b) -> a -> b
$
    [Certificate]
-> ExceptT GenesisDelegationError IO GenesisDelegation
forall (m :: * -> *).
MonadError GenesisDelegationError m =>
[Certificate] -> m GenesisDelegation
Genesis.mkGenesisDelegation []

  (Text -> ColeGenesisError)
-> ExceptT Text IO GenesisSpec
-> ExceptT ColeGenesisError IO GenesisSpec
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Text -> ColeGenesisError
GenesisSpecError (ExceptT Text IO GenesisSpec
 -> ExceptT ColeGenesisError IO GenesisSpec)
-> ExceptT Text IO GenesisSpec
-> ExceptT ColeGenesisError IO GenesisSpec
forall a b. (a -> b) -> a -> b
$
    IO (Either Text GenesisSpec) -> ExceptT Text IO GenesisSpec
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text GenesisSpec) -> ExceptT Text IO GenesisSpec)
-> (Either Text GenesisSpec -> IO (Either Text GenesisSpec))
-> Either Text GenesisSpec
-> ExceptT Text IO GenesisSpec
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Either Text GenesisSpec -> IO (Either Text GenesisSpec)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text GenesisSpec -> ExceptT Text IO GenesisSpec)
-> Either Text GenesisSpec -> ExceptT Text IO GenesisSpec
forall a b. (a -> b) -> a -> b
$ GenesisAvvmBalances
-> GenesisDelegation
-> ProtocolParameters
-> BlockCount
-> ProtocolMagic
-> GenesisInitializer
-> Either Text GenesisSpec
Genesis.mkGenesisSpec
      (Map CompactRedeemVerificationKey Entropic -> GenesisAvvmBalances
Genesis.GenesisAvvmBalances Map CompactRedeemVerificationKey Entropic
forall a. Monoid a => a
mempty)
      GenesisDelegation
genesisDelegation
      ProtocolParameters
protocolParameters
      (GenesisParameters -> BlockCount
gpK GenesisParameters
gp)
      (GenesisParameters -> ProtocolMagic
gpProtocolMagic GenesisParameters
gp)
      (Bool -> GenesisInitializer
mkGenesisInitialiser Bool
True)

  where
    mkGenesisInitialiser :: Bool -> Genesis.GenesisInitializer
    mkGenesisInitialiser :: Bool -> GenesisInitializer
mkGenesisInitialiser Bool
useHeavyDlg =
      TestnetBalanceOptions
-> FakeAvvmOptions -> Rational -> Bool -> GenesisInitializer
Genesis.GenesisInitializer
      (GenesisParameters -> TestnetBalanceOptions
gpTestnetBalance GenesisParameters
gp)
      (GenesisParameters -> FakeAvvmOptions
gpFakeAvvmOptions GenesisParameters
gp)
      (EntropicPortion -> Rational
Common.entropicPortionToRational (GenesisParameters -> EntropicPortion
gpAvvmBalanceFactor GenesisParameters
gp))
      Bool
useHeavyDlg

-- | Generate a genesis, for given blockchain start time, protocol parameters,
-- security parameter, protocol magic, testnet balance options, fake AVVM options,
-- AVVM balance factor and seed.  Throw an error in the following cases: if the
-- protocol parameters file can't be read or fails parse, if genesis delegation
-- couldn't be generated, if the parameter-derived genesis specification is wrong,
-- or if the genesis fails generation.
mkGenesis
  :: GenesisParameters
  -> ExceptT ColeGenesisError IO (Genesis.GenesisData, Genesis.GeneratedSecrets)
mkGenesis :: GenesisParameters
-> ExceptT ColeGenesisError IO (GenesisData, GeneratedSecrets)
mkGenesis GenesisParameters
gp = do
  GenesisSpec
genesisSpec <- GenesisParameters -> ExceptT ColeGenesisError IO GenesisSpec
mkGenesisSpec GenesisParameters
gp

  (GenesisDataGenerationError -> ColeGenesisError)
-> ExceptT
     GenesisDataGenerationError IO (GenesisData, GeneratedSecrets)
-> ExceptT ColeGenesisError IO (GenesisData, GeneratedSecrets)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GenesisDataGenerationError -> ColeGenesisError
GenesisGenerationError (ExceptT
   GenesisDataGenerationError IO (GenesisData, GeneratedSecrets)
 -> ExceptT ColeGenesisError IO (GenesisData, GeneratedSecrets))
-> ExceptT
     GenesisDataGenerationError IO (GenesisData, GeneratedSecrets)
-> ExceptT ColeGenesisError IO (GenesisData, GeneratedSecrets)
forall a b. (a -> b) -> a -> b
$
    UTCTime
-> GenesisSpec
-> ExceptT
     GenesisDataGenerationError IO (GenesisData, GeneratedSecrets)
Genesis.generateGenesisData (GenesisParameters -> UTCTime
gpStartTime GenesisParameters
gp) GenesisSpec
genesisSpec

-- | Read genesis from a file.
readGenesis :: GenesisFile
            -> NetworkId
            -> ExceptT ColeGenesisError IO Genesis.Config
readGenesis :: GenesisFile -> NetworkId -> ExceptT ColeGenesisError IO Config
readGenesis (GenesisFile String
file) NetworkId
nw =
  (GenesisDataError -> ColeGenesisError)
-> ExceptT GenesisDataError IO Config
-> ExceptT ColeGenesisError IO Config
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (String -> GenesisDataError -> ColeGenesisError
GenesisReadError String
file) (ExceptT GenesisDataError IO Config
 -> ExceptT ColeGenesisError IO Config)
-> ExceptT GenesisDataError IO Config
-> ExceptT ColeGenesisError IO Config
forall a b. (a -> b) -> a -> b
$ do
    (GenesisData
genesisData, GenesisHash
genesisHash) <- String -> ExceptT GenesisDataError IO (GenesisData, GenesisHash)
forall (m :: * -> *).
(MonadError GenesisDataError m, MonadIO m) =>
String -> m (GenesisData, GenesisHash)
Genesis.readGenesisData String
file
    Config -> ExceptT GenesisDataError IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return Config :: GenesisData
-> GenesisHash
-> RequiresNetworkMagic
-> UTxOConfiguration
-> Config
Genesis.Config {
      configGenesisData :: GenesisData
Genesis.configGenesisData       = GenesisData
genesisData,
      configGenesisHash :: GenesisHash
Genesis.configGenesisHash       = GenesisHash
genesisHash,
      configReqNetMagic :: RequiresNetworkMagic
Genesis.configReqNetMagic       = NetworkId -> RequiresNetworkMagic
toColeRequiresNetworkMagic NetworkId
nw,
      configUTxOConfiguration :: UTxOConfiguration
Genesis.configUTxOConfiguration = UTxOConfiguration
UTxO.defaultUTxOConfiguration
    }

-- | Write out genesis into a directory that must not yet exist.  An error is
-- thrown if the directory already exists, or the genesis has delegate keys that
-- are not delegated to.
dumpGenesis
  :: NewDirectory
  -> Genesis.GenesisData
  -> Genesis.GeneratedSecrets
  -> ExceptT ColeGenesisError IO ()
dumpGenesis :: NewDirectory
-> GenesisData
-> GeneratedSecrets
-> ExceptT ColeGenesisError IO ()
dumpGenesis (NewDirectory String
outDir) GenesisData
genesisData GeneratedSecrets
gs = do
  Bool
exists <- IO Bool -> ExceptT ColeGenesisError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT ColeGenesisError IO Bool)
-> IO Bool -> ExceptT ColeGenesisError IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesPathExist String
outDir
  if Bool
exists
  then ColeGenesisError -> ExceptT ColeGenesisError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ColeGenesisError -> ExceptT ColeGenesisError IO ())
-> ColeGenesisError -> ExceptT ColeGenesisError IO ()
forall a b. (a -> b) -> a -> b
$ String -> ColeGenesisError
GenesisOutputDirAlreadyExists String
outDir
  else IO () -> ExceptT ColeGenesisError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ColeGenesisError IO ())
-> IO () -> ExceptT ColeGenesisError IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
createDirectory String
outDir
  IO () -> ExceptT ColeGenesisError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ColeGenesisError IO ())
-> IO () -> ExceptT ColeGenesisError IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LB.writeFile String
genesisJSONFile (GenesisData -> ByteString
forall a. ToJSON Identity a => a -> ByteString
canonicalEncodePretty GenesisData
genesisData)

  [Certificate]
dlgCerts <- (SigningKey ColeKey -> ExceptT ColeGenesisError IO Certificate)
-> [SigningKey ColeKey]
-> ExceptT ColeGenesisError IO [Certificate]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SigningKey ColeKey -> ExceptT ColeGenesisError IO Certificate
findDelegateCert ([SigningKey ColeKey] -> ExceptT ColeGenesisError IO [Certificate])
-> ([SigningKey] -> [SigningKey ColeKey])
-> [SigningKey]
-> ExceptT ColeGenesisError IO [Certificate]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (SigningKey -> SigningKey ColeKey)
-> [SigningKey] -> [SigningKey ColeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map SigningKey -> SigningKey ColeKey
ColeSigningKey ([SigningKey] -> ExceptT ColeGenesisError IO [Certificate])
-> [SigningKey] -> ExceptT ColeGenesisError IO [Certificate]
forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [SigningKey]
gsRichSecrets GeneratedSecrets
gs

  IO () -> ExceptT ColeGenesisError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ColeGenesisError IO ())
-> IO () -> ExceptT ColeGenesisError IO ()
forall a b. (a -> b) -> a -> b
$ String
-> String
-> (SigningKey ColeKey -> ByteString)
-> [SigningKey ColeKey]
-> IO ()
forall a. String -> String -> (a -> ByteString) -> [a] -> IO ()
wOut String
"genesis-keys" String
"key"
                SigningKey ColeKey -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes
                ((SigningKey -> SigningKey ColeKey)
-> [SigningKey] -> [SigningKey ColeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map SigningKey -> SigningKey ColeKey
ColeSigningKey ([SigningKey] -> [SigningKey ColeKey])
-> [SigningKey] -> [SigningKey ColeKey]
forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [SigningKey]
gsDlgIssuersSecrets GeneratedSecrets
gs)
  IO () -> ExceptT ColeGenesisError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ColeGenesisError IO ())
-> IO () -> ExceptT ColeGenesisError IO ()
forall a b. (a -> b) -> a -> b
$ String
-> String
-> (SigningKey ColeKey -> ByteString)
-> [SigningKey ColeKey]
-> IO ()
forall a. String -> String -> (a -> ByteString) -> [a] -> IO ()
wOut String
"delegate-keys" String
"key"
                SigningKey ColeKey -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes
                ((SigningKey -> SigningKey ColeKey)
-> [SigningKey] -> [SigningKey ColeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map SigningKey -> SigningKey ColeKey
ColeSigningKey ([SigningKey] -> [SigningKey ColeKey])
-> [SigningKey] -> [SigningKey ColeKey]
forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [SigningKey]
gsRichSecrets GeneratedSecrets
gs)
  IO () -> ExceptT ColeGenesisError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ColeGenesisError IO ())
-> IO () -> ExceptT ColeGenesisError IO ()
forall a b. (a -> b) -> a -> b
$ String
-> String
-> (SigningKey ColeKey -> ByteString)
-> [SigningKey ColeKey]
-> IO ()
forall a. String -> String -> (a -> ByteString) -> [a] -> IO ()
wOut String
"poor-keys" String
"key"
                SigningKey ColeKey -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes
                ((PoorSecret -> SigningKey ColeKey)
-> [PoorSecret] -> [SigningKey ColeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (SigningKey -> SigningKey ColeKey
ColeSigningKey (SigningKey -> SigningKey ColeKey)
-> (PoorSecret -> SigningKey) -> PoorSecret -> SigningKey ColeKey
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PoorSecret -> SigningKey
Genesis.poorSecretToKey) ([PoorSecret] -> [SigningKey ColeKey])
-> [PoorSecret] -> [SigningKey ColeKey]
forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [PoorSecret]
gsPoorSecrets GeneratedSecrets
gs)
  IO () -> ExceptT ColeGenesisError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ColeGenesisError IO ())
-> IO () -> ExceptT ColeGenesisError IO ()
forall a b. (a -> b) -> a -> b
$ String
-> String -> (Certificate -> ByteString) -> [Certificate] -> IO ()
forall a. String -> String -> (a -> ByteString) -> [a] -> IO ()
wOut String
"delegation-cert" String
"json" Certificate -> ByteString
serialiseDelegationCert [Certificate]
dlgCerts
  IO () -> ExceptT ColeGenesisError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ColeGenesisError IO ())
-> IO () -> ExceptT ColeGenesisError IO ()
forall a b. (a -> b) -> a -> b
$ String
-> String
-> (RedeemSigningKey -> ByteString)
-> [RedeemSigningKey]
-> IO ()
forall a. String -> String -> (a -> ByteString) -> [a] -> IO ()
wOut String
"avvm-secrets" String
"secret" RedeemSigningKey -> ByteString
printFakeAvvmSecrets ([RedeemSigningKey] -> IO ()) -> [RedeemSigningKey] -> IO ()
forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [RedeemSigningKey]
gsFakeAvvmSecrets GeneratedSecrets
gs
 where
  dlgCertMap :: Map Common.KeyHash Certificate
  dlgCertMap :: Map KeyHash Certificate
dlgCertMap = GenesisDelegation -> Map KeyHash Certificate
Genesis.unGenesisDelegation (GenesisDelegation -> Map KeyHash Certificate)
-> GenesisDelegation -> Map KeyHash Certificate
forall a b. (a -> b) -> a -> b
$ GenesisData -> GenesisDelegation
Genesis.gdHeavyDelegation GenesisData
genesisData

  findDelegateCert :: SigningKey ColeKey -> ExceptT ColeGenesisError IO Certificate
  findDelegateCert :: SigningKey ColeKey -> ExceptT ColeGenesisError IO Certificate
findDelegateCert bSkey :: SigningKey ColeKey
bSkey@(ColeSigningKey sk) =
    case (Certificate -> Bool) -> [Certificate] -> Maybe Certificate
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (SigningKey -> Certificate -> Bool
isCertForSK SigningKey
sk) (Map KeyHash Certificate -> [Certificate]
forall k a. Map k a -> [a]
Map.elems Map KeyHash Certificate
dlgCertMap) of
      Maybe Certificate
Nothing -> ColeGenesisError -> ExceptT ColeGenesisError IO Certificate
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ColeGenesisError -> ExceptT ColeGenesisError IO Certificate)
-> (VerificationKey ColeKey -> ColeGenesisError)
-> VerificationKey ColeKey
-> ExceptT ColeGenesisError IO Certificate
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ColeGenesisError
NoGenesisDelegationForKey
                 (Text -> ColeGenesisError)
-> (VerificationKey ColeKey -> Text)
-> VerificationKey ColeKey
-> ColeGenesisError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. VerificationKey ColeKey -> Text
prettyPublicKey (VerificationKey ColeKey
 -> ExceptT ColeGenesisError IO Certificate)
-> VerificationKey ColeKey
-> ExceptT ColeGenesisError IO Certificate
forall a b. (a -> b) -> a -> b
$ SigningKey ColeKey -> VerificationKey ColeKey
forall keyrole.
Key keyrole =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey ColeKey
bSkey
      Just Certificate
x  -> Certificate -> ExceptT ColeGenesisError IO Certificate
forall (m :: * -> *) a x. Monad m => a -> ExceptT x m a
right Certificate
x

  genesisJSONFile :: FilePath
  genesisJSONFile :: String
genesisJSONFile = String
outDir String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/genesis.json"

  printFakeAvvmSecrets :: Crypto.RedeemSigningKey -> ByteString
  printFakeAvvmSecrets :: RedeemSigningKey -> ByteString
printFakeAvvmSecrets RedeemSigningKey
rskey = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (Builder -> Text) -> Builder -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Text
toStrict (Text -> Text) -> (Builder -> Text) -> Builder -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Builder -> Text
toLazyText (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ RedeemSigningKey -> Builder
forall p. Buildable p => p -> Builder
build RedeemSigningKey
rskey

  -- Compare a given 'SigningKey' with a 'Certificate' 'VerificationKey'
  isCertForSK :: Crypto.SigningKey -> Certificate -> Bool
  isCertForSK :: SigningKey -> Certificate -> Bool
isCertForSK SigningKey
sk Certificate
cert = Certificate -> VerificationKey
forall a. ACertificate a -> VerificationKey
delegateVK Certificate
cert VerificationKey -> VerificationKey -> Bool
forall a. Eq a => a -> a -> Bool
== SigningKey -> VerificationKey
Crypto.toVerification SigningKey
sk

  wOut :: String -> String -> (a -> ByteString) -> [a] -> IO ()
  wOut :: String -> String -> (a -> ByteString) -> [a] -> IO ()
wOut = String -> String -> String -> (a -> ByteString) -> [a] -> IO ()
forall a.
String -> String -> String -> (a -> ByteString) -> [a] -> IO ()
writeSecrets String
outDir

writeSecrets :: FilePath -> String -> String -> (a -> ByteString) -> [a] -> IO ()
writeSecrets :: String -> String -> String -> (a -> ByteString) -> [a] -> IO ()
writeSecrets String
outDir String
prefix String
suffix a -> ByteString
secretOp [a]
xs =
  [(a, Int)] -> ((a, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [Int
0::Int ..]) (((a, Int) -> IO ()) -> IO ()) -> ((a, Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
  \(a
secret, Int
nr)-> do
    let filename :: String
filename = String
outDir String -> ShowS
</> String
prefix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%03d" Int
nr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
suffix
    String -> ByteString -> IO ()
BS.writeFile String
filename (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
secretOp a
secret
#ifdef UNIX
    String -> FileMode -> IO ()
setFileMode    String
filename FileMode
ownerReadMode
#else
    setPermissions filename (emptyPermissions {readable = True})
#endif