voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-07-29 10:57:56 +03:00
parent 88d3788c99
commit 7f13629498
5 changed files with 174 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
hbs2-cli/app/Main.hs
View File

@ -11,6 +11,7 @@ import HBS2.CLI.Run.Sigil
import HBS2.CLI.Run.MetaData
import HBS2.CLI.Run.Peer
import HBS2.CLI.Run.RefLog
import HBS2.CLI.Run.LWWRef
import HBS2.Peer.RPC.Client.Unix
@ -78,6 +79,7 @@ main = do
metaDataEntries
peerEntries
reflogEntries
lwwRefEntries
entry $ bindMatch "help" $ nil_ $ \syn -> do
@ -103,11 +105,11 @@ main = do
[ListVal [SymbolVal "stdin"]] -> do
what <- getContents
>>= either (error.show) pure . parseTop
void $ run dict what
run dict what >>= eatNil display
[] -> do
void $ run dict [mkForm "help" []]
_ -> do
void $ run dict cli
run dict cli >>= eatNil display

1
hbs2-cli/hbs2-cli.cabal
View File

@ -112,6 +112,7 @@ library
HBS2.CLI.Run.MetaData
HBS2.CLI.Run.Peer
HBS2.CLI.Run.RefLog
HBS2.CLI.Run.LWWRef
HBS2.CLI.Run.Sigil
HBS2.CLI.Run.Help

19
hbs2-cli/lib/HBS2/CLI/Run/Internal.hs
View File

@ -38,6 +38,8 @@ pattern StringLikeList e <- (stringLikeList -> e)
pattern BlobLike :: forall {c} . ByteString -> Syntax c
pattern BlobLike s <- (blobLike -> Just s)
pattern Nil :: forall {c} . Syntax c
pattern Nil <- ListVal []
class Display a where
display :: MonadIO m => a -> m ()
@ -104,6 +106,11 @@ isFalse = \case
ListVal [] -> True
_ -> False
eatNil :: Monad m => (Syntax c -> m a) -> Syntax c -> m ()
eatNil f = \case
Nil -> pure ()
x -> void $ f x
class IsContext c => MkInt c s where
mkInt :: s -> Syntax c
@ -462,6 +469,18 @@ internalEntries = do
let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ]
pure $ mkForm "dict" wat
entry $ bindMatch "iterate" $ nil_ $ \syn -> do
case syn of
[ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
mapM_ (apply @c fn . List.singleton) rs
[Lambda decl body, ListVal args] -> do
mapM_ (applyLambda decl body . List.singleton) args
_ -> do
throwIO (BadFormException @C nil)
entry $ bindMatch "map" $ \syn -> do
case syn of
[ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do

109
hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs Normal file
View File

@ -0,0 +1,109 @@
module HBS2.CLI.Run.LWWRef where
import HBS2.CLI.Prelude
import HBS2.CLI.Run.Internal
import HBS2.CLI.Run.Internal.KeyMan
import HBS2.Data.Types.Refs
import HBS2.Storage
import HBS2.Peer.CLI.Detect
import HBS2.Peer.RPC.Client.Unix
import HBS2.Peer.RPC.API.Peer
import HBS2.Peer.RPC.API.RefLog
import HBS2.Peer.RPC.API.LWWRef
import HBS2.Peer.Proto hiding (request)
import HBS2.Base58
import HBS2.Net.Auth.Credentials
import HBS2.Net.Auth.Schema()
import HBS2.KeyMan.Keys.Direct
import HBS2.KeyMan.App.Types
import Codec.Serialise
import Data.Coerce
import Data.Either
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString (ByteString)
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.ByteString.Lazy qualified as LBS
import Data.Text.Encoding qualified as TE
import Data.Text qualified as Text
import Control.Monad.Trans.Cont
lwwRefEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m ()
lwwRefEntries = do
entry $ bindMatch "hbs2:lwwref:create" $ \case
[] -> do
reflog <- keymanNewCredentials (Just "lwwref") 0
flip runContT pure do
so <- detectRPC `orDie` "rpc not found"
api <- ContT $ withRPC2 @PeerAPI @UNIX so
void $ callService @RpcPollAdd api (reflog, "lwwref", 31)
pure $ mkStr (show $ pretty (AsBase58 reflog))
_ -> throwIO (BadFormException @C nil)
-- entry $ bindMatch "hbs2:reflog:tx:annhashref:create" $ \case
-- [StringLike puk, StringLike hash] -> do
-- flip runContT pure do
-- reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
-- sto <- ContT withPeerStorage
-- hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash)
-- void $ hasBlock sto (fromHashRef hashref) `orDie` "no block"
-- let sref = AnnotatedHashRef Nothing hashref
-- rlu <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise
-- pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
-- _ -> throwIO (BadFormException @C nil)
-- entry $ bindMatch "hbs2:reflog:tx:post" $ nil_ \case
-- [BlobLike blob] -> do
-- so <- detectRPC `orDie` "no rpc found"
-- withRPC2 @RefLogAPI so $ \caller -> do
-- wtf <- deserialiseOrFail @(RefLogUpdate L4Proto) (LBS.fromStrict blob)
-- & orThrowUser "invalid tx"
-- void $ callService @RpcRefLogPost caller wtf
-- _ -> throwIO (BadFormException @C nil)
-- entry $ bindMatch "hbs2:reflog:tx:seqref:create" $ \case
-- [StringLike puk, LitIntVal sn, StringLike hash] -> do
-- flip runContT pure do
-- reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
-- sto <- ContT withPeerStorage
-- hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash)
-- void $ hasBlock sto (fromHashRef hashref) `orDie` "no block"
-- let sref = SequentialRef sn (AnnotatedHashRef Nothing hashref)
-- rlu <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise
-- pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
-- _ -> throwIO (BadFormException @C nil)
-- entry $ bindMatch "hbs2:reflog:tx:create-raw" $ \case
-- [SymbolVal "stdin", StringLike rlo] -> do
-- reflog <- orThrowUser "bad reflog" (fromStringMay rlo)
-- rlu <- mkRefLogUpdateFrom reflog ( liftIO BS.getContents )
-- <&> serialise
-- pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
-- [LitStrVal s, StringLike rlo] -> do
-- reflog <- orThrowUser "bad reflog" (fromStringMay rlo)
-- rlu <- mkRefLogUpdateFrom reflog ( pure (BS8.pack (Text.unpack s)) )
-- <&> serialise
-- pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
-- _ -> throwIO (BadFormException @C nil)

43
hbs2-cli/lib/HBS2/CLI/Run/Peer.hs
View File

@ -11,6 +11,7 @@ import HBS2.Peer.CLI.Detect
import HBS2.Peer.RPC.Client.Unix
import HBS2.Peer.RPC.API.Peer
import HBS2.Peer.RPC.API.RefLog
import HBS2.Peer.RPC.API.LWWRef
import HBS2.Net.Auth.Schema()
import Data.List qualified as L
@ -22,7 +23,6 @@ import Lens.Micro.Platform
{- HLINT ignore "Functor law" -}
putTextLit :: forall c m . (IsContext c, MonadUnliftIO m)
=> AnyStorage
-> Text
@ -112,7 +112,6 @@ peerEntries = do
_ -> throwIO (BadFormException @C nil)
entry $ bindMatch "hbs2:peer:reflog:fetch" $ \case
[StringLike puk] -> do
flip runContT pure do
@ -134,3 +133,43 @@ peerEntries = do
pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
_ -> throwIO (BadFormException @C nil)
entry $ bindMatch "hbs2:peer:lwwref:list" $ \case
[] -> do
flip runContT pure do
so <- detectRPC `orDie` "rpc not found"
api <- ContT $ withRPC2 @PeerAPI @UNIX so
r <- callService @RpcPollList2 api (Just "lwwref", Nothing)
>>= orThrowUser "can't get lwwref list"
pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
_ -> throwIO (BadFormException @C nil)
entry $ bindMatch "hbs2:peer:lwwref:fetch" $ \case
[StringLike puk] -> do
flip runContT pure do
lww <- orThrowUser "bad reflog key" (fromStringMay puk)
so <- detectRPC `orDie` "rpc not found"
api <- ContT $ withRPC2 @LWWRefAPI @UNIX so
void $ callService @RpcLWWRefFetch api lww
pure $ mkStr "okay"
_ -> throwIO (BadFormException @C nil)
entry $ bindMatch "hbs2:peer:lwwref:get" $ \case
[StringLike puk] -> do
flip runContT pure do
ref <- orThrowUser "bad reflog key" (fromStringMay puk)
so <- detectRPC `orDie` "rpc not found"
api <- ContT $ withRPC2 @LWWRefAPI @UNIX so
what <- callService @RpcLWWRefGet api ref
>>= orThrowUser "can't get reflog"
pure $ mkStr (show $ pretty what)
_ -> throwIO (BadFormException @C nil)