never executed always true always false
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DerivingStrategies #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE OverloadedStrings #-}
5
6 {-# OPTIONS_HADDOCK prune #-}
7
8 module Cardano.Address.Script.Parser
9 (
10 -- ** Script Parser
11 scriptFromString
12 , scriptToText
13 , scriptParser
14
15 -- Internal
16 , requireSignatureOfParser
17 , requireAllOfParser
18 , requireAnyOfParser
19 , requireAtLeastOfParser
20 , requireCosignerOfParser
21 ) where
22
23 import Prelude
24
25 import Cardano.Address.Script
26 ( Cosigner (..)
27 , ErrValidateScript (..)
28 , KeyHash
29 , Script (..)
30 , keyHashFromText
31 , prettyErrKeyHashFromText
32 )
33 import Data.Char
34 ( isDigit, isLetter )
35 import Data.Text
36 ( Text )
37 import Data.Word
38 ( Word8 )
39 import Numeric.Natural
40 ( Natural )
41 import Text.ParserCombinators.ReadP
42 ( ReadP, readP_to_S, (<++) )
43
44 import qualified Data.Text as T
45 import qualified Text.ParserCombinators.ReadP as P
46
47 -- | Run 'scriptParser' on string input.
48 --
49 -- @since 3.0.0
50 scriptFromString
51 :: ReadP (Script a)
52 -> String
53 -> Either ErrValidateScript (Script a)
54 scriptFromString parser str =
55 case readP_to_S (scriptParser parser) str of
56 [(script, "")] -> pure script
57 _ -> Left Malformed
58
59 -- | Defines canonical string output for script that is
60 -- consistent with 'scriptFromString'.
61 --
62 -- @since 3.10.0
63 scriptToText
64 :: Show a
65 => Script a
66 -> Text
67 scriptToText (RequireSignatureOf object) = T.pack $ show object
68 scriptToText (RequireAllOf contents) =
69 "all [" <> T.intercalate "," (map scriptToText contents) <> "]"
70 scriptToText (RequireAnyOf contents) =
71 "any [" <> T.intercalate "," (map scriptToText contents) <> "]"
72 scriptToText (RequireSomeOf m contents) =
73 "at_least "<> T.pack (show m) <>
74 " [" <> T.intercalate "," (map scriptToText contents) <> "]"
75 scriptToText (ActiveFromSlot s) =
76 "active_from " <> T.pack (show s)
77 scriptToText (ActiveUntilSlot s) =
78 "active_until " <> T.pack (show s)
79
80
81 -- | The script embodies combination of signing keys that need to be met to make
82 -- it valid. We assume here that the script could
83 -- delivered from standard input. The examples below are self-explanatory:
84 --
85 -- 1. requiring signature
86 -- 3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe
87 --
88 -- 2. 'any' for signature required
89 -- any [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, 3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3f1]
90 --
91 -- 3. 'all' signatures required
92 -- all [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, 3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3f1]
93 --
94 -- 4. 'at_least' 1 signature required
95 -- at_least 1 [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, 3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3f1]
96 --
97 -- 5. Nested script are supported
98 -- at_least 1 [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, all [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3f1, 3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3f1]]
99 -- 6. 1 signature required after slot number 120
100 -- all [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, active_from 120]
101 -- 7. 1 signature required until slot number 150
102 -- all [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, active_until 150]
103 -- 8. 1 signature required in slot interval <145, 150)
104 -- all [3c07030e36bfffe67e2e2ec09e5293d384637cd2f004356ef320f3fe, active_from 145, active_until 150]
105 --
106 -- Parser is insensitive to whitespaces.
107 --
108 -- @since 3.0.0
109 scriptParser :: ReadP (Script a) -> ReadP (Script a)
110 scriptParser parser =
111 requireAllOfParser parser <++
112 requireAnyOfParser parser <++
113 requireAtLeastOfParser parser <++
114 parser <++
115 activeFromSlotParser <++
116 activeUntilSlotParser
117
118 requireSignatureOfParser :: ReadP (Script KeyHash)
119 requireSignatureOfParser = do
120 P.skipSpaces
121 verKeyStr <- P.munch1 (\c -> isDigit c || isLetter c || c == '_')
122 case keyHashFromText (T.pack verKeyStr) of
123 Left e -> fail (prettyErrKeyHashFromText e)
124 Right h -> pure (RequireSignatureOf h)
125
126 requireCosignerOfParser :: ReadP (Script Cosigner)
127 requireCosignerOfParser = do
128 P.skipSpaces
129 _identifier <- P.string "cosigner#"
130 cosignerid <- fromInteger . read <$> P.munch1 isDigit
131 pure $ RequireSignatureOf $ Cosigner cosignerid
132
133 requireAllOfParser :: ReadP (Script a) -> ReadP (Script a)
134 requireAllOfParser parser = do
135 P.skipSpaces
136 _identifier <- P.string "all"
137 RequireAllOf <$> commonPart parser
138
139 requireAnyOfParser :: ReadP (Script a) -> ReadP (Script a)
140 requireAnyOfParser parser = do
141 P.skipSpaces
142 _identifier <- P.string "any"
143 RequireAnyOf <$> commonPart parser
144
145 requireAtLeastOfParser :: ReadP (Script a) -> ReadP (Script a)
146 requireAtLeastOfParser parser = do
147 P.skipSpaces
148 _identifier <- P.string "at_least"
149 RequireSomeOf <$> naturalParser <*> commonPart parser
150
151 activeFromSlotParser :: ReadP (Script a)
152 activeFromSlotParser = do
153 P.skipSpaces
154 _identifier <- P.string "active_from"
155 ActiveFromSlot <$> slotParser
156
157 activeUntilSlotParser :: ReadP (Script a)
158 activeUntilSlotParser = do
159 P.skipSpaces
160 _identifier <- P.string "active_until"
161 ActiveUntilSlot <$> slotParser
162
163 naturalParser :: ReadP Word8
164 naturalParser = do
165 P.skipSpaces
166 fromInteger . read <$> P.munch1 isDigit
167
168 slotParser :: ReadP Natural
169 slotParser = do
170 P.skipSpaces
171 fromInteger . read <$> P.munch1 isDigit
172
173 commonPart :: ReadP (Script a) -> ReadP [Script a]
174 commonPart parser = do
175 P.skipSpaces
176 _open <- P.string "["
177 P.skipSpaces
178 content <- P.sepBy (scriptParser parser) (P.string ",")
179 P.skipSpaces
180 _close <- P.string "]"
181 P.skipSpaces
182 return content