mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
c50b16610f
commit
0f4c45e752
|
|
@ -4,6 +4,7 @@ module Main where
|
|||
|
||||
import HBS2.CLI.Prelude
|
||||
import HBS2.CLI.Run
|
||||
import HBS2.CLI.Run.Help
|
||||
import HBS2.CLI.Run.KeyMan
|
||||
import HBS2.CLI.Run.Keyring
|
||||
import HBS2.CLI.Run.GroupKey
|
||||
|
|
@ -25,6 +26,8 @@ import System.Environment
|
|||
|
||||
type RefLogId = PubKey 'Sign 'HBS2Basic
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
|
||||
setupLogger :: MonadIO m => m ()
|
||||
setupLogger = do
|
||||
|
|
@ -46,22 +49,6 @@ silence = do
|
|||
setLoggingOff @NOTICE
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
helpList :: MonadUnliftIO m => Maybe String -> RunM c m ()
|
||||
helpList p = do
|
||||
|
||||
let match = maybe (const True) (Text.isPrefixOf . Text.pack) p
|
||||
|
||||
d <- ask >>= readTVarIO <&> fromDict
|
||||
let ks = [k | Id k <- List.sort (HM.keys d)
|
||||
, match k
|
||||
]
|
||||
|
||||
display_ $ vcat (fmap pretty ks)
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
|
|
@ -82,22 +69,7 @@ main = do
|
|||
reflogEntries
|
||||
refchanEntries
|
||||
lwwRefEntries
|
||||
|
||||
entry $ bindMatch "help" $ nil_ $ \syn -> do
|
||||
|
||||
display_ $ "hbs2-cli tool" <> line
|
||||
|
||||
case syn of
|
||||
(StringLike p : _) -> do
|
||||
helpList (Just p)
|
||||
|
||||
[ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )] -> do
|
||||
liftIO $ hPutDoc stdout $
|
||||
"function" <+> ul (pretty what)
|
||||
<> line
|
||||
|
||||
_ -> helpList Nothing
|
||||
|
||||
helpEntries
|
||||
|
||||
entry $ bindMatch "debug:cli:show" $ nil_ \case
|
||||
_ -> display cli
|
||||
|
|
|
|||
|
|
@ -1 +1,43 @@
|
|||
module HBS2.CLI.Run.Help where
|
||||
|
||||
import HBS2.CLI.Prelude
|
||||
import HBS2.CLI.Run.Internal
|
||||
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.List qualified as List
|
||||
import Data.Text qualified as Text
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
helpList :: MonadUnliftIO m => Maybe String -> RunM c m ()
|
||||
helpList p = do
|
||||
|
||||
let match = maybe (const True) (Text.isPrefixOf . Text.pack) p
|
||||
|
||||
d <- ask >>= readTVarIO
|
||||
let ks = [k | Id k <- List.sort (HM.keys d)
|
||||
, match k
|
||||
]
|
||||
|
||||
display_ $ vcat (fmap pretty ks)
|
||||
|
||||
helpEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
|
||||
helpEntries = do
|
||||
|
||||
entry $ bindMatch "help" $ nil_ $ \syn -> do
|
||||
|
||||
display_ $ "hbs2-cli tool" <> line
|
||||
|
||||
case syn of
|
||||
(StringLike p : _) -> do
|
||||
helpList (Just p)
|
||||
|
||||
[ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )] -> do
|
||||
man <- ask >>= readTVarIO
|
||||
<&> HM.lookup what
|
||||
<&> maybe mzero bindMan
|
||||
|
||||
liftIO $ hPutDoc stdout (pretty man)
|
||||
|
||||
_ -> helpList Nothing
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.CLI.Run.Internal where
|
||||
|
||||
import HBS2.CLI.Prelude
|
||||
|
|
@ -13,11 +14,13 @@ import HBS2.Peer.RPC.API.Peer
|
|||
import HBS2.Peer.RPC.API.Storage
|
||||
import HBS2.Peer.RPC.Client.StorageClient
|
||||
|
||||
import Control.Applicative
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.List qualified as List
|
||||
import Data.Kind
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
import Data.Coerce
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.IO qualified as TIO
|
||||
|
|
@ -27,16 +30,138 @@ import Data.ByteString (ByteString)
|
|||
import Control.Monad.Identity
|
||||
import Control.Monad.Writer
|
||||
import System.Environment
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
|
||||
import Prettyprinter.Render.Terminal
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
|
||||
data ManApplyArg = ManApplyArg Text Text
|
||||
deriving stock (Eq,Show,Data,Generic)
|
||||
|
||||
newtype ManApply = ManApply [ ManApplyArg ]
|
||||
deriving stock (Eq,Show,Data,Generic)
|
||||
deriving newtype (Semigroup,Monoid)
|
||||
|
||||
data ManSynopsis =
|
||||
ManSynopsis ManApply
|
||||
deriving stock (Eq,Show,Data,Generic)
|
||||
|
||||
data ManDesc = ManDescRaw Text
|
||||
deriving stock (Eq,Show,Data,Generic)
|
||||
|
||||
data ManRetVal = ManRetVal
|
||||
deriving stock (Eq,Show,Data,Generic)
|
||||
|
||||
newtype ManName a = ManName Id
|
||||
deriving stock (Eq,Show,Data,Generic)
|
||||
deriving newtype (IsString,Pretty)
|
||||
|
||||
newtype ManBrief = ManBrief Text
|
||||
deriving stock (Eq,Show,Data,Generic)
|
||||
deriving newtype (Pretty,IsString)
|
||||
|
||||
data ManReturns = ManReturns Text Text
|
||||
deriving stock (Eq,Show,Data,Generic)
|
||||
|
||||
newtype ManExamples =
|
||||
ManExamples Text
|
||||
deriving stock (Eq,Show,Data,Generic)
|
||||
deriving newtype (Pretty,IsString,Monoid,Semigroup)
|
||||
|
||||
class ManNameOf a ann where
|
||||
manNameOf :: a -> ManName ann
|
||||
|
||||
data Man a =
|
||||
Man
|
||||
{ manName :: Maybe (ManName a)
|
||||
, manBrief :: Maybe ManBrief
|
||||
, manSynopsis :: [ManSynopsis]
|
||||
, manDesc :: Maybe ManDesc
|
||||
, manReturns :: Maybe ManReturns
|
||||
, manExamples :: [ManExamples]
|
||||
}
|
||||
deriving stock (Eq,Show,Generic)
|
||||
|
||||
instance Monoid (Man a) where
|
||||
mempty = Man Nothing Nothing mempty Nothing Nothing mempty
|
||||
|
||||
instance Semigroup (Man a) where
|
||||
(<>) a b = Man (manName b <|> manName a)
|
||||
(manBrief b <|> manBrief a)
|
||||
(manSynopsis a <> manSynopsis b)
|
||||
(manDesc b <|> manDesc a)
|
||||
(manReturns b <|> manReturns a)
|
||||
(manExamples a <> manExamples b)
|
||||
|
||||
instance ManNameOf Id a where
|
||||
manNameOf = ManName
|
||||
|
||||
|
||||
instance Pretty ManDesc where
|
||||
pretty = \case
|
||||
ManDescRaw t -> pretty t
|
||||
|
||||
instance Pretty (Man a) where
|
||||
pretty e = "NAME"
|
||||
<> line
|
||||
<> indent 8 (pretty (manName e) <> fmtBrief e)
|
||||
<> line
|
||||
<> fmtSynopsis
|
||||
<> fmtDescription
|
||||
<> retval
|
||||
<> fmtExamples
|
||||
where
|
||||
fmtBrief a = case manBrief a of
|
||||
Nothing -> mempty
|
||||
Just x -> " - " <> pretty x
|
||||
|
||||
retval = case manReturns e of
|
||||
Nothing -> mempty
|
||||
Just (ManReturns t s) ->
|
||||
line <> "RETURN VALUE" <> line
|
||||
<> indent 8 (
|
||||
pretty t <> line
|
||||
<> pretty s) <> line
|
||||
|
||||
fmtDescription = line
|
||||
<> "DESCRIPTION" <> line
|
||||
<> indent 8 ( case manDesc e of
|
||||
Nothing -> pretty (manBrief e)
|
||||
Just x -> pretty x)
|
||||
<> line
|
||||
|
||||
fmtSynopsis = case manSynopsis e of
|
||||
[] -> mempty
|
||||
_ ->
|
||||
line
|
||||
<> "SYNOPSIS"
|
||||
<> line
|
||||
<> vcat (fmap synEntry (manSynopsis e))
|
||||
<> line
|
||||
|
||||
fmtExamples = case manExamples e of
|
||||
[] -> mempty
|
||||
es -> line
|
||||
<> "EXAMPLES"
|
||||
<> line
|
||||
<> indent 8 ( vcat (fmap pretty es) )
|
||||
|
||||
synEntry (ManSynopsis (ManApply [])) =
|
||||
indent 8 ( parens (pretty (manName e)) ) <> line
|
||||
|
||||
synEntry (ManSynopsis (ManApply xs)) = do
|
||||
indent 8 do
|
||||
parens (pretty (manName e) <+>
|
||||
hsep [ pretty n | ManApplyArg t n <- xs ] )
|
||||
|
||||
pattern StringLike :: forall {c} . String -> Syntax c
|
||||
pattern StringLike e <- (stringLike -> Just e)
|
||||
|
||||
pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
|
||||
pattern StringLikeList e <- (stringLikeList -> e)
|
||||
|
||||
|
||||
pattern BlobLike :: forall {c} . ByteString -> Syntax c
|
||||
pattern BlobLike s <- (blobLike -> Just s)
|
||||
|
||||
|
|
@ -206,9 +331,8 @@ data BindAction c ( m :: Type -> Type) =
|
|||
| BindValue (Syntax c)
|
||||
|
||||
data Bind c ( m :: Type -> Type) = Bind
|
||||
{ bindAction :: BindAction c m
|
||||
, bindName :: Id
|
||||
, bindDescShort :: Text
|
||||
{ bindMan :: Maybe (Man AnsiStyle)
|
||||
, bindAction :: BindAction c m
|
||||
} deriving (Generic)
|
||||
|
||||
deriving newtype instance Hashable Id
|
||||
|
|
@ -248,8 +372,7 @@ instance Exception (BadFormException C)
|
|||
|
||||
instance Exception BadValueException
|
||||
|
||||
newtype Dict c m = Dict { fromDict :: HashMap Id (Bind c m) }
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
type Dict c m = HashMap Id (Bind c m)
|
||||
|
||||
newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a }
|
||||
deriving newtype ( Applicative
|
||||
|
|
@ -275,6 +398,44 @@ makeDict w = execWriter ( fromMakeDict w )
|
|||
entry :: Dict c m -> MakeDictM c m ()
|
||||
entry = tell
|
||||
|
||||
|
||||
brief :: ManBrief -> MakeDictM c m () -> MakeDictM c m ()
|
||||
brief txt = censor (HM.map setBrief)
|
||||
where
|
||||
w0 = mempty { manBrief = Just txt }
|
||||
setBrief (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x
|
||||
|
||||
returns :: Text -> Text -> MakeDictM c m () -> MakeDictM c m ()
|
||||
returns tp txt = censor (HM.map setReturns)
|
||||
where
|
||||
w0 = mempty { manReturns = Just (ManReturns tp txt) }
|
||||
setReturns (Bind w x) = Bind (Just (maybe w0 (<>w0) w)) x
|
||||
|
||||
|
||||
addSynopsis :: ManSynopsis -> Bind c m -> Bind c m
|
||||
addSynopsis synopsis (Bind w x) = Bind (Just updatedMan) x
|
||||
where
|
||||
updatedMan = case w of
|
||||
Nothing -> mempty { manSynopsis = [synopsis] }
|
||||
Just man -> man { manSynopsis = manSynopsis man <> [synopsis] }
|
||||
|
||||
noArgs :: MakeDictM c m () -> MakeDictM c m ()
|
||||
noArgs = censor (HM.map (addSynopsis (ManSynopsis (ManApply []))))
|
||||
|
||||
arg :: Text -> Text -> ManApplyArg
|
||||
arg = ManApplyArg
|
||||
|
||||
|
||||
args :: [ManApplyArg] -> MakeDictM c m () -> MakeDictM c m ()
|
||||
args argList = censor (HM.map (addSynopsis (ManSynopsis (ManApply argList))))
|
||||
|
||||
examples :: ManExamples -> MakeDictM c m () -> MakeDictM c m ()
|
||||
examples (ManExamples s) = censor (HM.map setExamples )
|
||||
where
|
||||
ex = ManExamples (Text.unlines $ Text.strip <$> Text.lines (Text.strip s))
|
||||
ex0 = mempty { manExamples = [ex] }
|
||||
setExamples (Bind w x) = Bind (Just (maybe ex0 (<>ex0) w)) x
|
||||
|
||||
splitForms :: [String] -> [[String]]
|
||||
splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
|
||||
where
|
||||
|
|
@ -322,7 +483,7 @@ apply :: forall c m . ( IsContext c
|
|||
-> RunM c m (Syntax c)
|
||||
apply name args' = do
|
||||
-- notice $ red "APPLY" <+> pretty name
|
||||
what <- ask >>= readTVarIO <&> HM.lookup name . fromDict
|
||||
what <- ask >>= readTVarIO <&> HM.lookup name
|
||||
|
||||
case bindAction <$> what of
|
||||
Just (BindLambda e) -> mapM eval args' >>= e
|
||||
|
|
@ -347,13 +508,13 @@ bind name expr = do
|
|||
|
||||
what <- case expr of
|
||||
ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> do
|
||||
Dict m <- readTVarIO t
|
||||
m <- readTVarIO t
|
||||
HM.lookup n m & maybe (throwIO (NameNotBound n)) pure
|
||||
|
||||
e -> pure $ Bind (BindValue e) "" ""
|
||||
e -> pure $ Bind mzero (BindValue e)
|
||||
|
||||
atomically do
|
||||
modifyTVar t (Dict . HM.insert name what . fromDict)
|
||||
modifyTVar t (HM.insert name what)
|
||||
|
||||
eval :: forall c m . ( IsContext c
|
||||
, MonadUnliftIO m
|
||||
|
|
@ -361,7 +522,7 @@ eval :: forall c m . ( IsContext c
|
|||
) => Syntax c -> RunM c m (Syntax c)
|
||||
eval syn = handle (handleForm syn) $ do
|
||||
|
||||
dict <- ask >>= readTVarIO <&> fromDict
|
||||
dict <- ask >>= readTVarIO
|
||||
|
||||
case syn of
|
||||
|
||||
|
|
@ -448,10 +609,12 @@ evalTop :: forall c m . ( IsContext c
|
|||
evalTop syn = lastDef nil <$> mapM eval syn
|
||||
|
||||
bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
|
||||
bindMatch n fn = Dict (HM.singleton n (Bind (BindLambda fn) n ""))
|
||||
bindMatch n fn = HM.singleton n (Bind man (BindLambda fn))
|
||||
where
|
||||
man = Just $ mempty { manName = Just (manNameOf n) }
|
||||
|
||||
bindValue :: Id -> Syntax c -> Dict c m
|
||||
bindValue n e = Dict (HM.singleton n (Bind (BindValue e) "" ""))
|
||||
bindValue n e = HM.singleton n (Bind mzero (BindValue e))
|
||||
|
||||
nil :: forall c . IsContext c => Syntax c
|
||||
nil = List noContext []
|
||||
|
|
@ -468,26 +631,47 @@ fixContext = go
|
|||
Literal _ l -> Literal noContext l
|
||||
|
||||
|
||||
fmt :: Syntax c -> Doc ann
|
||||
fmt = \case
|
||||
LitStrVal x -> pretty $ Text.unpack x
|
||||
x -> pretty x
|
||||
|
||||
internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
|
||||
internalEntries = do
|
||||
|
||||
entry $ bindValue "false" (Literal noContext (LitBool False))
|
||||
entry $ bindValue "true" (Literal noContext (LitBool True))
|
||||
|
||||
entry $ bindMatch "concat" $ \syn -> do
|
||||
brief "concatenates list of string-like elements into a string"
|
||||
$ args [arg "list" "(list ...)"]
|
||||
$ args [arg "..." "..."]
|
||||
$ returns "string" ""
|
||||
$ examples [qc|
|
||||
(concat a b c d)
|
||||
abcd|]
|
||||
$ examples [qc|
|
||||
(concat 1 2 3 4 5)
|
||||
12345|]
|
||||
|
||||
case syn of
|
||||
[ListVal (StringLikeList xs)] -> do
|
||||
pure $ mkStr ( mconcat xs )
|
||||
$ entry $ bindMatch "concat" $ \syn -> do
|
||||
|
||||
StringLikeList xs -> do
|
||||
pure $ mkStr ( mconcat xs )
|
||||
case syn of
|
||||
[ListVal xs] -> do
|
||||
pure $ mkStr ( show $ hcat (fmap fmt xs) )
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
xs -> do
|
||||
pure $ mkStr ( show $ hcat (fmap fmt xs) )
|
||||
|
||||
entry $ bindMatch "list" $ \case
|
||||
es -> do
|
||||
pure $ mkList es
|
||||
brief "creates a list of elements"
|
||||
$ args [arg "..." "..."]
|
||||
$ returns "list" ""
|
||||
$ examples [qc|
|
||||
(list 1 2 3 fuu bar "baz")
|
||||
(1 2 3 fuu bar "baz")
|
||||
|]
|
||||
$ entry $ bindMatch "list" $ \case
|
||||
es -> do
|
||||
pure $ mkList es
|
||||
|
||||
entry $ bindMatch "dict" $ \case
|
||||
(pairList -> es@(_:_)) -> do
|
||||
|
|
@ -554,22 +738,26 @@ internalEntries = do
|
|||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
|
||||
entry $ bindMatch "now" $ \case
|
||||
[] -> mkInt . round <$> liftIO getPOSIXTime
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
brief "returns current unix time"
|
||||
$ returns "int" "current unix time in seconds"
|
||||
$ noArgs
|
||||
$ entry $ bindMatch "now" $ \case
|
||||
[] -> mkInt . round <$> liftIO getPOSIXTime
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
entry $ bindMatch "display" $ nil_ \case
|
||||
[ sy ] -> display sy
|
||||
ss -> display (mkList ss)
|
||||
|
||||
entry $ bindMatch "newline" $ nil_ $ \case
|
||||
[] -> liftIO (putStrLn "")
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
brief "prints new line character to stdout"
|
||||
$ entry $ bindMatch "newline" $ nil_ $ \case
|
||||
[] -> liftIO (putStrLn "")
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
entry $ bindMatch "print" $ nil_ $ \case
|
||||
[ sy ] -> display sy
|
||||
ss -> mapM_ display ss
|
||||
brief "prints a list of terms to stdout"
|
||||
$ entry $ bindMatch "print" $ nil_ $ \case
|
||||
[ sy ] -> display sy
|
||||
ss -> mapM_ display ss
|
||||
|
||||
entry $ bindMatch "println" $ nil_ $ \case
|
||||
[ sy ] -> display sy >> liftIO (putStrLn "")
|
||||
|
|
@ -584,10 +772,11 @@ internalEntries = do
|
|||
[LitStrVal s] -> liftIO $ TIO.putStr s
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
entry $ bindMatch "str:read-file" $ \case
|
||||
[StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr
|
||||
brief "reads file as a string" do
|
||||
entry $ bindMatch "str:read-file" $ \case
|
||||
[StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr
|
||||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
entry $ bindMatch "str:save" $ nil_ \case
|
||||
[StringLike fn, StringLike what] ->
|
||||
|
|
@ -615,22 +804,40 @@ internalEntries = do
|
|||
[StringLike s] -> pure (mkSym s)
|
||||
e -> pure (mkSym $ show $ pretty e)
|
||||
|
||||
entry $ bindMatch "eq?" $ \case
|
||||
[a, b] -> do
|
||||
pure $ if a == b then mkBool True else mkBool False
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
brief "compares two terms" $
|
||||
args [arg "term" "a", arg "term" "b"] $
|
||||
returns "boolean" "#t if terms are equal, otherwise #f" $
|
||||
entry $ bindMatch "eq?" $ \case
|
||||
[a, b] -> do
|
||||
pure $ if a == b then mkBool True else mkBool False
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
entry $ bindMatch "not" $ \case
|
||||
[v] -> do
|
||||
w <- eval v
|
||||
[w] -> do
|
||||
pure $ if isFalse w then mkBool True else mkBool False
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
entry $ bindMatch "env" $ \case
|
||||
[StringLike s] -> do
|
||||
liftIO (lookupEnv s)
|
||||
<&> maybe nil mkStr
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
brief "get system environment"
|
||||
$ args []
|
||||
$ args [ arg "string" "string" ]
|
||||
$ returns "env" "single var or dict of all vars"
|
||||
$ examples [qc|
|
||||
(env HOME)
|
||||
/home/user
|
||||
|
||||
(env)
|
||||
(dict
|
||||
(HOME "/home/user") ... (CC "gcc") ...)
|
||||
|]
|
||||
$ entry $ bindMatch "env" $ \case
|
||||
[] -> do
|
||||
s <- liftIO getEnvironment
|
||||
pure $ mkForm "dict" [ mkList [mkSym @c a, mkStr b] | (a,b) <- s ]
|
||||
|
||||
[StringLike s] -> do
|
||||
liftIO (lookupEnv s)
|
||||
<&> maybe nil mkStr
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
-- FIXME: we-need-opaque-type
|
||||
entry $ bindMatch "blob:read-stdin" $ \case
|
||||
|
|
|
|||
|
|
@ -21,6 +21,8 @@ import Data.Text qualified as Text
|
|||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Lens.Micro.Platform
|
||||
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
putTextLit :: forall c m . (IsContext c, MonadUnliftIO m)
|
||||
|
|
@ -84,20 +86,33 @@ peerEntries = do
|
|||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "hbs2:peer:poke" $ \case
|
||||
_ -> do
|
||||
so <- detectRPC `orDie` "hbs2-peer not found"
|
||||
r <- newTVarIO nil
|
||||
withRPC2 @PeerAPI @UNIX so $ \caller -> do
|
||||
brief "checks if peer available"
|
||||
$ noArgs
|
||||
$ returns "dict" "dictionary of peer attributes"
|
||||
$ examples [qc|
|
||||
(hbs2:peer:poke)
|
||||
|
||||
what <- callRpcWaitMay @RpcPoke (TimeoutSec 1) caller ()
|
||||
<&> fromMaybe ""
|
||||
<&> parseTop
|
||||
<&> either (const nil) (mkForm "dict")
|
||||
(dict
|
||||
(peer-key: "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3")
|
||||
(udp: "0.0.0.0:7354")
|
||||
(tcp: "tcp://0.0.0.0:3001")
|
||||
(local-multicast: "239.192.152.145:10153")
|
||||
(rpc: "/tmp/hbs2-rpc.socket")
|
||||
(http-port: 5000))
|
||||
|]
|
||||
$ entry $ bindMatch "hbs2:peer:poke" $ \case
|
||||
_ -> do
|
||||
so <- detectRPC `orDie` "hbs2-peer not found"
|
||||
r <- newTVarIO nil
|
||||
withRPC2 @PeerAPI @UNIX so $ \caller -> do
|
||||
|
||||
atomically $ writeTVar r what
|
||||
|
||||
readTVarIO r
|
||||
what <- callRpcWaitMay @RpcPoke (TimeoutSec 1) caller ()
|
||||
<&> fromMaybe ""
|
||||
<&> parseTop
|
||||
<&> either (const nil) (mkForm "dict")
|
||||
|
||||
atomically $ writeTVar r what
|
||||
|
||||
readTVarIO r
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -22,18 +22,30 @@ import HBS2.KeyMan.App.Types
|
|||
|
||||
import Control.Monad.Trans.Cont
|
||||
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
|
||||
refchanEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m ()
|
||||
refchanEntries = do
|
||||
entry $ bindMatch "hbs2:refchan:list" $ \case
|
||||
[] -> do
|
||||
flip runContT pure do
|
||||
so <- detectRPC `orDie` "rpc not found"
|
||||
api <- ContT $ withRPC2 @PeerAPI @UNIX so
|
||||
r <- callService @RpcPollList2 api (Just "refchan", Nothing)
|
||||
>>= orThrowUser "can't get refchan list"
|
||||
pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
brief "requests all rechans that peer is subcribed to"
|
||||
$ args []
|
||||
$ returns "list" "list of all refchans"
|
||||
$ examples [qc|
|
||||
|
||||
(hbs2:refchan:list)
|
||||
("Atg67E6CPMJWKvR9BvwZTTEjg3Hjz4CYCaEARGANepGP"
|
||||
"A5W6jPBjzvdpxaQ2e8xBLYaRZjPXzi4yX7xjC52gTiKk"
|
||||
"EjjK7rpgRRJ4yzAhTcwis4XawwagCbmkns8n73ogY3uS")
|
||||
|]
|
||||
$ entry $ bindMatch "hbs2:refchan:list" $ \case
|
||||
[] -> do
|
||||
flip runContT pure do
|
||||
so <- detectRPC `orDie` "rpc not found"
|
||||
api <- ContT $ withRPC2 @PeerAPI @UNIX so
|
||||
r <- callService @RpcPollList2 api (Just "refchan", Nothing)
|
||||
>>= orThrowUser "can't get refchan list"
|
||||
pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue