-
Notifications
You must be signed in to change notification settings - Fork 155
/
Genesis.hs
99 lines (89 loc) · 3.12 KB
/
Genesis.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Cardano.Ledger.Conway.Genesis (
ConwayGenesis (..),
toConwayGenesisPairs,
cgDelegsL,
)
where
import Cardano.Ledger.Binary (
DecCBOR (..),
EncCBOR (..),
)
import Cardano.Ledger.Binary.Coders
import Cardano.Ledger.Conway.Era (ConwayEra)
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams, toUpgradeConwayPParamsUpdatePairs)
import Cardano.Ledger.Conway.TxCert (Delegatee)
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.DRep (DRepState)
import Cardano.Ledger.Keys (KeyRole (..))
import Data.Aeson (
FromJSON (..),
KeyValue (..),
ToJSON (..),
Value (..),
object,
pairs,
withObject,
(.!=),
(.:),
(.:?),
)
import Data.Functor.Identity (Identity)
import Data.ListMap (ListMap)
import GHC.Generics (Generic)
import Lens.Micro (Lens', lens)
import NoThunks.Class (NoThunks)
data ConwayGenesis c = ConwayGenesis
{ cgUpgradePParams :: !(UpgradeConwayPParams Identity)
, cgConstitution :: !(Constitution (ConwayEra c))
, cgCommittee :: !(Committee (ConwayEra c))
, cgDelegs :: ListMap (Credential 'Staking c) (Delegatee c)
, cgInitialDReps :: ListMap (Credential 'DRepRole c) (DRepState c)
}
deriving (Eq, Generic, Show)
cgDelegsL :: Lens' (ConwayGenesis c) (ListMap (Credential 'Staking c) (Delegatee c))
cgDelegsL = lens cgDelegs (\x y -> x {cgDelegs = y})
instance Crypto c => NoThunks (ConwayGenesis c)
-- | Genesis are always encoded with the version of era they are defined in.
instance Crypto c => DecCBOR (ConwayGenesis c) where
decCBOR = decode $ RecD ConwayGenesis <! From <! From <! From <! From <! From
instance Crypto c => EncCBOR (ConwayGenesis c) where
encCBOR (ConwayGenesis pparams constitution committee delegs initialDReps) =
encode $
Rec (ConwayGenesis @c)
!> To pparams
!> To constitution
!> To committee
!> To delegs
!> To initialDReps
instance Crypto c => ToJSON (ConwayGenesis c) where
toJSON = object . toConwayGenesisPairs
toEncoding = pairs . mconcat . toConwayGenesisPairs
instance Crypto c => FromJSON (ConwayGenesis c) where
parseJSON =
withObject "ConwayGenesis" $ \obj -> do
upgradeProtocolPParams <- parseJSON (Object obj)
ConwayGenesis
<$> pure upgradeProtocolPParams
<*> obj .: "constitution"
<*> obj .: "committee"
<*> obj .:? "delegs" .!= mempty
<*> obj .:? "initialDReps" .!= mempty
toConwayGenesisPairs :: (Crypto c, KeyValue e a) => ConwayGenesis c -> [a]
toConwayGenesisPairs cg@(ConwayGenesis _ _ _ _ _) =
let ConwayGenesis {..} = cg
in [ "constitution" .= cgConstitution
, "committee" .= cgCommittee
]
++ ["delegs" .= cgDelegs | not (null cgDelegs)]
++ ["initialDReps" .= cgInitialDReps | not (null cgInitialDReps)]
++ toUpgradeConwayPParamsUpdatePairs cgUpgradePParams