never executed always true always false
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE BinaryLiterals #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE DeriveGeneric #-}
5 {-# LANGUAGE DerivingStrategies #-}
6 {-# LANGUAGE FlexibleContexts #-}
7 {-# LANGUAGE MultiParamTypeClasses #-}
8 {-# LANGUAGE OverloadedStrings #-}
9 {-# LANGUAGE RecordWildCards #-}
10 {-# LANGUAGE TypeFamilies #-}
11
12 {-# OPTIONS_HADDOCK prune #-}
13
14 module Cardano.Address
15 ( -- * Address
16 Address
17 , PaymentAddress (..)
18 , StakeAddress (..)
19 , DelegationAddress (..)
20 , PointerAddress (..)
21 , ChainPointer (..)
22 , unsafeMkAddress
23 , unAddress
24
25 -- * Conversion From / To Text
26 , base58
27 , fromBase58
28 , bech32
29 , bech32With
30 , fromBech32
31
32 -- Internal / Network Discrimination
33 , HasNetworkDiscriminant (..)
34 , AddressDiscrimination (..)
35 , NetworkTag (..)
36 , invariantSize
37 , invariantNetworkTag
38 ) where
39
40 import Prelude
41
42 import Cardano.Address.Derivation
43 ( Depth (..), XPub )
44 import Cardano.Codec.Cbor
45 ( decodeAddress, deserialiseCbor )
46 import Codec.Binary.Bech32
47 ( HumanReadablePart )
48 import Codec.Binary.Encoding
49 ( AbstractEncoding (..), encode )
50 import Control.DeepSeq
51 ( NFData )
52 import Control.Monad
53 ( (<=<) )
54 import Data.Aeson
55 ( ToJSON (..), Value (..), object, (.=) )
56 import Data.Bits
57 ( Bits (testBit) )
58 import Data.ByteString
59 ( ByteString )
60 import Data.Either.Extra
61 ( eitherToMaybe )
62 import Data.Kind
63 ( Type )
64 import Data.Text
65 ( Text )
66 import Data.Word
67 ( Word32, Word8 )
68 import GHC.Generics
69 ( Generic )
70 import GHC.Stack
71 ( HasCallStack )
72 import Numeric.Natural
73 ( Natural )
74
75 import qualified Cardano.Codec.Bech32.Prefixes as CIP5
76 import qualified Codec.Binary.Encoding as E
77 import qualified Data.ByteString as BS
78 import qualified Data.Text.Encoding as T
79
80 -- | An 'Address' type representing 'Cardano' addresses. Internals are
81 -- irrevelant to the user.
82 --
83 -- @since 1.0.0
84 newtype Address = Address
85 { unAddress :: ByteString
86 } deriving stock (Generic, Show, Eq, Ord)
87 instance NFData Address
88
89 -- Unsafe constructor for easily lifting bytes inside an 'Address'.
90 --
91 -- /!\ Use at your own risks.
92 unsafeMkAddress :: ByteString -> Address
93 unsafeMkAddress = Address
94
95 -- | Encode an 'Address' to a base58 'Text'.
96 --
97 -- @since 1.0.0
98 base58 :: Address -> Text
99 base58 = T.decodeUtf8 . encode EBase58 . unAddress
100
101 -- | Decode a base58-encoded 'Text' into an 'Address'
102 --
103 -- @since 1.0.0
104 fromBase58 :: Text -> Maybe Address
105 fromBase58 =
106 (eitherToMaybe . deserialiseCbor (unsafeMkAddress <$> decodeAddress)
107 <=< (eitherToMaybe . E.fromBase58 . T.encodeUtf8))
108
109 -- | Encode a Shelley 'Address' to bech32 'Text', using @addr@ or @addr_test@ as
110 -- a human readable prefix (depending on the network tag in the address).
111 --
112 -- @since 1.0.0
113 bech32 :: Address -> Text
114 bech32 addr = bech32With (addressHrp addr) addr
115
116 -- | Encode an 'Address' to bech32 'Text', using the specified human readable
117 -- prefix.
118 --
119 -- @since 2.0.0
120 bech32With :: HumanReadablePart -> Address -> Text
121 bech32With hrp = T.decodeLatin1 . encode (EBech32 hrp) . unAddress
122
123 -- | Decode a bech32-encoded 'Text' into an 'Address'
124 --
125 -- @since 1.0.0
126 fromBech32 :: Text -> Maybe Address
127 fromBech32 = eitherToMaybe
128 . fmap (unsafeMkAddress . snd)
129 . E.fromBech32 (const id)
130 . T.encodeUtf8
131
132 -- | Returns the HRP for a shelley address, using the network tag.
133 addressHrp :: Address -> HumanReadablePart
134 addressHrp (Address bs) = case BS.uncons bs of
135 Just (w8, _) | testBit w8 0 -> CIP5.addr
136 _ -> CIP5.addr_test
137
138 -- | Encoding of addresses for certain key types and backend targets.
139 --
140 -- @since 2.0.0
141 class HasNetworkDiscriminant key => StakeAddress key where
142 -- | Convert a delegation key to a stake 'Address' (aka: reward account address)
143 -- valid for the given network discrimination.
144 --
145 -- @since 2.0.0
146 stakeAddress :: NetworkDiscriminant key -> key 'DelegationK XPub -> Address
147
148 -- | Encoding of addresses for certain key types and backend targets.
149 --
150 -- @since 1.0.0
151 class HasNetworkDiscriminant key => PaymentAddress key where
152 -- | Convert a public key to a payment 'Address' valid for the given
153 -- network discrimination.
154 --
155 -- @since 1.0.0
156 paymentAddress :: NetworkDiscriminant key -> key 'PaymentK XPub -> Address
157
158 -- | Encoding of delegation addresses for certain key types and backend targets.
159 --
160 -- @since 2.0.0
161 class PaymentAddress key
162 => DelegationAddress key where
163 -- | Convert a public key and a delegation key to a delegation 'Address' valid
164 -- for the given network discrimination. Funds sent to this address will be
165 -- delegated according to the delegation settings attached to the delegation
166 -- key.
167 --
168 -- @since 2.0.0
169 delegationAddress
170 :: NetworkDiscriminant key
171 -> key 'PaymentK XPub
172 -- ^ Payment key
173 -> key 'DelegationK XPub
174 -- ^ Delegation key
175 -> Address
176
177 -- | A 'ChainPointer' type representing location of some object
178 -- in the blockchain (eg., delegation certificate). This can be achieved
179 -- unambiguously by specifying slot number, transaction index and the index
180 -- in the object list (eg., certification list).
181 -- For delegation certificates, alternatively, the delegation key can be used and
182 -- then 'DelegationAddress' can be used.
183 --
184 -- @since 2.0.0
185 data ChainPointer = ChainPointer
186 { slotNum :: Natural
187 -- ^ Pointer to the slot
188 , transactionIndex :: Natural
189 -- ^ transaction index
190 , outputIndex :: Natural
191 -- ^ output list index
192 } deriving stock (Generic, Show, Eq, Ord)
193 instance NFData ChainPointer
194
195 instance ToJSON ChainPointer where
196 toJSON ChainPointer{..} = object
197 [ "slot_num" .= slotNum
198 , "transaction_index" .= transactionIndex
199 , "output_index" .= outputIndex
200 ]
201
202 -- | Encoding of pointer addresses for payment key type, pointer to delegation
203 -- certificate in the blockchain and backend targets.
204 --
205 -- @since 2.0.0
206 class PaymentAddress key
207 => PointerAddress key where
208 -- | Convert a payment public key and a pointer to delegation key in the
209 -- blockchain to a delegation 'Address' valid for the given network
210 -- discrimination. Funds sent to this address will be delegated according to
211 -- the delegation settings attached to the delegation key located by
212 -- 'ChainPointer'.
213 --
214 -- @since 2.0.0
215 pointerAddress
216 :: NetworkDiscriminant key
217 -> key 'PaymentK XPub
218 -- ^ Payment key
219 -> ChainPointer
220 -- ^ Pointer to locate delegation key in blockchain
221 -> Address
222
223 class HasNetworkDiscriminant (key :: Depth -> Type -> Type) where
224 type NetworkDiscriminant key :: Type
225
226 addressDiscrimination :: NetworkDiscriminant key -> AddressDiscrimination
227 networkTag :: NetworkDiscriminant key -> NetworkTag
228
229 -- Magic constant associated with a given network. This is mainly used in two
230 -- places:
231 --
232 -- (1) In 'Address' payloads, to discriminate addresses between networks.
233 -- (2) At the network-level, when doing handshake with nodes.
234 newtype NetworkTag
235 = NetworkTag { unNetworkTag :: Word32 }
236 deriving (Generic, Show, Eq)
237 instance NFData NetworkTag
238
239 instance ToJSON NetworkTag where
240 toJSON (NetworkTag net) = Number (fromIntegral net)
241
242 -- Describe requirements for address discrimination on the Byron era.
243 data AddressDiscrimination
244 = RequiresNetworkTag
245 | RequiresNoTag
246 deriving (Generic, Show, Eq)
247 instance NFData AddressDiscrimination
248
249 invariantSize :: HasCallStack => Int -> ByteString -> ByteString
250 invariantSize expectedLength bytes
251 | BS.length bytes == expectedLength = bytes
252 | otherwise = error
253 $ "length was "
254 ++ show (BS.length bytes)
255 ++ ", but expected to be "
256 ++ (show expectedLength)
257
258 invariantNetworkTag :: HasCallStack => Word32 -> NetworkTag -> Word8
259 invariantNetworkTag limit (NetworkTag num)
260 | num < limit = fromIntegral num
261 | otherwise = error
262 $ "network tag was "
263 ++ show num
264 ++ ", but expected to be less than "
265 ++ show limit