fix 3Z8iftDL9X

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"))
@@ -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) $

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'

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
 

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
 

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs

@@ -370,3 +370,7 @@ writeBundle env lbs = do
 
       pure $ HashRef th
 
+
+
+
+

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"
+
+

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
+