wip

hbs2-cli/app/Main.hs

@@ -9,60 +9,31 @@ import HBS2.CLI.Run.Keyring
 import HBS2.CLI.Run.GroupKey
 import HBS2.CLI.Run.Sigil
 import HBS2.CLI.Run.MetaData
+import HBS2.CLI.Run.Peer
 
-import HBS2.OrDie
 
 import HBS2.Data.Types.Refs
-import HBS2.Merkle
 import HBS2.Misc.PrettyStuff as All
 import HBS2.System.Logger.Simple.ANSI as All
 
-import HBS2.Storage
-import HBS2.Storage.Operations.ByteString
-import HBS2.Peer.CLI.Detect
 import HBS2.Peer.RPC.Client.Unix
-import HBS2.Peer.RPC.API.Peer
-import HBS2.Peer.RPC.API.Storage
-import HBS2.Peer.RPC.Client.StorageClient
 
 import HBS2.Peer.Proto hiding (request)
 import HBS2.Base58
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Auth.Schema()
 
-
 import HBS2.KeyMan.Keys.Direct
-import HBS2.KeyMan.State
 import HBS2.KeyMan.App.Types
 
 import Data.Coerce
-import Data.Config.Suckless
-import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
-import Data.Kind
-import Data.List (isPrefixOf)
 import Data.List qualified as List
 import Data.ByteString qualified as BS
-import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString (ByteString)
-import Data.ByteString.Lazy qualified as LBS
-import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as TE
-import Data.Text.IO qualified as TIO
-import Data.Either
-import Data.Maybe
-import Codec.Serialise
-import Control.Monad.Reader
-import Control.Monad.Writer
-import Control.Monad.Identity
-import Control.Monad.Trans.Maybe
-import UnliftIO
 import System.Environment
-import System.IO (hPrint)
-
-import Streaming.Prelude qualified as S
-import Prettyprinter
 
 type RefLogId = PubKey 'Sign 'HBS2Basic
 
@@ -134,6 +105,7 @@ main = do
         groupKeyEntries
         sigilEntries
         metaDataEntries
+        peerEntries
 
         entry $ bindMatch "help" $ nil_ $ \syn -> do
 
@@ -154,25 +126,6 @@ main = do
         entry $ bindMatch "debug:cli:show" $ nil_ \case
           _ -> display cli
 
-        entry $ bindMatch "hbs2:peer:detect" $ nil_ \case
-          _ -> do
-            so <- detectRPC
-            display so
-
-        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
 
 
         entry $ bindMatch "hbs2:reflog:tx:create-raw" $ \case
@@ -185,7 +138,6 @@ main = do
           _ -> throwIO (BadFormException @C nil)
 
 
-
   case cli of
     [ListVal [SymbolVal "stdin"]] -> do
       what <- getContents

hbs2-cli/hbs2-cli.cabal

@@ -107,7 +107,9 @@ library
       HBS2.CLI.Run.KeyMan
       HBS2.CLI.Run.Keyring
       HBS2.CLI.Run.MetaData
+      HBS2.CLI.Run.Peer
       HBS2.CLI.Run.Sigil
+
       HBS2.CLI.Run.Help
 
     build-depends:    base

hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs

@@ -25,6 +25,13 @@ groupKeyFromKeyList ks = do
 
 groupKeyEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
 groupKeyEntries = do
+
+  entry $ bindMatch "hbs2:groupkey:store" $ \case
+      [LitStrVal s] -> do
+        error "FUCK"
+
+      _ -> throwIO $ BadFormException @C nil
+
   entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do
     case syn of
       [ListVal (StringLikeList keys)] -> do

hbs2-cli/lib/HBS2/CLI/Run/Internal.hs

@@ -3,6 +3,15 @@ module HBS2.CLI.Run.Internal where
 
 import HBS2.CLI.Prelude
 
+import HBS2.OrDie
+import HBS2.Base58
+import HBS2.Storage
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client.StorageClient
+
 import Data.List (isPrefixOf)
 import Data.List qualified as List
 import Data.Kind
@@ -10,6 +19,8 @@ import Data.Maybe
 import Data.HashMap.Strict qualified as HM
 import Data.Text qualified as Text
 import Data.Text.IO qualified as TIO
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
 import Control.Monad.Identity
 import Control.Monad.Writer
 
@@ -31,6 +42,10 @@ instance  {-# OVERLAPPABLE #-} Pretty w => Display w  where
 instance Display (Syntax c) where
   display = \case
     LitStrVal s -> liftIO $ TIO.putStr s
+    ListVal [SymbolVal "blob", LitStrVal txt] -> do
+      let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
+      liftIO $ print $ parens $ "blob:base58" <+> dquotes s
+
     x           -> liftIO $ putStr (show $ pretty x)
 
 instance Display Text where
@@ -375,5 +390,85 @@ internalEntries = do
 
       _ -> throwIO (BadFormException @c nil)
 
+    -- FIXME: we-need-opaque-type
+    entry $ bindMatch "blob:read-stdin" $ \case
+      [] -> do
+        blob <- liftIO BS8.getContents <&> BS8.unpack
+        pure (mkForm "blob" [mkStr @c blob])
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "blob:read-file" $ \case
+      [StringLike fn] -> do
+        blob <- liftIO (BS8.readFile fn) <&> BS8.unpack
+        pure (mkForm "blob" [mkStr @c blob])
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "blob:base58" $ \case
+      [LitStrVal t] -> do
+        bs <- pure (Text.unpack t & BS8.pack & fromBase58)
+               `orDie` "invalid base58"
+              <&> BS8.unpack
+
+        pure (mkForm "blob" [mkStr @c bs])
+
+      _ -> throwIO (BadFormException @c nil)
+
+
+    let decodeB58 t = do
+          pure (Text.unpack t & BS8.pack & fromBase58)
+            `orDie` "invalid base58"
+
+    let decodeAndOut t = do
+          liftIO $ BS8.putStr =<< decodeB58 t
+
+    entry $ bindMatch "base58:encode" $ \case
+      [LitStrVal t] -> do
+        let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack
+        pure (mkForm "blob:base58" [mkStr @c s])
+
+      [ListVal [SymbolVal "blob", LitStrVal t]] -> do
+        let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack
+        pure (mkForm "blob:base58" [mkStr @c s])
+
+      e -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "base58:decode" $ \case
+      [ListVal [SymbolVal "blob:base58", LitStrVal t]] -> do
+        s <- decodeB58 t <&> BS8.unpack
+        pure $ mkForm "blob" [mkStr @c s]
+
+      e -> throwIO (BadFormException @c nil)
+
+
+    entry $ bindMatch "base58:out-decoded" $ nil_ $ \case
+      [ListVal [SymbolVal "blob:base58", LitStrVal t]] ->
+        decodeAndOut t
+
+      [LitStrVal t] -> decodeAndOut t
+
+      e -> throwIO (BadFormException @c nil)
+
+    -- entry $ bindMatch "str:read-file" $ \case
+    --   [StringLike fn] -> liftIO (readFile fn) <&> mkStr
+
+    --   _ -> throwIO (BadFormException @c nil)
+
+    -- entry $ bindMatch "str:save" $ nil_ \case
+    --   [StringLike fn, StringLike what] ->
+    --     liftIO (writeFile fn what)
+
+    --   _ -> throwIO (BadFormException @c nil)
+
+
+
+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/MetaData.hs

@@ -20,6 +20,7 @@ import HBS2.Net.Auth.Schema()
 
 import Codec.Serialise
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
 import Data.ByteString.Lazy qualified as LBS
 import Data.Either
 import Data.Set qualified as Set
@@ -139,8 +140,8 @@ metaDataEntries = do
             -> do
               pure [Encrypted key]
 
-          ListVal (SymbolVal "dict" : [ListVal [SymbolVal x, StringLike y]])  -> do
-            pure [MetaDataEntry x y]
+          ListVal (SymbolVal "dict" : w)  -> do
+            pure [MetaDataEntry x y | ListVal [SymbolVal x, StringLike y] <- w ]
 
           StringLike rest  -> do
             pure [MetaDataFile rest]
@@ -168,7 +169,10 @@ metaDataEntries = do
 
         let meta1  = HM.fromList [  (txt n, txt e) | MetaDataEntry n e <- universeBi opts ]
 
-        error $ show opts
+        let enc = headMay [ x | x@(Encrypted _) <- universeBi opts ]
+
+        when (isJust enc) do
+          error "ENCRYPTION"
 
         href <- createTreeWithMetadata (meta0 <> meta1) lbs
 

hbs2-cli/lib/HBS2/CLI/Run/Peer.hs

@@ -0,0 +1,57 @@
+module HBS2.CLI.Run.Peer where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Data.Types.Refs
+import HBS2.Storage
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Net.Auth.Schema()
+
+import Data.Maybe
+import Control.Monad.Trans.Cont
+import Data.Text qualified as Text
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+
+{- HLINT ignore "Functor law" -}
+
+peerEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m ()
+peerEntries = do
+
+  entry $ bindMatch "hbs2:peer:detect" $ nil_ \case
+    _ -> do
+      so <- detectRPC
+      display so
+
+  -- stores *small* block
+  entry $ bindMatch "hbs2:peer:put-block" $ \case
+    [LitStrVal s] -> do
+      flip runContT pure do
+        sto <- ContT withPeerStorage
+
+        h <- putBlock sto (LBS8.pack (Text.unpack s))
+               `orDie` "can't store block"
+             <&> HashRef
+
+        pure (mkStr @c (show $ pretty h))
+
+    _ -> throwIO $ BadFormException @C nil
+
+  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
+
+