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

wip

This commit is contained in:
Dmitry Zuikov 2024-03-14 11:46:30 +03:00
parent a3b9e7ff2e
commit 8c45e317e6
9 changed files with 249 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs
View File

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

8
hbs21-git/git-hbs21/Main.hs
View File

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

7
hbs21-git/git-remote-hbs21/Main.hs
View File

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

4
hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs
View File

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

8
hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs
View File

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

52
hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs
View File

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

2
hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs
View File

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

138
hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs Normal file
View File

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

1
hbs21-git/hbs21-git.cabal
View File

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