diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index 8a78a4fd..d001a803 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -4,6 +4,13 @@ module Main where import HBS2.Prelude.Plated import HBS2.OrDie +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Peer + +import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.State +import HBS2.KeyMan.App.Types import Data.Config.Suckless import Data.HashMap.Strict (HashMap) @@ -11,7 +18,11 @@ import Data.HashMap.Strict qualified as HM import Data.Kind import Control.Monad.Reader import Control.Monad.Writer +import Control.Monad.Identity +import UnliftIO +import System.Environment +import Streaming.Prelude qualified as S import Prettyprinter data BindAction c ( m :: Type -> Type) = BindAction { getAction :: [Syntax c] -> RunM c m (Syntax c) } @@ -24,48 +35,101 @@ data Bind c ( m :: Type -> Type) = Bind deriving newtype instance Hashable Id +newtype NameNotBoundException = NameNotBound Id + deriving stock Show + deriving newtype (Generic,Typeable) + +instance Exception NameNotBoundException + newtype Dict c m = Dict { fromDict :: HashMap Id (Bind c m) } deriving newtype (Semigroup, Monoid) -newtype RunM c m a = RunM { fromRunM :: ReaderT (Dict c m) m a } - deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader (Dict c m)) +newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a } + deriving newtype ( Applicative + , Functor + , Monad + , MonadIO + , MonadUnliftIO + , MonadReader (TVar (Dict c m)) + ) + + +splitForms :: [String] -> [[String]] +splitForms s0 = runIdentity $ S.toList_ (go mempty s0) + where + go acc ( "then" : rest ) = emit acc >> go mempty rest + go acc ( "and" : rest ) = emit acc >> go mempty rest + go acc ( x : rest ) = go ( x : acc ) rest + go acc [] = emit acc + + emit = S.yield . reverse + run :: forall c m . (IsContext c, MonadIO m) => Dict c m -> [Syntax c] -> m () run d sy = do - runReaderT (fromRunM (mapM_ runExpr sy)) d + tvd <- newTVarIO d + runReaderT (fromRunM (mapM_ runExpr sy)) tvd where runExpr :: Syntax c -> RunM c m (Syntax c) runExpr = \case ListVal (SymbolVal name : args') -> do - what <- asks (HM.lookup name . fromDict) `orDie` "JOPA" - case bindAction what of - BindAction e -> do - mapM runExpr args' >>= e + what <- ask >>= readTVarIO <&> HM.lookup name . fromDict + case bindAction <$> what of + Just (BindAction e) -> mapM runExpr args' >>= e + Nothing -> throwIO (NameNotBound name) e -> pure e bindOne :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m bindOne n fn = Dict (HM.singleton n (Bind (BindAction fn) n "")) -nil = List noContext [] +-- nil = List noContext [] + +nil_ :: (IsContext c, MonadIO m) => (a -> RunM c m b) -> a -> RunM c m (Syntax c) +nil_ m w = m w >> pure (List noContext []) main :: IO () main = do - wat <- getContents + + cli <- getArgs <&> unlines . mconcat . splitForms >>= either (error.show) pure . parseTop let dict = execWriter do - tell $ bindOne "jopa" $ \case - [] -> liftIO (print "JOPA") >> pure nil - _ -> pure nil - tell $ bindOne "help" $ \case - [] -> do - d <- asks (HM.keys . fromDict) - liftIO $ mapM_ (print.pretty) d - pure nil + tell $ bindOne "help" $ nil_ $ \case + [] -> do + d <- ask >>= readTVarIO <&> fromDict + liftIO $ mapM_ (print.pretty.bindName) d - _ -> pure nil + _ -> pure () - run dict wat + tell $ bindOne "internal:show-cli" $ nil_ $ \case + _ -> liftIO (print $ pretty cli) + + tell $ bindOne "hbs2:peer:detect" $ nil_ $ \case + _ -> do + so <- detectRPC + liftIO (print $ pretty so) + + tell $ bindOne "hbs2:peer:poke" $ nil_ $ \case + _ -> do + so <- detectRPC `orDie` "hbs2-peer not found" + withRPC2 @PeerAPI @UNIX so $ \caller -> do + what <- callRpcWaitMay @RpcPoke (TimeoutSec 1) caller () + liftIO $ print $ pretty what + + tell $ bindOne "hbs2:keyman:list" $ nil_ $ \case + _ -> do + void $ runKeymanClient $ KeyManClient $ do + k <- listKeys + liftIO $ print $ vcat (fmap pretty k) + + case cli of + [ListVal [SymbolVal "stdin"]] -> do + what <- getContents + >>= either (error.show) pure . parseTop + run dict what + + _ -> do + run dict cli