diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index 78b7712d..8b75ff31 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -20,6 +20,8 @@ import HBS2.Git.Data.GK import HBS2.KeyMan.Keys.Direct import HBS2.Storage.Operations.ByteString +import Data.Text qualified as Text +import Data.Text.IO qualified as Text import Data.HashSet qualified as HS import Data.Maybe import Data.Coerce @@ -27,6 +29,7 @@ import Options.Applicative as O import Data.ByteString.Lazy qualified as LBS import Data.ByteString (ByteString) -- import Data.ByteString.Lazy (ByteString) +import Text.InterpolatedString.Perl6 (qc) import Streaming.Prelude qualified as S @@ -47,11 +50,12 @@ 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")) - <> command "track" (info pTrack (progDesc "track tools")) - <> command "tools" (info pTools (progDesc "misc tools")) + 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")) ) @@ -169,6 +173,45 @@ pShowRef = do liftIO $ print $ vcat (fmap formatRef (_repoHeadRefs rh)) +pManifest :: GitPerks m => Parser (GitCLI m ()) +pManifest = hsubparser ( command "list" (info pManifestList (progDesc "list all manifest")) + <> command "show" (info pManifestShow (progDesc "show manifest")) + ) + +pManifestList :: GitPerks m => Parser (GitCLI m ()) +pManifestList = do + what <- argument pLwwKey (metavar "LWWREF") + pure do + heads <- withState $ selectRepoHeadsFor 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 + <+> mf + +pManifestShow :: GitPerks m => Parser (GitCLI m ()) +pManifestShow = do + what <- argument pHashRef (metavar "HASH") + pure do + + sto <- getStorage + rhead <- runExceptT (readFromMerkle sto (SimpleKey (coerce what))) + >>= orThrowUser "repo head not found" + <&> deserialiseOrFail @RepoHead + >>= orThrowUser "repo head format not supported" + + liftIO $ for_ (_repoManifest rhead) Text.putStrLn + + pKey :: GitPerks m => Parser (GitCLI m ()) pKey = hsubparser ( command "show" (info pKeyShow (progDesc "show current key")) <> command "update" (info pKeyUpdate (progDesc "update current key")) @@ -223,6 +266,7 @@ pKeyUpdate = do pTrack :: GitPerks m => Parser (GitCLI m ()) pTrack = hsubparser ( command "send-repo-notify" (info pSendRepoNotify (progDesc "sends repository notification")) <> command "show-repo-notify" (info pShowRepoNotify (progDesc "shows repository notification")) + <> command "gen-repo-index" (info pGenRepoIndex (progDesc "generates repo index tx")) ) pSendRepoNotify :: GitPerks m => Parser (GitCLI m ()) @@ -290,6 +334,19 @@ pShowRepoNotify = do liftIO $ print $ pretty ann + +pGenRepoIndex :: GitPerks m => Parser (GitCLI m ()) +pGenRepoIndex = do + what <- argument pLwwKey (metavar "LWWREF") + pure do + withState do + idx <- selectRepoIndexEntryFor what + `orDie` "repo head not found" + + liftIO $ print idx + + pure () + main :: IO () main = do (o, action) <- customExecParser (prefs showHelpOnError) $ 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 5d53ddab..dd7f2710 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 @@ -11,9 +11,12 @@ import HBS2.Git.Client.App.Types import HBS2.Git.Client.Config import HBS2.Peer.Proto.RefLog +import HBS2.Storage.Operations.ByteString +import HBS2.Git.Data.RepoHead import HBS2.Git.Data.RefLog import HBS2.Git.Data.LWWBlock +import HBS2.Git.Data.Tx.Index import DBPipe.SQLite import Data.Maybe @@ -39,6 +42,8 @@ instance ToField HashRef where instance FromField HashRef where fromField = fmap fromString . fromField @String +deriving newtype instance FromField (TaggedHashRef t) + instance ToField GitHash where toField h = toField (show $ pretty h) @@ -380,3 +385,48 @@ selectAllLww = do SELECT hash, seq, reflog FROM lww |] <&> fmap (over _3 (fromRefLogKey @'HBS2Basic)) + + +selectRepoHeadsFor :: (MonadIO m, HasStorage m) + => LWWRefKey 'HBS2Basic + -> DBPipeM m [TaggedHashRef RepoHead] + +selectRepoHeadsFor what = do + let q = [qc| +SELECT t.head +FROM lww l join tx t on l.reflog = t.reflog +WHERE l.hash = ? +ORDER BY l.seq ASC +|] + + select @(Only (TaggedHashRef RepoHead)) q (Only $ Base58Field what) + <&> fmap fromOnly + + +selectRepoIndexEntryFor :: (MonadIO m, HasStorage m) + => LWWRefKey 'HBS2Basic + -> DBPipeM m (Maybe GitIndexRepoDefineData) + +selectRepoIndexEntryFor what = runMaybeT do + let q = [qc| +SELECT l.hash, t.head +FROM lww l join tx t on l.reflog = t.reflog +WHERE l.hash = ? +ORDER BY l.seq DESC +LIMIT 1 +|] + + (k,rh) <- lift (select @(LWWRefKey 'HBS2Basic, HashRef) q (Only $ Base58Field what)) + <&> listToMaybe >>= toMPlus + + sto <- lift $ lift getStorage + + repohead <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef rh))) + >>= toMPlus + <&> deserialiseOrFail @RepoHead + >>= toMPlus + + pure $ GitIndexRepoDefineData (GitIndexRepoName $ _repoHeadName repohead) + (GitIndexRepoBrief $ _repoHeadBrief repohead) + + diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs index 3c87fe7a..95647335 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs @@ -28,12 +28,10 @@ data RepoForkInfo e = RepoForkInfoNone deriving stock (Generic) - data GitRepoAnnounce s = GitRepoAnnounce { repoLwwRef :: LWWRefKey s , repoForkInfo :: Maybe (RepoForkInfo s) - , repoHeadInfo :: Maybe (TaggedHashRef RepoHead) } deriving stock (Generic) @@ -46,8 +44,27 @@ instance ForGitIndex s => Pretty (GitRepoAnnounce s) where newtype NotifyCredentials s = NotifyCredentials (PeerCredentials s) +newtype GitIndexRepoName = GitIndexRepoName Text + deriving stock (Generic,Show) + deriving newtype (Serialise) + +newtype GitIndexRepoBrief = GitIndexRepoBrief Text + deriving stock (Generic,Show) + deriving newtype (Serialise) + +newtype GitIndexRepoManifest = GitIndexRepoManifest (Maybe Text) + deriving stock (Generic,Show) + deriving newtype (Serialise) + +data GitIndexRepoDefineData = + GitIndexRepoDefineData + { gitIndexRepoName :: GitIndexRepoName + , gitIndexRepoBrief :: GitIndexRepoBrief + } + deriving stock (Generic,Show) + data GitIndexEntry = - GitIndexRepoDefine + GitIndexRepoDefine GitIndexRepoDefineData | GitIndexRepoTombEntry | GitIndexRepoLikes Integer deriving stock (Generic) @@ -62,7 +79,7 @@ data GitIndexTx s = instance ForGitIndex s => Pretty (GitIndexTx s) where pretty GitIndexTx{..} = case gitIndexTxPayload of - GitIndexRepoDefine -> "git-repo-define" <+> pretty gitIndexTxRef + GitIndexRepoDefine{} -> "git-repo-define" <+> pretty gitIndexTxRef GitIndexRepoTombEntry -> "git-repo-tomb" <+> pretty gitIndexTxRef GitIndexRepoLikes n -> "git-repo-likes" <+> pretty gitIndexTxRef <+> pretty n @@ -78,7 +95,7 @@ makeNotificationTx :: forall s . (ForGitIndex s) -> SignedBox ByteString s makeNotificationTx ncred lww lwsk forkInfo = do let creds = coerce ncred :: PeerCredentials s - let annData = GitRepoAnnounce @s lww forkInfo Nothing + let annData = GitRepoAnnounce @s lww forkInfo let lwpk = coerce lww :: PubKey 'Sign s let repoAnn = makeSignedBox @s lwpk lwsk (LBS.toStrict $ serialise annData) makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict $ serialise repoAnn) @@ -101,3 +118,4 @@ unpackNotificationTx box = do & orThrowError UnsupportedFormat +