fork feature handles, fork itself is postponed

hbs2-cli/hbs2-cli.cabal

@@ -110,6 +110,7 @@ library
       HBS2.CLI.Run.Internal.Merkle
       HBS2.CLI.Run.Internal.KeyMan
       HBS2.CLI.Run.Internal.RefChan
+      HBS2.CLI.Run.Internal.RefLog
       HBS2.CLI.Run.GroupKey
       HBS2.CLI.Run.KeyMan
       HBS2.CLI.Run.Keyring

hbs2-cli/lib/HBS2/CLI/Run/Internal/RefLog.hs

@@ -0,0 +1,91 @@
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.CLI.Run.Internal.RefLog (copyTransactions, RefLogCLIException(..)) where
+
+import HBS2.CLI.Prelude hiding (mapMaybe)
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+
+import HBS2.Peer.Proto.RefLog
+import HBS2.Base58
+import HBS2.Storage
+import HBS2.Data.Detect
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
+import HBS2.Peer.Proto
+import HBS2.Data.Types.SignedBox
+import HBS2.Data.Types.Refs
+import HBS2.Storage.Operations.Class
+import HBS2.KeyMan.Keys.Direct
+
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefLog
+
+import Codec.Serialise
+import Control.Monad.Trans.Maybe
+import Data.ByteString.Lazy qualified as LBS
+import Data.Coerce
+import Data.Maybe
+import Lens.Micro.Platform
+
+data RefLogCLIException =
+   RefLogRpcTimeout
+ | RefLogNoCredentials String
+ deriving (Typeable, Show)
+
+instance Exception RefLogCLIException
+
+type ForCloneRefLog e s m = ( s ~ Encryption e
+                            , MonadUnliftIO m
+                            , HasClientAPI RefLogAPI UNIX m
+                            , HasClientAPI StorageAPI UNIX m
+                            , HasClientAPI PeerAPI UNIX m
+                            , HasStorage m
+                            , Signatures s
+                            , IsRefPubKey s
+                            , Serialise (Nonce (RefLogUpdate e))
+                            )
+
+
+-- useful for forking git repositories
+-- it accepts credential lookup method
+-- since reflog B may be inferred from some other secret
+-- normally, you dont need this method
+copyTransactions :: forall e s m . (ForCloneRefLog e s m, s ~ Encryption e, e ~ L4Proto)
+                 => m (PeerCredentials s) -- ^ obtain credentials for reflog B
+                 -> PubKey Sign s         -- ^ original reflog
+                 -> PubKey Sign s         -- ^ destination reflog
+                 -> m ()
+
+copyTransactions cre a b  = do
+
+  api <- getClientAPI @RefLogAPI @UNIX
+  sto <- getStorage
+
+  creds <- cre
+
+  let pk = view peerSignPk creds
+  let sk = view peerSignSk creds
+
+  void $ runMaybeT do
+
+    rvA <- lift (callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) api a)
+             >>= orThrow RefLogRpcTimeout
+             >>= toMPlus
+
+    logA <- readLogThrow (getBlock sto) rvA
+
+    new <- for logA $ \h -> runMaybeT do
+      RefLogUpdate{..} <- getBlock sto (coerce h)
+                            >>= toMPlus
+                            <&> deserialiseOrFail @(RefLogUpdate e)
+                            >>= toMPlus
+
+      lift (makeRefLogUpdate @e pk sk _refLogUpdData)
+
+    lift $ for_ (catMaybes new) $ \n -> do
+      void $ callService @RpcRefLogPost api n
+
+

hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs

@@ -1,8 +1,12 @@
-module HBS2.CLI.Run.RefLog where
+module HBS2.CLI.Run.RefLog
+  ( module HBS2.CLI.Run.RefLog
+  , module HBS2.CLI.Run.Internal.RefLog
+  ) where
 
 import HBS2.CLI.Prelude
 import HBS2.CLI.Run.Internal
 import HBS2.CLI.Run.Internal.KeyMan
+import HBS2.CLI.Run.Internal.RefLog
 
 import HBS2.Data.Types.Refs
 import HBS2.Merkle
@@ -95,6 +99,16 @@ reflogEntries = do
     _ -> throwIO (BadFormException @C nil)
 
 
+  entry $ bindMatch "hbs2:reflog:tx:copy:all" $ nil_ \case
+    [SignPubKeyLike a, SignPubKeyLike b] -> do
+
+      let cre = runKeymanClientRO (loadCredentials b)
+                   >>= orThrow (RefLogNoCredentials (show $ pretty (AsBase58 b)))
+
+      copyTransactions cre a b
+
+    e -> throwIO (BadFormException @c (mkList e))
+
   entry $ bindMatch "hbs2:reflog:tx:post" $ nil_ \case
     [BlobLike blob] -> do
       caller <- getClientAPI @RefLogAPI @UNIX

hbs2-git3/lib/HBS2/Git3/Repo/Init.hs

@@ -1,6 +1,6 @@
 {-# Language UndecidableInstances #-}
 {-# Language AllowAmbiguousTypes #-}
-module HBS2.Git3.Repo.Init (initRepo,newRepoOpt,encryptedNewOpt) where
+module HBS2.Git3.Repo.Init (initRepo,newRepoOpt,encryptedNewOpt,relayOnlyRepo) where
 
 import HBS2.Git3.Prelude
 import HBS2.Git3.State
@@ -18,6 +18,8 @@ import HBS2.KeyMan.Keys.Direct
 import Data.Config.Suckless.Script
 import Data.Config.Suckless.Almost.RPC
 
+import Data.List qualified as List
+import Data.Maybe
 import Data.Word
 import Data.Text qualified as Text
 import Lens.Micro.Platform
@@ -42,11 +44,22 @@ encryptedNewOpt :: Syntax C
 encryptedNewOpt = mkSym "--encrypted"
 
 
+relayOnlyRepo :: forall m . HBS2GitPerks m => [Syntax C] -> Git3 m ()
+relayOnlyRepo syn = connectedDo do
+  case syn of
+    [ SignPubKeyLike repo ] -> do
+      setGitRepoKey repo
+      waitRepo (Just 10) =<< getGitRepoKeyThrow
+
+    e -> throwIO (BadFormException (mkList e))
+
 
 initRepo :: forall m . HBS2GitPerks m => [Syntax C] -> Git3 m ()
 initRepo syn = do
 
-  let (opts, _) = splitOpts [("--new",0),("--encrypted",1)] syn
+  let (opts, _) = splitOpts [ ("--new",0)
+                            , ("--encrypted",1)
+                            ] syn
 
   let new = or [ True | ListVal [SymbolVal "--new"] <- opts ]
   let gkh = lastMay [ gk | ListVal [SymbolVal "--encrypted", HashLike gk] <- opts ]

hbs2-git3/lib/HBS2/Git3/Run.hs

@@ -579,12 +579,7 @@ compression      ;  prints compression level
           bindAlias "init" "repo:init"
 
         manRepoRelayOnly $
-          entry $ bindMatch "repo:relay-only" $ nil_ $ \case
-            [ SignPubKeyLike repo ] -> lift $ connectedDo do
-              setGitRepoKey repo
-              waitRepo (Just 10) =<< getGitRepoKeyThrow
-
-            _ -> throwIO (BadFormException @C nil)
+          entry $ bindMatch "repo:relay-only" $ nil_ $ lift . relayOnlyRepo
 
         exportEntries "reflog:"