voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-04-17 09:12:15 +03:00
parent b0ef09210c
commit ec428b3d73
3 changed files with 135 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
hbs2-git/git-hbs2/Main.hs
View File

@ -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) $

50
hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs
View File

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

28
hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs
View File

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