From f7119564fb1b188a851ea615681cc20ad51951b2 Mon Sep 17 00:00:00 2001 From: Vladimir Krutkin Date: Fri, 19 Jul 2024 15:06:16 +0300 Subject: [PATCH] Added the manifest update command, fixed bugs --- docs/papers/hbs2-git-doc-0.24.1.tex | 4 +- hbs2-core/lib/HBS2/Data/Types/EncryptedBox.hs | 2 +- hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs | 6 ++ hbs2-git/git-hbs2/Main.hs | 100 +++++++++++++++--- .../HBS2/Git/Client/App/Types.hs | 4 +- .../HBS2/Git/Client/App/Types/GitEnv.hs | 43 +++++--- .../HBS2/Git/Client/Config.hs | 29 +---- .../HBS2/Git/Client/Export.hs | 18 +++- .../HBS2/Git/Client/Manifest.hs | 48 +++++++++ .../HBS2/Git/Client/State.hs | 17 ++- hbs2-git/hbs2-git.cabal | 1 + 11 files changed, 202 insertions(+), 70 deletions(-) create mode 100644 hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Manifest.hs diff --git a/docs/papers/hbs2-git-doc-0.24.1.tex b/docs/papers/hbs2-git-doc-0.24.1.tex index c32e4c03..d71fc310 100644 --- a/docs/papers/hbs2-git-doc-0.24.1.tex +++ b/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 } +Для обновления манифеста --- редактировать файл \texttt{.hbs2-git/manifest} + и вызвать \texttt{git hbs2 manifest update } \subsubsection{Смотреть групповой ключ} diff --git a/hbs2-core/lib/HBS2/Data/Types/EncryptedBox.hs b/hbs2-core/lib/HBS2/Data/Types/EncryptedBox.hs index ba5389aa..0ec5c058 100644 --- a/hbs2-core/lib/HBS2/Data/Types/EncryptedBox.hs +++ b/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) diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index 59404ee1..119e2aab 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/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 diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index 8040cc0f..ceec75c2 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/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")) diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs index 0e29200b..b6a0a02a 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs index 75b5c15d..8d6fe60e 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs +++ b/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]) } diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Config.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Config.hs index 7cf654eb..feb39fa9 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Config.hs +++ b/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" -} 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 8bea1a4d..8b17fce8 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 @@ -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 diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Manifest.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Manifest.hs new file mode 100644 index 00000000..8f982806 --- /dev/null +++ b/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 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 d1597beb..b2e9c414 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 @@ -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 diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 7b052e7a..2e8a60f2 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/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