diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index 185264a1..32418ee5 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -10,29 +10,15 @@ import HBS2.CLI.Run.GroupKey import HBS2.CLI.Run.Sigil import HBS2.CLI.Run.MetaData import HBS2.CLI.Run.Peer - - -import HBS2.Data.Types.Refs -import HBS2.Misc.PrettyStuff as All -import HBS2.System.Logger.Simple.ANSI as All +import HBS2.CLI.Run.RefLog import HBS2.Peer.RPC.Client.Unix -import HBS2.Peer.Proto hiding (request) -import HBS2.Base58 -import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Schema() -import HBS2.KeyMan.Keys.Direct -import HBS2.KeyMan.App.Types - -import Data.Coerce import Data.HashMap.Strict qualified as HM import Data.List qualified as List -import Data.ByteString qualified as BS -import Data.ByteString (ByteString) import Data.Text qualified as Text -import Data.Text.Encoding qualified as TE import System.Environment type RefLogId = PubKey 'Sign 'HBS2Basic @@ -58,21 +44,6 @@ silence = do setLoggingOff @NOTICE -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 ] @@ -106,6 +77,7 @@ main = do sigilEntries metaDataEntries peerEntries + reflogEntries entry $ bindMatch "help" $ nil_ $ \syn -> do @@ -127,16 +99,6 @@ main = do _ -> display cli - entry $ 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 diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index f9e3e2d7..291ad4a3 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/hbs2-cli/hbs2-cli.cabal @@ -105,6 +105,7 @@ library HBS2.CLI.Run.Internal HBS2.CLI.Run.Internal.GroupKey HBS2.CLI.Run.Internal.Merkle + HBS2.CLI.Run.Internal.KeyMan HBS2.CLI.Run.GroupKey HBS2.CLI.Run.KeyMan HBS2.CLI.Run.Keyring diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index 925fe082..799ba666 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -307,6 +307,13 @@ run d sy = do tvd <- newTVarIO d lastDef nil <$> runReaderT (fromRunM (mapM runExpr sy)) tvd +evalTop :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c)) + => [Syntax c] + -> RunM c m (Syntax c) +evalTop syn = lastDef nil <$> mapM runExpr syn + bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m bindMatch n fn = Dict (HM.singleton n (Bind (BindLambda fn) n "")) @@ -387,6 +394,11 @@ internalEntries = do _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "now" $ \case + [] -> mkInt . round <$> liftIO getPOSIXTime + _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "display" $ nil_ \case [ sy ] -> display sy ss -> display (mkList ss) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs new file mode 100644 index 00000000..3fd3045b --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs @@ -0,0 +1,66 @@ +module HBS2.CLI.Run.Internal.KeyMan where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal + +import HBS2.Hash +import HBS2.System.Dir +import HBS2.Net.Auth.Credentials + +import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.State +import HBS2.KeyMan.App.Types + +import Codec.Serialise +import Data.Either +import Data.ByteString.Lazy qualified as LBS +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO +import System.Process.Typed +import Text.InterpolatedString.Perl6 (qc) + +fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2 +fixContext = go + where + go = \case + List _ xs -> List noContext (fmap go xs) + Symbol _ w -> Symbol noContext w + Literal _ l -> Literal noContext l + + +keymanGetConfig :: (IsContext c, MonadUnliftIO m) => m [Syntax c] +keymanGetConfig = do + (_,lbs,_) <- readProcess (shell [qc|hbs2-keyman config|] & setStderr closed) + + let conf = TE.decodeUtf8 (LBS.toStrict lbs) + & parseTop + & fromRight mempty + + pure $ fmap fixContext conf + +keymanUpdate :: MonadUnliftIO m => m () +keymanUpdate = do + void $ runProcess (shell [qc|hbs2-keyman update|]) + +keymanNewCredentials :: MonadUnliftIO m => Maybe String -> Int -> m (PubKey 'Sign 'HBS2Basic) +keymanNewCredentials suff n = do + conf <- keymanGetConfig @C + + path <- [ p + | ListVal [SymbolVal "default-key-path", StringLike p] <- conf + ] & headMay & orThrowUser "default-key-path not set" + + creds <- newCredentialsEnc @'HBS2Basic n + + let s = show $ pretty $ AsCredFile (AsBase58 creds) + + let psk = view peerSignPk creds + + let fpath = path show (pretty (AsBase58 psk) <> "-" <> pretty suff <> ".key") + + liftIO $ writeFile fpath s + + keymanUpdate + + pure psk + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs index 8e89dfed..43a92c3b 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs @@ -1,7 +1,9 @@ -module HBS2.CLI.Run.KeyMan where +module HBS2.CLI.Run.KeyMan + (keymanEntries) where import HBS2.CLI.Prelude import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.KeyMan import HBS2.Hash import HBS2.System.Dir @@ -18,28 +20,6 @@ import Data.Text.IO qualified as TIO import System.Process.Typed import Text.InterpolatedString.Perl6 (qc) -fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2 -fixContext = go - where - go = \case - List _ xs -> List noContext (fmap go xs) - Symbol _ w -> Symbol noContext w - Literal _ l -> Literal noContext l - - -keymanGetConfig :: (IsContext c, MonadUnliftIO m) => m [Syntax c] -keymanGetConfig = do - (_,lbs,_) <- readProcess (shell [qc|hbs2-keyman config|] & setStderr closed) - - let conf = TE.decodeUtf8 (LBS.toStrict lbs) - & parseTop - & fromRight mempty - - pure $ fmap fixContext conf - -keymanUpdate :: MonadUnliftIO m => m () -keymanUpdate = do - void $ runProcess (shell [qc|hbs2-keyman update|]) keymanEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m () keymanEntries = do diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs index 4c7fe603..d5ac4a8a 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs @@ -2,5 +2,119 @@ module HBS2.CLI.Run.RefLog where import HBS2.CLI.Prelude import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.KeyMan + +import HBS2.Data.Types.Refs +import HBS2.Storage +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.RefLog + +import HBS2.Peer.Proto hiding (request) +import HBS2.Base58 +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.Schema() + +import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.App.Types + +import Codec.Serialise +import Data.Coerce +import Data.Either +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString (ByteString) +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy qualified as LBS +import Data.Text.Encoding qualified as TE +import Data.Text qualified as Text +import Control.Monad.Trans.Cont + +getCredentialsForReflog :: MonadUnliftIO m => RefLogKey 'HBS2Basic -> m (PeerCredentials 'HBS2Basic) +getCredentialsForReflog reflog = do + runKeymanClient (loadCredentials reflog) + >>= orThrowUser "credentials not found" + +mkRefLogUpdateFrom :: (MonadUnliftIO m) => RefLogKey 'HBS2Basic -> m ByteString -> m (RefLogUpdate L4Proto) +mkRefLogUpdateFrom reflog mbs = do + what <- getCredentialsForReflog reflog + let puk = view peerSignPk what + let privk = view peerSignSk what + txraw <- mbs + makeRefLogUpdate @L4Proto @'HBS2Basic (coerce puk) privk txraw + + +reflogEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +reflogEntries = do + + entry $ bindMatch "hbs2:reflog:create" $ \case + [] -> do + reflog <- keymanNewCredentials (Just "reflog") 0 + + flip runContT pure do + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @PeerAPI @UNIX so + void $ callService @RpcPollAdd api (reflog, "reflog", 31) + pure $ mkStr (show $ pretty (AsBase58 reflog)) + + _ -> throwIO (BadFormException @C nil) + + + entry $ bindMatch "hbs2:reflog:tx:annhashref:create" $ \case + [StringLike puk, StringLike hash] -> do + flip runContT pure do + reflog <- orThrowUser "bad reflog key" (fromStringMay puk) + sto <- ContT withPeerStorage + hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash) + void $ hasBlock sto (fromHashRef hashref) `orDie` "no block" + let sref = AnnotatedHashRef Nothing hashref + rlu <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise + pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + _ -> throwIO (BadFormException @C nil) + + + entry $ bindMatch "hbs2:reflog:tx:post" $ nil_ \case + [BlobLike blob] -> do + so <- detectRPC `orDie` "no rpc found" + withRPC2 @RefLogAPI so $ \caller -> do + wtf <- deserialiseOrFail @(RefLogUpdate L4Proto) (LBS.fromStrict blob) + & orThrowUser "invalid tx" + void $ callService @RpcRefLogPost caller wtf + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "hbs2:reflog:tx:seqref:create" $ \case + [StringLike puk, LitIntVal sn, StringLike hash] -> do + flip runContT pure do + reflog <- orThrowUser "bad reflog key" (fromStringMay puk) + sto <- ContT withPeerStorage + hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash) + void $ hasBlock sto (fromHashRef hashref) `orDie` "no block" + let sref = SequentialRef sn (AnnotatedHashRef Nothing hashref) + rlu <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise + pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "hbs2:reflog:tx:create-raw" $ \case + [SymbolVal "stdin", StringLike rlo] -> do + reflog <- orThrowUser "bad reflog" (fromStringMay rlo) + + rlu <- mkRefLogUpdateFrom reflog ( liftIO BS.getContents ) + <&> serialise + + pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + [LitStrVal s, StringLike rlo] -> do + reflog <- orThrowUser "bad reflog" (fromStringMay rlo) + + rlu <- mkRefLogUpdateFrom reflog ( pure (BS8.pack (Text.unpack s)) ) + <&> serialise + + pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + _ -> throwIO (BadFormException @C nil) diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index 857c3809..4f13c814 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs @@ -29,7 +29,7 @@ import Data.List.Split (chunksOf) import Data.List qualified as List import Lens.Micro.Platform import Data.Kind - +import Control.Monad instance Signatures 'HBS2Basic where type Signature 'HBS2Basic = Sign.Signature @@ -128,6 +128,17 @@ newCredentials = do pure $ PeerCredentials @s (secretKey pair) (publicKey pair) mempty +newCredentialsEnc :: forall s m . ( MonadIO m + , Signatures s + , PrivKey 'Sign s ~ Sign.SecretKey + , PubKey 'Sign s ~ Sign.PublicKey + , PrivKey 'Encrypt s ~ Encrypt.SecretKey + , PubKey 'Encrypt s ~ Encrypt.PublicKey + ) => Int -> m (PeerCredentials s) +newCredentialsEnc n = do + cred0 <- newCredentials @s + foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n] + newKeypair :: forall s m . ( MonadIO m , PrivKey 'Encrypt s ~ Encrypt.SecretKey , PubKey 'Encrypt s ~ Encrypt.PublicKey