voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip, reflog tx and post

This commit is contained in:
Dmitry Zuikov 2024-07-26 19:45:40 +03:00
parent 1980f3c904
commit b4341a7163
7 changed files with 210 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
hbs2-cli/app/Main.hs
View File

@ -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

1
hbs2-cli/hbs2-cli.cabal
View File

@ -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

12
hbs2-cli/lib/HBS2/CLI/Run/Internal.hs
View File

@ -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)

66
hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs Normal file
View File

@ -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

26
hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs
View File

@ -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

114
hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs
View File

@ -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)

13
hbs2-core/lib/HBS2/Net/Auth/Credentials.hs
View File

@ -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