diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index d001a803..94fb4526 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -4,28 +4,72 @@ module Main where import HBS2.Prelude.Plated import HBS2.OrDie + +import HBS2.Misc.PrettyStuff as All +import HBS2.System.Logger.Simple.ANSI as All + import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client.Unix import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.Proto hiding (request) +import HBS2.Peer.Proto.RefLog +import HBS2.Base58 +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.Schema() +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.Credentials.Sigil +import HBS2.Data.Types.SignedBox + + import HBS2.KeyMan.Keys.Direct import HBS2.KeyMan.State import HBS2.KeyMan.App.Types +import HBS2.Misc.PrettyStuff + +import Data.Coerce import Data.Config.Suckless import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Data.Kind +import Data.List (isPrefixOf) +import Data.ByteString qualified as BS +import Data.ByteString (ByteString) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import Data.Maybe +import Codec.Serialise import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.Identity import UnliftIO import System.Environment +import System.IO (hPrint) import Streaming.Prelude qualified as S import Prettyprinter -data BindAction c ( m :: Type -> Type) = BindAction { getAction :: [Syntax c] -> RunM c m (Syntax c) } +type RefLogId = PubKey 'Sign 'HBS2Basic + +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) + +stringLike :: Syntax c -> Maybe String +stringLike = \case + LitStrVal s -> Just $ Text.unpack s + SymbolVal (Id s) -> Just $ Text.unpack s + _ -> Nothing + +stringLikeList :: [Syntax c] -> [String] +stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes + +data BindAction c ( m :: Type -> Type) = + BindLambda { fromLambda :: [Syntax c] -> RunM c m (Syntax c) } + | BindValue (Syntax c) data Bind c ( m :: Type -> Type) = Bind { bindAction :: BindAction c m @@ -39,8 +83,28 @@ newtype NameNotBoundException = NameNotBound Id deriving stock Show deriving newtype (Generic,Typeable) + +newtype NotLambda = NotLambda Id + deriving stock Show + deriving newtype (Generic,Typeable) + +instance Exception NotLambda + +data BadFormException c = BadFormException (Syntax c) + +newtype BadValueException = BadValueException String + deriving stock Show + deriving newtype (Generic,Typeable) + instance Exception NameNotBoundException +instance IsContext c => Show (BadFormException c) where + show (BadFormException sy) = show $ "BadFormException" <+> pretty sy + +instance Exception (BadFormException C) + +instance Exception BadValueException + newtype Dict c m = Dict { fromDict :: HashMap Id (Bind c m) } deriving newtype (Semigroup, Monoid) @@ -59,77 +123,208 @@ 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 ) | isPrefixOf "-" x = go ( x : acc ) rest + go acc ( x : rest ) | isPrefixOf "--" x = go ( x : acc ) 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 :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) => Dict c m -> [Syntax c] -> m (Syntax c) run d sy = do tvd <- newTVarIO d - runReaderT (fromRunM (mapM_ runExpr sy)) tvd + lastDef nil <$> runReaderT (fromRunM (mapM runExpr sy)) tvd where runExpr :: Syntax c -> RunM c m (Syntax c) - runExpr = \case + runExpr syn = handle (handleForm syn) $ case syn of ListVal (SymbolVal name : args') -> do what <- ask >>= readTVarIO <&> HM.lookup name . fromDict case bindAction <$> what of - Just (BindAction e) -> mapM runExpr args' >>= e + Just (BindLambda e) -> mapM runExpr args' >>= e + Just (BindValue v) -> throwIO (NotLambda name) Nothing -> throwIO (NameNotBound name) + SymbolVal (Id s) | Text.isPrefixOf ":" s -> do + pure (mkSym @c (Text.drop 1 s)) + + SymbolVal name -> do + what <- ask >>= readTVarIO + <&> HM.lookup name . fromDict + <&> maybe (BindValue (mkSym name)) bindAction + + case what of + BindValue e -> pure e + BindLambda e -> pure $ mkForm "lambda" [mkSym "..."] + 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 "")) + handleForm syn (BadFormException _ :: BadFormException c) = do + throwIO (BadFormException syn) --- nil = List noContext [] +bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m +bindMatch n fn = Dict (HM.singleton n (Bind (BindLambda fn) n "")) + +nil :: forall c . IsContext c => Syntax c +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 []) +bind :: (MonadUnliftIO m, IsContext c) => Id -> Syntax c -> RunM c m (Syntax c) +bind name expr = do + tv <- ask -- >>= readTVarIO + atomically do + w@(Dict x) <- readTVar tv + writeTVar tv w + pure nil + +setupLogger :: MonadIO m => m () +setupLogger = do + setLogging @DEBUG $ toStderr . logPrefix "[debug] " + setLogging @ERROR $ toStderr . logPrefix "[error] " + setLogging @WARN $ toStderr . logPrefix "[warn] " + setLogging @NOTICE $ toStdout . logPrefix "" + pure () + +flushLoggers :: MonadIO m => m () +flushLoggers = do + silence + +silence :: MonadIO m => m () +silence = do + setLoggingOff @DEBUG + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE + +display :: (MonadIO m, Pretty a) => a -> m () +display = liftIO . print . pretty + +display_ :: (MonadIO m, Show a) => a -> m () +display_ = liftIO . print + +{- HLINT ignore "Functor law" -} + +class IsContext c => MkSym c a where + mkSym :: a -> Syntax c + +instance IsContext c => MkSym c String where + mkSym s = Symbol noContext (Id $ Text.pack s) + +instance IsContext c => MkSym c Text where + mkSym s = Symbol noContext (Id s) + +instance IsContext c => MkSym c Id where + mkSym = Symbol noContext + +mkStr :: forall c . IsContext c => String -> Syntax c +mkStr s = Literal noContext $ LitStr (Text.pack s) + +mkForm :: forall c . IsContext c => String -> [Syntax c] -> Syntax c +mkForm s sy = List noContext ( mkSym s : sy ) + +mkList :: [Syntax C] -> Syntax C +mkList = List noContext + +getCredentialsForReflog :: MonadUnliftIO m => String -> m (PeerCredentials 'HBS2Basic) +getCredentialsForReflog reflog = do + puk <- orThrow (BadValueException reflog) (fromStringMay @(RefLogKey HBS2Basic) reflog) + runKeymanClient (loadCredentials puk) + >>= orThrowUser "credentials not found" + +mkRefLogUpdateFrom :: MonadUnliftIO m => m ByteString -> String -> m (Syntax C) +mkRefLogUpdateFrom mbs reflog = do + what <- getCredentialsForReflog reflog + let puk = view peerSignPk what + let privk = view peerSignSk what + txraw <- mbs + w <- makeRefLogUpdate @L4Proto @'HBS2Basic (coerce puk) privk txraw + let s = show $ pretty $ AsBase58 (serialise w) + pure $ mkForm "cbor:base58" [ mkStr s ] + + main :: IO () main = do - cli <- getArgs <&> unlines . mconcat . splitForms + setupLogger + + cli <- getArgs <&> unlines . fmap unwords . splitForms >>= either (error.show) pure . parseTop let dict = execWriter do - tell $ bindOne "help" $ nil_ $ \case + tell $ bindMatch "help" $ nil_ \case [] -> do d <- ask >>= readTVarIO <&> fromDict - liftIO $ mapM_ (print.pretty.bindName) d + mapM_ (display.bindName) d _ -> pure () - tell $ bindOne "internal:show-cli" $ nil_ $ \case - _ -> liftIO (print $ pretty cli) + tell $ bindMatch "concat" $ \case + StringLikeList xs@(_:_) -> do + pure $ mkStr ( mconcat xs ) + _ -> throwIO (BadFormException @C nil) - tell $ bindOne "hbs2:peer:detect" $ nil_ $ \case + + tell $ bindMatch "lookup" $ \case + [StringLike s, ListVal (SymbolVal "dict" : es) ] -> do + let val = headDef nil [ v | ListVal [StringLike k, v] <- es, k == s ] + pure val + + _ -> throwIO (BadFormException @C nil) + + tell $ bindMatch "display" $ nil_ \case + [ sy ] -> display sy + ss -> display (mkList ss) + + tell $ bindMatch "internal:show-cli" $ nil_ \case + _ -> display cli + + tell $ bindMatch "hbs2:peer:detect" $ nil_ \case _ -> do so <- detectRPC - liftIO (print $ pretty so) + display so - tell $ bindOne "hbs2:peer:poke" $ nil_ $ \case + tell $ bindMatch "hbs2:peer:poke" $ \case _ -> do so <- detectRPC `orDie` "hbs2-peer not found" + r <- newTVarIO nil withRPC2 @PeerAPI @UNIX so $ \caller -> do - what <- callRpcWaitMay @RpcPoke (TimeoutSec 1) caller () - liftIO $ print $ pretty what - tell $ bindOne "hbs2:keyman:list" $ nil_ $ \case + what <- callRpcWaitMay @RpcPoke (TimeoutSec 1) caller () + <&> fromMaybe "" + <&> parseTop + <&> either (const nil) (mkForm "dict") + + atomically $ writeTVar r what + + readTVarIO r + + tell $ bindMatch "hbs2:keyman:list" $ nil_ \case _ -> do void $ runKeymanClient $ KeyManClient $ do k <- listKeys - liftIO $ print $ vcat (fmap pretty k) + display_ $ vcat (fmap pretty k) + + tell $ bindMatch "hbs2:reflog:tx:create-raw" $ \case + [SymbolVal "stdin", StringLike reflog] -> do + mkRefLogUpdateFrom ( liftIO BS.getContents ) reflog + + [LitStrVal s, StringLike reflog] -> do + mkRefLogUpdateFrom ( pure (TE.encodeUtf8 s) ) reflog + + _ -> throwIO (BadFormException @C nil) case cli of [ListVal [SymbolVal "stdin"]] -> do what <- getContents >>= either (error.show) pure . parseTop - run dict what + void $ run dict what _ -> do - run dict cli + void $ run dict cli