mirror of https://github.com/voidlizard/hbs2
101 lines
3.0 KiB
Haskell
101 lines
3.0 KiB
Haskell
module HBS2.CLI.Run.Tree
|
|
( treeEntries
|
|
) where
|
|
|
|
import HBS2.CLI.Prelude
|
|
import HBS2.CLI.Run.Internal
|
|
import HBS2.CLI.Run.Internal.GroupKey as G
|
|
import HBS2.CLI.Run.Internal.Merkle
|
|
|
|
import HBS2.Defaults
|
|
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Merkle
|
|
import HBS2.System.Dir
|
|
import HBS2.Storage
|
|
import HBS2.Storage.Operations.ByteString
|
|
|
|
import HBS2.Net.Auth.Schema()
|
|
|
|
import HBS2.Peer.RPC.API.Storage
|
|
import HBS2.Peer.RPC.Client
|
|
import HBS2.Peer.RPC.Client.Unix
|
|
|
|
import Data.Text qualified as Text
|
|
import Control.Monad.Except
|
|
import Codec.Serialise
|
|
|
|
pattern GroveHashes :: forall {c}. [HashRef] -> [Syntax c]
|
|
pattern GroveHashes hashes <- ( groveHashes -> hashes )
|
|
|
|
groveHashes :: [Syntax c] -> [HashRef]
|
|
groveHashes = \case
|
|
[ ListVal (HashLikeList hashes) ] -> hashes
|
|
HashLikeList hashes -> hashes
|
|
_ -> mempty
|
|
|
|
treeEntries :: forall c m . ( IsContext c
|
|
, MonadUnliftIO m
|
|
, Exception (BadFormException c)
|
|
, HasStorage m
|
|
, HasClientAPI StorageAPI UNIX m
|
|
) => MakeDictM c m ()
|
|
treeEntries = do
|
|
|
|
brief "reads merkle tree data from storage"
|
|
$ args [arg "string" "tree"]
|
|
$ desc "hbs2:tree:read HASH"
|
|
$ returns "bytestring" "data"
|
|
$ entry $ bindMatch "hbs2:tree:read" $ \case
|
|
[ HashLike h ] -> lift do
|
|
sto <- getStorage
|
|
|
|
co <- runExceptT (getTreeContents sto h)
|
|
>>= orThrowPassIO
|
|
|
|
mkOpaque co
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
brief "reads merkle tree data from storage"
|
|
$ args [arg "list of hashes" "trees"]
|
|
$ desc [qc|hbs2:grove creates a 'grove' - merkle tree of list of hashes of merkle trees
|
|
It's just an easy way to create a such thing, you may browse it by hbs2 cat -H
|
|
|]
|
|
$ returns "hash" "string"
|
|
$ entry $ bindMatch "hbs2:grove" $ \case
|
|
HashLikeList hashes@(x:_) -> lift do
|
|
sto <- getStorage
|
|
let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) hashes
|
|
mkSym . show . pretty <$> liftIO (makeMerkle 0 pt $ \(_,_,bss) -> do
|
|
void $ putBlock sto bss)
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
entry $ bindMatch "hbs2:grove:annotated" $ \case
|
|
(ListVal ann : GroveHashes hashes) -> lift do
|
|
sto <- getStorage
|
|
|
|
let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) hashes
|
|
|
|
tree <- liftIO (makeMerkle 0 pt $ \(_,_,bss) -> do
|
|
void $ putBlock sto bss)
|
|
|
|
block <- getBlock sto tree
|
|
>>= orThrow MissedBlockError
|
|
<&> deserialiseOrFail @(MTree [HashRef])
|
|
>>= orThrow UnsupportedFormat
|
|
|
|
let kwa = Text.unlines $ fmap (Text.pack . show . pretty) ann
|
|
let mann = MTreeAnn (ShortMetadata kwa) NullEncryption block
|
|
|
|
r <- putBlock sto (serialise mann)
|
|
>>= orThrowUser "can't write tree"
|
|
<&> HashRef
|
|
|
|
pure $ mkSym (show $ pretty r)
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|