diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index 4c0f03b3..cb8f9938 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/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 diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs index 7312d1dc..5b536f25 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs +++ b/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