wip

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

@@ -86,6 +86,11 @@ mkForm s sy = List noContext ( mkSym s :  sy )
 mkList :: forall c. IsContext c => [Syntax c] -> Syntax c
 mkList = List noContext
 
+class IsContext c => MkInt c s where
+  mkInt :: s -> Syntax c
+
+instance (Integral i, IsContext c) => MkInt c i where
+  mkInt n = Literal noContext $ LitInt (fromIntegral n)
 
 class OptionalVal c b where
   optional :: b -> Syntax c -> b
@@ -371,16 +376,20 @@ internalEntries = do
       _  -> throwIO (BadFormException @c nil)
 
     entry $ bindMatch "print" $ nil_ $ \case
-      [ sy ] -> display sy >> liftIO (putStrLn "")
-      ss     -> mapM_ display ss >> liftIO (putStrLn "")
+      [ sy ] -> display sy
+      ss     -> mapM_ display ss
 
     entry $ bindMatch "str:read-stdin" $ \case
       [] -> liftIO getContents <&> mkStr @c
 
       _ -> throwIO (BadFormException @c nil)
 
+    entry $ bindMatch "str:put" $ nil_ $ \case
+      [LitStrVal s] -> liftIO $ TIO.putStr s
+      _ -> throwIO (BadFormException @c nil)
+
     entry $ bindMatch "str:read-file" $ \case
-      [StringLike fn] -> liftIO (readFile fn) <&> mkStr
+      [StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr
 
       _ -> throwIO (BadFormException @c nil)
 
@@ -405,6 +414,21 @@ internalEntries = do
 
       _ -> throwIO (BadFormException @c nil)
 
+    entry $ bindMatch "blob:save" $ nil_ $ \case
+      [StringLike fn, ListVal [SymbolVal "blob", LitStrVal t]] -> do
+        let s = Text.unpack t & BS8.pack
+        liftIO $ BS8.writeFile fn s
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "blob:put" $ nil_ $ \case
+      [ListVal [SymbolVal "blob", LitStrVal t]] -> do
+        let s = Text.unpack t & BS8.pack
+        liftIO $ BS8.putStr s
+
+      _ -> throwIO (BadFormException @c nil)
+
+
     entry $ bindMatch "blob:base58" $ \case
       [LitStrVal t] -> do
         bs <- pure (Text.unpack t & BS8.pack & fromBase58)
@@ -441,8 +465,7 @@ internalEntries = do
 
       e -> throwIO (BadFormException @c nil)
 
-
-    entry $ bindMatch "base58:out-decoded" $ nil_ $ \case
+    entry $ bindMatch "base58:put" $ nil_ $ \case
       [ListVal [SymbolVal "blob:base58", LitStrVal t]] ->
         decodeAndOut t
 
@@ -450,18 +473,6 @@ internalEntries = do
 
       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

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

@@ -3,6 +3,7 @@ module HBS2.CLI.Run.Peer where
 import HBS2.CLI.Prelude
 import HBS2.CLI.Run.Internal
 
+import HBS2.Hash
 import HBS2.Data.Types.Refs
 import HBS2.Storage
 import HBS2.Peer.CLI.Detect
@@ -10,6 +11,7 @@ import HBS2.Peer.RPC.Client.Unix
 import HBS2.Peer.RPC.API.Peer
 import HBS2.Net.Auth.Schema()
 
+import Data.List qualified as L
 import Data.Maybe
 import Control.Monad.Trans.Cont
 import Data.Text qualified as Text
@@ -17,6 +19,19 @@ import Data.ByteString.Lazy.Char8 qualified as LBS8
 
 {- HLINT ignore "Functor law" -}
 
+
+putTextLit :: forall c m . (IsContext c, MonadUnliftIO m)
+           => AnyStorage
+           -> Text
+           -> RunM c m (Syntax c)
+
+putTextLit sto s = do
+    h <- putBlock sto (LBS8.pack (Text.unpack s))
+           `orDie` "can't store block"
+         <&> HashRef
+
+    pure (mkStr @c (show $ pretty h))
+
 peerEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m ()
 peerEntries = do
 
@@ -25,17 +40,44 @@ peerEntries = do
       so <- detectRPC
       display so
 
+  entry $ bindMatch "hbs2:peer:get-block" $ \case
+    [StringLike s] -> do
+      flip runContT pure do
+
+        sto <- ContT withPeerStorage
+        ha <- pure (fromStringMay @HashRef s)
+               `orDie` "invalid hash"
+
+        lbs <- getBlock sto (fromHashRef ha)
+                `orDie` show ("missed-block" <+> pretty ha)
+
+        pure $ mkForm "blob" [mkStr (LBS8.unpack lbs)]
+
+  entry $ bindMatch "hbs2:peer:has-block" $ \case
+    [StringLike s] -> do
+      flip runContT pure do
+
+        sto <- ContT withPeerStorage
+        ha <- pure (fromStringMay @HashRef s)
+               `orDie` "invalid hash"
+
+        mbsz <- hasBlock sto (fromHashRef ha)
+
+        pure $ maybe (mkSym "no-block") mkInt mbsz
+
+    _ -> 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
+        lift $ putTextLit sto s
+
     [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))
+        lift $ putTextLit sto s
 
     _ -> throwIO $ BadFormException @C nil