diff --git a/.fixme-new/config b/.fixme-new/config index 59c1cd0e..0433b911 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -31,20 +31,16 @@ fixme-file-comments "*.scm" ";" fixme-comments ";" "--" ;(fixme-play-log-action -; (import-fixmies ".fixme-new/fixme.log") +; (import ".fixme-new/log") ;) -(fixme-play-log-action - (play-log-file ".fixme-new/log") -) - (fixme-play-log-action (play-git-log-file-all ".fixme-new/log") ) -;(fixme-play-log-action -; (export-fixmies ".fixme-new/fixme.log") -;) +(fixme-play-log-action + (export ".fixme-new/fixme.log") +) (fixme-play-log-action (hello kitty) diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 29876b13..0c0ebecc 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -17,6 +17,7 @@ import HBS2.Git.Local.CLI import HBS2.Base58 import HBS2.Merkle import HBS2.Data.Types.Refs +import HBS2.Storage import HBS2.Storage.Compact import HBS2.System.Dir import DBPipe.SQLite hiding (field) @@ -293,6 +294,72 @@ modify_ txt a b = do ha <- toMPlus =<< lift (selectFixmeHash txt) lift $ insertFixmeModStaged ha (fromString a) (fromString b) +exportToLog :: FixmePerks m => FilePath -> FixmeM m () +exportToLog fn = do + e <- getEpoch + warn $ red "EXPORT-FIXMIES" <+> pretty fn + sto <- compactStorageOpen @HbSync mempty fn + fx <- selectFixmeThin () + for_ fx $ \(FixmeThin m) -> void $ runMaybeT do + h <- HM.lookup "fixme-hash" m & toMPlus + loaded <- lift (selectFixme (coerce h)) >>= toMPlus + let what = Added e loaded + let k = mkKey what + get sto k >>= guard . isNothing + put sto (mkKey what) (LBS.toStrict $ serialise what) + warn $ red "export" <+> pretty h + + what <- selectStage + + for_ what $ \w -> do + let k = mkKey w + v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) + case v0 of + Nothing -> do + put sto k (LBS.toStrict $ serialise w) + + Just (Left{}) -> do + put sto k (LBS.toStrict $ serialise w) + + Just (Right prev) | getSequence w > getSequence prev -> do + put sto k (LBS.toStrict $ serialise w) + + _ -> pure () + + compactStorageClose sto + + +importFromLog :: FixmePerks m => CompactStorage HbSync -> FixmeM m () +importFromLog sto = do + fset <- listAllFixmeHashes + + -- sto <- compactStorageOpen @HbSync readonly fn + ks <- keys sto + + toImport <- S.toList_ do + for_ ks $ \k -> runMaybeT do + v <- get sto k & MaybeT + what <- deserialiseOrFail @CompactAction (LBS.fromStrict v) & toMPlus + + case what of + Added _ fx -> do + let ha = hashObject @HbSync (serialise fx) & HashRef + unless (HS.member ha fset) do + warn $ red "import" <+> viaShow (pretty ha) + lift $ S.yield (Right fx) + w -> lift $ S.yield (Left $ fromRight mempty $ parseTop (show $ pretty w)) + + withState $ transactional do + for_ (rights toImport) insertFixme + + let w = lefts toImport + runForms (mconcat w) + + unless (List.null toImport) do + updateIndexes + + -- compactStorageClose sto + printEnv :: FixmePerks m => FixmeM m () printEnv = do g <- asks fixmeEnvGitDir >>= readTVarIO @@ -566,89 +633,17 @@ runForms ss = for_ ss $ \s -> do ListVal [SymbolVal "play-git-log-file-all", StringLike fn] -> do warn $ red "play-git-log-file-all" <+> pretty fn - scanGitLogLocal fn runForms - - ListVal [SymbolVal "import-fixmies", StringLike fn] -> do - warn $ red "IMPORT-FIXMIES" <+> pretty fn - - fset <- listAllFixmeHashes - - sto <- compactStorageOpen @HbSync readonly fn - ks <- keys sto - - toImport <- S.toList_ do - for_ ks $ \k -> runMaybeT do - v <- get sto k & MaybeT - what <- deserialiseOrFail @CompactAction (LBS.fromStrict v) & toMPlus - - case what of - Added _ fx -> do - let ha = hashObject @HbSync (serialise fx) & HashRef - unless (HS.member ha fset) do - warn $ red "import" <+> viaShow (pretty ha) - lift $ S.yield (Right fx) - w -> lift $ S.yield (Left $ fromRight mempty $ parseTop (show $ pretty w)) - - withState $ transactional do - for_ (rights toImport) insertFixme - - let w = lefts toImport - runForms (mconcat w) - - unless (List.null toImport) do - updateIndexes + scanGitLogLocal fn importFromLog + ListVal [SymbolVal "import", StringLike fn] -> do + warn $ red "IMPORT" <+> pretty fn + sto <- compactStorageOpen readonly fn + importFromLog sto compactStorageClose sto - pure () - - ListVal [SymbolVal "export-fixmies", StringLike fn] -> do - e <- getEpoch - warn $ red "EXPORT-FIXMIES" <+> pretty fn - sto <- compactStorageOpen @HbSync mempty fn - fx <- selectFixmeThin () - for_ fx $ \(FixmeThin m) -> void $ runMaybeT do - h <- HM.lookup "fixme-hash" m & toMPlus - loaded <- lift (selectFixme (coerce h)) >>= toMPlus - let what = Added e loaded - let k = mkKey what - get sto k >>= guard . isNothing - put sto (mkKey what) (LBS.toStrict $ serialise what) - warn $ red "export" <+> pretty h - compactStorageClose sto - - ListVal [SymbolVal "play-log-file", StringLike fn] -> do - - env <- ask - - debug $ red "play-log-file" <+> pretty fn - - what <- selectStage - - sto <- compactStorageOpen @HbSync mempty fn - - for_ what $ \w -> do - let k = mkKey w - v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) - case v0 of - Nothing -> do - put sto k (LBS.toStrict $ serialise w) - - Just (Left{}) -> do - put sto k (LBS.toStrict $ serialise w) - - Just (Right prev) | getSequence w > getSequence prev -> do - put sto k (LBS.toStrict $ serialise w) - - _ -> pure () - - compactStorageCommit sto - - loadAllEntriesFromLog sto >>= runForms - - cleanStage - - compactStorageClose sto + ListVal [SymbolVal "export", StringLike fn] -> do + warn $ red "EXPORT" <+> pretty fn + exportToLog fn ListVal [SymbolVal "git:list-refs"] -> do refs <- listRefs False diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs index 2bffe13b..aa02b279 100644 --- a/fixme-new/lib/Fixme/Scan/Git/Local.hs +++ b/fixme-new/lib/Fixme/Scan/Git/Local.hs @@ -11,6 +11,7 @@ import Fixme.State import Fixme.Scan as Scan import Fixme.Log +import HBS2.Storage import HBS2.Storage.Compact import HBS2.System.Dir import HBS2.Git.Local.CLI @@ -164,7 +165,7 @@ filterBlobs xs = do scanGitLogLocal :: FixmePerks m => FilePath - -> ( [Syntax C] -> FixmeM m () ) + -> ( CompactStorage HbSync -> FixmeM m () ) -> FixmeM m () scanGitLogLocal refMask play = do warn $ red "scanGitLogLocal" <+> pretty refMask @@ -211,7 +212,7 @@ scanGitLogLocal refMask play = do either (const $ warn $ "skip malformed/unknown log" <+> pretty h) (const none) esto sto <- either (const $ shit ()) pure esto - lift $ lift $ loadAllEntriesFromLog sto >>= play + lift $ lift $ play sto compactStorageClose sto