wip, reflog tx and post

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.CLI.Run.RefLog
-
-import HBS2.Data.Types.Refs
-import HBS2.Misc.PrettyStuff as All
-import HBS2.System.Logger.Simple.ANSI as All
 
 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

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

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)

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
+

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

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)
 
 

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