From e702f3609fdf2eeb828c3d48f6e53582d2df6616 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sat, 16 Mar 2024 07:03:07 +0300 Subject: [PATCH] wip --- hbs21-git/git-hbs21/Main.hs | 1 - .../HBS2/Git/Client/App/Types/GitEnv.hs | 22 +++++++++++++++++++ .../HBS2/Git/Client/Export.hs | 6 ++++- .../HBS2/Git/Client/Import.hs | 21 ++++++++++++++---- .../HBS2/Git/Client/Prelude.hs | 2 ++ .../HBS2/Git/Client/RefLog.hs | 17 +++++++------- hbs21-git/hbs21-git.cabal | 14 ++++++++++++ nix/peer/flake.lock | 8 +++---- 8 files changed, 72 insertions(+), 19 deletions(-) diff --git a/hbs21-git/git-hbs21/Main.hs b/hbs21-git/git-hbs21/Main.hs index fa4d7b07..8d0d3eb5 100644 --- a/hbs21-git/git-hbs21/Main.hs +++ b/hbs21-git/git-hbs21/Main.hs @@ -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")) ) diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs index ffdb85e6..d2901cde 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs @@ -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 diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs index 12813c55..c48ee7b1 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs @@ -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 () diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs index 655aaa6c..d3f90ede 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs @@ -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 () diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs index 156789d3..6f2df4f9 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs @@ -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 diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs index 13371f5d..b5be6be9 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs @@ -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 diff --git a/hbs21-git/hbs21-git.cabal b/hbs21-git/hbs21-git.cabal index 1cc21eae..6db693e6 100644 --- a/hbs21-git/hbs21-git.cabal +++ b/hbs21-git/hbs21-git.cabal @@ -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 diff --git a/nix/peer/flake.lock b/nix/peer/flake.lock index aa451d41..62438eff 100644 --- a/nix/peer/flake.lock +++ b/nix/peer/flake.lock @@ -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" },