wip

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
 
@@ -50,6 +53,7 @@ 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 "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) $

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

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
 
 
+