From 3d778a73a359b2ee87443325eebb3d057aa14c92 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Fri, 16 Oct 2020 20:54:50 +0200 Subject: [PATCH 1/4] ic-ref: Process requests in the background MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit @hansl reported issues with `ic-ref` when doing a heavy request (such as installing a large canister via a wallet canister): The subsequent `/api/v1/read` would not be handled, and eventually timed out. The fact that installing a large caniter via the wallet caniter is very slow is hard to fix while we use an interpreter (optimizing the candid library might help, though – the universal canister handles this use case fine, as the newly added test shows). But with some changes to the code (in `read`, do not try to read from an `MVar` that is blocked, and make sure that the processing after returning HTTP 202 happens in the background), the request status read would be handled, and `dfx` keeps polling as expected. Also added a `--http-log` option that prints some (not very helpful) HTTP logs. Originally https://github.com/dfinity-lab/ic-ref/commit/b0942527bfded26eacf6a1fca8ca77e708ba68fe --- cabal.project.freeze | 11 +++++++++++ ic-ref.cabal | 1 + nix/generated/ic-ref.nix | 2 ++ src/IC/HTTP.hs | 37 +++++++++++++++++++++++++------------ src/IC/Test/Spec.hs | 7 +++++++ src/ic-ref.hs | 17 ++++++++++++----- 6 files changed, 58 insertions(+), 17 deletions(-) diff --git a/cabal.project.freeze b/cabal.project.freeze index e4304502..cf711fcb 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -19,6 +19,7 @@ constraints: any.FloatingHex ==0.4, any.base-orphans ==0.8.2, any.base16-bytestring ==0.1.1.7, any.base32 ==0.1.1.2, + any.base64-bytestring ==1.0.0.3, any.basement ==0.0.11, any.bifunctors ==5.5.7, any.binary ==0.8.7.0, @@ -49,8 +50,10 @@ constraints: any.FloatingHex ==0.4, any.directory ==1.3.6.0, any.distributive ==0.6.2, any.dlist ==0.8.0.8, + any.easy-file ==0.2.2, any.ed25519 ==0.0.5.0, any.exceptions ==0.10.4, + any.fast-logger ==3.0.1, any.filepath ==1.4.2.1, any.generic-deriving ==1.13.1, any.generic-lens ==2.0.0.0, @@ -86,6 +89,8 @@ constraints: any.FloatingHex ==0.4, any.network ==3.1.1.1, any.network-byte-order ==0.1.5, any.network-uri ==2.6.3.0, + any.old-locale ==1.0.0.7, + any.old-time ==1.1.0.3, any.optparse-applicative ==0.15.1.0, any.parsec ==3.1.14.0, any.parser-combinators ==1.2.1, @@ -98,6 +103,7 @@ constraints: any.FloatingHex ==0.4, any.profunctors ==5.5.2, any.psqueues ==0.2.7.2, any.random ==1.1, + any.resourcet ==1.2.4.2, any.row-types ==0.4.0.0, any.rts ==1.0, any.scientific ==0.3.6.2, @@ -124,12 +130,17 @@ constraints: any.FloatingHex ==0.4, any.unbounded-delays ==0.1.1.0, any.unix ==2.7.2.2, any.unix-compat ==0.5.2, + any.unix-time ==0.4.7, + any.unliftio-core ==0.1.2.0, any.unordered-containers ==0.2.10.0, any.utf8-string ==1.0.1.1, any.uuid-types ==1.0.3, any.vault ==0.3.1.4, any.vector ==0.12.1.2, + any.void ==0.7.3, any.wai ==3.2.2.1, + any.wai-extra ==3.0.29.2, + any.wai-logger ==2.3.6, any.warp ==3.3.13, any.wcwidth ==0.0.2, any.winter ==1.0.0, diff --git a/ic-ref.cabal b/ic-ref.cabal index b66d8337..73fc6311 100644 --- a/ic-ref.cabal +++ b/ic-ref.cabal @@ -118,6 +118,7 @@ executable ic-ref build-depends: cborg build-depends: aeson build-depends: warp + build-depends: wai-extra build-depends: wai build-depends: http-types build-depends: unordered-containers diff --git a/nix/generated/ic-ref.nix b/nix/generated/ic-ref.nix index d9548d05..667f4ede 100644 --- a/nix/generated/ic-ref.nix +++ b/nix/generated/ic-ref.nix @@ -44,6 +44,7 @@ , utf8-string , vector , wai +, wai-extra , warp , winter }: @@ -95,6 +96,7 @@ mkDerivation { utf8-string vector wai + wai-extra warp winter ]; diff --git a/src/IC/HTTP.hs b/src/IC/HTTP.hs index 8132bf19..86fa7bb2 100644 --- a/src/IC/HTTP.hs +++ b/src/IC/HTTP.hs @@ -3,7 +3,9 @@ module IC.HTTP where import Network.Wai +import Control.Concurrent (forkIO) import Control.Concurrent.MVar +import Data.IORef import Network.HTTP.Types import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -20,18 +22,19 @@ import IC.Debug.JSON () startApp :: IO Application startApp = do ic <- initialIC - stateVar <- newMVar [ic] - return $ handle stateVar + stateVar <- newMVar ic + history <- newIORef [ic] + return $ handle stateVar history -handle :: MVar [IC] -> Application -handle stateVar req respond = case (requestMethod req, pathInfo req) of +handle :: MVar IC -> IORef [IC] -> Application +handle stateVar history req respond = case (requestMethod req, pathInfo req) of ("GET", []) -> withHistory $ json status200 ("GET", ["api","v1","status"]) -> cbor status200 IC.HTTP.Status.r ("POST", ["api","v1","submit"]) -> withSignedCBOR $ \(pk, gr) -> case asyncRequest gr of Left err -> invalidRequest err - Right ar -> (<* loopIC runStep) $ runIC $ do + Right ar -> runIC $ do authd <- authAsyncRequest pk ar if authd then do @@ -54,20 +57,30 @@ handle stateVar req respond = case (requestMethod req, pathInfo req) of else lift $ invalidRequest "Wrong signature" _ -> notFound where + -- This modifies state, so must be atomic, so blocks on stateVar runIC :: StateT IC IO a -> IO a - runIC a = modifyMVar stateVar $ \(s:ss) -> do + runIC a = do + x <- modifyMVar stateVar $ \s -> do (x, s') <- runStateT a s - return (s':s:ss, x) - + modifyIORef history (s':) + return (s', x) + -- begin processing in the background (it is important that + -- this thread returns, else warp is blocked somehow) + void $ forkIO (loopIC runStep) + return x + + -- Not atomic, reads most recent state from history peekIC :: StateT IC IO a -> IO a peekIC a = do - (s:_) <- readMVar stateVar + (s:_) <- readIORef history evalStateT a s + -- This modifies state, so must be atomic, so blocks on stateVar stepIC :: StateT IC IO Bool -> IO Bool - stepIC a = modifyMVar stateVar $ \(s:ss) -> do + stepIC a = modifyMVar stateVar $ \s -> do (changed, s') <- runStateT a s - return (if changed then s':s:ss else s:ss, changed) + when changed $ modifyIORef history (s':) + return (if changed then s' else s, changed) loopIC :: StateT IC IO Bool -> IO () loopIC a = stepIC a >>= \case @@ -75,7 +88,7 @@ handle stateVar req respond = case (requestMethod req, pathInfo req) of False -> return () withHistory :: ([IC] -> IO a) -> IO a - withHistory a = readMVar stateVar >>= a . reverse + withHistory a = readIORef history >>= a . reverse cbor status gr = respond $ responseBuilder status diff --git a/src/IC/Test/Spec.hs b/src/IC/Test/Spec.hs index 7949d93c..3d948e51 100644 --- a/src/IC/Test/Spec.hs +++ b/src/IC/Test/Spec.hs @@ -391,6 +391,13 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" step "Reinstall on empty" 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 "" + do call can_id $ replyData "Hi" + >>= is "Hi" + , simpleTestCase "randomness" $ \cid -> do r1 <- ic_raw_rand ic00 r2 <- ic_raw_rand ic00 diff --git a/src/ic-ref.hs b/src/ic-ref.hs index e1e51521..76d2fb28 100644 --- a/src/ic-ref.hs +++ b/src/ic-ref.hs @@ -3,6 +3,7 @@ import Options.Applicative import Data.Foldable import Control.Concurrent import Control.Monad (join, forever) +import Network.Wai.Middleware.RequestLogger import Network.Wai.Handler.Warp import qualified Data.Text as T import IC.HTTP @@ -12,18 +13,21 @@ defaultPort :: Port defaultPort = 8001 -work :: Bool -> Maybe FilePath -> IO () -work pickPort writePortTo = do +work :: Bool -> Maybe FilePath -> Bool -> IO () +work pickPort writePortTo log = do putStrLn "Starting ic-ref..." + if pickPort - then withApplicationSettings settings IC.HTTP.startApp $ \port -> do + then withApplicationSettings settings start $ \port -> do greet port forever (threadDelay maxBound) else do - app <- IC.HTTP.startApp + app <- start greet defaultPort runSettings settings app where + start = (if log then logStdoutDev else id) <$> IC.HTTP.startApp + greet port = do putStrLn $ "Running at http://127.0.0.1:" ++ show port ++ "/" for_ writePortTo $ \fn -> writeFile fn (show port) @@ -52,4 +56,7 @@ main = join . customExecParser (prefs showHelpOnError) $ ( long "write-port-to" <> help "write port to the given file" )) - + <*> switch + ( long "http-log" + <> help "print a HTTP log to stdout" + ) From 35250a7809cb39a1ddc84b4862e431bc63bb49cd Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 21 Oct 2020 11:52:21 +0200 Subject: [PATCH 2/4] ic-ref-test: Share one canister among many tests Originally https://github.com/dfinity-lab/ic-ref/commit/79b234087520e241a729f2f8fcb424976873beb5 --- ic-ref.cabal | 1 + src/IC/Test/DelayedIO.hs | 26 ++++++++++++++++ src/IC/Test/Spec.hs | 65 ++++++++++++++++++++++++++++++---------- 3 files changed, 76 insertions(+), 16 deletions(-) create mode 100644 src/IC/Test/DelayedIO.hs diff --git a/ic-ref.cabal b/ic-ref.cabal index b66d8337..adcc879d 100644 --- a/ic-ref.cabal +++ b/ic-ref.cabal @@ -133,6 +133,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 7949d93c..52ecf94e 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 @@ -179,6 +180,7 @@ futureExpiryEnv = modNatField "ingress_expiry" (+ 3600_000_000_000) data TestConfig = TestConfig { tc_manager :: Manager , tc_endPoint :: String + , tc_simple_canister :: IO Blob } preFlight :: OptionSet -> IO TestConfig @@ -193,9 +195,12 @@ preFlight os = do putStrLn $ "Spec version tested: " ++ T.unpack specVersion putStrLn $ "Spec version claimed: " ++ T.unpack (status_api_version s) + sharedCanister <- installSharedCanister manager ep + return TestConfig { tc_manager = manager , tc_endPoint = ep + , tc_simple_canister = sharedCanister } @@ -323,7 +328,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] @@ -351,8 +356,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" @@ -438,7 +444,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" @@ -502,16 +509,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) @@ -541,7 +551,7 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" install' cid prog )) (reqResponse (\prog -> do - cid <- install noop + cid <- useShared upgrade' cid prog )) , "G" =: reqResponse (\prog -> do @@ -549,21 +559,21 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" upgrade' cid noop ) , "U" =: reqResponse (\prog -> do - cid <- install noop + cid <- useShared call' cid (prog >>> reply) ) , "Q" =: reqResponse (\prog -> do - cid <- install noop + cid <- useShared query' cid (prog >>> reply) ) , "Ry" =: reqResponse (\prog -> do - cid <- install noop + cid <- useShared call' cid $ inter_query cid defArgs{ on_reply = prog >>> reply } ) , "Rt" =: reqResponse (\prog -> do - cid <- install noop + cid <- useShared call' cid $ inter_query cid defArgs{ on_reject = prog >>> reply, other_side = trap "trap!" @@ -676,14 +686,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 } @@ -703,7 +715,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" >>> @@ -1729,8 +1742,28 @@ 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. + 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 :: Manager -> String -> IO (IO Blob) +installSharedCanister manager ep = delayed $ do + cid <- ic_create ic00 + installAt cid noop + return cid + where + ?testConfig = TestConfig + { tc_manager = manager + , tc_endPoint = ep + , tc_simple_canister = error "tc_simple_canister not defined yet" + } + -- * Programmatic test generation From 47c00f4f096f30ca42c4f5602184d2a4de679b68 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 21 Oct 2020 12:28:19 +0200 Subject: [PATCH 3/4] Also only load the universal_wasm once Originally https://github.com/dfinity-lab/ic-ref/commit/76ff94d5a73fe696454946d953af62f1222264ae --- src/IC/Test/Spec.hs | 72 +++++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 39 deletions(-) diff --git a/src/IC/Test/Spec.hs b/src/IC/Test/Spec.hs index 78699072..d9607712 100644 --- a/src/IC/Test/Spec.hs +++ b/src/IC/Test/Spec.hs @@ -180,6 +180,7 @@ 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 } @@ -195,13 +196,17 @@ preFlight os = do putStrLn $ "Spec version tested: " ++ T.unpack specVersion putStrLn $ "Spec version claimed: " ++ T.unpack (status_api_version s) - sharedCanister <- installSharedCanister manager 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 TestConfig - { tc_manager = manager - , tc_endPoint = ep - , tc_simple_canister = sharedCanister - } + return pre_test_config{tc_simple_canister = sharedCanister} -- * The actual test suite (see below for helper functions) @@ -398,9 +403,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" @@ -558,7 +562,7 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" install' cid prog )) (reqResponse (\prog -> do - cid <- useShared + cid <- install noop upgrade' cid prog )) , "G" =: reqResponse (\prog -> do @@ -816,16 +820,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 ] @@ -995,8 +1000,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" $ @@ -1667,13 +1671,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 @@ -1684,23 +1686,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 @@ -1751,7 +1749,8 @@ 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. +-- 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 $ useShared >>= act @@ -1759,17 +1758,9 @@ simpleTestCase name act = testCase name $ useShared >>= act useShared :: HasTestConfig => IO Blob useShared = tc_simple_canister testConfig -installSharedCanister :: Manager -> String -> IO (IO Blob) -installSharedCanister manager ep = delayed $ do - cid <- ic_create ic00 - installAt cid noop - return cid - where - ?testConfig = TestConfig - { tc_manager = manager - , tc_endPoint = ep - , tc_simple_canister = error "tc_simple_canister not defined yet" - } +installSharedCanister :: TestConfig -> IO (IO Blob) +installSharedCanister pre_test_config = delayed $ install noop + where ?testConfig = pre_test_config -- * Programmatic test generation @@ -1811,6 +1802,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 From 707607b66e6660edf3a6cd4cd36c99c0c7912288 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 21 Oct 2020 12:46:12 +0200 Subject: [PATCH 4/4] Move API availability tests to the end Originally https://github.com/dfinity-lab/ic-ref/commit/d4b18e0414f321f650c0d818ee5b3a2415a9fee4 --- src/IC/Test/Spec.hs | 202 ++++++++++++++++++++++---------------------- 1 file changed, 101 insertions(+), 101 deletions(-) diff --git a/src/IC/Test/Spec.hs b/src/IC/Test/Spec.hs index d9607712..dec9a5fc 100644 --- a/src/IC/Test/Spec.hs +++ b/src/IC/Test/Spec.hs @@ -540,107 +540,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 <- 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" - ] - , simpleTestCase "self" $ \cid -> query cid (replyData self) >>= is cid @@ -1285,6 +1184,107 @@ icTests = withTestConfig $ testGroup "Public Spec acceptance tests" postCBOR "/api/v1/read" (env (mod_req status_req)) >>= 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