From 4f563a760ac51bbdbc20d9db657f5b387fc28cc3 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sat, 3 Aug 2024 10:20:50 +0300 Subject: [PATCH] wip, refactored --- hbs2-cli/app/Main.hs | 20 +-- .../Data/Config/Suckless/Script/Internal.hs | 3 +- hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs | 69 ++++----- hbs2-cli/lib/HBS2/CLI/Run/Internal.hs | 139 ++++++++++++++++-- .../lib/HBS2/CLI/Run/Internal/GroupKey.hs | 12 +- hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs | 10 +- hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs | 83 +++++------ hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs | 44 +++--- hbs2-cli/lib/HBS2/CLI/Run/Peer.hs | 43 +++--- hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs | 30 +++- hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs | 80 +++++----- hbs2-peer/hbs2-peer.cabal | 1 + hbs2-peer/lib/HBS2/Peer/RPC/Client.hs | 12 ++ 13 files changed, 353 insertions(+), 193 deletions(-) create mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/Client.hs diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index df1ad8b5..e2fe2f6e 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -80,16 +80,18 @@ main = do entry $ bindMatch "debug:cli:show" $ nil_ \case _ -> display cli + runHBS2Cli do - case cli of - [ListVal [SymbolVal "stdin"]] -> do - what <- getContents - >>= either (error.show) pure . parseTop - run dict what >>= eatNil display + case cli of + [ListVal [SymbolVal "stdin"]] -> do + what <- liftIO getContents + >>= either (error.show) pure . parseTop - [] -> do - void $ run dict [mkForm "help" []] + recover $ run dict what >>= eatNil display - _ -> do - run dict cli >>= eatNil display + [] -> do + void $ run dict [mkForm "help" []] + + _ -> do + recover $ run dict cli >>= eatNil display diff --git a/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs b/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs index abaabe56..edb7fb22 100644 --- a/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs +++ b/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs @@ -379,7 +379,8 @@ newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a } , MonadReader (TVar (Dict c m)) ) - +instance MonadTrans (RunM c) where + lift = RunM . lift newtype MakeDictM c m a = MakeDictM { fromMakeDict :: Writer (Dict c m) a } deriving newtype ( Applicative diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs index 0f9cbeb2..bba86b8c 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs @@ -7,15 +7,20 @@ import HBS2.System.Logger.Simple.ANSI as All import HBS2.Storage.Operations.Class import HBS2.Storage.Operations.ByteString import HBS2.Base58 -import Data.List qualified as L -import Data.Maybe import HBS2.CLI.Run.Internal import HBS2.CLI.Run.Internal.GroupKey as G import HBS2.Net.Auth.GroupKeySymm as Symm +import HBS2.Storage import HBS2.Net.Auth.Credentials import HBS2.KeyMan.Keys.Direct +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.Client.Unix + +import Data.List qualified as L +import Data.Maybe import Data.Text qualified as Text import Data.ByteString.Lazy.Char8 as LBS8 import Data.ByteString.Lazy as LBS @@ -30,34 +35,35 @@ import Lens.Micro.Platform {- HLINT ignore "Functor law" -} -groupKeyEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m () +groupKeyEntries :: forall c m . ( MonadUnliftIO m + , IsContext c + , HasClientAPI StorageAPI UNIX m + , HasStorage m + ) => MakeDictM c m () groupKeyEntries = do entry $ bindMatch "hbs2:groupkey:load" $ \case [StringLike s] -> do - flip runContT pure do - sto <- ContT withPeerStorage + sto <- getStorage - gk <- runExceptT (readFromMerkle sto (SimpleKey (fromString s))) - >>= orThrowUser "can't load group key" - <&> deserialiseOrFail @(GroupKey 'Symm 'HBS2Basic) - >>= orThrowUser "invalid group key" + gk <- runExceptT (readFromMerkle sto (SimpleKey (fromString s))) + >>= orThrowUser "can't load group key" + <&> deserialiseOrFail @(GroupKey 'Symm 'HBS2Basic) + >>= orThrowUser "invalid group key" - pure $ mkStr (show $ pretty $ AsGroupKeyFile gk) + pure $ mkStr (show $ pretty $ AsGroupKeyFile gk) _ -> throwIO $ BadFormException @C nil entry $ bindMatch "hbs2:groupkey:store" $ \case [LitStrVal s] -> do - flip runContT pure do + let lbs = LBS8.pack (Text.unpack s) + gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) + `orDie` "invalid group key" - let lbs = LBS8.pack (Text.unpack s) - gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) - `orDie` "invalid group key" - - sto <- ContT withPeerStorage - ha <- writeAsMerkle sto (serialise gk) - pure $ mkStr (show $ pretty ha) + sto <- getStorage + ha <- writeAsMerkle sto (serialise gk) + pure $ mkStr (show $ pretty ha) _ -> throwIO $ BadFormException @C nil @@ -69,17 +75,15 @@ groupKeyEntries = do entry $ bindMatch "hbs2:groupkey:update" $ \case [LitStrVal s, ListVal ins] -> do - flip runContT pure do + sto <- getStorage - sto <- ContT withPeerStorage + let lbs = LBS8.pack (Text.unpack s) + gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) + `orDie` "invalid group key" - let lbs = LBS8.pack (Text.unpack s) - gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) - `orDie` "invalid group key" + gk1 <- modifyGroupKey gk ins - gk1 <- lift $ modifyGroupKey gk ins - - pure $ mkStr (show $ pretty $ AsGroupKeyFile gk1) + pure $ mkStr (show $ pretty $ AsGroupKeyFile gk1) _ -> throwIO $ BadFormException @C nil @@ -118,16 +122,16 @@ groupKeyEntries = do entry $ bindMatch "hbs2:groupkey:decrypt-block" $ \case - [BlobLike bs] -> flip runContT pure do + [BlobLike bs] -> do - sto <- ContT withPeerStorage + sto <- getStorage let lbs = LBS.fromStrict bs seb <- pure (deserialiseOrFail lbs) `orDie` "invalid SmallEncryptedBlock" - decrypted <- lift $ G.decryptBlock sto seb + decrypted <- G.decryptBlock sto seb pure $ mkForm @c "blob" [mkStr (BS8.unpack decrypted)] @@ -135,11 +139,10 @@ groupKeyEntries = do entry $ bindMatch "hbs2:groupkey:encrypt-block" $ \case [StringLike gkh, BlobLike what] -> do - flip runContT pure do - sto <- ContT withPeerStorage - gk <- lift $ loadGroupKey (fromString gkh) + sto <- getStorage + gk <- loadGroupKey (fromString gkh) `orDie` "can't load group key" - seb <- lift $ G.encryptBlock sto gk what + seb <- G.encryptBlock sto gk what pure $ mkForm "blob" [mkStr (LBS8.unpack (serialise seb))] _ -> throwIO $ BadFormException @C nil diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index 95883748..3a5e2439 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -1,3 +1,4 @@ +{-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} {-# Language AllowAmbiguousTypes #-} module HBS2.CLI.Run.Internal @@ -12,16 +13,24 @@ import HBS2.Base58 import HBS2.Data.Types.Refs import HBS2.Storage import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client import HBS2.Peer.RPC.Client.Unix import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.RefLog +import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.API.LWWRef import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.API.RefChan import HBS2.Peer.RPC.Client.StorageClient import Data.Config.Suckless.Script qualified as SC import Data.Config.Suckless.Script hiding (internalEntries) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Cont import Data.ByteString.Char8 qualified as BS8 import Data.Text qualified as Text +import Lens.Micro.Platform pattern HashLike:: forall {c} . HashRef -> Syntax c pattern HashLike x <- ( @@ -37,6 +46,121 @@ pattern SignPubKeyLike x <- ( _ -> Nothing -> Just x ) + +data HBS2CliEnv = + HBS2CliEnv + { _peerSocket :: FilePath + , _peerRefChanAPI :: ServiceCaller RefChanAPI UNIX + , _peerRefLogAPI :: ServiceCaller RefLogAPI UNIX + , _peerLwwRefAPI :: ServiceCaller LWWRefAPI UNIX + , _peerPeerAPI :: ServiceCaller PeerAPI UNIX + , _peerStorageAPI :: ServiceCaller StorageAPI UNIX + } + +makeLenses 'HBS2CliEnv + +newtype HBS2Cli m a = HBS2Cli { fromHBS2Cli :: ReaderT (TVar (Maybe HBS2CliEnv)) m a } + deriving newtype ( Applicative + , Functor + , Monad + , MonadIO + , MonadUnliftIO + , MonadReader (TVar (Maybe HBS2CliEnv)) + ) + +withHBS2Cli :: TVar (Maybe HBS2CliEnv) -> HBS2Cli m a -> m a +withHBS2Cli env action = runReaderT (fromHBS2Cli action) env + +recover :: HBS2Cli IO a -> HBS2Cli IO a +recover what = do + catch what $ \case + PeerNotConnectedException -> do + + soname <- detectRPC + `orDie` "can't locate hbs2-peer rpc" + + flip runContT pure do + + client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) + >>= orThrowUser ("can't connect to" <+> pretty soname) + + void $ ContT $ withAsync $ runMessagingUnix client + + peerAPI <- makeServiceCaller @PeerAPI (fromString soname) + refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname) + refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname) + storageAPI <- makeServiceCaller @StorageAPI (fromString soname) + lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname) + + -- let sto = AnyStorage (StorageClient storageAPI) + + let endpoints = [ Endpoint @UNIX peerAPI + , Endpoint @UNIX refLogAPI + , Endpoint @UNIX refChanAPI + , Endpoint @UNIX lwwAPI + , Endpoint @UNIX storageAPI + ] + + void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + + let env = Just (HBS2CliEnv soname refChanAPI refLogAPI lwwAPI peerAPI storageAPI) + tv <- newTVarIO env + + liftIO $ withHBS2Cli tv what + + +runHBS2Cli :: MonadUnliftIO m => HBS2Cli m a -> m a +runHBS2Cli action = do + noenv <- newTVarIO Nothing + withHBS2Cli noenv action + +data PeerException = + PeerNotConnectedException + deriving stock (Show, Typeable) + +instance Exception PeerException + + +instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where + getClientAPI = lift (getClientAPI @api @proto) + +instance (MonadUnliftIO m, HasStorage m) => HasStorage (RunM c m) where + getStorage = lift getStorage + +instance (MonadUnliftIO m, HasClientAPI StorageAPI UNIX m, HasStorage m) => HasStorage (ContT a (RunM c m)) where + getStorage = lift getStorage + +instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where + getClientAPI = lift $ getClientAPI @api @proto + +instance MonadUnliftIO m => HasClientAPI RefChanAPI UNIX (HBS2Cli m) where + getClientAPI = do + what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException + pure $ view peerRefChanAPI what + +instance MonadUnliftIO m => HasClientAPI RefLogAPI UNIX (HBS2Cli m) where + getClientAPI = do + what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException + pure $ view peerRefLogAPI what + +instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (HBS2Cli m) where + getClientAPI = do + what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException + pure $ view peerPeerAPI what + +instance MonadUnliftIO m => HasClientAPI StorageAPI UNIX (HBS2Cli m) where + getClientAPI = do + what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException + pure $ view peerStorageAPI what + +instance MonadUnliftIO m => HasClientAPI LWWRefAPI UNIX (HBS2Cli m) where + getClientAPI = do + what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException + pure $ view peerLwwRefAPI what + +instance MonadUnliftIO m => HasStorage (HBS2Cli m) where + getStorage = getClientAPI @StorageAPI @UNIX <&> AnyStorage . StorageClient + internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m () internalEntries = do SC.internalEntries @@ -87,18 +211,3 @@ internalEntries = do e -> throwIO (BadFormException @c nil) -instance MonadUnliftIO m => HasStorage (RunM c m) where - getStorage = do - so <- detectRPC `orDie` "hbs2-peer not found" - withRPC2 @StorageAPI @UNIX so $ \caller -> do - pure $ AnyStorage (StorageClient caller) - -withPeerStorage :: (IsContext c, MonadUnliftIO m) => (AnyStorage -> RunM c m a) -> RunM c m a -withPeerStorage m = do - so <- detectRPC `orDie` "hbs2-peer not found" - - withRPC2 @StorageAPI @UNIX so $ \caller -> do - let sto = AnyStorage (StorageClient caller) - m sto - - diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs index f7af2a33..1023443d 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs @@ -16,6 +16,10 @@ import HBS2.Storage.Operations.ByteString import HBS2.KeyMan.Keys.Direct import HBS2.Net.Auth.GroupKeySymm as Symm +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.API.Storage + import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS import Data.Maybe @@ -56,11 +60,15 @@ decryptBlock sto seb = do runExceptT (Symm.decryptBlock sto find seb) >>= orThrowUser "can't decrypt block" -loadGroupKey :: (IsContext c, MonadUnliftIO m) => HashRef -> RunM c m (Maybe (GroupKey 'Symm HBS2Basic)) +loadGroupKey :: ( IsContext c + , MonadUnliftIO m + , HasStorage m + , HasClientAPI StorageAPI UNIX m + ) => HashRef -> RunM c m (Maybe (GroupKey 'Symm HBS2Basic)) loadGroupKey h = do flip runContT pure do - sto <- ContT withPeerStorage + sto <- getStorage raw <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h))) <&> either (const Nothing) Just diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs index a10cd76c..13c48feb 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs @@ -12,6 +12,8 @@ import HBS2.Merkle import HBS2.Storage import HBS2.Storage.Operations.ByteString import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.API.Storage import HBS2.KeyMan.Keys.Direct import HBS2.Net.Auth.Schema() @@ -24,12 +26,16 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Cont import Control.Monad.Except -getGroupKeyHash :: (IsContext c, MonadUnliftIO m) +getGroupKeyHash :: ( IsContext c + , MonadUnliftIO m + , HasStorage m + , HasClientAPI StorageAPI UNIX m + ) => HashRef -> RunM c m (Maybe HashRef, MTreeAnn [HashRef]) getGroupKeyHash h = do flip runContT pure do - sto <- ContT withPeerStorage + sto <- getStorage headBlock <- getBlock sto (fromHashRef h) >>= orThrowUser "no-block" diff --git a/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs index b68cceb1..b912ee8a 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs @@ -8,6 +8,7 @@ import HBS2.Data.Types.Refs import HBS2.Storage import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.Client import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.API.LWWRef @@ -23,7 +24,12 @@ import HBS2.KeyMan.App.Types import Control.Monad.Trans.Cont -lwwRefEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +lwwRefEntries :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + , HasClientAPI PeerAPI UNIX m + , HasClientAPI LWWRefAPI UNIX m + ) => MakeDictM c m () lwwRefEntries = do brief "creates a new lwwref" @@ -32,12 +38,9 @@ lwwRefEntries = do $ entry $ bindMatch "hbs2:lwwref:create" $ \case [] -> do reflog <- keymanNewCredentials (Just "lwwref") 0 - - flip runContT pure do - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @PeerAPI @UNIX so - void $ callService @RpcPollAdd api (reflog, "lwwref", 31) - pure $ mkStr (show $ pretty (AsBase58 reflog)) + api <- getClientAPI @PeerAPI @UNIX + void $ callService @RpcPollAdd api (reflog, "lwwref", 31) + pure $ mkStr (show $ pretty (AsBase58 reflog)) _ -> throwIO (BadFormException @C nil) @@ -46,12 +49,10 @@ lwwRefEntries = do $ returns "list of string" "lwwref list" $ entry $ bindMatch "hbs2:lwwref:list" $ \case [] -> do - flip runContT pure do - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @PeerAPI @UNIX so - r <- callService @RpcPollList2 api (Just "lwwref", Nothing) - >>= orThrowUser "can't get lwwref list" - pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r + api <- getClientAPI @PeerAPI @UNIX + r <- callService @RpcPollList2 api (Just "lwwref", Nothing) + >>= orThrowUser "can't get lwwref list" + pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r _ -> throwIO (BadFormException @C nil) @@ -62,12 +63,10 @@ lwwRefEntries = do $ returns "atom" "okay" $ entry $ bindMatch "hbs2:lwwref:fetch" $ \case [StringLike puk] -> do - flip runContT pure do - lww <- orThrowUser "bad lwwref key" (fromStringMay puk) - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @LWWRefAPI @UNIX so - void $ callService @RpcLWWRefFetch api lww - pure $ mkStr "okay" + lww <- orThrowUser "bad lwwref key" (fromStringMay puk) + api <- getClientAPI @LWWRefAPI @UNIX + void $ callService @RpcLWWRefFetch api lww + pure $ mkStr "okay" _ -> throwIO (BadFormException @C nil) @@ -86,13 +85,11 @@ lwwRefEntries = do $ entry $ bindMatch "hbs2:lwwref:get" $ \case [StringLike puk] -> do - flip runContT pure do - ref <- orThrowUser "bad lwwref key" (fromStringMay puk) - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @LWWRefAPI @UNIX so - what <- callService @RpcLWWRefGet api ref - >>= orThrowUser "can't get lwwref value" - pure $ mkStr (show $ pretty what) + ref <- orThrowUser "bad lwwref key" (fromStringMay puk) + api <- getClientAPI @LWWRefAPI @UNIX + what <- callService @RpcLWWRefGet api ref + >>= orThrowUser "can't get lwwref value" + pure $ mkStr (show $ pretty what) _ -> throwIO (BadFormException @C nil) @@ -104,31 +101,29 @@ lwwRefEntries = do $ entry $ bindMatch "hbs2:lwwref:update" $ \case [StringLike puks, HashLike new] -> do - flip runContT pure do - puk <- orThrowUser "bad lwwref key" (fromStringMay puks) - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @LWWRefAPI @UNIX so + puk <- orThrowUser "bad lwwref key" (fromStringMay puks) + api <- getClientAPI @LWWRefAPI @UNIX - (sk,pk) <- liftIO $ runKeymanClient do - creds <- loadCredentials puk - >>= orThrowUser "can't load credentials" - pure ( view peerSignSk creds, view peerSignPk creds ) + (sk,pk) <- liftIO $ runKeymanClient do + creds <- loadCredentials puk + >>= orThrowUser "can't load credentials" + pure ( view peerSignSk creds, view peerSignPk creds ) - what <- callService @RpcLWWRefGet api puk - >>= orThrowUser "can't get lwwref value" + what <- callService @RpcLWWRefGet api puk + >>= orThrowUser "can't get lwwref value" - sno' <- case what of - Nothing -> pure 0 - Just lwwv -> pure (lwwSeq lwwv) + sno' <- case what of + Nothing -> pure 0 + Just lwwv -> pure (lwwSeq lwwv) - let sno = succ sno' + let sno = succ sno' - let box = makeSignedBox pk sk (LWWRef sno new Nothing) + let box = makeSignedBox pk sk (LWWRef sno new Nothing) - callService @RpcLWWRefUpdate api box - >>= orThrowUser "lww ref update error" + callService @RpcLWWRefUpdate api box + >>= orThrowUser "lww ref update error" - pure nil + pure nil _ -> throwIO (BadFormException @C nil) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index 751aa9e0..166a321d 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -15,6 +15,10 @@ import HBS2.Storage.Operations.ByteString import HBS2.Net.Auth.Schema() +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.Client.Unix + import Codec.Serialise import Control.Monad.Trans.Maybe import Control.Monad.Trans.Cont @@ -50,7 +54,12 @@ metaFromSyntax syn = t x = Text.pack (show $ pretty x) -metaDataEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +metaDataEntries :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + , HasStorage m + , HasClientAPI StorageAPI UNIX m + ) => MakeDictM c m () metaDataEntries = do brief "update group key for tree" @@ -84,20 +93,19 @@ metaDataEntries = do gk1 <- modifyGroupKey gk ins - flip runContT pure do - sto <- ContT withPeerStorage - gk1h <- writeAsMerkle sto (serialise gk1) + sto <- getStorage + gk1h <- writeAsMerkle sto (serialise gk1) - case headBlk of - w@(MTreeAnn { _mtaCrypt = EncryptGroupNaClSymm _ nonce }) -> do - let w1 = w { _mtaCrypt = EncryptGroupNaClSymm gk1h nonce } + case headBlk of + w@(MTreeAnn { _mtaCrypt = EncryptGroupNaClSymm _ nonce }) -> do + let w1 = w { _mtaCrypt = EncryptGroupNaClSymm gk1h nonce } - h <- putBlock sto (serialise w1) - >>= orThrowUser "can't put block" + h <- putBlock sto (serialise w1) + >>= orThrowUser "can't put block" - pure $ mkStr (show $ pretty h) + pure $ mkStr (show $ pretty h) - _ -> pure nil + _ -> pure nil _ -> throwIO (BadFormException @c nil) @@ -142,7 +150,7 @@ file-name: "qqq.txt" r <- flip runContT pure do - sto <- ContT withPeerStorage + sto <- getStorage runMaybeT do @@ -179,7 +187,7 @@ file-name: "qqq.txt" let xs = parseTop r0 - & fromRight mempty + & either mempty (fmap fixContext) pure $ mkForm "dict" xs @@ -302,14 +310,12 @@ $ hbs2-cli hbs2:groupkey:list-public-keys [hbs2:groupkey:load GixS4wssCD4x7LzvHv when (isJust enc && isNothing gk) do error $ show $ "Can't load group key" <+> pretty enc - flip runContT pure do + sto <- getStorage - sto <- ContT withPeerStorage + href <- lift (createTreeWithMetadata sto gk (meta0 <> meta1) lbs) + `orDie` "encryption error" - href <- lift (createTreeWithMetadata sto gk (meta0 <> meta1) lbs) - `orDie` "encryption error" - - pure $ mkStr (show $ pretty href) + pure $ mkStr (show $ pretty href) entry $ bindMatch "cbor:base58" $ \case [ LitStrVal x ] -> do diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs index e06b825a..67678bc2 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs @@ -7,10 +7,12 @@ import HBS2.Hash import HBS2.Base58 import HBS2.Data.Types.Refs import HBS2.Storage +import HBS2.Peer.RPC.Client import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client.Unix import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.API.RefLog +import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.API.LWWRef import HBS2.Net.Auth.Schema() @@ -37,7 +39,13 @@ putTextLit sto s = do pure (mkStr @c (show $ pretty h)) -peerEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +peerEntries :: forall c m . ( IsContext c + , MonadUnliftIO m + , HasClientAPI PeerAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , Exception (BadFormException c) + ) => MakeDictM c m () peerEntries = do entry $ bindMatch "hbs2:peer:detect" $ \case @@ -47,7 +55,7 @@ peerEntries = do [StringLike s] -> do flip runContT pure do - sto <- ContT withPeerStorage + sto <- getStorage ha <- pure (fromStringMay @HashRef s) `orDie` "invalid hash" @@ -56,13 +64,14 @@ peerEntries = do pure $ mkForm "blob" [mkStr (LBS8.unpack lbs)] - _ -> throwIO $ BadFormException @C nil + _ -> throwIO $ BadFormException @c nil entry $ bindMatch "hbs2:peer:has-block" $ \case [StringLike s] -> do flip runContT pure do - sto <- ContT withPeerStorage + sto <- getStorage + ha <- pure (fromStringMay @HashRef s) `orDie` "invalid hash" @@ -70,21 +79,21 @@ peerEntries = do pure $ maybe (mkSym "no-block") mkInt mbsz - _ -> throwIO $ BadFormException @C nil + _ -> throwIO $ BadFormException @c nil -- stores *small* block entry $ bindMatch "hbs2:peer:put-block" $ \case [ListVal [SymbolVal "blob", LitStrVal s]] -> do flip runContT pure do - sto <- ContT withPeerStorage + sto <- getStorage lift $ putTextLit sto s [LitStrVal s] -> do flip runContT pure do - sto <- ContT withPeerStorage + sto <- getStorage lift $ putTextLit sto s - _ -> throwIO $ BadFormException @C nil + _ -> throwIO $ BadFormException @c nil brief "checks if peer available" $ noArgs @@ -102,17 +111,11 @@ peerEntries = do |] $ entry $ bindMatch "hbs2:peer:poke" $ \case _ -> do - so <- detectRPC `orDie` "hbs2-peer not found" - r <- newTVarIO nil - withRPC2 @PeerAPI @UNIX so $ \caller -> do - - what <- callRpcWaitMay @RpcPoke (TimeoutSec 1) caller () - <&> fromMaybe "" - <&> parseTop - <&> either (const nil) (mkForm "dict") - - atomically $ writeTVar r what - - readTVarIO r + api <- getClientAPI @PeerAPI @UNIX + callRpcWaitMay @RpcPoke (TimeoutSec 1) api () + <&> fromMaybe "" + <&> parseTop + <&> either (const nil) (mkForm "dict" . fmap fixContext) + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs index fdc428d4..3a1909c1 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs @@ -30,6 +30,9 @@ import HBS2.Base58 import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Schema() import HBS2.Data.Types.SignedBox +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.API.Storage +import HBS2.Storage import HBS2.KeyMan.Keys.Direct import HBS2.KeyMan.App.Types @@ -42,7 +45,14 @@ import Control.Monad.Except import Text.InterpolatedString.Perl6 (qc) -refchanEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +refchanEntries :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasClientAPI PeerAPI UNIX m + , HasStorage m + ) => MakeDictM c m () refchanEntries = do brief "requests all rechans that peer is subcribed to" @@ -98,8 +108,8 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr callCC $ \exit -> do so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @RefChanAPI @UNIX so - sto <- ContT $ withPeerStorage + api <- getClientAPI @RefChanAPI @UNIX + sto <- getStorage w <- callService @RpcRefChanHeadGet api puk >>= orThrowUser "can't get refchan head" @@ -124,6 +134,15 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "hbs2:refchan:create" $ \case + [StringLike headFile] -> do + error "CREATES FUCKIN REFCHAN WITH HEAD BLOCK" + + [] -> do + error "CREATES FUCKIN DEFAULT REFCHAN" + + _ -> throwIO (BadFormException @c nil) + brief "prints refchan head example" $ returns "nil" mempty $ entry $ bindMatch "hbs2:refchan:head:example" $ nil_ $ \case @@ -131,10 +150,7 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr let rch0 = refChanHeadDefault @L4Proto - so <- detectRPC - >>= orThrowUser "hbs2-peer not found" - - api <- ContT $ withRPC2 @PeerAPI @UNIX so + api <- getClientAPI @PeerAPI @UNIX pips <- callService @RpcPeers api () <&> either (const mempty) (HM.fromList . fmap ((,1) . fst) . take 3) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs index dfbe95aa..859f98b4 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs @@ -7,10 +7,12 @@ import HBS2.CLI.Run.Internal.KeyMan import HBS2.Data.Types.Refs import HBS2.Merkle import HBS2.Storage +import HBS2.Peer.RPC.Client import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client.Unix import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.API.RefLog +import HBS2.Peer.RPC.API.Storage import HBS2.Peer.Proto hiding (request) import HBS2.Base58 @@ -48,18 +50,23 @@ mkRefLogUpdateFrom reflog mbs = do makeRefLogUpdate @L4Proto @'HBS2Basic (coerce puk) privk txraw -reflogEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +reflogEntries :: forall c m . ( IsContext c + , Exception (BadFormException c) + , MonadUnliftIO m + , HasStorage m + , HasClientAPI PeerAPI UNIX m + , HasClientAPI RefLogAPI UNIX m + , HasClientAPI StorageAPI UNIX m + ) => MakeDictM c m () reflogEntries = do entry $ bindMatch "hbs2:reflog:create" $ \case [] -> do reflog <- keymanNewCredentials (Just "reflog") 0 - flip runContT pure do - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @PeerAPI @UNIX so - void $ callService @RpcPollAdd api (reflog, "reflog", 31) - pure $ mkStr (show $ pretty (AsBase58 reflog)) + api <- getClientAPI @PeerAPI @UNIX + void $ callService @RpcPollAdd api (reflog, "reflog", 31) + pure $ mkStr (show $ pretty (AsBase58 reflog)) _ -> throwIO (BadFormException @C nil) @@ -67,11 +74,9 @@ reflogEntries = do [SignPubKeyLike reflog] -> do -- reflog <- keymanNewCredentials (Just "reflog") 0 - flip runContT pure do - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @PeerAPI @UNIX so - void $ callService @RpcPollAdd api (reflog, "reflog", 31) - pure $ mkStr (show $ pretty (AsBase58 reflog)) + api <- getClientAPI @PeerAPI @UNIX + void $ callService @RpcPollAdd api (reflog, "reflog", 31) + pure $ mkStr (show $ pretty (AsBase58 reflog)) _ -> throwIO (BadFormException @C nil) @@ -79,38 +84,35 @@ reflogEntries = do entry $ bindMatch "hbs2:reflog:tx:annhashref:create" $ \case [StringLike puk, StringLike hash] -> do - flip runContT pure do - reflog <- orThrowUser "bad reflog key" (fromStringMay puk) - sto <- ContT withPeerStorage - hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash) - void $ hasBlock sto (fromHashRef hashref) `orDie` "no block" - let sref = AnnotatedHashRef Nothing hashref - rlu <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise - pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + reflog <- orThrowUser "bad reflog key" (fromStringMay puk) + sto <- getStorage + hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash) + void $ hasBlock sto (fromHashRef hashref) `orDie` "no block" + let sref = AnnotatedHashRef Nothing hashref + rlu <- mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise + pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] _ -> throwIO (BadFormException @C nil) entry $ bindMatch "hbs2:reflog:tx:post" $ nil_ \case [BlobLike blob] -> do - so <- detectRPC `orDie` "no rpc found" - withRPC2 @RefLogAPI so $ \caller -> do - wtf <- deserialiseOrFail @(RefLogUpdate L4Proto) (LBS.fromStrict blob) - & orThrowUser "invalid tx" - void $ callService @RpcRefLogPost caller wtf + caller <- getClientAPI @RefLogAPI @UNIX + wtf <- deserialiseOrFail @(RefLogUpdate L4Proto) (LBS.fromStrict blob) + & orThrowUser "invalid tx" + void $ callService @RpcRefLogPost caller wtf _ -> throwIO (BadFormException @C nil) entry $ bindMatch "hbs2:reflog:tx:seqref:create" $ \case [StringLike puk, LitIntVal sn, StringLike hash] -> do - flip runContT pure do - reflog <- orThrowUser "bad reflog key" (fromStringMay puk) - sto <- ContT withPeerStorage - hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash) - void $ hasBlock sto (fromHashRef hashref) `orDie` "no block" - let sref = SequentialRef sn (AnnotatedHashRef Nothing hashref) - rlu <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise - pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + reflog <- orThrowUser "bad reflog key" (fromStringMay puk) + sto <- getStorage + hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash) + void $ hasBlock sto (fromHashRef hashref) `orDie` "no block" + let sref = SequentialRef sn (AnnotatedHashRef Nothing hashref) + rlu <- mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise + pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] _ -> throwIO (BadFormException @C nil) @@ -138,8 +140,7 @@ reflogEntries = do flip runContT pure do reflog <- orThrowUser "bad reflog key" (fromStringMay puk) - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @RefLogAPI @UNIX so + api <- getClientAPI @RefLogAPI @UNIX what <- callService @RpcRefLogGet api reflog >>= orThrowUser "can't get reflog" pure $ mkStr (show $ pretty what) @@ -150,8 +151,7 @@ reflogEntries = do [StringLike puk] -> do flip runContT pure do reflog <- orThrowUser "bad reflog key" (fromStringMay puk) - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @RefLogAPI @UNIX so + api <- getClientAPI @RefLogAPI @UNIX void $ callService @RpcRefLogFetch api reflog pure $ mkStr "okay" @@ -160,8 +160,7 @@ reflogEntries = do entry $ bindMatch "hbs2:reflog:list" $ \case [] -> do flip runContT pure do - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @PeerAPI @UNIX so + api <- getClientAPI @PeerAPI @UNIX r <- callService @RpcPollList2 api (Just "reflog", Nothing) >>= orThrowUser "can't get reflog list" pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r @@ -187,9 +186,8 @@ reflogEntries = do callCC \exit -> do - so <- detectRPC `orDie` "rpc not found" - api <- ContT $ withRPC2 @RefLogAPI @UNIX so - sto <- ContT withPeerStorage + api <- getClientAPI @RefLogAPI @UNIX + sto <- getStorage r <- callService @RpcRefLogGet api puk >>= orThrowUser "can't get reflog value" diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 5c831b47..877efece 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -163,6 +163,7 @@ library HBS2.Peer.Proto.LWWRef.Internal HBS2.Peer.Proto.BrowserPlugin + HBS2.Peer.RPC.Client HBS2.Peer.RPC.Class HBS2.Peer.RPC.API.Peer HBS2.Peer.RPC.API.RefLog diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client.hs new file mode 100644 index 00000000..b52f5fe6 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client.hs @@ -0,0 +1,12 @@ +module HBS2.Peer.RPC.Client where + +import HBS2.Net.Proto.Service + +import Data.Kind + +class Monad m => HasClientAPI (api :: [Type]) proto m where + getClientAPI :: m (ServiceCaller api proto) + + + +