never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE BlockArguments #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE DeriveGeneric #-}
5 {-# LANGUAGE DerivingStrategies #-}
6 {-# LANGUAGE FlexibleContexts #-}
7 {-# LANGUAGE FlexibleInstances #-}
8 {-# LANGUAGE KindSignatures #-}
9 {-# LANGUAGE LambdaCase #-}
10 {-# LANGUAGE OverloadedStrings #-}
11 {-# LANGUAGE TypeApplications #-}
12 {-# LANGUAGE UndecidableInstances #-}
13
14 {-# OPTIONS_HADDOCK prune #-}
15
16 module Cardano.Address.Script
17 (
18 -- * Script
19 Script (..)
20 , serializeScript
21 , foldScript
22
23 -- * Script template
24 , ScriptTemplate (..)
25 , Cosigner (..)
26 , cosignerToText
27
28 -- * Validation
29 , ValidationLevel (..)
30 , ErrValidateScript (..)
31 , ErrRecommendedValidateScript (..)
32 , ErrValidateScriptTemplate (..)
33 , validateScript
34 , validateScriptTemplate
35 , validateScriptOfTemplate
36 , prettyErrValidateScript
37 , prettyErrValidateScriptTemplate
38
39 -- * Hashing
40 , ScriptHash (..)
41 , toScriptHash
42 , scriptHashFromBytes
43
44 , KeyHash (..)
45 , KeyRole (..)
46 , keyHashFromBytes
47 , keyHashFromText
48 , keyHashToText
49 , ErrKeyHashFromText
50 , prettyErrKeyHashFromText
51 ) where
52
53 import Prelude
54
55 import Cardano.Address.Derivation
56 ( XPub, credentialHashSize, hashCredential, xpubFromBytes, xpubToBytes )
57 import Codec.Binary.Encoding
58 ( AbstractEncoding (..), encode, fromBase16 )
59 import Control.Applicative
60 ( (<|>) )
61 import Control.DeepSeq
62 ( NFData )
63 import Control.Monad
64 ( foldM, unless, when )
65 import Data.Aeson
66 ( FromJSON (..)
67 , ToJSON (..)
68 , Value (..)
69 , object
70 , withObject
71 , withText
72 , (.:)
73 , (.:?)
74 , (.=)
75 )
76 import Data.Aeson.Types
77 ( Parser )
78 import Data.Bifunctor
79 ( first )
80 import Data.ByteString
81 ( ByteString )
82 import Data.Either.Combinators
83 ( maybeToRight )
84 import Data.Foldable
85 ( asum, foldl', traverse_ )
86 import Data.Functor.Identity
87 ( Identity (..) )
88 import Data.Hashable
89 ( Hashable )
90 import Data.Kind
91 ( Type )
92 import Data.Map.Strict
93 ( Map )
94 import Data.Text
95 ( Text )
96 import Data.Traversable
97 ( for )
98 import Data.Word
99 ( Word8 )
100 import GHC.Generics
101 ( Generic )
102 import qualified HaskellWorks.Data.Aeson.Compat as J
103 import qualified HaskellWorks.Data.Aeson.Compat.Map as JM
104 import Numeric.Natural
105 ( Natural )
106
107 import qualified Cardano.Codec.Bech32.Prefixes as CIP5
108 import qualified Cardano.Codec.Cbor as CBOR
109 import qualified Codec.Binary.Bech32 as Bech32
110 import qualified Codec.CBOR.Encoding as CBOR
111 import qualified Data.Aeson.Types as Json
112 import qualified Data.ByteString as BS
113 import qualified Data.HashSet as Set
114 import qualified Data.List as L
115 import qualified Data.Map.Strict as Map
116 import qualified Data.Text as T
117 import qualified Data.Text.Encoding as T
118 import qualified Data.Text.Read as T
119
120 -- | A 'Script' type represents multi signature script. The script embodies conditions
121 -- that need to be satisfied to make it valid.
122 --
123 -- @since 3.0.0
124 data Script (elem :: Type)
125 = RequireSignatureOf !elem
126 | RequireAllOf ![Script elem]
127 | RequireAnyOf ![Script elem]
128 | RequireSomeOf Word8 ![Script elem]
129 | ActiveFromSlot Natural
130 | ActiveUntilSlot Natural
131 deriving stock (Generic, Show, Eq)
132 instance NFData elem => NFData (Script elem)
133
134 -- | This function realizes what cardano-node's `Api.serialiseToCBOR script` realizes
135 -- This is basically doing the symbolically following:
136 -- toCBOR [0,multisigScript]
137 --
138 -- @since 3.0.0
139 serializeScript :: Script KeyHash -> ByteString
140 serializeScript script =
141 multisigTag <> CBOR.toStrictByteString (toCBOR script)
142 where
143 -- | Magic number representing the tag of the native multi-signature script
144 -- language. For each script language included, a new tag is chosen.
145 multisigTag :: ByteString
146 multisigTag = "\00"
147
148 toCBOR :: Script KeyHash -> CBOR.Encoding
149 toCBOR = \case
150 RequireSignatureOf (KeyHash _ verKeyHash) ->
151 encodeMultiscriptCtr 0 2 <> CBOR.encodeBytes verKeyHash
152 RequireAllOf contents ->
153 encodeMultiscriptCtr 1 2 <> encodeFoldable toCBOR contents
154 RequireAnyOf contents ->
155 encodeMultiscriptCtr 2 2 <> encodeFoldable toCBOR contents
156 RequireSomeOf m contents -> mconcat
157 [ encodeMultiscriptCtr 3 3
158 , CBOR.encodeInt (fromInteger $ toInteger m)
159 , encodeFoldable toCBOR contents
160 ]
161 ActiveFromSlot slotNum ->
162 encodeMultiscriptCtr 4 2 <> CBOR.encodeWord64 (fromInteger $ toInteger slotNum)
163 ActiveUntilSlot slotNum ->
164 encodeMultiscriptCtr 5 2 <> CBOR.encodeWord64 (fromInteger $ toInteger slotNum)
165
166 encodeMultiscriptCtr :: Word -> Word -> CBOR.Encoding
167 encodeMultiscriptCtr ctrIndex listLen =
168 CBOR.encodeListLen listLen <> CBOR.encodeWord ctrIndex
169
170 encodeFoldable :: (Foldable f) => (a -> CBOR.Encoding) -> f a -> CBOR.Encoding
171 encodeFoldable encode' xs = wrapArray len contents
172 where
173 (len, contents) = foldl' go (0, mempty) xs
174 go (!l, !enc) next = (l + 1, enc <> encode' next)
175
176 wrapArray :: Word -> CBOR.Encoding -> CBOR.Encoding
177 wrapArray len' contents'
178 | len' <= 23 = CBOR.encodeListLen len' <> contents'
179 | otherwise = CBOR.encodeListLenIndef <> contents' <> CBOR.encodeBreak
180
181 -- | Represents the cosigner of the script, ie., party that co-shares the script.
182 --
183 -- @since 3.2.0
184 newtype Cosigner = Cosigner Word8
185 deriving (Generic, Ord, Eq)
186 instance Hashable Cosigner
187 instance NFData Cosigner
188
189 instance Show Cosigner where
190 show = T.unpack . cosignerToText
191
192 -- | Represents the script template that show the structure of the script and determines
193 -- the expected place of verification keys corresponding to given cosigners.
194 --
195 -- @since 3.2.0
196 data ScriptTemplate = ScriptTemplate
197 { cosigners :: Map Cosigner XPub
198 , template :: Script Cosigner
199 } deriving (Generic, Show, Eq)
200 instance NFData ScriptTemplate
201
202 -- | Computes the hash of a given script, by first serializing it to CBOR.
203 --
204 -- @since 3.0.0
205 toScriptHash :: Script KeyHash -> ScriptHash
206 toScriptHash = ScriptHash . hashCredential . serializeScript
207
208 -- | A 'ScriptHash' type represents script hash. The hash is expected to have size of
209 -- 28-byte.
210 --
211 -- @since 3.0.0
212 newtype ScriptHash = ScriptHash { unScriptHash :: ByteString }
213 deriving (Generic, Show, Ord, Eq)
214 instance NFData ScriptHash
215
216 -- | Construct an 'ScriptHash' from raw 'ByteString' (28 bytes).
217 --
218 -- @since 3.0.0
219 scriptHashFromBytes :: ByteString -> Maybe ScriptHash
220 scriptHashFromBytes bytes
221 | BS.length bytes /= credentialHashSize = Nothing
222 | otherwise = Just $ ScriptHash bytes
223
224 data KeyRole = Payment | Delegation | Policy | Unknown
225 deriving (Generic, Show, Ord, Eq)
226 instance NFData KeyRole
227
228 -- | A 'KeyHash' type represents verification key hash that participate in building
229 -- multi-signature script. The hash is expected to have size of 28-byte.
230 --
231 -- @since 3.0.0
232 data KeyHash = KeyHash
233 { role :: KeyRole
234 , digest :: ByteString }
235 deriving (Generic, Show, Ord, Eq)
236 instance NFData KeyHash
237
238 -- | Construct an 'KeyHash' from raw 'ByteString' (28 bytes).
239 --
240 -- @since 3.0.0
241 keyHashFromBytes :: (KeyRole, ByteString) -> Maybe KeyHash
242 keyHashFromBytes (cred, bytes)
243 | BS.length bytes /= credentialHashSize = Nothing
244 | otherwise = Just $ KeyHash cred bytes
245
246 -- | Encode a 'KeyHash' to bech32 'Text' or hex is key role unknown.
247 --
248 -- @since 3.0.0
249 keyHashToText :: KeyHash -> Text
250 keyHashToText (KeyHash cred keyHash) = case cred of
251 Payment ->
252 T.decodeUtf8 $ encode (EBech32 CIP5.addr_shared_vkh) keyHash
253 Delegation ->
254 T.decodeUtf8 $ encode (EBech32 CIP5.stake_shared_vkh) keyHash
255 Policy ->
256 T.decodeUtf8 $ encode (EBech32 CIP5.policy_vkh) keyHash
257 Unknown ->
258 T.decodeUtf8 $ encode EBase16 keyHash
259
260 -- | Construct a 'KeyHash' from 'Text'. It should be
261 -- Bech32 encoded text with one of following hrp:
262 -- - `addr_shared_vkh`
263 -- - `stake_shared_vkh`
264 -- - `addr_vkh`
265 -- - `stake_vkh`
266 -- - `policy_vkh`
267 -- - `addr_shared_vk`
268 -- - `stake_shared_vk`
269 -- - `addr_vk`
270 -- - `stake_vk`
271 -- - `addr_shared_xvk`
272 -- - `stake_shared_xvk`
273 -- - `addr_xvk`
274 -- - `stake_xvk`
275 -- - `policy_vk`
276 -- - `policy_xvk`
277 -- Raw keys will be hashed on the fly, whereas hash that are directly
278 -- provided will remain as such.
279 -- If if hex is encountered Unknown policy key is assumed
280 --
281 -- @since 3.1.0
282 keyHashFromText :: Text -> Either ErrKeyHashFromText KeyHash
283 keyHashFromText txt =
284 case (fromBase16 $ T.encodeUtf8 txt) of
285 Right bs ->
286 if checkBSLength bs 28 then
287 pure $ KeyHash Unknown bs
288 else if checkBSLength bs 32 then
289 pure $ KeyHash Unknown (hashCredential bs)
290 else if checkBSLength bs 64 then
291 pure $ KeyHash Unknown (hashCredential $ BS.take 32 bs)
292 else
293 Left ErrKeyHashFromTextInvalidHex
294 Left _ -> do
295 (hrp, dp) <- first (const ErrKeyHashFromTextInvalidString) $
296 Bech32.decodeLenient txt
297
298 maybeToRight ErrKeyHashFromTextWrongDataPart (Bech32.dataPartToBytes dp)
299 >>= maybeToRight ErrKeyHashFromTextWrongHrp . convertBytes hrp
300 >>= maybeToRight ErrKeyHashFromTextWrongPayload . keyHashFromBytes
301 where
302 convertBytes hrp bytes
303 | hrp == CIP5.addr_shared_vkh && checkBSLength bytes 28 =
304 Just (Payment, bytes)
305 | hrp == CIP5.stake_shared_vkh && checkBSLength bytes 28 =
306 Just (Delegation, bytes)
307 | hrp == CIP5.addr_vkh && checkBSLength bytes 28 =
308 Just (Payment, bytes)
309 | hrp == CIP5.stake_vkh && checkBSLength bytes 28 =
310 Just (Delegation, bytes)
311 | hrp == CIP5.policy_vkh && checkBSLength bytes 28 =
312 Just (Policy, bytes)
313 | hrp == CIP5.addr_shared_vk && checkBSLength bytes 32 =
314 Just (Payment, hashCredential bytes)
315 | hrp == CIP5.addr_vk && checkBSLength bytes 32 =
316 Just (Payment, hashCredential bytes)
317 | hrp == CIP5.addr_shared_xvk && checkBSLength bytes 64 =
318 Just (Payment, hashCredential $ BS.take 32 bytes)
319 | hrp == CIP5.addr_xvk && checkBSLength bytes 64 =
320 Just (Payment, hashCredential $ BS.take 32 bytes)
321 | hrp == CIP5.stake_shared_vk && checkBSLength bytes 32 =
322 Just (Delegation, hashCredential bytes)
323 | hrp == CIP5.stake_vk && checkBSLength bytes 32 =
324 Just (Delegation, hashCredential bytes)
325 | hrp == CIP5.stake_shared_xvk && checkBSLength bytes 64 =
326 Just (Delegation, hashCredential $ BS.take 32 bytes)
327 | hrp == CIP5.stake_xvk && checkBSLength bytes 64 =
328 Just (Delegation, hashCredential $ BS.take 32 bytes)
329 | hrp == CIP5.policy_vk && checkBSLength bytes 32 =
330 Just (Policy, hashCredential bytes)
331 | hrp == CIP5.policy_xvk && checkBSLength bytes 64 =
332 Just (Policy, hashCredential $ BS.take 32 bytes)
333 | otherwise = Nothing
334 checkBSLength bytes expLength =
335 BS.length bytes == expLength
336
337 -- Validation level. Required level does basic check that will make sure the script
338 -- is accepted in ledger. Recommended level collects a number of checks that will
339 -- warn about dangerous, unwise and redundant things present in the script.
340 --
341 -- @since 3.2.0
342 data ValidationLevel = RequiredValidation | RecommendedValidation
343 deriving (Show, Eq, Generic)
344 instance NFData ValidationLevel
345
346 -- Possible errors when deserializing a key hash from text.
347 --
348 -- @since 3.0.0
349 data ErrKeyHashFromText
350 = ErrKeyHashFromTextInvalidString
351 | ErrKeyHashFromTextWrongPayload
352 | ErrKeyHashFromTextWrongHrp
353 | ErrKeyHashFromTextWrongDataPart
354 | ErrKeyHashFromTextInvalidHex
355 deriving (Show, Eq)
356
357 -- Possible errors when deserializing a key hash from text.
358 --
359 -- @since 3.0.0
360 prettyErrKeyHashFromText :: ErrKeyHashFromText -> String
361 prettyErrKeyHashFromText = \case
362 ErrKeyHashFromTextInvalidString ->
363 "Invalid encoded string: must be either bech32 or hex-encoded."
364 ErrKeyHashFromTextWrongPayload ->
365 "Verification key hash must contain exactly 28 bytes."
366 ErrKeyHashFromTextWrongHrp ->
367 "Invalid human-readable prefix: must be 'X_vkh', 'X_vk', 'X_xvk' where X is 'addr_shared', 'stake_shared' or 'policy'."
368 ErrKeyHashFromTextWrongDataPart ->
369 "Verification key hash is Bech32-encoded but has an invalid data part."
370 ErrKeyHashFromTextInvalidHex ->
371 "Invalid hex-encoded string: must be either 28, 32 or 64 bytes"
372
373 --
374 -- Script folding
375 --
376
377 -- | 'Script' folding
378 --
379 -- @since 3.2.0
380 foldScript :: (a -> b -> b) -> b -> Script a -> b
381 foldScript fn zero = \case
382 RequireSignatureOf k -> fn k zero
383 RequireAllOf xs -> foldMScripts xs
384 RequireAnyOf xs -> foldMScripts xs
385 RequireSomeOf _ xs -> foldMScripts xs
386 ActiveFromSlot _ -> zero
387 ActiveUntilSlot _ -> zero
388 where
389 foldMScripts =
390 runIdentity . foldM (\acc -> Identity . foldScript fn acc) zero
391
392 --
393 -- Script validation
394 --
395
396 -- | Validate a 'Script', semantically
397 --
398 -- @since 3.0.0
399 validateScript
400 :: ValidationLevel
401 -> Script KeyHash
402 -> Either ErrValidateScript ()
403 validateScript level script = do
404 let validateKeyHash (KeyHash _ bytes) =
405 (BS.length bytes == credentialHashSize)
406 let allSigs = foldScript (:) [] script
407 unless (L.all validateKeyHash allSigs) $ Left WrongKeyHash
408
409 when (L.length (L.nub $ map role allSigs) > 1) $
410 Left NotUniformKeyType
411
412 requiredValidation script
413
414 when (level == RecommendedValidation) $
415 first NotRecommended (recommendedValidation script)
416
417 requiredValidation
418 :: Script elem
419 -> Either ErrValidateScript ()
420 requiredValidation script =
421 unless (check script) $ Left LedgerIncompatible
422 where
423 check = \case
424 RequireSignatureOf _ -> True
425
426 RequireAllOf xs ->
427 L.all check xs
428
429 RequireAnyOf xs ->
430 L.any check xs
431
432 RequireSomeOf m xs ->
433 m <= sum (fmap (\x -> if check x then 1 else 0) xs)
434
435 ActiveFromSlot _ -> True
436
437 ActiveUntilSlot _ -> True
438
439 recommendedValidation
440 :: Eq elem
441 => Script elem
442 -> Either ErrRecommendedValidateScript ()
443 recommendedValidation = \case
444 RequireSignatureOf _ -> pure ()
445
446 RequireAllOf script -> do
447 when (L.null (omitTimelocks script)) $ Left EmptyList
448 when (hasDuplicate script) $ Left DuplicateSignatures
449 when (redundantTimelocks script) $ Left RedundantTimelocks
450 when (timelockTrap script) $ Left TimelockTrap
451 traverse_ recommendedValidation script
452
453 RequireAnyOf script -> do
454 when (hasDuplicate script) $ Left DuplicateSignatures
455 when (redundantTimelocks script) $ Left RedundantTimelocks
456 when (redundantTimelocksInAny script) $ Left RedundantTimelocks
457 traverse_ recommendedValidation script
458
459 RequireSomeOf m script -> do
460 when (m == 0) $ Left MZero
461 when (length (omitTimelocks script) < fromIntegral m) $ Left ListTooSmall
462 when (hasDuplicate script) $ Left DuplicateSignatures
463 when (redundantTimelocks script) $ Left RedundantTimelocks
464 traverse_ recommendedValidation script
465
466 ActiveFromSlot _ -> pure ()
467
468 ActiveUntilSlot _ -> pure ()
469 where
470 hasDuplicate xs =
471 length sigs /= length (L.nub sigs)
472 where
473 sigs = [ sig | RequireSignatureOf sig <- xs ]
474 hasTimelocks = \case
475 ActiveFromSlot _ -> True
476 ActiveUntilSlot _ -> True
477 _ -> False
478 redundantTimelocks xs = case L.filter hasTimelocks xs of
479 [] -> False
480 [_] -> False
481 [_, _] -> False
482 _ -> True
483 -- situation where any [active_until slot1, active_from slot2]
484 -- (a) acceptable when slot1 < slot2 as either it is satisfied
485 -- (0, slot1) or <slot2, +inf)
486 -- (b) otherwise redundant as it is always satified
487 redundantTimelocksInAny xs = case L.filter hasTimelocks xs of
488 [] -> False
489 [_] -> False
490 [ActiveFromSlot s1, ActiveUntilSlot s2] -> s2 >= s1
491 [ActiveUntilSlot s2, ActiveFromSlot s1] -> s2 >= s1
492 _ -> True
493 -- situation where all [active_until slot1, active_from slot2]
494 -- (a) trap when slot1 < slot2 as both can never be satisfied
495 -- (0, slot1)
496 -- (slot2, +inf)
497 -- (b) acceptable when slot1 == slot2
498 -- then all satisfied at slot1
499 -- (c) acceptable when slot1 >= slot2
500 -- then all satisfied at <slot2, slot1)
501 timelockTrap xs = case L.filter hasTimelocks xs of
502 [ActiveFromSlot s1, ActiveUntilSlot s2] -> s2 < s1
503 [ActiveUntilSlot s2, ActiveFromSlot s1] -> s2 < s1
504 _ -> False
505 omitTimelocks = filter (not . hasTimelocks)
506 --
507 -- ScriptTemplate validation
508 --
509
510 -- | Validate a 'ScriptTemplate', semantically
511 --
512 -- @since 3.2.0
513 validateScriptTemplate
514 :: ValidationLevel
515 -> ScriptTemplate
516 -> Either ErrValidateScriptTemplate ()
517 validateScriptTemplate level (ScriptTemplate cosigners_ script) = do
518 first WrongScript (validateScriptOfTemplate level script)
519 check NoCosignerInScript (nonEmpty scriptCosigners)
520 check NoCosignerXPub (nonEmpty cosignerKeys)
521 check DuplicateXPubs (Set.size cosignerKeys == Map.size cosigners_)
522 check UnknownCosigner (cosignerSet `Set.isSubsetOf` scriptCosigners)
523 check MissingCosignerXPub (scriptCosigners `Set.isSubsetOf` cosignerSet)
524 where
525 scriptCosigners = Set.fromList $ foldScript (:) [] script
526 cosignerKeys = Set.fromList $ Map.elems cosigners_
527 cosignerSet = Set.fromList $ Map.keys cosigners_
528
529 -- throws error if condition doesn't apply
530 check err cond = unless cond (Left err)
531 nonEmpty = not . Set.null
532
533 -- | Validate a script in 'ScriptTemplate'
534 --
535 -- @since 3.5.0
536 validateScriptOfTemplate
537 :: ValidationLevel
538 -> Script Cosigner
539 -> Either ErrValidateScript ()
540 validateScriptOfTemplate level script = do
541 requiredValidation script
542 when (level == RecommendedValidation ) $
543 first NotRecommended (recommendedValidation script)
544
545 -- | Possible validation errors when validating a script
546 --
547 -- @since 3.0.0
548 data ErrValidateScript
549 = LedgerIncompatible
550 | WrongKeyHash
551 | NotUniformKeyType
552 | Malformed
553 | NotRecommended ErrRecommendedValidateScript
554 deriving (Eq, Show)
555
556 -- | Possible recommended validation errors when validating a script
557 --
558 -- @since 3.2.0
559 data ErrRecommendedValidateScript
560 = EmptyList
561 | ListTooSmall
562 | MZero
563 | DuplicateSignatures
564 | RedundantTimelocks
565 | TimelockTrap
566 deriving (Eq, Show)
567
568 -- | Possible validation errors when validating a script template
569 --
570 -- @since 3.2.0
571 data ErrValidateScriptTemplate
572 = WrongScript ErrValidateScript
573 | DuplicateXPubs
574 | UnknownCosigner
575 | MissingCosignerXPub
576 | NoCosignerInScript
577 | NoCosignerXPub
578 deriving (Eq, Show)
579
580 -- | Pretty-print a script validation error.
581 --
582 -- @since 3.0.0
583 prettyErrValidateScript
584 :: ErrValidateScript
585 -> String
586 prettyErrValidateScript = \case
587 LedgerIncompatible ->
588 "The script is ill-formed and is not going to be accepted by the ledger."
589 WrongKeyHash ->
590 "The hash of verification key is expected to have "
591 <> show credentialHashSize <> " bytes."
592 NotUniformKeyType ->
593 "All keys of a script must have the same role: either payment or delegation."
594 Malformed ->
595 "Parsing of the script failed. The script should be composed of nested \
596 \lists, the verification keys should be bech32-encoded with prefix \
597 \'X_vkh', 'X_vk', 'X_xvk' where X is 'addr_shared', 'stake_shared' or 'policy' and\
598 \timelocks must use non-negative numbers as slots."
599 NotRecommended EmptyList ->
600 "The list inside a script is empty or only contains timelocks \
601 \(which is not recommended)."
602 NotRecommended MZero ->
603 "At least's coefficient is 0 (which is not recommended)."
604 NotRecommended ListTooSmall ->
605 "At least's coefficient is larger than the number of non-timelock \
606 \elements in the list (which is not recommended)."
607 NotRecommended DuplicateSignatures ->
608 "The list inside a script has duplicate keys (which is not recommended)."
609 NotRecommended RedundantTimelocks ->
610 "Some timelocks used are redundant (which is not recommended)."
611 NotRecommended TimelockTrap ->
612 "The timelocks used are contradictory when used with 'all' (which is not recommended)."
613
614 -- | Pretty-print a script template validation error.
615 --
616 -- @since 3.2.0
617 prettyErrValidateScriptTemplate
618 :: ErrValidateScriptTemplate
619 -> String
620 prettyErrValidateScriptTemplate = \case
621 WrongScript err -> prettyErrValidateScript err
622 DuplicateXPubs ->
623 "The cosigners in a script template must stand behind an unique extended public key."
624 MissingCosignerXPub ->
625 "Each cosigner in a script template must have an extended public key."
626 NoCosignerInScript ->
627 "The script of a template must have at least one cosigner defined."
628 NoCosignerXPub ->
629 "The script template must have at least one cosigner with an extended public key."
630 UnknownCosigner ->
631 "The specified cosigner must be present in the script of the template."
632 --
633 -- Internal
634 --
635
636 -- Examples of Script jsons:
637 --"addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
638 --"stake_shared_vkh1nqc00hvlc6cq0sfhretk0rmzw8dywmusp8retuqnnxzajtzhjg5"
639 --{ "all" : [ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
640 -- , "addr_shared_vkh1y3zl4nqgm96ankt96dsdhc86vd5geny0wr7hu8cpzdfcqskq2cp"
641 -- ]
642 --}
643 --{ "all" : [ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
644 -- , {"any": [ "addr_shared_vkh1y3zl4nqgm96ankt96dsdhc86vd5geny0wr7hu8cpzdfcqskq2cp"
645 -- , "addr_shared_vkh175wsm9ckhm3snwcsn72543yguxeuqm7v9r6kl6gx57h8gdydcd9"
646 -- ]
647 -- }
648 -- ]
649 --}
650 --{ "all" : [ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
651 -- , {"some": { "from" :[ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
652 -- , "addr_shared_vkh1y3zl4nqgm96ankt96dsdhc86vd5geny0wr7hu8cpzdfcqskq2cp"
653 -- , "addr_shared_vkh175wsm9ckhm3snwcsn72543yguxeuqm7v9r6kl6gx57h8gdydcd9"
654 -- ]
655 -- , "at_least" : 2
656 -- }
657 -- }
658 -- ]
659 --}
660 --{ "all" : [ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
661 -- , {"active_from": 120 }
662 -- ]
663 --}
664 --{ "all" : [ "addr_shared_vkh1zxt0uvrza94h3hv4jpv0ttddgnwkvdgeyq8jf9w30mcs6y8w3nq"
665 -- , any [{"active_until": 100 }, {"active_from": 120 }]
666 -- ]
667 --}
668
669 instance ToJSON elem => ToJSON (Script elem) where
670 toJSON (RequireSignatureOf content) = toJSON content
671 toJSON (RequireAllOf content) =
672 object ["all" .= fmap toJSON content]
673 toJSON (RequireAnyOf content) =
674 object ["any" .= fmap toJSON content]
675 toJSON (RequireSomeOf count scripts) =
676 object ["some" .= object ["at_least" .= count, "from" .= scripts]]
677 toJSON (ActiveFromSlot slot) =
678 object ["active_from" .= slot]
679 toJSON (ActiveUntilSlot slot) =
680 object ["active_until" .= slot]
681
682 instance ToJSON KeyHash where
683 toJSON = String . keyHashToText
684
685 instance FromJSON (Script KeyHash) where
686 parseJSON v =
687 fromScriptJson parseKey backtrack v
688 where
689 parseKey = withText "Script KeyHash" $
690 either
691 (fail . prettyErrKeyHashFromText)
692 (pure . RequireSignatureOf)
693 . keyHashFromText
694
695 -- NOTE: Because we use an alternative sum to define all parsers, in
696 -- case all parser fails, only the last error is returned which can be
697 -- very misleading. For example, sending {"any": []} yields an error
698 -- telling us that the key `"some"` is missing.
699 --
700 -- To cope with this, we add a last parser 'backtrack' which always
701 -- fail but with a more helpful error which tries its best at
702 -- identifying the right constructor.
703 backtrack = \case
704 Object o -> do
705 mAny <- o .:? "any" :: Parser (Maybe Value)
706 mAll <- o .:? "all" :: Parser (Maybe Value)
707 mSome <- o .:? "some" :: Parser (Maybe Value)
708 case (mAny, mAll, mSome) of
709 (Just{}, Nothing, Nothing) -> parseAnyOf v
710 (Nothing, Just{}, Nothing) -> parseAllOf v
711 (Nothing, Nothing, Just{}) -> parseAtLeast v
712 (Nothing, Nothing, Nothing) -> fail
713 "Found object with unknown key. Expecting 'any', 'all' or 'some'"
714 ( _, _, _) -> fail
715 "Found multiple keys 'any', 'all' and/or 'some' at the same level"
716 String{} ->
717 parseKey v
718 _ ->
719 Json.typeMismatch "Object or String" v
720
721 fromScriptJson
722 :: FromJSON (Script elem)
723 => (Value -> Parser (Script elem))
724 -> (Value -> Parser (Script elem))
725 -> Value
726 -> Parser (Script elem)
727 fromScriptJson parseElem backtrack v =
728 asum
729 [ parseElem v
730 , parseAnyOf v
731 , parseAllOf v
732 , parseAtLeast v
733 , parseActiveFrom v
734 , parseActiveUntil v
735 ] <|> backtrack v
736
737 parseAnyOf
738 :: FromJSON (Script elem)
739 => Value
740 -> Parser (Script elem)
741 parseAnyOf = withObject "Script AnyOf" $ \o ->
742 RequireAnyOf <$> o .: "any"
743
744 parseAllOf
745 :: FromJSON (Script elem)
746 => Value
747 -> Parser (Script elem)
748 parseAllOf = withObject "Script AllOf" $ \o ->
749 RequireAllOf <$> o .: "all"
750
751 parseAtLeast
752 :: FromJSON (Script elem)
753 => Value
754 -> Parser (Script elem)
755 parseAtLeast = withObject "Script SomeOf" $ \o -> do
756 some <- o .: "some"
757 RequireSomeOf <$> some .: "at_least" <*> some .: "from"
758
759 parseActiveFrom
760 :: Value
761 -> Parser (Script elem)
762 parseActiveFrom = withObject "Script ActiveFrom" $ \o ->
763 ActiveFromSlot <$> o .: "active_from"
764
765 parseActiveUntil
766 :: Value
767 -> Parser (Script elem)
768 parseActiveUntil = withObject "Script ActiveUntil" $ \o ->
769 ActiveUntilSlot <$> o .: "active_until"
770
771 cosignerToText :: Cosigner -> Text
772 cosignerToText (Cosigner ix) = "cosigner#"<> T.pack (show ix)
773
774 instance ToJSON Cosigner where
775 toJSON = String . cosignerToText
776
777 instance FromJSON Cosigner where
778 parseJSON = withText "Cosigner" $ \txt -> case T.splitOn "cosigner#" txt of
779 ["",numTxt] -> case T.decimal numTxt of
780 Right (num,"") -> do
781 when (num < minBound @Word8 || num > maxBound @Word8) $
782 fail "Cosigner number should be between '0' and '255'"
783 pure $ Cosigner num
784 _ -> fail "Cosigner should be enumerated with number"
785 _ -> fail "Cosigner should be of the form: cosigner#num"
786
787 encodeXPub :: XPub -> Value
788 encodeXPub = String . T.decodeUtf8 . encode EBase16 . xpubToBytes
789
790 parseXPub :: Value -> Parser XPub
791 parseXPub = withText "XPub" $ \txt ->
792 case fromBase16 (T.encodeUtf8 txt) of
793 Left err -> fail err
794 Right hex -> case xpubFromBytes hex of
795 Nothing -> fail "Extended public key cannot be retrieved from a given hex bytestring"
796 Just validXPub -> pure validXPub
797
798 instance ToJSON ScriptTemplate where
799 toJSON (ScriptTemplate cosigners' template') =
800 object [ "cosigners" .= object (fmap (first J.textToKey . toPair) (Map.toList cosigners'))
801 , "template" .= toJSON template']
802 where
803 toPair (cosigner', xpub) =
804 ( cosignerToText cosigner'
805 , encodeXPub xpub )
806
807 instance FromJSON (Script Cosigner) where
808 parseJSON v = fromScriptJson parserCosigner backtrack v
809 where
810 parserCosigner o = do
811 cosigner <- parseJSON @Cosigner o
812 pure $ RequireSignatureOf cosigner
813 backtrack = \case
814 Object o -> do
815 mAny <- o .:? "any" :: Parser (Maybe Value)
816 mAll <- o .:? "all" :: Parser (Maybe Value)
817 mSome <- o .:? "some" :: Parser (Maybe Value)
818 mCos <- o .:? "cosigner" :: Parser (Maybe Value)
819 case (mAny, mAll, mSome, mCos) of
820 (Just{}, Nothing, Nothing, Nothing) -> parseAnyOf v
821 (Nothing, Just{}, Nothing, Nothing) -> parseAllOf v
822 (Nothing, Nothing, Just{}, Nothing) -> parseAtLeast v
823 (Nothing, Nothing, Nothing, Just{}) -> parserCosigner v
824 (Nothing, Nothing, Nothing, Nothing) -> fail
825 "Found object with unknown key. Expecting 'any', 'all', 'some' or 'cosigner'"
826 ( _, _, _, _) -> fail
827 "Found multiple keys 'any', 'all', 'cosigner' and/or 'some' at the same level"
828 _ ->
829 Json.typeMismatch "Object only" v
830
831 instance FromJSON ScriptTemplate where
832 parseJSON = withObject "ScriptTemplate" $ \o -> do
833 template' <- parseJSON <$> o .: "template"
834 cosigners' <- parseCosignerPairs <$> o .: "cosigners"
835 ScriptTemplate . Map.fromList <$> cosigners' <*> template'
836 where
837 parseCosignerPairs = withObject "Cosigner pairs" $ \o ->
838 case JM.toList o of
839 [] -> fail "Cosigners object array should not be empty"
840 cs -> for (reverse cs) $ \(numTxt, str) -> do
841 cosigner' <- parseJSON @Cosigner (String (J.keyToText numTxt))
842 xpub <- parseXPub str
843 pure (cosigner', xpub)