From 8bb16c352f302e3e4818b97d5f3a57bd75ef20e7 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 8 Aug 2024 17:01:23 +0300 Subject: [PATCH] wip, cursed --- hbs2-sync/src/HBS2/Sync/Prelude.hs | 132 +++++++++++++++++++++++------ 1 file changed, 106 insertions(+), 26 deletions(-) diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index b2796d7d..14bfc2e1 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -137,6 +137,7 @@ data SyncEnv = , dirSyncEnv :: TVar (Map FilePath DirSyncEnv) , dirThis :: TVar (Maybe FilePath) , dirTombs :: TVar (Map FilePath (CompactStorage HbSync)) + , dirCache :: TVar (Map FilePath (CompactStorage HbSync)) } newtype SyncApp m a = @@ -155,6 +156,11 @@ class Monad m => HasTombs m where getTombs :: m (CompactStorage HbSync) closeTombs :: m () + +class Monad m => HasCache m where + getCache :: m (CompactStorage HbSync) + closeCache :: m () + instance MonadUnliftIO m => HasTombs (SyncApp m) where getTombs = do SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException @@ -186,6 +192,38 @@ instance MonadUnliftIO m => HasTombs (SyncApp m) where compactStorageClose tombs +instance MonadUnliftIO m => HasCache (SyncApp m) where + getCache = do + SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException + path <- getRunDir + + mbCache <- dirCache & readTVarIO + <&> Map.lookup path + + case mbCache of + Just tomb -> pure tomb + Nothing -> do + -- FIXME: path-hardcode + let cachePath = path ".hbs2-sync" "state" "txcache" + mkdir (dropFileName cachePath) + stoCache <- compactStorageOpen mempty cachePath + atomically (modifyTVar dirCache (Map.insert path stoCache)) + pure stoCache + + closeCache = do + path <- getRunDir + + void $ runMaybeT do + + SyncEnv{..} <- lift ask >>= toMPlus + + cache <- dirCache & readTVarIO + <&> Map.lookup path + >>= toMPlus + + compactStorageClose cache + + instance MonadIO m => HasClientAPI StorageAPI UNIX (SyncApp m) where getClientAPI = ask >>= orThrow PeerNotConnectedException <&> storageAPI @@ -242,8 +280,9 @@ recover what = do dsync <- newTVarIO mempty this <- newTVarIO Nothing tombs <- newTVarIO mempty + cache <- newTVarIO mempty - let env = Just (SyncEnv refChanAPI storageAPI peerAPI dsync this tombs) + let env = Just (SyncEnv refChanAPI storageAPI peerAPI dsync this tombs cache) liftIO $ withSyncApp env what @@ -325,6 +364,11 @@ data Entry = DirEntry EntryDesc FilePath deriving stock (Eq,Ord,Show,Data,Generic) + +instance Serialise Entry +instance Serialise EntryType +instance Serialise EntryDesc + instance IsContext c => ToSexp c EntryType where toSexp a = mkStr @c $ Text.toLower $ Text.pack $ show a @@ -410,6 +454,7 @@ runDirectory :: ( IsContext c , HasStorage m , HasRunDir m , HasTombs m + , HasCache m , Exception (BadFormException c) ) => RunM c m () runDirectory = do @@ -435,6 +480,7 @@ runDirectory = do `finally` do closeTombs + closeCache where @@ -517,16 +563,19 @@ runDirectory = do notice $ green "removed" <+> pretty p D (p,e) _ -> do - notice $ "deleted locally" <+> pretty p tombs <- getTombs n <- Compact.getValEither @Integer tombs p <&> fromRight (Just 0) - when (n < Just 2) do - postEntryTx (HM.lookup p hasGK0) refchan path e - Compact.putVal tombs p (maybe 0 succ n) + notice $ "deleted locally" <+> pretty n <+> pretty p + + when (n < Just 1) do + notice $ "FUCKING POST TOMB TX" <+> pretty n <+> pretty p + now <- liftIO $ getPOSIXTime <&> round <&> LBS.take 6 . serialise + postEntryTx (Just now) (HM.lookup p hasGK0) refchan path e + Compact.putVal tombs p (maybe 1 succ n) N (p,_) -> do notice $ "?" <+> pretty p @@ -535,14 +584,14 @@ runDirectory = do notice $ green "move" <+> pretty f <+> pretty t mv (path f) (path t) notice $ green "post renamed entry tx" <+> pretty f - postEntryTx (HM.lookup f hasGK0) refchan path e + postEntryTx Nothing (HM.lookup f hasGK0) refchan path e E (p,UpdatedFileEntry _ e) -> do let fullPath = path p here <- liftIO $ doesFileExist fullPath writeEntry path e notice $ red "updated" <+> pretty here <+> pretty p - postEntryTx (HM.lookup p hasGK0) refchan path e + postEntryTx Nothing (HM.lookup p hasGK0) refchan path e E (p,e@(FileEntry _)) -> do let fullPath = path p @@ -564,7 +613,7 @@ runDirectory = do let members = view refChanHeadReaders rch & HS.toList when (rcpt /= members) do notice $ red "update group key" <+> pretty p - lift $ postEntryTx (Just gk0) refchan path e + lift $ postEntryTx Nothing (Just gk0) refchan path e E (p,TombEntry e) -> do let fullPath = path p @@ -572,11 +621,12 @@ runDirectory = do when here do tombs <- getTombs - postEntryTx (HM.lookup p hasGK0) refchan path e + postEntryTx Nothing (HM.lookup p hasGK0) refchan path e n <- Compact.getValEither @Integer tombs p <&> fromRight (Just 0) + notice $ red "YEAH, mttf!" Compact.putVal tombs p (maybe 0 succ n) b <- backupMode @@ -624,12 +674,13 @@ postEntryTx :: ( MonadUnliftIO m , HasClientAPI StorageAPI UNIX m , HasClientAPI RefChanAPI UNIX m ) - => Maybe (GroupKey 'Symm 'HBS2Basic) + => Maybe (LBS.ByteString) + -> Maybe (GroupKey 'Symm 'HBS2Basic) -> MyRefChan -> FilePath -> Entry -> m () -postEntryTx mgk refchan path entry = do +postEntryTx nonce' mgk refchan path entry = do sto <- getStorage @@ -691,7 +742,7 @@ postEntryTx mgk refchan path entry = do -- FIXME: remove-nonce -- пока что будем постить транзакцию всегда. -- в дальнейшем стоит избавиться от нонса - nonce <- liftIO getPOSIXTime <&> serialise . take 4 . reverse . show + let nonce = fromMaybe mempty nonce' let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx <> nonce) notice $ red "post tree tx" <+> pretty p <+> pretty href @@ -827,6 +878,7 @@ getStateFromDir0 :: ( MonadUnliftIO m , HasClientAPI StorageAPI UNIX m , HasStorage m , HasRunDir m + , HasCache m ) => Bool -> m [(FilePath, Entry)] @@ -846,6 +898,7 @@ getStateFromDir :: ( MonadUnliftIO m , HasClientAPI StorageAPI UNIX m , HasStorage m , HasRunDir m + , HasCache m ) => Bool -- ^ use remote state as seed -> FilePath -- ^ dir @@ -888,6 +941,7 @@ getStateFromRefChan :: forall m . ( MonadUnliftIO m , HasClientAPI StorageAPI UNIX m , HasStorage m , HasRunDir m + , HasCache m ) => MyRefChan -> m [(FilePath, Entry)] @@ -895,6 +949,8 @@ getStateFromRefChan rchan = do debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan) + cache <- getCache + sto <- getStorage outq <- newTQueueIO @@ -919,27 +975,31 @@ getStateFromRefChan rchan = do for_ s $ lift . S.yield pure $ headMay r + -- FIXME: may-be-slow - walkRefChanTx @UNIX (const $ pure True) rchan $ \txh -> \case - A (AcceptTran ts _ what) -> do - -- debug $ red "ACCEPT" <+> pretty ts <+> pretty what - for_ ts $ \w -> do - atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 w)) + walkRefChanTx @UNIX (\t -> pure True) rchan $ \txh u -> do - P orig (ProposeTran _ box) -> void $ runMaybeT do - (_, bs) <- unboxSignedBox0 box & toMPlus - AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs) - & toMPlus . either (const Nothing) Just + case u of - runExceptT (extractMetaData @'HBS2Basic findKey sto href) - >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, (href, meta)) ) + A (AcceptTran ts _ what) -> do + -- debug $ red "ACCEPT" <+> pretty ts <+> pretty what + for_ ts $ \w -> do + atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 w)) + + P orig (ProposeTran _ box) -> void $ runMaybeT do + (_, bs) <- unboxSignedBox0 box & toMPlus + AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs) + & toMPlus . either (const Nothing) Just + + runExceptT (extractMetaData @'HBS2Basic findKey sto href) + >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, ((href, meta), txh)) ) trees <- atomically (flushTQueue outq) tsmap <- readTVarIO tss ess0 <- S.toList_ do - for_ trees $ \(txh, (tree, meta)) -> do + for_ trees $ \(txh, ((tree, meta),txxx)) -> do let what = parseTop meta & fromRight mempty let loc = headDef "" [ l | ListVal [StringLike "location:", StringLike l] <- what ] @@ -958,7 +1018,13 @@ getStateFromRefChan rchan = do let r = entriesFromFile (Just tree) ts fullPath lift $ S.yield r - pure $ Map.toList $ Map.unionsWith merge ess0 + let r = Map.unionsWith merge ess0 + + liftIO $ LBS.writeFile ".GOVNOSTATE" (serialise r) + + pure (Map.toList r) + + -- pure $ Map.toList $ Map.unionsWith merge ess0 getTreeContents :: ( MonadUnliftIO m @@ -1041,6 +1107,19 @@ instance (Monad m, HasTombs m) => HasTombs (RunM c m) where getTombs = lift getTombs closeTombs = lift closeTombs +instance HasCache m => HasCache (ContT r m) where + getCache = lift getCache + closeCache = lift closeCache + +instance HasCache m => HasCache (MaybeT m) where + getCache = lift getCache + closeCache = lift closeCache + +instance (Monad m, HasCache m) => HasCache (RunM c m) where + getCache = lift getCache + closeCache = lift closeCache + + syncEntries :: forall c m . ( MonadUnliftIO m , IsContext c , Exception (BadFormException c) @@ -1049,6 +1128,7 @@ syncEntries :: forall c m . ( MonadUnliftIO m , HasStorage m , HasRunDir m , HasTombs m + , HasCache m , MonadReader (Maybe SyncEnv) m ) => MakeDictM c m () @@ -1302,7 +1382,7 @@ syncEntries = do now <- liftIO getPOSIXTime <&> round notice $ red "ABOUT TO POST TOMB TX" <+> pretty p - lift $ postEntryTx Nothing rchan path (makeTomb now p mzero) + lift $ postEntryTx Nothing Nothing rchan path (makeTomb now p mzero) _ -> pure ()