From ef7fc8960e06f35edd49ffbd5477a8969706321d Mon Sep 17 00:00:00 2001 From: voidlizard Date: Tue, 8 Oct 2024 13:08:33 +0300 Subject: [PATCH] fix 3Z8iftDL9X --- hbs2-git/git-hbs2/Main.hs | 116 +++++++++++++++--- hbs2-git/git-remote-hbs2/Main.hs | 9 +- .../HBS2/Git/Client/Export.hs | 7 +- .../HBS2/Git/Client/State.hs | 33 +++++ .../HBS2/Git/Data/Tx/Git.hs | 4 + .../hbs2-git-client-lib/HBS2/Git/Local.hs | 2 + .../hbs2-git-client-lib/HBS2/Git/Local/CLI.hs | 20 +++ 7 files changed, 169 insertions(+), 22 deletions(-) diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index ceec75c2..91f6d622 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -22,15 +22,21 @@ import HBS2.Git.Data.GK import HBS2.KeyMan.Keys.Direct import HBS2.Storage.Operations.ByteString +import Data.Config.Suckless.Script + import Data.Text qualified as Text import Data.Text.IO qualified as Text import Data.HashSet qualified as HS import Data.Maybe import Data.List (nubBy) +import Data.List qualified as L import Data.Function (on) +import Data.HashMap.Strict qualified as HM import Data.Coerce import Options.Applicative as O import Data.ByteString.Lazy qualified as LBS +import Prettyprinter +import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString (ByteString) -- import Data.ByteString.Lazy (ByteString) import Text.InterpolatedString.Perl6 (qc) @@ -39,6 +45,8 @@ import Streaming.Prelude qualified as S import System.Exit +{- HLINT ignore "Functor law" -} + globalOptions :: Parser [GitOption] globalOptions = do @@ -54,12 +62,13 @@ globalOptions = do commands :: GitPerks m => Parser (GitCLI m ()) commands = - hsubparser ( command "export" (info pExport (progDesc "export repo to hbs2-git")) - <> command "import" (info pImport (progDesc "import repo from reflog")) - <> command "key" (info pKey (progDesc "key management")) + hsubparser ( command "export" (info pExport (progDesc "export repo to hbs2-git")) + <> command "import" (info pImport (progDesc "import repo from reflog")) + <> command "key" (info pKey (progDesc "key management")) <> command "manifest" (info pManifest (progDesc "manifest commands")) - <> command "track" (info pTrack (progDesc "track tools")) - <> command "tools" (info pTools (progDesc "misc tools")) + <> command "track" (info pTrack (progDesc "track tools")) + <> command "tools" (info pTools (progDesc "misc tools")) + <> command "run" (info pRun (progDesc "run new cli command; run help to figure it out")) ) @@ -80,6 +89,11 @@ pInit = do pure runDefault +pRun :: GitPerks m => Parser (GitCLI m ()) +pRun = do + args <- many (strArgument (metavar "SCRIPT")) + pure $ runScriptArgs args + pExport :: GitPerks m => Parser (GitCLI m ()) pExport = do @@ -165,17 +179,9 @@ pShowLww = pure do pShowRef :: GitPerks m => Parser (GitCLI m ()) pShowRef = do + remote <- strArgument (metavar "REMOTE") pure do - sto <- asks _storage - void $ runMaybeT do - - tx <- withState do - selectMaxAppliedTx >>= lift . toMPlus <&> fst - - (_,rh) <- TX.readRepoHeadFromTx sto tx >>= toMPlus - - liftIO $ print $ vcat (fmap formatRef (view repoHeadRefs rh)) - + runScript [mkList @C [mkSym "remote:refs:show", mkSym remote]] pManifest :: GitPerks m => Parser (GitCLI m ()) pManifest = hsubparser ( command "list" (info pManifestList (progDesc "list all manifest")) @@ -250,7 +256,7 @@ pManifestUpdate = do addManifestBriefAndName $ Just t StdInput -> do t <- liftIO $ Text.getContents - addManifestBriefAndName $ Just t + addManifestBriefAndName $ Just t env <- ask enc <- getRepoEnc let manifestUpdateEnv = Just $ ManifestUpdateEnv {_manifest = manifest} @@ -417,6 +423,84 @@ pGenRepoIndex = do let tx = GitIndexTx what seq (GitIndexRepoDefine hd) liftIO $ LBS.putStr (serialise tx) + +script :: GitPerks m => Parser (GitCLI m ()) +script = do + rest <- many (strArgument (metavar "CLI") ) + pure do + cli <- parseTop (unlines $ unwords <$> splitForms rest) + & either (error.show) pure + void $ runScript cli + +runScriptArgs :: GitPerks m => [String] -> GitCLI m () +runScriptArgs cli = do + cli <- parseTop (unlines $ unwords <$> splitForms cli) + & either (error.show) pure + void $ runScript cli + +runScript :: GitPerks m => [Syntax C] -> GitCLI m () +runScript syn = void $ run theDict syn + +quit :: MonadIO m => m () +quit = liftIO exitSuccess + +theDict :: forall m . ( GitPerks m + -- , HasTimeLimits UNIX (ServiceProto MyRPC UNIX) m + ) => Dict C (GitCLI m) +theDict = do + makeDict @C do + -- TODO: write-man-entries + myHelpEntry + myEntries + + where + + myHelpEntry = do + entry $ bindMatch "help" $ nil_ $ \case + HelpEntryBound what -> do + helpEntry what + quit + + [StringLike s] -> helpList False (Just s) >> quit + + _ -> helpList False Nothing >> quit + + + myEntries = do + entry $ bindMatch "remote:hbs2:show" $ nil_ $ \case + _ -> do + -- TODO: move-to-HBS2.Local.CLI + remotes <- Git.gitListHBS2Remotes + let w = fmap (length.fst) remotes & maximumDef 8 + for_ remotes $ \(n,r) -> do + liftIO $ print $ fill w (pretty n) <+> pretty (AsBase58 r) + + entry $ bindMatch "remote:refs:show" $ nil_ $ \args -> lift do + + sto <- getStorage + + remotez <- Git.gitListHBS2Remotes <&> HM.fromList + let zetomer = HM.fromList [ (v,k) | (k,v) <- HM.toList remotez ] + + lww <- case args of + + [ StringLike x ] | x `HM.member` remotez -> do + orThrowUser ( "remote" <+> pretty x <+> "not found" ) (HM.lookup x remotez) + + [ SignPubKeyLike what ] | what `HM.member` zetomer -> do + pure what + + _ -> throwIO $ BadFormException @C nil + + warn $ green "lwwref" <+> pretty (AsBase58 lww) + + void $ runMaybeT do + rh <- readActualRepoHeadFor (LWWRefKey lww) + >>= toMPlus + + liftIO $ print $ vcat (fmap formatRef (view repoHeadRefs rh)) + + main :: IO () main = do (o, action) <- customExecParser (prefs showHelpOnError) $ diff --git a/hbs2-git/git-remote-hbs2/Main.hs b/hbs2-git/git-remote-hbs2/Main.hs index 6ec3f9fd..d0df4157 100644 --- a/hbs2-git/git-remote-hbs2/Main.hs +++ b/hbs2-git/git-remote-hbs2/Main.hs @@ -178,10 +178,13 @@ main = do -- FIXME: may-cause-reference-inconsistency -- надо брать max(head) для lwwref -- а не максимальную транзу, накаченную на репо - r' <- runMaybeT $ withState do - tx <- selectMaxAppliedTx >>= lift . toMPlus <&> fst + r' <- runMaybeT do + -- tx <- selectMaxAppliedTx >>= lift . toMPlus <&> fst + + -- (_,rh) <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus + rh <- liftIO (withGitEnv env (readActualRepoHeadFor puk)) + >>= toMPlus - (_,rh) <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus pure (view repoHeadRefs rh) let r = fromMaybe mempty r' diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs index 8b17fce8..ced32209 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs @@ -33,6 +33,7 @@ import Data.Maybe import Data.List qualified as L import Data.Ord (comparing) import Data.Either +import Data.Coerce data ExportError = ExportUnsupportedOperation | ExportBundleCreateError @@ -191,7 +192,7 @@ export key refs = do callCC \exit -> do - tx0 <- getLastAppliedTx + tx0 <- getLastAppliedTx key rh <- runMaybeT ( toMPlus tx0 >>= readRepoHeadFromTx sto >>= toMPlus ) @@ -309,8 +310,8 @@ export key refs = do notInTx Nothing _ = pure True notInTx (Just tx0) obj = not <$> isObjectInTx tx0 obj - getLastAppliedTx = runMaybeT do - (tx0,_) <- withState selectMaxAppliedTx + getLastAppliedTx lww = runMaybeT do + (tx0,_) <- withState (selectMaxAppliedTxForRepo lww) >>= toMPlus pure tx0 diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs index b2e9c414..cfb960cd 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs @@ -17,6 +17,8 @@ import HBS2.Git.Data.RepoHead import HBS2.Git.Data.RefLog import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.Tx.Index +import HBS2.Git.Data.Tx.Git qualified as TX +-- import HBS2.Git.Data.Tx qualified as TX import DBPipe.SQLite import Data.Maybe @@ -294,6 +296,21 @@ SELECT t.tx, t.seq FROM txdone d JOIN tx t ON d.tx = t.tx ORDER BY t.seq DESC LI |] () <&> listToMaybe + +selectMaxAppliedTxForRepo :: MonadIO m => LWWRefKey 'HBS2Basic -> DBPipeM m (Maybe (HashRef, Integer)) +selectMaxAppliedTxForRepo lww = do + select [qc| + with rl as ( + select l.hash, l.reflog from lww l where l.hash = ? + order by seq desc limit 1 + ) + select t.tx, t.seq + from txdone d join tx t on d.tx = t.tx + join rl on rl.reflog = t.reflog + order by t.seq desc limit 1 + |] (Only (Base58Field lww)) + <&> listToMaybe + insertBundleDone :: MonadIO m => HashRef -> DBPipeM m () insertBundleDone hashRef = do insert [qc| @@ -470,4 +487,20 @@ loadRepoHead rh = do <&> deserialiseOrFail @RepoHead >>= toMPlus +readActualRepoHeadFor :: ( HasStorage m + , MonadReader GitEnv m + , MonadIO m + ) + => LWWRefKey 'HBS2Basic -> m (Maybe RepoHead) + +readActualRepoHeadFor lww = do + sto <- getStorage + runMaybeT do + tx <- lift ( withState $ + selectMaxAppliedTxForRepo lww + <&> fmap fst + ) >>= toMPlus + + (_,rh) <- TX.readRepoHeadFromTx sto tx >>= toMPlus + pure rh diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs index ff5728ec..03968aab 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs @@ -370,3 +370,7 @@ writeBundle env lbs = do pure $ HashRef th + + + + diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs index b2658571..37b87342 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs @@ -69,3 +69,5 @@ instance Pretty GitObjectType where Commit -> pretty @String "commit" Tree -> pretty @String "tree" Blob -> pretty @String "blob" + + diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local/CLI.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local/CLI.hs index 83238623..590ff259 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local/CLI.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local/CLI.hs @@ -1,6 +1,7 @@ module HBS2.Git.Local.CLI where import HBS2.Prelude +import HBS2.Git.Client.Prelude import System.FilePath import HBS2.System.Dir @@ -10,10 +11,14 @@ import System.Environment hiding (setEnv) import Control.Monad.Trans.Maybe import Control.Applicative import System.Process.Typed +import Data.List qualified as L +import Data.Maybe import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy.Char8 qualified as LBS8 import Text.InterpolatedString.Perl6 (qc) +{- HLINT ignore "Functor law" -} + findGitDir :: MonadIO m => m (Maybe FilePath) findGitDir = findGitDir' =<< pwd where @@ -64,3 +69,18 @@ gitRunCommand cmd = do e -> pure (Left e) +gitListHBS2Remotes :: MonadIO m + => m [(String,PubKey 'Sign HBS2Basic)] +gitListHBS2Remotes = do + let gd = "" :: String + gitRunCommand [qc|git {gd} remote -v|] + >>= either (error.show) pure + <&> LBS8.unpack + <&> lines + <&> fmap (take 2 . words) + <&> mapMaybe \case + [n, r] | L.isPrefixOf "hbs2://" r -> do + (n,) <$> (L.stripPrefix "hbs2://" r >>= fromStringMay @(PubKey 'Sign HBS2Basic)) + _ -> Nothing + <&> L.nub +