mirror of https://github.com/voidlizard/hbs2
136 lines
4.0 KiB
Haskell
136 lines
4.0 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
|
{-# Language UndecidableInstances #-}
|
|
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)
|
|
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) }
|
|
|
|
data Bind c ( m :: Type -> Type) = Bind
|
|
{ bindAction :: BindAction c m
|
|
, bindName :: Id
|
|
, bindDescShort :: Text
|
|
} deriving (Generic)
|
|
|
|
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 (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
|
|
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 <- 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_ :: (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
|
|
|
|
cli <- getArgs <&> unlines . mconcat . splitForms
|
|
>>= either (error.show) pure . parseTop
|
|
|
|
let dict = execWriter do
|
|
|
|
tell $ bindOne "help" $ nil_ $ \case
|
|
[] -> do
|
|
d <- ask >>= readTVarIO <&> fromDict
|
|
liftIO $ mapM_ (print.pretty.bindName) d
|
|
|
|
_ -> pure ()
|
|
|
|
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
|
|
|