dump repo announce

hbs2-core/lib/HBS2/Storage/Operations/Class.hs

@@ -11,6 +11,7 @@ import Data.Kind
 data OperationError =
     StorageError
   | CryptoError
+  | SignCheckError
   | DecryptError
   | DecryptionError
   | MissedBlockError

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
 
@@ -219,6 +222,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"))
                     )
 
 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) $

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

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