correct EmptyList and ListTooSmall errors when timelocks present

IntersectMBO · Jan 11, 2021 · 311f268 · 311f268
1 parent f5c2337
commit 311f268
Show file tree

Hide file tree

Showing 2 changed files with 29 additions and 20 deletions.
diff --git a/core/lib/Cardano/Address/Script.hs b/core/lib/Cardano/Address/Script.hs
@@ -317,20 +317,20 @@ validateScript' validateRequireSignatureOf = \case
         validateRequireSignatureOf element
 
     RequireAllOf script -> do
-        when (L.null script) $ Left EmptyList
+        when (L.null (omitTimelocks script)) $ Left EmptyList
         when (hasDuplicate script) $ Left DuplicateSignatures
         when (invalidTimelocks script) $ Left InvalidTimelocks
         traverse_ (validateScript' validateRequireSignatureOf) script
 
     RequireAnyOf script -> do
-        when (L.null script) $ Left EmptyList
+        when (L.null (omitTimelocks script)) $ Left EmptyList
         when (hasDuplicate script) $ Left DuplicateSignatures
         when (invalidTimelocks script) $ Left InvalidTimelocks
         traverse_ (validateScript' validateRequireSignatureOf) script
 
     RequireSomeOf m script -> do
         when (m == 0) $ Left MZero
-        when (length script < fromIntegral m) $ Left ListTooSmall
+        when (length (omitTimelocks script) < fromIntegral m) $ Left ListTooSmall
         when (hasDuplicate script) $ Left DuplicateSignatures
         when (invalidTimelocks script) $ Left InvalidTimelocks
         traverse_ (validateScript' validateRequireSignatureOf) script
@@ -343,19 +343,18 @@ validateScript' validateRequireSignatureOf = \case
         length sigs /= length (L.nub sigs)
       where
         sigs = [ sig | RequireSignatureOf sig <- xs ]
-    invalidTimelocks xs =
-        let hasTimelocks = \case
-                ActiveFromSlot _ -> True
-                ActiveUntilSlot _ -> True
-                _ -> False
-        in case filter hasTimelocks xs of
-            [] -> False
-            [ActiveFromSlot s1, ActiveUntilSlot s2] -> s2 <= s1
-            [ActiveUntilSlot s2, ActiveFromSlot s1] -> s2 <= s1
-            [ActiveFromSlot _] -> False
-            [ActiveUntilSlot _] -> False
-            _ -> True
-
+    hasTimelocks = \case
+        ActiveFromSlot _ -> True
+        ActiveUntilSlot _ -> True
+        _ -> False
+    invalidTimelocks xs = case filter hasTimelocks xs of
+        [] -> False
+        [ActiveFromSlot s1, ActiveUntilSlot s2] -> s2 <= s1
+        [ActiveUntilSlot s2, ActiveFromSlot s1] -> s2 <= s1
+        [ActiveFromSlot _] -> False
+        [ActiveUntilSlot _] -> False
+        _ -> True
+    omitTimelocks = filter (not . hasTimelocks)
 --
 -- ScriptTemplate validation
 --

diff --git a/core/test/Cardano/Address/ScriptSpec.hs b/core/test/Cardano/Address/ScriptSpec.hs
@@ -41,9 +41,7 @@ import Cardano.Address.Style.Shelley
 import Cardano.Mnemonic
     ( mkSomeMnemonic )
 import Codec.Binary.Encoding
-    ( fromBase16 )
-import Codec.Binary.Encoding
-    ( AbstractEncoding (..), encode )
+    ( AbstractEncoding (..), encode, fromBase16 )
 import Data.Aeson
     ( FromJSON, ToJSON )
 import Data.Either
@@ -443,6 +441,18 @@ spec = do
                     ])
             validateScriptTemplate scriptTemplate `shouldBe` (Left InvalidTimelocks)
 
+        it "too high m in RequireSomeOf when timelocks" $ do
+            let scriptTemplate = ScriptTemplate cosigners' (RequireSomeOf 3 [cosigner0, cosigner1, ActiveFromSlot 21, ActiveUntilSlot 30])
+            validateScriptTemplate scriptTemplate `shouldBe` (Left ListTooSmall)
+
+        it "no content in RequireAnyOf when timelocks" $ do
+            let scriptTemplate = ScriptTemplate cosigners' (RequireAnyOf [ActiveFromSlot 21, ActiveUntilSlot 30])
+            validateScriptTemplate scriptTemplate `shouldBe` (Left EmptyList)
+
+        it "no content in RequireAnyOf when timelocks" $ do
+            let scriptTemplate = ScriptTemplate cosigners' (RequireAnyOf [ActiveFromSlot 21, ActiveUntilSlot 30])
+            validateScriptTemplate scriptTemplate `shouldBe` (Left EmptyList)
+
     describe "can perform roundtrip JSON serialization & deserialization - Script KeyHash" $
         it "fromJSON . toJSON === pure" $ property prop_jsonRoundtripWithValidation
     describe "can perform roundtrip JSON serialization & deserialization - Script Cosigner" $
@@ -553,7 +563,7 @@ genScript elemGen = scale (`div` 3) $ sized scriptTree
                     ([ActiveFromSlot _], _) -> scripts
                     ([ActiveUntilSlot _], _) -> scripts
                     (_,rest) -> rest
-            case fromIntegral (L.length scriptsWithValidTimelocks) of
+            case fromIntegral (L.length (filter (not . hasTimelocks) scriptsWithValidTimelocks)) of
                 0 -> scriptTree 0
                 num -> do
                     atLeast <- choose (1, num)