wip

hbs2-cli/app/Main.hs

@@ -100,40 +100,6 @@ mkRefLogUpdateFrom mbs  reflog = do
   pure $ mkForm "cbor:base58" [ mkStr s ]
 
 
-metaFromSyntax :: [Syntax c] -> HashMap Text Text
-metaFromSyntax syn =
-  HM.fromList [ (t k, t v) | (ListVal [ k, v ]) <- syn ]
-  where
-    t x = Text.pack (show $ pretty x)
-
-createTreeWithMetadata :: (MonadUnliftIO m)
-                       => HashMap Text Text
-                       -> LBS.ByteString
-                       -> m HashRef
-createTreeWithMetadata meta lbs = do
-    debug   "create fucking metadata"
-    -- TODO: set-hbs2-peer
-    so <- detectRPC `orDie` "hbs2-peer not found"
-
-    let mt = vcat [ pretty k <> ":" <+> pretty v | (k,v) <- HM.toList meta ]
-               & show & Text.pack
-
-    withRPC2 @StorageAPI  @UNIX so $ \caller -> do
-      let sto = AnyStorage (StorageClient caller)
-
-      t0 <- writeAsMerkle sto lbs
-              >>= getBlock sto
-              >>= orThrowUser "can't read merkle tree just written"
-              <&> deserialiseOrFail @(MTree [HashRef])
-              >>= orThrowUser "merkle tree corrupted/invalid"
-
-      -- FIXME: support-encryption
-      let mann = MTreeAnn (ShortMetadata mt) NullEncryption t0
-
-      putBlock sto (serialise mann)
-        >>= orThrowUser "can't write tree"
-        <&> HashRef
-
 
 helpList :: MonadUnliftIO m => Maybe String -> RunM c m ()
 helpList p = do
@@ -148,7 +114,6 @@ helpList p = do
   display_ $ vcat (fmap pretty ks)
 
 
-
 main :: IO ()
 main = do
 
@@ -238,92 +203,6 @@ main = do
 
           _ -> throwIO (BadFormException @C nil)
 
-        entry $ bindMatch "str:read-stdin" $ \case
-          [] -> liftIO getContents <&> mkStr @C
-
-          _ -> throwIO (BadFormException @C nil)
-
-        entry $ bindMatch "str:read-file" $ \case
-          [StringLike fn] -> liftIO (readFile fn) <&> mkStr @C
-
-          _ -> throwIO (BadFormException @C nil)
-
-        entry $ bindMatch "str:save" $ nil_ \case
-          [StringLike fn, StringLike what] ->
-            liftIO (writeFile fn what)
-
-          _ -> throwIO (BadFormException @C nil)
-
-
-        entry $ bindMatch "hbs2:tree:metadata:get" $ \case
-          [ SymbolVal how, StringLike hash ] -> do
-
-            -- FIXME: put-to-the-state
-            so <- detectRPC `orDie` "hbs2-peer not found"
-
-            r <- withRPC2 @StorageAPI  @UNIX so $ \caller -> do
-              let sto = AnyStorage (StorageClient caller)
-
-              runMaybeT do
-
-                headBlock <- getBlock sto (fromString hash)
-                               >>= toMPlus
-                               <&> deserialiseOrFail @(MTreeAnn [HashRef])
-                               >>= toMPlus
-
-                case headBlock of
-                  MTreeAnn { _mtaMeta = ShortMetadata s } -> do
-                    pure $ mkStr @C s
-
-                  MTreeAnn { _mtaMeta = AnnHashRef h } -> do
-                    getBlock sto h
-                       >>= toMPlus
-                       <&> LBS.toStrict
-                       <&> TE.decodeUtf8
-                       <&> mkStr @C
-
-                  _ -> mzero
-
-
-            case (how, r) of
-              ("parsed", Just (LitStrVal r0)) -> do
-
-
-                let xs = parseTop r0
-                           & fromRight mempty
-
-                pure $ mkForm @C "dict" xs
-
-              _ -> pure $ fromMaybe nil r
-
-          _ -> throwIO (BadFormException @C nil)
-
-        entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do
-
-          case syn of
-
-            (LitStrVal s : meta) -> do
-              let lbs = fromString (Text.unpack s) :: LBS.ByteString
-              h <- createTreeWithMetadata (metaFromSyntax meta) lbs
-              pure $ mkStr (show $ pretty h)
-
-            (ListVal [SymbolVal "from-file", StringLike fn ] : meta) -> do
-              lbs <- liftIO $ LBS.readFile fn
-              h <- createTreeWithMetadata (metaFromSyntax meta) lbs
-              pure $ mkStr (show $ pretty h)
-
-            (ListVal [SymbolVal "from-stdin"] : meta) -> do
-              lbs <- liftIO $ LBS.getContents
-              h <- createTreeWithMetadata (metaFromSyntax meta) lbs
-              pure $ mkStr (show $ pretty h)
-
-            _ -> throwIO (BadFormException @C nil)
-
-        entry $ bindMatch "cbor:base58" $ \case
-          [ LitStrVal x ] -> do
-            pure $ mkForm "cbor:base58" [mkStr x]
-
-          _ -> throwIO (BadFormException @C nil)
 
 
   case cli of

hbs2-cli/hbs2-cli.cabal

@@ -104,6 +104,7 @@ library
       HBS2.CLI.Run
       HBS2.CLI.Run.Internal
       HBS2.CLI.Run.KeyMan
+      HBS2.CLI.Run.MetaData
       HBS2.CLI.Run.Help
 
     build-depends:    base

hbs2-cli/lib/HBS2/CLI/Prelude.hs

@@ -1,5 +1,6 @@
 module HBS2.CLI.Prelude
   ( module HBS2.Prelude.Plated
+  , module HBS2.OrDie
   , module UnliftIO
   , module Data.Config.Suckless
   , module Data.HashMap.Strict
@@ -8,6 +9,7 @@ module HBS2.CLI.Prelude
   ) where
 
 import HBS2.Prelude.Plated
+import HBS2.OrDie
 
 import Data.HashMap.Strict
 import Data.Config.Suckless

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

@@ -329,5 +329,21 @@ internalEntries = do
       [ sy ] -> display sy >> liftIO (putStrLn "")
       ss     -> mapM_ display ss >> liftIO (putStrLn "")
 
+    entry $ bindMatch "str:read-stdin" $ \case
+      [] -> liftIO getContents <&> mkStr @C
+
+      _ -> throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "str:read-file" $ \case
+      [StringLike fn] -> liftIO (readFile fn) <&> mkStr @C
+
+      _ -> throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "str:save" $ nil_ \case
+      [StringLike fn, StringLike what] ->
+        liftIO (writeFile fn what)
+
+      _ -> throwIO (BadFormException @C nil)
+
 
 

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

@@ -0,0 +1,138 @@
+module HBS2.CLI.Run.MetaData where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Data.Types.Refs
+import HBS2.Merkle
+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.Storage
+import HBS2.Peer.RPC.Client.StorageClient
+
+import HBS2.Net.Auth.Schema()
+
+import Codec.Serialise
+import Control.Monad.Trans.Maybe
+import Data.ByteString.Lazy qualified as LBS
+import Data.Either
+import Data.HashMap.Strict qualified as HM
+import Data.Maybe
+import Data.Text.Encoding qualified as TE
+import Data.Text qualified as Text
+
+metaFromSyntax :: [Syntax c] -> HashMap Text Text
+metaFromSyntax syn =
+  HM.fromList [ (t k, t v) | (ListVal [ k, v ]) <- syn ]
+  where
+    t x = Text.pack (show $ pretty x)
+
+createTreeWithMetadata :: (MonadUnliftIO m)
+                       => HashMap Text Text
+                       -> LBS.ByteString
+                       -> m HashRef
+createTreeWithMetadata meta lbs = do
+    debug   "create fucking metadata"
+    -- TODO: set-hbs2-peer
+    so <- detectRPC `orDie` "hbs2-peer not found"
+
+    let mt = vcat [ pretty k <> ":" <+> pretty v | (k,v) <- HM.toList meta ]
+               & show & Text.pack
+
+    withRPC2 @StorageAPI  @UNIX so $ \caller -> do
+      let sto = AnyStorage (StorageClient caller)
+
+      t0 <- writeAsMerkle sto lbs
+              >>= getBlock sto
+              >>= orThrowUser "can't read merkle tree just written"
+              <&> deserialiseOrFail @(MTree [HashRef])
+              >>= orThrowUser "merkle tree corrupted/invalid"
+
+      -- FIXME: support-encryption
+      let mann = MTreeAnn (ShortMetadata mt) NullEncryption t0
+
+      putBlock sto (serialise mann)
+        >>= orThrowUser "can't write tree"
+        <&> HashRef
+
+
+
+
+metaDataEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m ()
+metaDataEntries = do
+
+  entry $ bindMatch "hbs2:tree:metadata:get" $ \case
+    [ SymbolVal how, StringLike hash ] -> do
+
+      -- FIXME: put-to-the-state
+      so <- detectRPC `orDie` "hbs2-peer not found"
+
+      r <- withRPC2 @StorageAPI  @UNIX so $ \caller -> do
+        let sto = AnyStorage (StorageClient caller)
+
+        runMaybeT do
+
+          headBlock <- getBlock sto (fromString hash)
+                         >>= toMPlus
+                         <&> deserialiseOrFail @(MTreeAnn [HashRef])
+                         >>= toMPlus
+
+          case headBlock of
+            MTreeAnn { _mtaMeta = ShortMetadata s } -> do
+              pure $ mkStr s
+
+            MTreeAnn { _mtaMeta = AnnHashRef h } -> do
+              getBlock sto h
+                 >>= toMPlus
+                 <&> LBS.toStrict
+                 <&> TE.decodeUtf8
+                 <&> mkStr
+
+            _ -> mzero
+
+
+      case (how, r) of
+        ("parsed", Just (LitStrVal r0)) -> do
+
+
+          let xs = parseTop r0
+                     & fromRight mempty
+
+          pure $ mkForm  "dict" xs
+
+        _ -> pure $ fromMaybe nil r
+
+    _ -> throwIO (BadFormException @c nil)
+
+  entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do
+
+    case syn of
+
+      (LitStrVal s : meta) -> do
+        let lbs = fromString (Text.unpack s) :: LBS.ByteString
+        h <- createTreeWithMetadata (metaFromSyntax meta) lbs
+        pure $ mkStr (show $ pretty h)
+
+      (ListVal [SymbolVal "from-file", StringLike fn ] : meta) -> do
+        lbs <- liftIO $ LBS.readFile fn
+        h <- createTreeWithMetadata (metaFromSyntax meta) lbs
+        pure $ mkStr (show $ pretty h)
+
+      (ListVal [SymbolVal "from-stdin"] : meta) -> do
+        lbs <- liftIO $ LBS.getContents
+        h <- createTreeWithMetadata (metaFromSyntax meta) lbs
+        pure $ mkStr (show $ pretty h)
+
+      _ -> throwIO (BadFormException @c nil)
+
+  entry $ bindMatch "cbor:base58" $ \case
+    [ LitStrVal x ] -> do
+      pure $ mkForm "cbor:base58" [mkStr x]
+
+    _ -> throwIO (BadFormException @c nil)
+
+