mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
0f4c45e752
commit
7c042ab332
|
|
@ -7,6 +7,7 @@ module HBS2.CLI.Prelude
|
|||
, module Control.Monad.Reader
|
||||
, module HBS2.System.Logger.Simple.ANSI
|
||||
, module HBS2.Misc.PrettyStuff
|
||||
, qc,qq,q
|
||||
, Generic
|
||||
) where
|
||||
|
||||
|
|
@ -21,4 +22,5 @@ import Data.Config.Suckless
|
|||
import Control.Monad.Reader
|
||||
import UnliftIO
|
||||
|
||||
import Text.InterpolatedString.Perl6 (qc,q,qq)
|
||||
|
||||
|
|
|
|||
|
|
@ -103,6 +103,9 @@ instance Pretty ManDesc where
|
|||
pretty = \case
|
||||
ManDescRaw t -> pretty t
|
||||
|
||||
instance IsString ManDesc where
|
||||
fromString s = ManDescRaw (Text.pack s)
|
||||
|
||||
instance Pretty (Man a) where
|
||||
pretty e = "NAME"
|
||||
<> line
|
||||
|
|
@ -122,8 +125,7 @@ instance Pretty (Man a) where
|
|||
Just (ManReturns t s) ->
|
||||
line <> "RETURN VALUE" <> line
|
||||
<> indent 8 (
|
||||
pretty t <> line
|
||||
<> pretty s) <> line
|
||||
pretty t <> hsep ["","-",""] <> pretty s) <> line
|
||||
|
||||
fmtDescription = line
|
||||
<> "DESCRIPTION" <> line
|
||||
|
|
@ -155,6 +157,9 @@ instance Pretty (Man a) where
|
|||
indent 8 do
|
||||
parens (pretty (manName e) <+>
|
||||
hsep [ pretty n | ManApplyArg t n <- xs ] )
|
||||
<> line
|
||||
<> line
|
||||
<> vcat [ pretty n <+> ":" <+> pretty t | ManApplyArg t n <- xs ]
|
||||
|
||||
pattern StringLike :: forall {c} . String -> Syntax c
|
||||
pattern StringLike e <- (stringLike -> Just e)
|
||||
|
|
@ -398,6 +403,11 @@ makeDict w = execWriter ( fromMakeDict w )
|
|||
entry :: Dict c m -> MakeDictM c m ()
|
||||
entry = tell
|
||||
|
||||
desc :: Doc ann -> MakeDictM c m () -> MakeDictM c m ()
|
||||
desc txt = censor (HM.map setDesc)
|
||||
where
|
||||
w0 = mempty { manDesc = Just (ManDescRaw $ Text.pack $ show txt) }
|
||||
setDesc (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x
|
||||
|
||||
brief :: ManBrief -> MakeDictM c m () -> MakeDictM c m ()
|
||||
brief txt = censor (HM.map setBrief)
|
||||
|
|
@ -680,9 +690,32 @@ internalEntries = do
|
|||
pure $ mkForm "dict" [ mkList [a, b] ]
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "kw" $ \syn -> do
|
||||
let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ]
|
||||
pure $ mkForm "dict" wat
|
||||
brief "creates a dict from a linear list of string-like items"
|
||||
$ args [arg "list-of-terms" "..."]
|
||||
$ desc ( "macro; syntax sugar" <> line
|
||||
<> "useful for creating function args" <> line
|
||||
<> "leftover records are skipped"
|
||||
)
|
||||
$ returns "dict" ""
|
||||
$ examples [qc|
|
||||
[kw a 1 b 2 c 3]
|
||||
(dict (a 1) (b 2) (c 3))
|
||||
|
||||
[kw a]
|
||||
(dict (a ()))
|
||||
|
||||
[kw a b]
|
||||
(dict (a b))
|
||||
|
||||
[kw 1 2 3]
|
||||
(dict)
|
||||
|
||||
[kw a b c]
|
||||
(dict (a b) (c ()))
|
||||
|]
|
||||
$ entry $ bindMatch "kw" $ \syn -> 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
|
||||
|
|
|
|||
|
|
@ -26,84 +26,109 @@ 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
|
||||
brief "creates a new lwwref"
|
||||
$ desc "Creates a new keyring; adds it to keyman and subsribes hbs2-peer to listen this lwwref"
|
||||
$ returns "string" "lwwref public key"
|
||||
$ 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))
|
||||
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)
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "hbs2: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
|
||||
brief "lists all lwwref that hbs2-peer is subscribed to"
|
||||
$ noArgs
|
||||
$ returns "list of string" "lwwref list"
|
||||
$ entry $ bindMatch "hbs2: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)
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
|
||||
entry $ bindMatch "hbs2:lwwref:fetch" $ \case
|
||||
[StringLike puk] -> do
|
||||
flip runContT pure do
|
||||
lww <- orThrowUser "bad lwwref key" (fromStringMay puk)
|
||||
so <- detectRPC `orDie` "rpc not found"
|
||||
api <- ContT $ withRPC2 @LWWRefAPI @UNIX so
|
||||
void $ callService @RpcLWWRefFetch api lww
|
||||
pure $ mkStr "okay"
|
||||
brief "fetches lwwref value"
|
||||
$ desc "makes peer to request lwwref from neighbors"
|
||||
$ args [arg "string" "lwwref"]
|
||||
$ returns "atom" "okay"
|
||||
$ entry $ bindMatch "hbs2:lwwref:fetch" $ \case
|
||||
[StringLike puk] -> do
|
||||
flip runContT pure do
|
||||
lww <- orThrowUser "bad lwwref 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)
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
|
||||
entry $ bindMatch "hbs2:lwwref:get" $ \case
|
||||
[StringLike puk] -> do
|
||||
brief "get lwwref value"
|
||||
$ args [arg "string" "lwwref"]
|
||||
$ returns "string" "hashref"
|
||||
$ examples [qc|
|
||||
|
||||
flip runContT pure do
|
||||
ref <- orThrowUser "bad lwwref key" (fromStringMay puk)
|
||||
so <- detectRPC `orDie` "rpc not found"
|
||||
api <- ContT $ withRPC2 @LWWRefAPI @UNIX so
|
||||
what <- callService @RpcLWWRefGet api ref
|
||||
>>= orThrowUser "can't get lwwref value"
|
||||
pure $ mkStr (show $ pretty what)
|
||||
(hbs2:lwwref:get BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP)
|
||||
(lwwref
|
||||
(seq 4)
|
||||
(value "74vDGwBYebH3oM6xPXC7kqpgu6deqi7E549QpvHvvQKf")
|
||||
)
|
||||
|]
|
||||
$ entry $ bindMatch "hbs2:lwwref:get" $ \case
|
||||
[StringLike puk] -> do
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
flip runContT pure do
|
||||
ref <- orThrowUser "bad lwwref key" (fromStringMay puk)
|
||||
so <- detectRPC `orDie` "rpc not found"
|
||||
api <- ContT $ withRPC2 @LWWRefAPI @UNIX so
|
||||
what <- callService @RpcLWWRefGet api ref
|
||||
>>= orThrowUser "can't get lwwref value"
|
||||
pure $ mkStr (show $ pretty what)
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
|
||||
entry $ bindMatch "hbs2:lwwref:update" $ \case
|
||||
[StringLike puks, HashLike new] -> do
|
||||
brief "updates lwwref"
|
||||
$ desc "updates lwwref value and increments it's counter"
|
||||
$ args [arg "string" "lwwref", arg "string" "hash"]
|
||||
$ returns "nil" ""
|
||||
$ entry $ bindMatch "hbs2:lwwref:update" $ \case
|
||||
[StringLike puks, HashLike new] -> do
|
||||
|
||||
flip runContT pure do
|
||||
puk <- orThrowUser "bad lwwref key" (fromStringMay puks)
|
||||
so <- detectRPC `orDie` "rpc not found"
|
||||
api <- ContT $ withRPC2 @LWWRefAPI @UNIX so
|
||||
flip runContT pure do
|
||||
puk <- orThrowUser "bad lwwref key" (fromStringMay puks)
|
||||
so <- detectRPC `orDie` "rpc not found"
|
||||
api <- ContT $ withRPC2 @LWWRefAPI @UNIX so
|
||||
|
||||
(sk,pk) <- liftIO $ runKeymanClient do
|
||||
creds <- loadCredentials puk
|
||||
>>= orThrowUser "can't load credentials"
|
||||
pure ( view peerSignSk creds, view peerSignPk creds )
|
||||
(sk,pk) <- liftIO $ runKeymanClient do
|
||||
creds <- loadCredentials puk
|
||||
>>= orThrowUser "can't load credentials"
|
||||
pure ( view peerSignSk creds, view peerSignPk creds )
|
||||
|
||||
what <- callService @RpcLWWRefGet api puk
|
||||
>>= orThrowUser "can't get lwwref value"
|
||||
what <- callService @RpcLWWRefGet api puk
|
||||
>>= orThrowUser "can't get lwwref value"
|
||||
|
||||
sno' <- case what of
|
||||
Nothing -> pure 0
|
||||
Just lwwv -> pure (lwwSeq lwwv)
|
||||
sno' <- case what of
|
||||
Nothing -> pure 0
|
||||
Just lwwv -> pure (lwwSeq lwwv)
|
||||
|
||||
let sno = succ sno'
|
||||
let sno = succ sno'
|
||||
|
||||
let box = makeSignedBox pk sk (LWWRef sno new Nothing)
|
||||
let box = makeSignedBox pk sk (LWWRef sno new Nothing)
|
||||
|
||||
callService @RpcLWWRefUpdate api box
|
||||
>>= orThrowUser "lww ref update error"
|
||||
callService @RpcLWWRefUpdate api box
|
||||
>>= orThrowUser "lww ref update error"
|
||||
|
||||
pure nil
|
||||
pure nil
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue