diff --git a/ic-ref.cabal b/ic-ref.cabal index 3705eafd..2e8cbf05 100644 --- a/ic-ref.cabal +++ b/ic-ref.cabal @@ -148,6 +148,7 @@ executable ic-ref-test main-is: ic-ref-test.hs other-modules: IC.Test.Spec other-modules: IC.Test.Options + other-modules: IC.Test.DelayedIO other-modules: IC.Test.Universal other-modules: IC.Management other-modules: IC.Types diff --git a/src/IC/Test/DelayedIO.hs b/src/IC/Test/DelayedIO.hs new file mode 100644 index 00000000..d06ffcef --- /dev/null +++ b/src/IC/Test/DelayedIO.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +module IC.Test.DelayedIO where + +import Control.Concurrent +import Control.Exception + + +-- | `delayed act` returns an IO action that, upon first execution executes +-- `act`, and caches the result (including a possible exception) for all +-- further executions, in a thread-safe way +delayed :: IO a -> IO (IO a) +delayed act = do + ref <- newMVar Nothing + return $ do + eoa <- modifyMVar ref $ \case + Nothing -> do + x <- try @SomeException act + return (Just x, Just x) + Just x -> return (Just x, Just x) + case eoa of + Just (Left e) -> throwIO e + Just (Right x) -> return x + Nothing -> error "delayed: inconsinstent value in ref" + + diff --git a/src/IC/Test/Spec.hs b/src/IC/Test/Spec.hs index 871fb41c..8d0fd35e 100644 --- a/src/IC/Test/Spec.hs +++ b/src/IC/Test/Spec.hs @@ -62,6 +62,7 @@ import IC.Crypto import IC.Id.Forms hiding (Blob) import IC.Test.Options import IC.Test.Universal +import IC.Test.DelayedIO import IC.Funds import IC.Hash @@ -199,6 +200,8 @@ futureExpiryEnv = modNatField "ingress_expiry" (+ 3600_000_000_000) data TestConfig = TestConfig { tc_manager :: Manager , tc_endPoint :: String + , tc_universal_wasm :: Blob + , tc_simple_canister :: IO Blob } preFlight :: OptionSet -> IO TestConfig @@ -213,10 +216,17 @@ preFlight os = do putStrLn $ "Spec version tested: " ++ T.unpack specVersion putStrLn $ "Spec version claimed: " ++ T.unpack (status_api_version s) - return TestConfig - { tc_manager = manager - , tc_endPoint = ep - } + universal_wasm <- getTestWasm "universal_canister" + + let pre_test_config = TestConfig + { tc_manager = manager + , tc_endPoint = ep + , tc_universal_wasm = universal_wasm + , tc_simple_canister = error "tc_simple_canister not available yet" + } + sharedCanister <- installSharedCanister pre_test_config + + return pre_test_config{tc_simple_canister = sharedCanister} -- * The actual test suite (see below for helper functions) @@ -347,7 +357,7 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" -- call' cid reply >>= isReject [3] step "Cannot call (inter-canister)?" - cid2 <- install noop + cid2 <- useShared do call' cid2 $ inter_update cid defArgs >>= isRelayReject [3] @@ -375,8 +385,9 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" , testCaseSteps "aaaaa-aa (inter-canister)" $ \step -> do - -- install universal canisters to proxy the requests - cid <- install noop + -- used universal canisters to proxy the requests + cid <- useShared + -- a second canister with different id cid2 <- install noop step "Create" @@ -416,9 +427,8 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" ic_install (ic00via cid) (enum #reinstall) can_id2 trivialWasmModule "" , simpleTestCase "aaaaa-aa (inter-canister, large)" $ \cid -> do - universal_wasm <- getTestWasm "universal_canister" can_id <- ic_create (ic00via cid) - ic_install (ic00via cid) (enum #install) can_id universal_wasm "" + ic_install (ic00via cid) (enum #install) can_id universalWasm "" do call can_id $ replyData "Hi" >>= is "Hi" @@ -469,7 +479,8 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" , simpleTestCase "No response" $ \cid -> call' cid noop >>= isReject [5] - , simpleTestCase "No response does not rollback" $ \cid -> do + , testCase "No response does not rollback" $ do + cid <- install noop call' cid (setGlobal "FOO") >>= isReject [5] query cid (replyData getGlobal) >>= is "FOO" @@ -533,16 +544,19 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" ] , testGroup "state" - [ simpleTestCase "set/get" $ \cid -> do + [ testCase "set/get" $ do + cid <- install noop call_ cid $ setGlobal "FOO" >>> reply query cid (replyData getGlobal) >>= is "FOO" - , simpleTestCase "set/set/get" $ \cid -> do + , testCase "set/set/get" $ do + cid <- install noop call_ cid $ setGlobal "FOO" >>> reply call_ cid $ setGlobal "BAR" >>> reply query cid (replyData getGlobal) >>= is "BAR" - , simpleTestCase "resubmission" $ \cid -> do + , testCase "resubmission" $ do + cid <- install noop -- Submits the same request (same nonce) twice, checks that -- the IC does not act twice. -- (Using growing stable memory as non-idempotent action) @@ -550,107 +564,6 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" query cid (replyData (i2b stableSize)) >>= is "\1\0\0\0" ] - , testGroup "API availablility" $ - {- - This section checks various API calls in various contexts, to see - if they trap when they should - This mirros the table in https://docs.dfinity.systems/public/#system-api-imports - - -} - let - {- - Contexts - - A context is a function of type - (String, Prog -> TestCase, Prog -> TestCase) - building a test for does-not-trap or does-trap - -} - contexts = mconcat - [ "I" =: twoContexts - (reqResponse (\prog -> do - cid <- ic_create ic00 - install' cid prog - )) - (reqResponse (\prog -> do - cid <- install noop - upgrade' cid prog - )) - , "G" =: reqResponse (\prog -> do - cid <- install (onPreUpgrade (callback prog)) - upgrade' cid noop - ) - , "U" =: reqResponse (\prog -> do - cid <- install noop - call' cid (prog >>> reply) - ) - , "Q" =: reqResponse (\prog -> do - cid <- install noop - query' cid (prog >>> reply) - ) - , "Ry" =: reqResponse (\prog -> do - cid <- install noop - call' cid $ inter_query cid defArgs{ - on_reply = prog >>> reply - } - ) - , "Rt" =: reqResponse (\prog -> do - cid <- install noop - call' cid $ inter_query cid defArgs{ - on_reject = prog >>> reply, - other_side = trap "trap!" - } - ) - ] - - -- context builder helpers - reqResponse act = (act >=> void . isReply, act >=> isReject [5]) - twoContexts (aNT1, aT1) (aNT2, aT2) = (\p -> aNT1 p >> aNT2 p,\p -> aT1 p >> aT2 p) - - -- assembling it all - t name trapping prog - | Just n <- find (not . (`HM.member` contexts)) s - = error $ "Undefined context " ++ T.unpack n - | otherwise = - [ if cname `S.member` s - then testCase (name ++ " works in " ++ T.unpack cname) $ actNT prog - else testCase (name ++ " traps in " ++ T.unpack cname) $ actTrap prog - | (cname, (actNT, actTrap)) <- HM.toList contexts - ] - where s = S.fromList (T.words trapping) - - star = "I G U Q Ry Rt" - never = "" - - in concat - [ t "msg_arg_data" "I U Q Ry" $ ignore argData - , t "msg_caller" "I G U Q" $ ignore caller - , t "msg_reject_code" "Ry Rt" $ ignore reject_code - , t "msg_reject_msg" "Rt" $ ignore reject_msg - , t "msg_reply_data_append" "U Q Ry Rt" $ replyDataAppend "Hey!" - , t "msg_reply" never reply -- due to double reply - , t "msg_reject" never $ reject "rejecting" -- due to double reply - , t "msg_funds_available" "U Rt Ry" $ ignore (getAvailableFunds (bytes cycle_unit)) - , t "msg_funds_refunded" "Rt Ry" $ ignore (getRefund (bytes cycle_unit)) - , t "msg_funds_accept" "U Rt Ry" $ acceptFunds (bytes cycle_unit) (int64 0) - , t "canister_self" star $ ignore self - , t "canister_balance" star $ ignore (getBalance (bytes cycle_unit)) - , t "call_new…call_perform" "U Rt Ry" $ - callNew "foo" "bar" "baz" "quux" >>> - callDataAppend "foo" >>> - callFundsAdd (bytes cycle_unit) (int64 0) >>> - callPerform - , t "call_data_append" never $ callDataAppend (bytes "foo") - , t "call_funds_add" never $ callFundsAdd (bytes cycle_unit) (int64 0) - , t "call_perform" never callPerform - , t "stable_size" star $ ignore stableSize - , t "stable_grow" star $ ignore $ stableGrow (int 1) - , t "stable_read" star $ ignore $ stableRead (int 0) (int 0) - , t "stable_write" star $ stableWrite (int 0) "" - , t "time" star $ ignore getTime - , t "debug_print" star $ debugPrint "hello" - , t "trap" never $ trap "this better traps" - ] - , simpleTestCase "self" $ \cid -> query cid (replyData self) >>= is cid @@ -707,14 +620,16 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" call cid (inter_query cid defArgs) >>= is ("Hello " <> cid <> " this is " <> cid) - , simpleTestCase "update commits" $ \cid -> do + , testCase "update commits" $ do + cid <- install noop call_ cid $ setGlobal "FOO" >>> inter_update cid defArgs{ other_side = setGlobal "BAR" >>> reply } query cid (replyData getGlobal) >>= is "BAR" - , simpleTestCase "query does not commit" $ \cid -> do + , testCase "query does not commit" $ do + cid <- install noop call_ cid $ setGlobal "FOO" >>> inter_query cid defArgs{ other_side = setGlobal "BAR" >>> reply } @@ -734,7 +649,8 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" do call' cid $ inter_query cid defArgs{ on_reply = replyData (i2b reject_code) } >>= isRelayReject [0] - , simpleTestCase "Second reply in callback" $ \cid -> do + , testCase "Second reply in callback" $ do + cid <- install noop do call cid $ setGlobal "FOO" >>> replyData "First reply" >>> @@ -827,16 +743,17 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" , simpleTestCase "in update" $ \cid -> query cid (replyData getTimeTwice) >>= as2Word64 >>= bothSame , testCase "in install" $ do - cid <- install $ setGlobal (getTimeTwice) + cid <- install $ setGlobal getTimeTwice query cid (replyData getGlobal) >>= as2Word64 >>= bothSame , testCase "in pre_upgrade" $ do cid <- install $ ignore (stableGrow (int 1)) >>> - onPreUpgrade (callback $ stableWrite (int 0) (getTimeTwice)) + onPreUpgrade (callback $ stableWrite (int 0) getTimeTwice) upgrade cid noop query cid (replyData (stableRead (int 0) (int (2*8)))) >>= as2Word64 >>= bothSame - , simpleTestCase "in post_upgrade" $ \cid -> do - upgrade cid $ setGlobal (getTimeTwice) + , testCase "in post_upgrade" $ do + cid <- install noop + upgrade cid $ setGlobal getTimeTwice query cid (replyData getGlobal) >>= as2Word64 >>= bothSame ] @@ -1006,8 +923,7 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" return cid create_via cid initial_icpts = do cid2 <- ic_create (ic00viaWithFunds cid 1000000000 initial_icpts) - universal_wasm <- getTestWasm "universal_canister" - ic_install (ic00via cid) (enum #install) cid2 universal_wasm (run noop) + ic_install (ic00via cid) (enum #install) cid2 universalWasm (run noop) return cid2 in [ testGroup "can use balance API" $ @@ -1323,6 +1239,107 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" env (mod_req status_req) >>= postCBOR "/api/v1/read" >>= code4xx ] + , testGroup "API availablility" $ + {- + This section checks various API calls in various contexts, to see + if they trap when they should + This mirros the table in https://docs.dfinity.systems/public/#system-api-imports + + -} + let + {- + Contexts + + A context is a function of type + (String, Prog -> TestCase, Prog -> TestCase) + building a test for does-not-trap or does-trap + -} + contexts = mconcat + [ "I" =: twoContexts + (reqResponse (\prog -> do + cid <- ic_create ic00 + install' cid prog + )) + (reqResponse (\prog -> do + cid <- install noop + upgrade' cid prog + )) + , "G" =: reqResponse (\prog -> do + cid <- install (onPreUpgrade (callback prog)) + upgrade' cid noop + ) + , "U" =: reqResponse (\prog -> do + cid <- useShared + call' cid (prog >>> reply) + ) + , "Q" =: reqResponse (\prog -> do + cid <- useShared + query' cid (prog >>> reply) + ) + , "Ry" =: reqResponse (\prog -> do + cid <- useShared + call' cid $ inter_query cid defArgs{ + on_reply = prog >>> reply + } + ) + , "Rt" =: reqResponse (\prog -> do + cid <- useShared + call' cid $ inter_query cid defArgs{ + on_reject = prog >>> reply, + other_side = trap "trap!" + } + ) + ] + + -- context builder helpers + reqResponse act = (act >=> void . isReply, act >=> isReject [5]) + twoContexts (aNT1, aT1) (aNT2, aT2) = (\p -> aNT1 p >> aNT2 p,\p -> aT1 p >> aT2 p) + + -- assembling it all + t name trapping prog + | Just n <- find (not . (`HM.member` contexts)) s + = error $ "Undefined context " ++ T.unpack n + | otherwise = + [ if cname `S.member` s + then testCase (name ++ " works in " ++ T.unpack cname) $ actNT prog + else testCase (name ++ " traps in " ++ T.unpack cname) $ actTrap prog + | (cname, (actNT, actTrap)) <- HM.toList contexts + ] + where s = S.fromList (T.words trapping) + + star = "I G U Q Ry Rt" + never = "" + + in concat + [ t "msg_arg_data" "I U Q Ry" $ ignore argData + , t "msg_caller" "I G U Q" $ ignore caller + , t "msg_reject_code" "Ry Rt" $ ignore reject_code + , t "msg_reject_msg" "Rt" $ ignore reject_msg + , t "msg_reply_data_append" "U Q Ry Rt" $ replyDataAppend "Hey!" + , t "msg_reply" never reply -- due to double reply + , t "msg_reject" never $ reject "rejecting" -- due to double reply + , t "msg_funds_available" "U Rt Ry" $ ignore (getAvailableFunds (bytes cycle_unit)) + , t "msg_funds_refunded" "Rt Ry" $ ignore (getRefund (bytes cycle_unit)) + , t "msg_funds_accept" "U Rt Ry" $ acceptFunds (bytes cycle_unit) (int64 0) + , t "canister_self" star $ ignore self + , t "canister_balance" star $ ignore (getBalance (bytes cycle_unit)) + , t "call_new…call_perform" "U Rt Ry" $ + callNew "foo" "bar" "baz" "quux" >>> + callDataAppend "foo" >>> + callFundsAdd (bytes cycle_unit) (int64 0) >>> + callPerform + , t "call_data_append" never $ callDataAppend (bytes "foo") + , t "call_funds_add" never $ callFundsAdd (bytes cycle_unit) (int64 0) + , t "call_perform" never callPerform + , t "stable_size" star $ ignore stableSize + , t "stable_grow" star $ ignore $ stableGrow (int 1) + , t "stable_read" star $ ignore $ stableRead (int 0) (int 0) + , t "stable_write" star $ stableWrite (int 0) "" + , t "time" star $ ignore getTime + , t "debug_print" star $ debugPrint "hello" + , t "trap" never $ trap "this better traps" + ] + ] type Blob = BS.ByteString @@ -1709,13 +1726,11 @@ barrier cids = do install' :: (HasCallStack, HasTestConfig) => Blob -> Prog -> IO ReqResponse install' cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install' ic00 (enum #install) cid universal_wasm (run prog) + ic_install' ic00 (enum #install) cid universalWasm (run prog) installAt :: (HasCallStack, HasTestConfig) => Blob -> Prog -> IO () installAt cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install ic00 (enum #install) cid universal_wasm (run prog) + ic_install ic00 (enum #install) cid universalWasm (run prog) -- Also calls create, used default 'ic00' install :: (HasCallStack, HasTestConfig) => Prog -> IO Blob @@ -1726,23 +1741,19 @@ install prog = do upgrade' :: (HasCallStack, HasTestConfig) => Blob -> Prog -> IO ReqResponse upgrade' cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install' ic00 (enum #upgrade) cid universal_wasm (run prog) + ic_install' ic00 (enum #upgrade) cid universalWasm (run prog) upgrade :: (HasCallStack, HasTestConfig) => Blob -> Prog -> IO () upgrade cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install ic00 (enum #upgrade) cid universal_wasm (run prog) + ic_install ic00 (enum #upgrade) cid universalWasm (run prog) reinstall' :: (HasCallStack, HasTestConfig) => Blob -> Prog -> IO ReqResponse reinstall' cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install' ic00 (enum #reinstall) cid universal_wasm (run prog) + ic_install' ic00 (enum #reinstall) cid universalWasm (run prog) reinstall :: (HasCallStack, HasTestConfig) => Blob -> Prog -> IO () reinstall cid prog = do - universal_wasm <- getTestWasm "universal_canister" - ic_install ic00 (enum #reinstall) cid universal_wasm (run prog) + ic_install ic00 (enum #reinstall) cid universalWasm (run prog) callRequest :: HasTestConfig => Blob -> Prog -> GenR callRequest cid prog = rec @@ -1791,8 +1802,21 @@ query_ :: (HasCallStack, HasTestConfig) => Blob -> Prog -> IO () query_ cid prog = query cid prog >>= is "" -- Shortcut for test cases that just need one canister +-- +-- This canister may be shared between different tests, so do not assume +-- that its state (stable memory, global) is unmodified, and do not +-- use this canister in upgrades or for stopping etc. + simpleTestCase :: HasTestConfig => String -> (Blob -> IO ()) -> TestTree -simpleTestCase name act = testCase name $ install noop >>= act +simpleTestCase name act = testCase name $ useShared >>= act + +useShared :: HasTestConfig => IO Blob +useShared = tc_simple_canister testConfig + +installSharedCanister :: TestConfig -> IO (IO Blob) +installSharedCanister pre_test_config = delayed $ install noop + where ?testConfig = pre_test_config + -- * Programmatic test generation @@ -1833,6 +1857,9 @@ endPoint = tc_endPoint testConfig testManager :: HasTestConfig => Manager testManager = tc_manager testConfig +universalWasm :: HasTestConfig => Blob +universalWasm = tc_universal_wasm testConfig + -- * Test data access getTestFile :: FilePath -> IO FilePath