From 8c45e317e6c5983add8987b07d3bd8cd242373f3 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 14 Mar 2024 11:46:30 +0300 Subject: [PATCH] wip --- hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs | 54 +++++++ hbs21-git/git-hbs21/Main.hs | 8 +- hbs21-git/git-remote-hbs21/Main.hs | 7 +- .../HBS2/Git/Client/App.hs | 4 + .../HBS2/Git/Client/Export.hs | 8 +- .../HBS2/Git/Client/Import.hs | 52 ++++--- .../HBS2/Git/Client/Progress.hs | 2 + .../HBS2/Git/Data/LWWBlock.hs | 138 ++++++++++++++++++ hbs21-git/hbs21-git.cabal | 1 + 9 files changed, 249 insertions(+), 25 deletions(-) create mode 100644 hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs index 17346c20..e3239467 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs @@ -3,8 +3,12 @@ module HBS2.Peer.Proto.LWWRef where import HBS2.Prelude.Plated +import HBS2.OrDie import HBS2.Base58 +import HBS2.Storage import HBS2.Hash +import HBS2.Net.Auth.Credentials +import HBS2.Net.Proto.Types import HBS2.Data.Types.SignedBox import HBS2.Data.Types.Refs import HBS2.Net.Proto.Types @@ -14,6 +18,9 @@ import Data.ByteString (ByteString) import Data.Hashable hiding (Hashed) import Data.Maybe import Data.Word +import Control.Monad.Trans.Maybe +import Control.Monad.Except +import Codec.Serialise data LWWRefProtoReq e = LWWProtoGet (LWWRefKey (Encryption e)) @@ -83,3 +90,50 @@ instance Pretty (LWWRef e) where | otherwise = parens ( "proof" <+> pretty lwwProof) +data ReadLWWRefError = + ReadLWWStorageError + | ReadLWWFormatError + | ReadLWWSignatureError + deriving stock (Show,Typeable) + +readLWWRef :: forall e s m . ( MonadIO m + , MonadError ReadLWWRefError m + , Encryption e ~ s + , ForLWWRefProto e + , Signatures s + , IsRefPubKey s + ) + => AnyStorage + -> LWWRefKey s + -> m (Maybe (LWWRef e)) + +readLWWRef sto key = runMaybeT do + getRef sto key + >>= toMPlus + >>= getBlock sto + >>= toMPlus + <&> deserialiseOrFail @(SignedBox (LWWRef e) e) + >>= orThrowError ReadLWWFormatError + <&> unboxSignedBox0 + >>= orThrowError ReadLWWSignatureError + <&> snd + +updateLWWRef :: forall s e m . ( Encryption e ~ s + , ForLWWRefProto e + , MonadIO m + , Signatures s + , IsRefPubKey s + ) + => AnyStorage + -> LWWRefKey s + -> PrivKey 'Sign s + -> LWWRef e + -> m (Maybe HashRef) + +updateLWWRef sto k sk v = do + let box = makeSignedBox @e (fromLwwRefKey k) sk v + runMaybeT do + hx <- putBlock sto (serialise box) >>= toMPlus + updateRef sto k hx + pure (HashRef hx) + diff --git a/hbs21-git/git-hbs21/Main.hs b/hbs21-git/git-hbs21/Main.hs index fb71c0fa..03d3b6ba 100644 --- a/hbs21-git/git-hbs21/Main.hs +++ b/hbs21-git/git-hbs21/Main.hs @@ -11,6 +11,7 @@ import HBS2.Git.Data.RefLog import HBS2.Git.Local.CLI qualified as Git import HBS2.Git.Data.Tx qualified as TX import HBS2.Git.Data.Tx (RepoHead(..)) +import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.GK import HBS2.Storage.Operations.ByteString @@ -46,6 +47,9 @@ pRefLogId :: ReadM RefLogId pRefLogId = maybeReader (fromStringMay @RefLogId) +pLwwKey :: ReadM (LWWRefKey HBS2Basic) +pLwwKey = maybeReader fromStringMay + pHashRef :: ReadM HashRef pHashRef = maybeReader (fromStringMay @HashRef) @@ -57,7 +61,7 @@ pInit = do pExport :: GitPerks m => Parser (GitCLI m ()) pExport = do - puk <- argument pRefLogId (metavar "REFLOG-KEY") + puk <- argument pLwwKey (metavar "REFLOG-KEY") et <- flag ExportInc ExportNew ( long "new" <> help "new is usable to export to a new empty reflog" @@ -86,7 +90,7 @@ pExport = do pImport :: GitPerks m => Parser (GitCLI m ()) pImport = do - puk <- argument pRefLogId (metavar "REFLOG-KEY") + puk <- argument pLwwKey (metavar "LWWREF") pure do git <- Git.findGitDir >>= orThrowUser "not a git dir" diff --git a/hbs21-git/git-remote-hbs21/Main.hs b/hbs21-git/git-remote-hbs21/Main.hs index 04c2fc4b..7bd78504 100644 --- a/hbs21-git/git-remote-hbs21/Main.hs +++ b/hbs21-git/git-remote-hbs21/Main.hs @@ -12,6 +12,7 @@ import HBS2.Git.Client.Config import HBS2.Git.Data.RefLog import HBS2.Git.Data.Tx qualified as TX import HBS2.Git.Data.Tx (RepoHead(..)) +import HBS2.Git.Data.LWWBlock import HBS2.System.Dir @@ -47,7 +48,7 @@ sendLine = liftIO . IO.putStrLn die :: (MonadIO m, Pretty a) => a -> m b die s = liftIO $ Exit.die (show $ pretty s) -parseURL :: String -> Maybe RefLogId +parseURL :: String -> Maybe (LWWRefKey HBS2Basic) parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s) where p = do @@ -55,7 +56,7 @@ parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s) Atto.takeWhile1 (`elem` getAlphabet) <&> BS8.unpack - <&> fromStringMay @RefLogId + <&> fromStringMay @(LWWRefKey HBS2Basic) >>= maybe (fail "invalid reflog key") pure parsePush :: String -> Maybe (Maybe GitRef, GitRef) @@ -111,7 +112,7 @@ main = do pause @'Seconds 0.25 liftIO $ hFlush stderr liftIO $ hPutDoc stderr $ "" - <> ul (yellow "Reflog" <+> pretty url <+> yellow "is not available yet.") <> line + <> ul (yellow "Reference" <+> pretty url <+> yellow "is not available yet.") <> line <> "If you sure it's a new one -- make sure you've added the key to hbs2-keyman and then run" <> line <> line <> "hbs2-keyman update" <> line <> line diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs index 7ecdddb8..3b1a17b0 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs @@ -62,6 +62,10 @@ drawProgress (ProgressQ q) = do put "" next qq + ImportWaitLWW n lww -> do + limit 0.25 $ put ("wait lwwref" <+> pretty lww <+> pretty n) + next quiet + ImportRefLogStart puk -> do put ("wait reflog" <+> pretty (AsBase58 puk)) next quiet diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs index df487b44..94c0a929 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs @@ -9,6 +9,7 @@ import HBS2.Git.Client.Progress import HBS2.Git.Data.RefLog import HBS2.Git.Data.Tx +import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.GK import HBS2.Git.Local.CLI @@ -38,6 +39,7 @@ instance Exception ExportError instance HasErrorStatus ExportError where getStatus = \case ExportUnsupportedOperation -> Failed + ExportBundleCreateError -> Failed instance ToFilePath (GitRef, GitHash) where toFilePath (g, r) = show (pretty g) @@ -143,10 +145,12 @@ storeNewGK0 = do writeAsMerkle sto (serialise gk) <&> HashRef <&> (,epoch) export :: (GitPerks m, MonadReader GitEnv m, GroupKeyOperations m) - => RefLogId + => LWWRefKey HBS2Basic -> [(GitRef,Maybe GitHash)] -> m () -export puk refs = do +export lww refs = do + + puk <- error "FIXME: puk" subscribeRefLog puk diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs index 16a48e67..348227d8 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs @@ -11,6 +11,7 @@ import HBS2.Git.Client.Progress import HBS2.Git.Data.RefLog import HBS2.Git.Data.Tx +import HBS2.Git.Data.LWWBlock import Data.ByteString.Lazy qualified as LBS @@ -26,7 +27,6 @@ import System.Exit data ImportRefLogNotFound = ImportRefLogNotFound deriving stock (Typeable,Show) - instance Exception ImportRefLogNotFound @@ -53,47 +53,64 @@ instance Show ImportTxError where instance Exception ImportTxError data IState = - IWaitRefLog Int - | IScanRefLog HashRef + IWaitLWWBlock Int + | IWaitRefLog Int RefLogId + | IScanRefLog RefLogId HashRef | IApplyTx HashRef | IExit importRepoWait :: (GitPerks m, MonadReader GitEnv m) - => RefLogId + => LWWRefKey HBS2Basic -> m () -importRepoWait puk = do +importRepoWait lwwKey = do env <- ask - subscribeRefLog puk - - ip <- asks _progress + ip <- asks _progress + sto <- asks _storage meet <- newTVarIO (mempty :: HashMap HashRef Int) - flip fix (IWaitRefLog 20) $ \next -> \case - IWaitRefLog w | w <= 0 -> do + flip fix (IWaitLWWBlock 20) $ \next -> \case + + IWaitLWWBlock w | w <= 0 -> do throwIO ImportRefLogNotFound - IWaitRefLog w -> do + IWaitLWWBlock w -> do + onProgress ip (ImportWaitLWW w lwwKey) + lww <- readLWWBlock @L4Proto sto lwwKey + + case lww of + Nothing -> do + pause @'Seconds 2 + next (IWaitLWWBlock (pred w)) + + Just blk -> do + error "FOUND SHIT!" + pure () + + IWaitRefLog w puk | w <= 0 -> do + throwIO ImportRefLogNotFound + + IWaitRefLog w puk -> do onProgress ip (ImportRefLogStart puk) try @_ @SomeException (getRefLogMerkle puk) >>= \case Left _ -> do onProgress ip (ImportRefLogDone puk Nothing) pause @'Seconds 2 - next (IWaitRefLog (pred w)) + next (IWaitRefLog (pred w) puk) Right Nothing -> do onProgress ip (ImportRefLogDone puk Nothing) pause @'Seconds 2 - next (IWaitRefLog (pred w)) + next (IWaitRefLog (pred w) puk) Right (Just h) -> do onProgress ip (ImportRefLogDone puk (Just h)) - next (IScanRefLog h) + next (IScanRefLog puk h) - IScanRefLog h -> do + IScanRefLog puk h -> do scanRefLog puk h withState (selectMaxSeqTxNotDone puk) >>= \case Just tx -> next (IApplyTx tx) @@ -108,7 +125,7 @@ importRepoWait puk = do onProgress ip (ImportWaitTx h) pause @'Seconds 0.25 - next (IScanRefLog h) + next (IScanRefLog puk h) IApplyTx h -> do onProgress ip (ImportApplyTx h) @@ -152,8 +169,7 @@ importRepoWait puk = do pure IExit else do pause @'Seconds 2 - pure (IWaitRefLog 5) - + pure (IWaitLWWBlock 5) scanRefLog :: (GitPerks m, MonadReader GitEnv m) => RefLogId diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs index 8e3a7c70..f865db30 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs @@ -4,6 +4,7 @@ module HBS2.Git.Client.Progress where import HBS2.Git.Client.Prelude import HBS2.Git.Data.RefLog +import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.Tx @@ -21,6 +22,7 @@ class HasProgress a where data ProgressEvent = ImportIdle + | ImportWaitLWW Int (LWWRefKey HBS2Basic) | ImportRefLogStart RefLogId | ImportRefLogDone RefLogId (Maybe HashRef) | ImportWaitTx HashRef diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs new file mode 100644 index 00000000..2e76defe --- /dev/null +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs @@ -0,0 +1,138 @@ +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} +module HBS2.Git.Data.LWWBlock + ( module HBS2.Git.Data.LWWBlock + , module HBS2.Peer.Proto.LWWRef + , HBS2Basic + ) where + +import HBS2.Prelude.Plated +import HBS2.OrDie +import HBS2.Net.Proto.Types +import HBS2.Data.Types.Refs +import HBS2.Data.Types.SignedBox +import HBS2.Net.Auth.Schema() +import HBS2.Net.Auth.Credentials +import HBS2.Storage +import HBS2.Peer.Proto.LWWRef + +import Data.Word +import Codec.Serialise +import System.Random + +import Control.Exception +import Control.Monad.Except +import Control.Monad.Trans.Maybe + +-- NOTE: on-lww-block-data +-- HKDF ( SK(LWWRef) , lwwRefNonce ) ==> SK( RefLog ) +-- lwwRefLogPubKey == PK ( SK (RefLog ) ) +-- +-- LWWBlock is required to make repo reference "stable", +-- i.e. it should remains the same even if the structure +-- of repository has been changed or it was, say, "trimmed". +-- +-- Therefore, there is the root key and the LWWRef, pointing +-- to a block, which contains actual seed data for the "current" +-- repo and it's possible to support permanent reference (LWWRef) +-- to a repo, while it's actual structure may be changed +-- (hbs2-git repo structure changes or garbage collecting (removing old +-- transactions, etc). +-- +-- (LWWRef PK) -> (LWWBlockData) -> (RefLog : [TX]) +-- + +data LWWBlockData e = + LWWBlockData + { lwwRefSeed :: Word64 + , lwwRefLogPubKey :: PubKey 'Sign (Encryption e) + } + deriving stock Generic + +data LWWBlock e = + LWWBlock1 { lwwBlockData :: LWWBlockData e } + deriving stock Generic + +instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlockData e) +instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlock e) + + +data LWWBlockOpError = + LWWBlockOpSkNotAvail + | LWWBlockOpStorageError + | LWWBlockOpSomeError + deriving stock (Show,Typeable,Generic) + +instance Exception LWWBlockOpError + + +readLWWBlock :: forall e s m . ( MonadIO m + , Signatures s + , s ~ Encryption e + , ForLWWRefProto e + , IsRefPubKey s + ) + => AnyStorage + -> LWWRefKey s + -> m (Maybe (LWWBlockData e)) + +readLWWBlock sto k = runMaybeT do + + LWWRef{..} <- runExceptT (readLWWRef @e sto k) + >>= toMPlus + >>= toMPlus + + getBlock sto (fromHashRef lwwValue) + >>= toMPlus + <&> deserialiseOrFail @(LWWBlock e) + >>= toMPlus + <&> lwwBlockData + +initLWWRef :: forall s e m . ( MonadIO m + , MonadError LWWBlockOpError m + , IsRefPubKey s + , ForSignedBox e + , HasDerivedKey s 'Sign Word64 m + , s ~ Encryption e + , Signatures s + ) + => AnyStorage + -> Maybe Word64 + -> ( PubKey 'Sign s -> m (Maybe (PrivKey 'Sign s) ) ) + -> LWWRefKey s + -> m HashRef +initLWWRef sto seed' findSk lwwKey = do + -- let k0 = fromLwwRefKey lww + seed <- maybe1 seed' randomIO pure + + let pk0 = fromLwwRefKey lwwKey + sk0 <- findSk pk0 + >>= orThrowError LWWBlockOpSkNotAvail + + lww0 <- runMaybeT do + getRef sto lwwKey >>= toMPlus + >>= getBlock sto >>= toMPlus + <&> deserialiseOrFail @(SignedBox (LWWRef e) e) + >>= toMPlus + <&> unboxSignedBox0 + >>= toMPlus + <&> snd + + (pk1, _) <- derivedKey @s @'Sign seed sk0 + + let newLwwData = LWWBlock1 (LWWBlockData @e seed pk1) + + hx <- putBlock sto (serialise newLwwData) + >>= orThrowError LWWBlockOpStorageError + <&> HashRef + + let lww :: LWWRef e + lww = LWWRef { lwwSeq = succ (maybe 0 lwwSeq lww0) + , lwwValue = hx + , lwwProof = Nothing + } + + updateLWWRef @s sto lwwKey sk0 lww + >>= orThrowError LWWBlockOpStorageError + + diff --git a/hbs21-git/hbs21-git.cabal b/hbs21-git/hbs21-git.cabal index 08a5e175..658cd841 100644 --- a/hbs21-git/hbs21-git.cabal +++ b/hbs21-git/hbs21-git.cabal @@ -103,6 +103,7 @@ library hbs2-git-client-lib HBS2.Git.Data.Tx HBS2.Git.Data.GK HBS2.Git.Data.RefLog + HBS2.Git.Data.LWWBlock HBS2.Git.Client.Prelude HBS2.Git.Client.App.Types