Added the manifest update command, fixed bugs

docs/papers/hbs2-git-doc-0.24.1.tex

@@ -668,8 +668,8 @@ Cloning into '8vFu9S79ysdWag4wek53YWXbC5nCRLF7arGp6181G4js'...
 git hbs2 export --encrypted ./gk-new.key  C6tTuapmG7sE8QktQo4q4tBr8kNWKvBruNb36HYThpuy
 \end{verbatim}
 
-Для обновления манифеста --- редактировать файл \texttt{.hbs2-git/manifest} и сделать
-git commit/push либо же вызвать \texttt{git hbs2 export <LWWREF>}
+Для обновления манифеста --- редактировать файл \texttt{.hbs2-git/manifest}
+ и вызвать \texttt{git hbs2 manifest update <LWWREF>}
 
 \subsubsection{Смотреть групповой ключ}
 

hbs2-core/lib/HBS2/Data/Types/EncryptedBox.hs

@@ -8,7 +8,7 @@ import Data.ByteString (ByteString)
 -- TODO: encryption-type-into-tags
 -- FIXME: show-scrambled?
 newtype EncryptedBox t = EncryptedBox { unEncryptedBox :: ByteString }
-  deriving stock (Generic,Show,Data)
+  deriving stock (Eq,Generic,Show,Data)
 
 instance Serialise (EncryptedBox t)
 

hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs

@@ -77,6 +77,12 @@ data instance GroupKey 'Symm s =
   }
   deriving stock (Generic)
 
+deriving instance
+    ( Eq (PubKey 'Encrypt s)
+    , Eq (EncryptedBox GroupSecret)
+    )
+    => Eq (GroupKey 'Symm s)
+
 instance ForGroupKeySymm s => Monoid (GroupKey 'Symm s) where
   mempty = GroupKeySymm mempty
 

hbs2-git/git-hbs2/Main.hs

@@ -1,11 +1,12 @@
 {-# Language UndecidableInstances #-}
 module Main where
 
-import HBS2.Git.Client.Prelude hiding (info)
+import HBS2.Git.Client.Prelude hiding (info, Input(..))
 import HBS2.Git.Client.App
 import HBS2.Git.Client.Export
 import HBS2.Git.Client.Import
 import HBS2.Git.Client.State
+import HBS2.Git.Client.Manifest
 
 import HBS2.Data.Types.SignedBox
 import HBS2.Git.Data.RepoHead
@@ -25,6 +26,8 @@ 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.Function (on)
 import Data.Coerce
 import Options.Applicative as O
 import Data.ByteString.Lazy qualified as LBS
@@ -177,26 +180,28 @@ pShowRef = do
 pManifest :: GitPerks m => Parser (GitCLI m ())
 pManifest = hsubparser (   command "list" (info pManifestList (progDesc "list all manifest"))
                         <> command "show" (info pManifestShow (progDesc "show manifest"))
+                        <> command "update" (info pManifestUpdate (progDesc "update manifest"))
                        )
 
 pManifestList :: GitPerks m => Parser (GitCLI m ())
 pManifestList = do
   what <- argument pLwwKey (metavar "LWWREF")
   pure do
-    heads <- withState $ selectRepoHeadsFor ASC what
-    sto   <- getStorage
-    for_ heads $ \h -> runMaybeT do
-
-      rhead <- runExceptT (readFromMerkle sto (SimpleKey (coerce h)))
-                 >>= toMPlus
-                 <&> deserialiseOrFail @RepoHead
-                 >>= toMPlus
-
-      let mfsize = maybe 0 Text.length (_repoManifest rhead)
-      let mf = parens ( "manifest" <+> pretty mfsize)
-
-      liftIO $ print $ pretty (_repoHeadTime rhead)
-                         <+> pretty h
+    repoHeadRefs' <- withState $ selectRepoHeadsFor ASC what
+    sto <- getStorage
+    repoHeads <- for repoHeadRefs' $ \repoHeadRef -> runMaybeT $ do
+      repoHead <- runExceptT (readFromMerkle sto (SimpleKey (coerce repoHeadRef)))
+        >>= toMPlus
+        <&> deserialiseOrFail @RepoHead
+        >>= toMPlus
+      pure (repoHeadRef, repoHead)
+    let removeDuplicates = nubBy ((==) `on` (_repoManifest . snd))
+    let filteredRepoHeads = removeDuplicates $ catMaybes repoHeads
+    for_ filteredRepoHeads $ \(repoHeadRef, repoHead) -> do
+      let mfLen = maybe 0 Text.length (_repoManifest repoHead)
+      let mf = parens ("manifest length" <+> pretty mfLen)
+      liftIO $ print $ pretty (_repoHeadTime repoHead)
+                         <+> pretty repoHeadRef
                          <+> mf
 
 pManifestShow :: GitPerks m => Parser (GitCLI m ())
@@ -212,6 +217,71 @@ pManifestShow = do
 
       liftIO $ for_ (_repoManifest rhead) Text.putStrLn
 
+data Input
+  = FileInput FilePath
+  | StdInput
+
+manifestFileInput :: Parser Input
+manifestFileInput = FileInput <$> strOption
+  (  long "file"
+  <> short 'f'
+  <> metavar "FILENAME"
+  <> help "Read manifest from file" )
+
+manifestStdInput :: Parser Input
+manifestStdInput = flag' StdInput
+  (  long "stdin"
+  <> help "Read manifest from stdin" )
+
+pManifestUpdate :: (GitPerks m) => Parser (GitCLI m ())
+pManifestUpdate = do
+  what <- argument pLwwKey (metavar "LWWREF")
+  manifestInput <- manifestFileInput <|> manifestStdInput
+  et <-
+    flag
+      ExportInc
+      ExportNew
+      ( long "new" <> help "This flag is used for new repositories. It allows you to skip the step of downloading data from peers."
+      )
+  pure do
+    manifest <- case manifestInput of
+      FileInput f -> do
+         t <- liftIO $ Text.readFile f
+         addManifestBriefAndName $ Just t
+      StdInput -> do
+        t <- liftIO $ Text.getContents
+        addManifestBriefAndName $ Just t 
+    env <- ask
+    enc <- getRepoEnc
+    let manifestUpdateEnv = Just $ ManifestUpdateEnv {_manifest = manifest}
+    withGitEnv
+      ( env
+          & set gitApplyHeads False
+          & set gitExportType et
+          & set gitExportEnc enc
+          & set gitManifestUpdateEnv manifestUpdateEnv
+      )
+      do
+        unless (et == ExportNew) do
+          importRepoWait what
+        export what mempty
+        importRepoWait what
+
+getRepoEnc :: (GitPerks m) => GitCLI m ExportEncryption
+getRepoEnc = do
+  sto <- asks _storage
+  mgkh <- runMaybeT do
+    tx <- withState do
+      selectMaxAppliedTx >>= lift . toMPlus <&> fst
+    (_, rh) <-
+      TX.readRepoHeadFromTx sto tx
+        >>= toMPlus
+    toMPlus $ _repoHeadGK0 rh
+  case mgkh of
+    Nothing -> pure ExportPublic
+    Just gkh -> do
+      gk <- runExceptT (readGK0 sto gkh) >>= orThrowUser "failed to read encryption key"
+      pure $ ExportPrivateGK gk
 
 pKey :: GitPerks m => Parser (GitCLI m ())
 pKey = hsubparser (  command "show"   (info pKeyShow  (progDesc "show current key"))

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs

@@ -35,7 +35,7 @@ data GitOption = GitTrace
                | GitExport ExportType
                | GitEnc ExportEncryption
                | GitDontApplyHeads
-               deriving stock (Eq,Ord)
+               deriving stock (Eq)
 
 
 
@@ -93,6 +93,7 @@ newGitEnv :: GitPerks m
 newGitEnv p opts path cpath conf peer reflog rchan lww sto = do
   let dbfile  = cpath </> "state.db"
   let dOpt = dbPipeOptsDef { dbLogger = \x -> debug ("state:" <+> pretty x) }
+  let manifestUpdateEnv = Nothing
   db <- newDBPipeEnv dOpt dbfile
   cache <- newTVarIO mempty
   pure $ GitEnv
@@ -101,6 +102,7 @@ newGitEnv p opts path cpath conf peer reflog rchan lww sto = do
            applyHeadsOpt
            exportType
            exportEnc
+           manifestUpdateEnv
            path
            cpath
            conf

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs

@@ -6,6 +6,8 @@ import HBS2.Git.Client.Prelude hiding (info)
 
 import HBS2.Git.Client.Progress
 
+import HBS2.Git.Data.GK
+
 import HBS2.Net.Auth.GroupKeySymm
 
 import Data.Config.Suckless
@@ -20,7 +22,8 @@ data ExportType = ExportNew
 data ExportEncryption =
     ExportPublic
   | ExportPrivate FilePath
-  deriving stock (Eq,Ord,Generic,Show)
+  | ExportPrivateGK GK0
+  deriving stock (Eq)
 
 type Config = [Syntax C]
 
@@ -30,24 +33,30 @@ class Monad m => HasProgressIndicator m where
 class HasAPI api proto m where
   getAPI :: m (ServiceCaller api proto)
 
+data ManifestUpdateEnv =
+  ManifestUpdateEnv
+  {  _manifest :: (Text, Text, Maybe Text)
+  }
+
 data GitEnv =
   GitEnv
-  { _gitTraceEnabled :: Bool
-  , _gitDebugEnabled :: Bool
-  , _gitApplyHeads   :: Bool
-  , _gitExportType   :: ExportType
-  , _gitExportEnc    :: ExportEncryption
-  , _gitPath         :: FilePath
-  , _configPath      :: FilePath
-  , _config          :: Config
-  , _peerAPI         :: ServiceCaller PeerAPI UNIX
-  , _refLogAPI       :: ServiceCaller RefLogAPI UNIX
-  , _refChanAPI      :: ServiceCaller RefChanAPI UNIX
-  , _lwwRefAPI       :: ServiceCaller LWWRefAPI UNIX
-  , _storage         :: AnyStorage -- ServiceCaller StorageAPI UNIX
-  , _db              :: DBPipeEnv
-  , _progress        :: AnyProgress
-  , _keyringCache    :: TVar (HashMap HashRef [KeyringEntry 'HBS2Basic])
+  { _gitTraceEnabled      :: Bool
+  , _gitDebugEnabled      :: Bool
+  , _gitApplyHeads        :: Bool
+  , _gitExportType        :: ExportType
+  , _gitExportEnc         :: ExportEncryption
+  , _gitManifestUpdateEnv :: Maybe ManifestUpdateEnv
+  , _gitPath              :: FilePath
+  , _configPath           :: FilePath
+  , _config               :: Config
+  , _peerAPI              :: ServiceCaller PeerAPI UNIX
+  , _refLogAPI            :: ServiceCaller RefLogAPI UNIX
+  , _refChanAPI           :: ServiceCaller RefChanAPI UNIX
+  , _lwwRefAPI            :: ServiceCaller LWWRefAPI UNIX
+  , _storage              :: AnyStorage -- ServiceCaller StorageAPI UNIX
+  , _db                   :: DBPipeEnv
+  , _progress             :: AnyProgress
+  , _keyringCache         :: TVar (HashMap HashRef [KeyringEntry 'HBS2Basic])
   }
 
 

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Config.hs

@@ -1,4 +1,4 @@
-module HBS2.Git.Client.Config (getConfigDir, readConfig, getManifest, hbs2Name) where
+module HBS2.Git.Client.Config (getConfigDir, readConfig, hbs2Name) where
 
 import HBS2.Git.Client.Prelude
 import HBS2.Git.Client.App.Types
@@ -6,8 +6,6 @@ import HBS2.Git.Client.App.Types
 import HBS2.System.Dir
 import HBS2.Git.Local.CLI
 
-import Data.List qualified as L
-import Data.Text qualified as Text
 import Data.Either
 import Text.InterpolatedString.Perl6 (qc)
 
@@ -34,31 +32,6 @@ getConfigDir = do
   else do
     pure $ git </> ".hbs2-git"
 
-getManifest :: GitPerks m => m (Text, Text, Maybe Text)
-getManifest = do
-  dir <- getConfigDir
-  let mf = dir </> "manifest"
-
-  let defname = takeFileName (takeDirectory dir) & Text.pack
-  let defbrief = "n/a"
-
-  content <- liftIO (try @_ @IOException $ readFile mf)
-               <&> fromRight ""
-
-  let txt = if L.null content then Nothing else Just (Text.pack content)
-
-  -- FIXME: size-hardcode
-  let header  = lines (take 1024 content)
-                   & takeWhile ( not . L.null )
-                   & unlines
-                   & parseTop
-                   & fromRight mempty
-
-  let name = lastDef defname [ n | ListVal [ SymbolVal "name:", LitStrVal n ] <- header ]
-  let brief = lastDef defbrief [ n | ListVal [ SymbolVal "brief:", LitStrVal n ] <- header ]
-
-  pure (name,brief,txt)
-
 readConfig :: (GitPerks m) => Bool -> m Config
 readConfig canTouch = do
 {- HLINT ignore "Functor law" -}

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs

@@ -3,7 +3,7 @@ module HBS2.Git.Client.Export (export) where
 
 import HBS2.Git.Client.Prelude hiding (info)
 import HBS2.Git.Client.App.Types
-import HBS2.Git.Client.Config
+import HBS2.Git.Client.Manifest
 import HBS2.Git.Client.RefLog
 import HBS2.Git.Client.State
 import HBS2.Git.Client.Progress
@@ -142,8 +142,10 @@ storeNewGK0 = do
   sto <- asks _storage
   enc <- asks _gitExportEnc
   runMaybeT do
-    gkf <- headMay [ f | ExportPrivate f <- [enc] ] & toMPlus
-    gk <- loadGK0FromFile gkf >>= toMPlus
+    gk <- case enc of
+      ExportPrivate f -> loadGK0FromFile f >>= toMPlus
+      ExportPrivateGK k -> toMPlus $ Just k
+      _ -> toMPlus Nothing
     epoch <- getEpoch
     writeAsMerkle sto (serialise gk) <&> HashRef <&> (,epoch)
 
@@ -160,6 +162,7 @@ export key refs  = do
   git <- asks _gitPath
   sto <- asks _storage
   new <- asks _gitExportType <&> (== ExportNew)
+  manifestUpdateEnv <- asks _gitManifestUpdateEnv
   reflog <- asks _refLogAPI
   ip <- asks _progress
 
@@ -194,7 +197,10 @@ export key refs  = do
 
       let rh0 = snd <$> rh
 
-      (name,brief,mf) <- lift getManifest
+      (name,brief,mf) <- case manifestUpdateEnv of
+        -- TODO: do not update manifest if not needed
+        Nothing -> lift $ getLastManifestFromStorage key
+        Just (ManifestUpdateEnv manifest) -> pure manifest
 
       gk0new0 <- loadNewGK0 puk tx0
 
@@ -226,7 +232,9 @@ export key refs  = do
       objs <- lift enumAllGitObjects
                 >>= withState . filterM (notInTx tx0)
 
-      when (null objs && not new && oldRefs == myrefs) do
+      let updateManifest = isJust manifestUpdateEnv
+
+      when (null objs && not new && oldRefs == myrefs && not updateManifest) do
         exit ()
 
       debug $ red "REFS-FOR-EXPORT:" <+> pretty myrefs

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Manifest.hs

@@ -0,0 +1,48 @@
+module HBS2.Git.Client.Manifest (getLastManifestFromStorage, addManifestBriefAndName) where
+
+import Data.Coerce
+import Data.Either
+import Data.List qualified as L
+import Data.Maybe
+import Data.Text qualified as Text
+import HBS2.Git.Client.App.Types
+import HBS2.Git.Client.Config
+import HBS2.Git.Client.Prelude
+import HBS2.Git.Client.State
+import HBS2.Git.Data.RepoHead
+import HBS2.Storage.Operations.ByteString
+import HBS2.System.Dir
+
+addManifestBriefAndName :: (GitPerks m) => Maybe Text -> m (Text, Text, Maybe Text)
+addManifestBriefAndName manifest = do
+  dir <- getConfigDir
+  let defBrief = "n/a"
+      defName = takeFileName (takeDirectory dir) & Text.pack
+      -- FIXME: size-hardcode
+      header =
+        lines (take 1024 (Text.unpack $ fromMaybe "" manifest))
+          & takeWhile (not . L.null)
+          & unlines
+          & parseTop
+          & fromRight mempty
+      name = lastDef defName [n | ListVal [SymbolVal "name:", LitStrVal n] <- header]
+      brief = lastDef defBrief [n | ListVal [SymbolVal "brief:", LitStrVal n] <- header]
+  pure (name, brief, manifest)
+
+getLastManifestFromStorage ::
+  ( MonadReader GitEnv m,
+    GitPerks m
+  ) =>
+  LWWRefKey 'HBS2Basic ->
+  m (Text, Text, Maybe Text)
+getLastManifestFromStorage lwwref = do
+  manifest <- runMaybeT do
+    sto <- asks _storage
+    headRef <- MaybeT $ withState $ selectLastRepoHeadFor lwwref
+    rhead <-
+      runExceptT (readFromMerkle sto (SimpleKey (coerce headRef)))
+        >>= toMPlus
+          <&> deserialiseOrFail @RepoHead
+        >>= toMPlus
+    MaybeT $ pure $ _repoManifest rhead
+  addManifestBriefAndName manifest

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs

@@ -401,7 +401,7 @@ SELECT hash, seq, reflog FROM lww
 
 
 
-selectRepoHeadsFor :: (MonadIO m, HasStorage m)
+selectRepoHeadsFor :: (MonadIO m)
                     => SortOrder
                     -> LWWRefKey 'HBS2Basic
                     -> DBPipeM m [TaggedHashRef RepoHead]
@@ -417,6 +417,21 @@ ORDER BY t.seq {pretty (SQL order)}
   select @(Only (TaggedHashRef RepoHead)) q (Only $ Base58Field what)
    <&> fmap fromOnly
 
+selectLastRepoHeadFor :: (MonadIO m)
+                    => LWWRefKey 'HBS2Basic
+                    -> DBPipeM m (Maybe (TaggedHashRef RepoHead))
+
+selectLastRepoHeadFor what = do
+  let q = [qc|
+SELECT t.head
+FROM lww l join tx t on l.reflog = t.reflog
+WHERE l.hash = ?
+ORDER BY t.seq DESC
+LIMIT 1
+|]
+
+  select @(Only (TaggedHashRef RepoHead)) q (Only $ Base58Field what)
+   <&> (fmap fromOnly . listToMaybe)
 
 instance (Monad m, HasStorage m) => HasStorage (DBPipeM m) where
   getStorage = lift getStorage

hbs2-git/hbs2-git.cabal

@@ -116,6 +116,7 @@ library
       HBS2.Git.Client.Export
       HBS2.Git.Client.Import
       HBS2.Git.Client.Progress
+      HBS2.Git.Client.Manifest
 
     build-depends:    base
                     , base16-bytestring