wip, refactored

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
+        what <- liftIO getContents
                   >>= either (error.show) pure . parseTop
-      run dict what >>= eatNil display
+
+        recover $ run dict what >>= eatNil display
 
       [] -> do
         void $ run dict [mkForm  "help" []]
 
       _ -> do
-      run dict cli >>= eatNil display
+        recover $ run dict cli >>= eatNil display
 

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

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,13 +35,16 @@ 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 <- getStorage
-          sto <- ContT withPeerStorage
 
         gk <- runExceptT (readFromMerkle sto (SimpleKey (fromString s)))
                 >>= orThrowUser "can't load group key"
@@ -49,13 +57,11 @@ groupKeyEntries = do
 
   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"
 
-          sto <- ContT withPeerStorage
+        sto <- getStorage
         ha <- writeAsMerkle sto (serialise gk)
         pure $ mkStr (show $ pretty ha)
 
@@ -69,15 +75,13 @@ 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"
 
-        gk1 <- lift $ modifyGroupKey gk ins
+      gk1 <- modifyGroupKey gk ins
 
       pure $ mkStr (show $ pretty $ AsGroupKeyFile gk1)
 
@@ -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 <- getStorage
-        sto <- ContT withPeerStorage
+        gk <- loadGroupKey (fromString gkh)
-        gk <- lift $ 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

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

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

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"

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,10 +38,7 @@ lwwRefEntries = do
     $ entry $ bindMatch "hbs2:lwwref:create" $ \case
         [] -> do
           reflog <- keymanNewCredentials (Just "lwwref") 0
-
+          api <- getClientAPI @PeerAPI  @UNIX
-          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))
 
@@ -46,9 +49,7 @@ lwwRefEntries = do
     $ returns "list of string" "lwwref list"
     $ entry $ bindMatch "hbs2:lwwref:list" $ \case
       [] -> do
-        flip runContT pure do
+        api <- getClientAPI  @PeerAPI @UNIX
-          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
@@ -62,10 +63,8 @@ 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 <- getClientAPI @LWWRefAPI @UNIX
-          api <- ContT $ withRPC2 @LWWRefAPI @UNIX so
         void $ callService @RpcLWWRefFetch api lww
         pure $ mkStr "okay"
 
@@ -86,10 +85,8 @@ 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 <- getClientAPI @LWWRefAPI  @UNIX
-          api <- ContT $ withRPC2 @LWWRefAPI  @UNIX so
         what <- callService @RpcLWWRefGet api ref
                   >>= orThrowUser "can't get lwwref value"
         pure $ mkStr (show $ pretty what)
@@ -104,10 +101,8 @@ 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 <- getClientAPI @LWWRefAPI  @UNIX
-          api <- ContT $ withRPC2 @LWWRefAPI  @UNIX so
 
         (sk,pk) <- liftIO $ runKeymanClient do
                      creds  <- loadCredentials puk

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,8 +93,7 @@ metaDataEntries = do
 
         gk1 <- modifyGroupKey gk ins
 
-        flip runContT pure do
+        sto <- getStorage
-          sto <- ContT withPeerStorage
         gk1h <- writeAsMerkle sto (serialise gk1)
 
         case headBlk of
@@ -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,9 +310,7 @@ $ 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"

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"
+        api <- getClientAPI @PeerAPI @UNIX
-        r <- newTVarIO nil
+        callRpcWaitMay @RpcPoke (TimeoutSec 1) api ()
-        withRPC2 @PeerAPI  @UNIX so $ \caller -> do
-
-          what <- callRpcWaitMay @RpcPoke (TimeoutSec 1) caller ()
           <&> fromMaybe ""
           <&> parseTop
-                    <&> either (const nil) (mkForm "dict")
+          <&> either (const nil) (mkForm "dict" . fmap fixContext)
-
+
-          atomically $ writeTVar r what
-
-        readTVarIO r
 
 

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
+            api <- getClientAPI @RefChanAPI @UNIX
-            sto <- ContT $ withPeerStorage
+            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
+          api <- getClientAPI @PeerAPI  @UNIX
-                   >>= orThrowUser "hbs2-peer not found"
-
-          api <- ContT $ withRPC2 @PeerAPI  @UNIX so
 
           pips <- callService @RpcPeers api ()
                     <&> either (const mempty) (HM.fromList . fmap ((,1) . fst) . take 3)

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,16 +50,21 @@ 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
+      api <- getClientAPI @PeerAPI  @UNIX
-        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))
 
@@ -67,9 +74,7 @@ reflogEntries = do
     [SignPubKeyLike reflog] -> do
       -- reflog <- keymanNewCredentials (Just "reflog") 0
 
-      flip runContT pure do
+      api <- getClientAPI @PeerAPI @UNIX
-        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))
 
@@ -79,13 +84,12 @@ 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
+      sto <- getStorage
       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
+      rlu <- mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise
       pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
 
     _ -> throwIO (BadFormException @C nil)
@@ -93,8 +97,7 @@ reflogEntries = do
 
   entry $ bindMatch "hbs2:reflog:tx:post" $ nil_ \case
     [BlobLike blob] -> do
-      so <- detectRPC `orDie` "no rpc found"
+      caller <- getClientAPI @RefLogAPI @UNIX
-      withRPC2 @RefLogAPI so $ \caller -> do
       wtf <- deserialiseOrFail @(RefLogUpdate L4Proto) (LBS.fromStrict blob)
               & orThrowUser "invalid tx"
       void $ callService @RpcRefLogPost caller wtf
@@ -103,13 +106,12 @@ reflogEntries = do
 
   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
+      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 <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise
+      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 <- getClientAPI @RefLogAPI  @UNIX
-        api <- ContT $ withRPC2 @RefLogAPI  @UNIX so
         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 <- getClientAPI @RefLogAPI  @UNIX
-        api <- ContT $ withRPC2 @RefLogAPI  @UNIX so
         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 <- getClientAPI @PeerAPI @UNIX
-        api <- ContT $ withRPC2 @PeerAPI @UNIX so
         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 <- getClientAPI @RefLogAPI  @UNIX
-          api <- ContT $ withRPC2 @RefLogAPI  @UNIX so
+          sto <- getStorage
-          sto <- ContT withPeerStorage
 
           r <- callService @RpcRefLogGet api puk
                  >>= orThrowUser "can't get reflog value"

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

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