diff options
| -rw-r--r-- | src/Test.hs | 25 |
1 files changed, 25 insertions, 0 deletions
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 |