From d6a08908bcc392a3215b8e914841d86bce2d6afa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 13 Aug 2022 17:48:08 +0200 Subject: Test: shared state get and wait --- src/Test.hs | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) (limited to 'src/Test.hs') diff --git a/src/Test.hs b/src/Test.hs index b3c7345..694f16d 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -211,6 +211,8 @@ commands = map (T.pack *** id) , ("stored-set-list", cmdStoredSetList) , ("create-identity", cmdCreateIdentity) , ("start-server", cmdStartServer) + , ("shared-state-get", cmdSharedStateGet) + , ("shared-state-wait", cmdSharedStateWait) , ("watch-local-identity", cmdWatchLocalIdentity) , ("watch-shared-identity", cmdWatchSharedIdentity) , ("update-local-identity", cmdUpdateLocalIdentity) @@ -322,6 +324,29 @@ cmdStartServer = do modify $ \s -> s { tsServer = Just server, tsPeers = Just peers } +cmdSharedStateGet :: Command +cmdSharedStateGet = do + h <- maybe (fail "failed to reload head") return =<< maybe (fail "no current head") reloadHead =<< gets tsHead + cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h) + +cmdSharedStateWait :: Command +cmdSharedStateWait = do + st <- asks tiStorage + out <- asks tiOutput + Just h <- gets tsHead + trefs <- asks tiParams + + liftIO $ do + mvar <- newEmptyMVar + w <- watchHeadWith h (lsShared . headObject) $ \cur -> do + mbobjs <- mapM (readRef st . encodeUtf8) trefs + case map wrappedLoad <$> sequence mbobjs of + Just objs | filterAncestors (cur ++ objs) == cur -> do + outLine out $ unwords $ "shared-state-wait" : map T.unpack trefs + void $ forkIO $ unwatchHead =<< takeMVar mvar + _ -> return () + putMVar mvar w + cmdWatchLocalIdentity :: Command cmdWatchLocalIdentity = do Just h <- gets tsHead -- cgit v1.2.3