From e78cab0362ae076366254090ed6fa6396a5fd446 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Wed, 17 Apr 2024 06:44:26 +0300 Subject: [PATCH] dump repo announce --- .../lib/HBS2/Storage/Operations/Class.hs | 1 + hbs2-git/git-hbs2/Main.hs | 26 ++++++++- .../HBS2/Git/Data/Tx/Index.hs | 53 ++++++++++++++++--- hbs2/Main.hs | 11 ++-- 4 files changed, 79 insertions(+), 12 deletions(-) diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs index 2ae0a6e6..f69eeacb 100644 --- a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs +++ b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs @@ -11,6 +11,7 @@ import Data.Kind data OperationError = StorageError | CryptoError + | SignCheckError | DecryptError | DecryptionError | MissedBlockError diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index cde8f40c..78b7712d 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -7,6 +7,7 @@ import HBS2.Git.Client.Export import HBS2.Git.Client.Import import HBS2.Git.Client.State +import HBS2.Data.Types.SignedBox import HBS2.Git.Data.RefLog import HBS2.Git.Local.CLI qualified as Git import HBS2.Git.Data.Tx.Git qualified as TX @@ -24,6 +25,8 @@ import Data.Maybe import Data.Coerce import Options.Applicative as O import Data.ByteString.Lazy qualified as LBS +import Data.ByteString (ByteString) +-- import Data.ByteString.Lazy (ByteString) import Streaming.Prelude qualified as S @@ -218,7 +221,8 @@ pKeyUpdate = do pTrack :: GitPerks m => Parser (GitCLI m ()) -pTrack = hsubparser ( command "send-repo-notify" (info pSendRepoNotify (progDesc "sends repository notification")) +pTrack = hsubparser ( command "send-repo-notify" (info pSendRepoNotify (progDesc "sends repository notification")) + <> command "show-repo-notify" (info pShowRepoNotify (progDesc "shows repository notification")) ) pSendRepoNotify :: GitPerks m => Parser (GitCLI m ()) @@ -266,6 +270,26 @@ pSendRepoNotify = do -- кто парсит ссылку и помещает в рефчан + +pShowRepoNotify :: GitPerks m => Parser (GitCLI m ()) +pShowRepoNotify = do + href <- argument pHashRef (metavar "HASH") + pure do + sto <- asks _storage + + box <- getBlock sto (coerce href) + `orDie` "tx not found" + <&> deserialiseOrFail @(RefChanNotify L4Proto) + >>= orThrowUser "malformed announce tx 1" + >>= \case + Notify _ box -> pure box + _ -> throwIO (userError "malformed announce tx 2") + + ann <- runExceptT (unpackNotificationTx box) + >>= either (error . show) pure + + liftIO $ print $ pretty ann + main :: IO () main = do (o, action) <- customExecParser (prefs showHelpOnError) $ 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 cc5b5e2c..944c9428 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 @@ -6,9 +6,14 @@ import HBS2.Git.Client.Prelude import HBS2.Data.Types.Refs import HBS2.Data.Types.SignedBox +import HBS2.Storage.Operations.Class + import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as LBS import Data.Coerce +import Control.Monad.Identity + +import Data.Word -- | -- Module : HBS2.Git.Data.Tx.Index @@ -32,20 +37,35 @@ data GitRepoAnnounceData s = } deriving stock (Generic) -data GitRepoAnnounce s = - GitRepoAnnounce - { gitRepoAnnounce :: SignedBox (GitRepoAnnounceData s) s - } - deriving stock (Generic) - instance ForGitIndex s => Serialise (RepoForkInfo s) instance ForGitIndex s => Serialise (GitRepoAnnounceData s) -instance ForGitIndex s => Serialise (GitRepoAnnounce s) +instance ForGitIndex s => Pretty (GitRepoAnnounceData s) where + pretty GitRepoAnnounceData{..} = parens $ "git-repo-announce-data" <+> pretty repoLwwRef newtype NotifyCredentials s = NotifyCredentials (PeerCredentials s) +data GitIndexEntry = + GitIndexRepoDefine + | GitIndexRepoTombEntry + | GitIndexRepoLikes Integer + deriving stock (Generic) + +data GitIndexTx s = + GitIndexTx + { gitIndexTxRef :: LWWRefKey s -- ^ primary key + , gitIndexTxSeq :: Word64 -- ^ sequence ( set tomb / bring from tomb ) + , gitIndexTxPayload :: GitIndexEntry -- ^ statement + } + deriving stock (Generic) + +instance ForGitIndex s => Pretty (GitIndexTx s) where + pretty GitIndexTx{..} = case gitIndexTxPayload of + GitIndexRepoDefine -> "git-repo-define" <+> pretty gitIndexTxRef + GitIndexRepoTombEntry -> "git-repo-tomb" <+> pretty gitIndexTxRef + GitIndexRepoLikes n -> "git-repo-likes" <+> pretty gitIndexTxRef <+> pretty n + -- | makes notification tx -- | it is signed by lwwref private key in order to proove authorship -- | and signed with published notification private key in order @@ -63,3 +83,22 @@ makeNotificationTx ncred lww lwsk forkInfo = do let repoAnn = makeSignedBox @s lwpk lwsk (LBS.toStrict $ serialise annData) makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict $ serialise repoAnn) + +unpackNotificationTx :: forall s m . (ForGitIndex s, MonadError OperationError m) + => SignedBox ByteString s + -> m (GitRepoAnnounceData s) +unpackNotificationTx box = do + (_, bs1) <- unboxSignedBox0 @_ @s box + & orThrowError SignCheckError + + bs2 <- deserialiseOrFail @(SignedBox ByteString s) (LBS.fromStrict bs1) + & orThrowError UnsupportedFormat + + (_, bs3) <- unboxSignedBox0 bs2 + & orThrowError SignCheckError + + deserialiseOrFail @(GitRepoAnnounceData s) (LBS.fromStrict bs3) + & orThrowError UnsupportedFormat + + + diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 96d52cd3..4e894023 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -187,8 +187,11 @@ exitFailure = do die :: MonadIO m => String -> m a die = liftIO . Exit.die -runHash :: HashOpts -> SimpleStorage HbSync -> IO () -runHash opts _ = do +runHash :: Maybe HashOpts -> SimpleStorage HbSync -> IO () +runHash Nothing _ = do + LBS.getContents >>= print . pretty . hashObject @HbSync + +runHash (Just opts) _ = do withBinaryFile (hashFp opts) ReadMode $ \h -> do LBS.hGetContents h >>= print . pretty . hashObject @HbSync @@ -726,8 +729,8 @@ main = join . customExecParser (prefs showHelpOnError) $ pHash = do o <- common - hash <- strArgument ( metavar "HASH" ) - pure $ withStore o $ runHash $ HashOpts hash + what <- optional $ HashOpts <$> strArgument ( metavar "FILE" ) + pure $ withStore o $ runHash what iNewKey = info pNewKey (progDesc "generates a new keyring")