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-03-16 07:03:07 +03:00
parent ce7c1f37c0
commit e702f3609f
8 changed files with 72 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
hbs21-git/git-hbs21/Main.hs
View File

@ -38,7 +38,6 @@ 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 "subscribe" (info pSubscribe (progDesc "subscribe to repo"))
<> command "key" (info pKey (progDesc "key management"))
<> command "tools" (info pTools (progDesc "misc tools"))
)

22
hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs
View File

@ -1,4 +1,5 @@
{-# Language TemplateHaskell #-}
{-# Language UndecidableInstances #-}
module HBS2.Git.Client.App.Types.GitEnv where
import HBS2.Git.Client.Prelude hiding (info)
@ -23,6 +24,12 @@ data ExportEncryption =
type Config = [Syntax C]
class Monad m => HasProgressIndicator m where
getProgressIndicator :: m AnyProgress
class HasAPI api proto m where
getAPI :: m (ServiceCaller api proto)
data GitEnv =
GitEnv
{ _gitTraceEnabled :: Bool
@ -42,4 +49,19 @@ data GitEnv =
, _keyringCache :: TVar (HashMap HashRef [KeyringEntry HBS2Basic])
}
instance (Monad m, MonadReader GitEnv m) => HasProgressIndicator m where
getProgressIndicator = asks _progress
instance MonadReader GitEnv m => HasStorage m where
getStorage = asks _storage
instance MonadReader GitEnv m => HasAPI PeerAPI UNIX m where
getAPI = asks _peerAPI
instance MonadReader GitEnv m => HasAPI LWWRefAPI UNIX m where
getAPI = asks _lwwRefAPI
instance MonadReader GitEnv m => HasAPI RefLogAPI UNIX m where
getAPI = asks _refLogAPI
makeLenses 'GitEnv

6
hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs
View File

@ -148,7 +148,11 @@ storeNewGK0 = do
epoch <- getEpoch
writeAsMerkle sto (serialise gk) <&> HashRef <&> (,epoch)
export :: (GitPerks m, MonadReader GitEnv m, GroupKeyOperations m)
export :: ( GitPerks m
, MonadReader GitEnv m
, GroupKeyOperations m
, HasAPI PeerAPI UNIX m
)
=> LWWRefKey HBS2Basic
-> [(GitRef,Maybe GitHash)]
-> m ()

21
hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs
View File

@ -60,13 +60,21 @@ data IState =
| IExit
merelySubscribeRepo :: (GitPerks m, MonadReader GitEnv m)
-- class
merelySubscribeRepo :: ( GitPerks m
, HasStorage m
, HasProgressIndicator m
, HasAPI PeerAPI UNIX m
, HasAPI LWWRefAPI UNIX m
, HasAPI RefLogAPI UNIX m
)
=> LWWRefKey HBS2Basic
-> m (Maybe HashRef)
merelySubscribeRepo lwwKey = do
ip <- asks _progress
sto <- asks _storage
ip <- getProgressIndicator
sto <- getStorage
subscribeLWWRef lwwKey
@ -116,7 +124,12 @@ merelySubscribeRepo lwwKey = do
_ -> pure Nothing
importRepoWait :: (GitPerks m, MonadReader GitEnv m)
importRepoWait :: ( GitPerks m
, MonadReader GitEnv m
, HasAPI PeerAPI UNIX m
, HasAPI LWWRefAPI UNIX m
, HasAPI RefLogAPI UNIX m
)
=> LWWRefKey HBS2Basic
-> m ()

2
hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs
View File

@ -14,6 +14,7 @@ module HBS2.Git.Client.Prelude
-- peer
, module HBS2.Net.Proto.Service
, module HBS2.Peer.Proto.LWWRef
, module HBS2.Peer.RPC.API.Peer
, module HBS2.Peer.RPC.API.RefLog
, module HBS2.Peer.RPC.API.LWWRef
@ -52,6 +53,7 @@ import HBS2.System.Logger.Simple.ANSI
import HBS2.Net.Messaging.Unix
import HBS2.Net.Proto.Service
import HBS2.Peer.Proto.LWWRef
import HBS2.Peer.RPC.API.Peer
import HBS2.Peer.RPC.API.RefLog
import HBS2.Peer.RPC.API.LWWRef

17
hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs
View File

@ -19,26 +19,25 @@ instance Exception RefLogRequestTimeout
instance Exception RefLogRequestError
subscribeRefLog :: (GitPerks m, MonadReader GitEnv m) => RefLogId -> m ()
subscribeRefLog :: (GitPerks m, HasAPI PeerAPI UNIX m) => RefLogId -> m ()
subscribeRefLog puk = do
api <- asks _peerAPI
api <- getAPI @PeerAPI @UNIX
void $ callService @RpcPollAdd api (puk, "reflog", 13)
subscribeLWWRef :: (GitPerks m, MonadReader GitEnv m) => LWWRefKey HBS2Basic -> m ()
subscribeLWWRef :: (GitPerks m, HasAPI PeerAPI UNIX m) => LWWRefKey HBS2Basic -> m ()
subscribeLWWRef puk = do
api <- asks _peerAPI
api <- getAPI @PeerAPI @UNIX
void $ callService @RpcPollAdd api (fromLwwRefKey puk, "lwwref", 17)
fetchLWWRef :: (GitPerks m, MonadReader GitEnv m) => LWWRefKey HBS2Basic -> m ()
fetchLWWRef :: (GitPerks m, HasAPI LWWRefAPI UNIX m) => LWWRefKey HBS2Basic -> m ()
fetchLWWRef key = do
api <- asks _lwwRefAPI
api <- getAPI @LWWRefAPI @UNIX
void $ race (pause @'Seconds 1) (callService @RpcLWWRefFetch api key)
getRefLogMerkle :: (GitPerks m, MonadReader GitEnv m) => RefLogId -> m (Maybe HashRef)
getRefLogMerkle :: (GitPerks m, HasAPI RefLogAPI UNIX m) => RefLogId -> m (Maybe HashRef)
getRefLogMerkle puk = do
api <- asks _refLogAPI
api <- getAPI @RefLogAPI @UNIX
void $ race (pause @'Seconds 1) (callService @RpcRefLogFetch api puk)
>>= orThrow RefLogRequestTimeout

14
hbs21-git/hbs21-git.cabal
View File

@ -124,6 +124,20 @@ library hbs2-git-client-lib
hs-source-dirs: hbs2-git-client-lib
executable hbs2-git-subscribe
import: shared-properties
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends:
base, hbs2-git-client-lib
, binary
, vector
, optparse-applicative
hs-source-dirs: git-hbs2-subscribe
default-language: GHC2021
executable git-hbs21
import: shared-properties
main-is: Main.hs

8
nix/peer/flake.lock
View File

@ -295,11 +295,11 @@
"suckless-conf": "suckless-conf_2"
},
"locked": {
"lastModified": 1710495385,
"narHash": "sha256-TnbsguspieZr//Wa/L7Fak1tOJis1NFfwYBM1rd462s=",
"lastModified": 1710558394,
"narHash": "sha256-Io0xjrddivrVznym5rpvwzO0PjP2++dnNlpXtGPyfU0=",
"ref": "lwwrepo",
"rev": "ec2c1cc3174cec02c5d161374828096958a676ec",
"revCount": 984,
"rev": "ce7c1f37c046fa5806613a1d3eb67d4d6b00e84c",
"revCount": 989,
"type": "git",
"url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
},