mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
92bb0ba911
commit
b4772f83ad
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue