← Back to branch summary

~zinigor/cardano-node/trunk

« back to all changes in this revision

Viewing changes to cardano-cli/src/Cardano/CLI/Byron/Genesis.hs

  • Committer: Igor Zinovyev
  • Date: 2021-08-13 19:12:27 UTC
  • Revision ID: zinigor@gmail.com-20210813191227-stlnsj3mc5ypwn0c
Tags: upstream-1.27.0
Import upstream version 1.27.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
cardano-cli/src/Cardano/CLI/Byron/Genesis.hs
 
1
{-# LANGUAGE CPP #-}
 
2
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
 
3
 
 
4
#if !defined(mingw32_HOST_OS)
 
5
#define UNIX
 
6
#endif
 
7
 
 
8
module Cardano.CLI.Byron.Genesis
 
9
  ( ByronGenesisError(..)
 
10
  , GenesisParameters(..)
 
11
  , NewDirectory(..)
 
12
  , dumpGenesis
 
13
  , mkGenesis
 
14
  , readGenesis
 
15
  , renderByronGenesisError
 
16
  )
 
17
where
 
18
 
 
19
import           Cardano.Prelude hiding (option, show, trace)
 
20
import           Prelude (String)
 
21
 
 
22
import           Control.Monad.Trans.Except.Extra (firstExceptT, left, right)
 
23
import qualified Data.ByteString as BS
 
24
import qualified Data.ByteString.Lazy as LB
 
25
import qualified Data.Map.Strict as Map
 
26
import           Data.Text.Lazy.Builder (toLazyText)
 
27
import           Data.Time (UTCTime)
 
28
import           Formatting.Buildable
 
29
import           Text.Printf (printf)
 
30
 
 
31
import           System.Directory (createDirectory, doesPathExist)
 
32
import           System.FilePath ((</>))
 
33
#ifdef UNIX
 
34
import           System.Posix.Files (ownerReadMode, setFileMode)
 
35
#else
 
36
import           System.Directory (emptyPermissions, readable, setPermissions)
 
37
#endif
 
38
import           Cardano.Api (Key (..), NetworkId)
 
39
import           Cardano.Api.Byron (ByronKey, SerialiseAsRawBytes (..), SigningKey (..),
 
40
                     toByronRequiresNetworkMagic)
 
41
 
 
42
import qualified Cardano.Chain.Common as Common
 
43
import           Cardano.Chain.Delegation hiding (Map, epoch)
 
44
import           Cardano.Chain.Genesis (GeneratedSecrets (..))
 
45
import qualified Cardano.Chain.Genesis as Genesis
 
46
import qualified Cardano.Chain.UTxO as UTxO
 
47
 
 
48
import qualified Cardano.Crypto as Crypto
 
49
 
 
50
import           Cardano.CLI.Byron.Delegation
 
51
import           Cardano.CLI.Byron.Key
 
52
import           Cardano.CLI.Helpers (textShow)
 
53
import           Cardano.CLI.Types (GenesisFile (..))
 
54
 
 
55
data ByronGenesisError
 
56
  = ByronDelegationCertSerializationError !ByronDelegationError
 
57
  | ByronDelegationKeySerializationError ByronDelegationError
 
58
  | GenesisGenerationError !Genesis.GenesisDataGenerationError
 
59
  | GenesisOutputDirAlreadyExists FilePath
 
60
  | GenesisReadError !FilePath !Genesis.GenesisDataError
 
61
  | GenesisSpecError !Text
 
62
  | MakeGenesisDelegationError !Genesis.GenesisDelegationError
 
63
  | NoGenesisDelegationForKey !Text
 
64
  | ProtocolParametersParseFailed !FilePath !Text
 
65
  | PoorKeyFailure !ByronKeyFailure
 
66
 
 
67
  deriving Show
 
68
 
 
69
renderByronGenesisError :: ByronGenesisError -> Text
 
70
renderByronGenesisError err =
 
71
  case err of
 
72
    ProtocolParametersParseFailed pParamFp parseError ->
 
73
      "Protocol parameters parse failed at: " <> textShow pParamFp <> " Error: " <> parseError
 
74
    ByronDelegationCertSerializationError bDelegSerErr ->
 
75
      "Error while serializing the delegation certificate: " <> textShow bDelegSerErr
 
76
    ByronDelegationKeySerializationError bKeySerErr ->
 
77
      "Error while serializing the delegation key: " <> textShow bKeySerErr
 
78
    PoorKeyFailure bKeyFailure ->
 
79
      "Error creating poor keys: " <> textShow bKeyFailure
 
80
    MakeGenesisDelegationError genDelegError ->
 
81
      "Error creating genesis delegation: " <> textShow genDelegError
 
82
    GenesisGenerationError genDataGenError ->
 
83
      "Error generating genesis: " <> textShow genDataGenError
 
84
    GenesisOutputDirAlreadyExists genOutDir ->
 
85
      "Genesis output directory already exists: " <> textShow genOutDir
 
86
    GenesisReadError genFp genDataError ->
 
87
      "Error while reading genesis file at: " <> textShow genFp <> " Error: " <> textShow genDataError
 
88
    GenesisSpecError genSpecError ->
 
89
      "Error while creating genesis spec" <> textShow genSpecError
 
90
    NoGenesisDelegationForKey verKey ->
 
91
      "Error while creating genesis, no delegation certificate for this verification key:" <> textShow verKey
 
92
 
 
93
newtype NewDirectory =
 
94
  NewDirectory FilePath
 
95
  deriving (Eq, Ord, Show, IsString)
 
96
 
 
97
-- | Parameters required for generation of new genesis.
 
98
data GenesisParameters = GenesisParameters
 
99
  { gpStartTime :: !UTCTime
 
100
  , gpProtocolParamsFile :: !FilePath
 
101
  , gpK :: !Common.BlockCount
 
102
  , gpProtocolMagic :: !Crypto.ProtocolMagic
 
103
  , gpTestnetBalance :: !Genesis.TestnetBalanceOptions
 
104
  , gpFakeAvvmOptions :: !Genesis.FakeAvvmOptions
 
105
  , gpAvvmBalanceFactor :: !Common.LovelacePortion
 
106
  , gpSeed :: !(Maybe Integer)
 
107
  } deriving Show
 
108
 
 
109
 
 
110
mkGenesisSpec :: GenesisParameters -> ExceptT ByronGenesisError IO Genesis.GenesisSpec
 
111
mkGenesisSpec gp = do
 
112
  protoParamsRaw <- lift . LB.readFile $ gpProtocolParamsFile gp
 
113
 
 
114
  protocolParameters <- withExceptT
 
115
    (ProtocolParametersParseFailed (gpProtocolParamsFile gp)) $
 
116
    ExceptT . pure $ canonicalDecodePretty protoParamsRaw
 
117
 
 
118
  -- We're relying on the generator to fake AVVM and delegation.
 
119
  genesisDelegation <- withExceptT MakeGenesisDelegationError $
 
120
    Genesis.mkGenesisDelegation []
 
121
 
 
122
  withExceptT GenesisSpecError $
 
123
    ExceptT . pure $ Genesis.mkGenesisSpec
 
124
      (Genesis.GenesisAvvmBalances mempty)
 
125
      genesisDelegation
 
126
      protocolParameters
 
127
      (gpK gp)
 
128
      (gpProtocolMagic gp)
 
129
      (mkGenesisInitialiser True)
 
130
 
 
131
  where
 
132
    mkGenesisInitialiser :: Bool -> Genesis.GenesisInitializer
 
133
    mkGenesisInitialiser useHeavyDlg =
 
134
      Genesis.GenesisInitializer
 
135
      (gpTestnetBalance gp)
 
136
      (gpFakeAvvmOptions gp)
 
137
      (Common.lovelacePortionToRational (gpAvvmBalanceFactor gp))
 
138
      useHeavyDlg
 
139
 
 
140
-- | Generate a genesis, for given blockchain start time, protocol parameters,
 
141
-- security parameter, protocol magic, testnet balance options, fake AVVM options,
 
142
-- AVVM balance factor and seed.  Throw an error in the following cases: if the
 
143
-- protocol parameters file can't be read or fails parse, if genesis delegation
 
144
-- couldn't be generated, if the parameter-derived genesis specification is wrong,
 
145
-- or if the genesis fails generation.
 
146
mkGenesis
 
147
  :: GenesisParameters
 
148
  -> ExceptT ByronGenesisError IO (Genesis.GenesisData, Genesis.GeneratedSecrets)
 
149
mkGenesis gp = do
 
150
  genesisSpec <- mkGenesisSpec gp
 
151
 
 
152
  withExceptT GenesisGenerationError $
 
153
    Genesis.generateGenesisData (gpStartTime gp) genesisSpec
 
154
 
 
155
-- | Read genesis from a file.
 
156
readGenesis :: GenesisFile
 
157
            -> NetworkId
 
158
            -> ExceptT ByronGenesisError IO Genesis.Config
 
159
readGenesis (GenesisFile file) nw =
 
160
  firstExceptT (GenesisReadError file) $ do
 
161
    (genesisData, genesisHash) <- Genesis.readGenesisData file
 
162
    return Genesis.Config {
 
163
      Genesis.configGenesisData       = genesisData,
 
164
      Genesis.configGenesisHash       = genesisHash,
 
165
      Genesis.configReqNetMagic       = toByronRequiresNetworkMagic nw,
 
166
      Genesis.configUTxOConfiguration = UTxO.defaultUTxOConfiguration
 
167
    }
 
168
 
 
169
-- | Write out genesis into a directory that must not yet exist.  An error is
 
170
-- thrown if the directory already exists, or the genesis has delegate keys that
 
171
-- are not delegated to.
 
172
dumpGenesis
 
173
  :: NewDirectory
 
174
  -> Genesis.GenesisData
 
175
  -> Genesis.GeneratedSecrets
 
176
  -> ExceptT ByronGenesisError IO ()
 
177
dumpGenesis (NewDirectory outDir) genesisData gs = do
 
178
  exists <- liftIO $ doesPathExist outDir
 
179
  if exists
 
180
  then left $ GenesisOutputDirAlreadyExists outDir
 
181
  else liftIO $ createDirectory outDir
 
182
  liftIO $ LB.writeFile genesisJSONFile (canonicalEncodePretty genesisData)
 
183
 
 
184
  dlgCerts <- mapM findDelegateCert . map ByronSigningKey $ gsRichSecrets gs
 
185
 
 
186
  liftIO $ wOut "genesis-keys" "key"
 
187
                serialiseToRawBytes
 
188
                (map ByronSigningKey $ gsDlgIssuersSecrets gs)
 
189
  liftIO $ wOut "delegate-keys" "key"
 
190
                serialiseToRawBytes
 
191
                (map ByronSigningKey $ gsRichSecrets gs)
 
192
  liftIO $ wOut "poor-keys" "key"
 
193
                serialiseToRawBytes
 
194
                (map (ByronSigningKey . Genesis.poorSecretToKey) $ gsPoorSecrets gs)
 
195
  liftIO $ wOut "delegation-cert" "json" serialiseDelegationCert dlgCerts
 
196
  liftIO $ wOut "avvm-secrets" "secret" printFakeAvvmSecrets $ gsFakeAvvmSecrets gs
 
197
 where
 
198
  dlgCertMap :: Map Common.KeyHash Certificate
 
199
  dlgCertMap = Genesis.unGenesisDelegation $ Genesis.gdHeavyDelegation genesisData
 
200
 
 
201
  findDelegateCert :: SigningKey ByronKey -> ExceptT ByronGenesisError IO Certificate
 
202
  findDelegateCert bSkey@(ByronSigningKey sk) =
 
203
    case find (isCertForSK sk) (Map.elems dlgCertMap) of
 
204
      Nothing -> left . NoGenesisDelegationForKey
 
205
                 . prettyPublicKey $ getVerificationKey bSkey
 
206
      Just x  -> right x
 
207
 
 
208
  genesisJSONFile :: FilePath
 
209
  genesisJSONFile = outDir <> "/genesis.json"
 
210
 
 
211
  printFakeAvvmSecrets :: Crypto.RedeemSigningKey -> ByteString
 
212
  printFakeAvvmSecrets rskey = encodeUtf8 . toStrict . toLazyText $ build rskey
 
213
 
 
214
  -- Compare a given 'SigningKey' with a 'Certificate' 'VerificationKey'
 
215
  isCertForSK :: Crypto.SigningKey -> Certificate -> Bool
 
216
  isCertForSK sk cert = delegateVK cert == Crypto.toVerification sk
 
217
 
 
218
  wOut :: String -> String -> (a -> ByteString) -> [a] -> IO ()
 
219
  wOut = writeSecrets outDir
 
220
 
 
221
writeSecrets :: FilePath -> String -> String -> (a -> ByteString) -> [a] -> IO ()
 
222
writeSecrets outDir prefix suffix secretOp xs =
 
223
  forM_ (zip xs [0::Int ..]) $
 
224
  \(secret, nr)-> do
 
225
    let filename = outDir </> prefix <> "." <> printf "%03d" nr <> "." <> suffix
 
226
    BS.writeFile filename $ secretOp secret
 
227
#ifdef UNIX
 
228
    setFileMode    filename ownerReadMode
 
229
#else
 
230
    setPermissions filename (emptyPermissions {readable = True})
 
231
#endif