diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index 09fc27fc..b622b247 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/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 diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/RefLog.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/RefLog.hs new file mode 100644 index 00000000..059eebca --- /dev/null +++ b/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 + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs index 859f98b4..77c7acd4 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs +++ b/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 diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs index d4caa9cc..518956ef 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs +++ b/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 ] diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 8c8cc25b..e891e315 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/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:"