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

fixed reflog sync bug

This commit is contained in:
Dmitry Zuikov 2023-10-18 10:16:11 +03:00
parent 2962cc78ea
commit 29fdd23602
18 changed files with 108 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
examples/refchan-qblf/app/RefChanQBLFMain.hs
View File

@ -393,6 +393,7 @@ balances :: forall e s m . ( e ~ L4Proto
, s ~ Encryption e
, ToBalance L4Proto (EmitTx L4Proto)
, ToBalance L4Proto (MoveTx L4Proto)
, Pretty (AsBase58 (PubKey 'Sign s))
)
=> HashRef
-> m (HashMap (Account e) Amount)

1
hbs2-core/hbs2-core.cabal
View File

@ -127,6 +127,7 @@ library
, HBS2.Storage
, HBS2.Storage.Operations.Class
, HBS2.Storage.Operations.ByteString
, HBS2.Storage.Operations.Missed
, HBS2.System.Logger.Simple
, HBS2.System.Logger.Simple.Class
, HBS2.Net.Dialog.Core

12
hbs2-core/lib/HBS2/Actors/Peer.hs
View File

@ -6,16 +6,14 @@
module HBS2.Actors.Peer
( module HBS2.Actors.Peer
, module HBS2.Actors.Peer.Types
, HasStorage(..), AnyStorage(..)
) where
import HBS2.Actors
import HBS2.Actors.Peer.Types
import HBS2.Clock
import HBS2.Data.Types.Crypto
import HBS2.Data.Types.Peer
import HBS2.Defaults
import HBS2.Events
import HBS2.Hash
import HBS2.Net.Auth.Credentials
import HBS2.Net.Messaging
import HBS2.Net.PeerLocator
@ -28,7 +26,6 @@ import HBS2.System.Logger.Simple
import Data.Config.Suckless.KeyValue (HasConf(..))
import Control.Applicative
import Control.Monad.Trans.Maybe
import Control.Concurrent.Async
import Control.Monad.Reader
@ -37,7 +34,6 @@ import Data.Cache (Cache)
import Data.Cache qualified as Cache
import Data.Dynamic
import Data.Foldable hiding (find)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe
import GHC.TypeLits
@ -46,16 +42,10 @@ import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM
import UnliftIO (MonadUnliftIO(..))
import Crypto.Saltine.Core.SecretBox qualified as SBox -- Симметричное шифрование с nonce без подписи
import Crypto.Saltine.Core.Box qualified as Encrypt -- Асимметричное шифрование без подписи
import Control.Monad.IO.Unlift
import Codec.Serialise (serialise, deserialiseOrFail)
import Prettyprinter hiding (pipe)
-- import Debug.Trace
data AnyMessage enc e = AnyMessage !Integer !(Encoded e)
deriving stock (Generic)

21
hbs2-core/lib/HBS2/Actors/Peer/Types.hs
View File

@ -25,27 +25,6 @@ instance {-# OVERLAPPABLE #-}
-- instance HasConf m => HasConf (ResponseM e m)
instance (IsKey HbSync, MonadIO m) => Storage AnyStorage HbSync ByteString m where
putBlock (AnyStorage s) = liftIO . putBlock s
enqueueBlock (AnyStorage s) = liftIO . enqueueBlock s
getBlock (AnyStorage s) = liftIO . getBlock s
getChunk (AnyStorage s) h a b = liftIO $ getChunk s h a b
hasBlock (AnyStorage s) = liftIO . hasBlock s
updateRef (AnyStorage s) r v = liftIO $ updateRef s r v
getRef (AnyStorage s) = liftIO . getRef s
delBlock (AnyStorage s) = liftIO . delBlock s
delRef (AnyStorage s) = liftIO . delRef s
data AnyStorage = forall zu . ( Storage zu HbSync ByteString IO
) => AnyStorage zu
class HasStorage m where
getStorage :: m AnyStorage
instance (Monad m, HasStorage m) => HasStorage (MaybeT m) where
getStorage = lift getStorage
class (Monad m, HasProtocol e p) => HasGossip e p m where
gossip :: p -> m ()

6
hbs2-core/lib/HBS2/Data/Types/Refs.hs
View File

@ -66,12 +66,18 @@ type IsRefPubKey s = ( Eq (PubKey 'Sign s)
, Serialise (PubKey 'Sign s)
, FromStringMaybe (PubKey 'Sign s)
, Hashable (PubKey 'Sign s)
, Pretty (AsBase58 (PubKey 'Sign s))
)
type ForSomeRefKey a = ( Hashed HbSync a )
newtype SomeRefKey a = SomeRefKey a
instance Hashed HbSync (SomeRefKey a) => Pretty (SomeRefKey a) where
pretty a = pretty $ hashObject @HbSync a
-- instance Hashed HbSync (SomeRefKey a) => Pretty (AsBase58 (SomeRefKey a)) where
-- pretty a = pretty $ AsBase58 (hashObject @HbSync a)
-- TODO: fix-slow-hash-calculation
instance Serialise a => Hashed HbSync (SomeRefKey a) where
hashObject (SomeRefKey s) = hashObject (serialise s)

2
hbs2-core/lib/HBS2/Net/Proto/RefChan.hs
View File

@ -68,7 +68,7 @@ data RefChanHeadBlock e =
makeLenses 'RefChanHeadBlockSmall
type ForRefChans e = ( Serialise ( PubKey 'Sign (Encryption e))
-- , Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
, Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
, FromStringMaybe (PubKey 'Sign (Encryption e))
, Signatures (Encryption e)
, Serialise (Signature (Encryption e))

31
hbs2-core/lib/HBS2/Storage.hs
View File

@ -6,6 +6,8 @@ import HBS2.Prelude.Plated
import Data.Kind
import Lens.Micro.Platform
import Data.ByteString.Lazy (ByteString)
import Control.Monad.Trans.Maybe
import Codec.Serialise()
@ -46,10 +48,37 @@ class ( Monad m
updateRef :: Hashed h k => a -> k -> Key h -> m ()
getRef :: Hashed h k => a -> k -> m (Maybe (Key h))
getRef :: (Hashed h k, Pretty k) => a -> k -> m (Maybe (Key h))
delRef :: Hashed h k => a -> k -> m ()
data AnyStorage = forall zu . ( Storage zu HbSync ByteString IO
) => AnyStorage zu
class HasStorage m where
getStorage :: m AnyStorage
instance (Monad m, HasStorage m) => HasStorage (MaybeT m) where
getStorage = lift getStorage
instance (IsKey HbSync, MonadIO m) => Storage AnyStorage HbSync ByteString m where
putBlock (AnyStorage s) = liftIO . putBlock s
enqueueBlock (AnyStorage s) = liftIO . enqueueBlock s
getBlock (AnyStorage s) = liftIO . getBlock s
getChunk (AnyStorage s) h a b = liftIO $ getChunk s h a b
hasBlock (AnyStorage s) = liftIO . hasBlock s
updateRef (AnyStorage s) r v = liftIO $ updateRef s r v
getRef (AnyStorage s) = liftIO . getRef s
delBlock (AnyStorage s) = liftIO . delBlock s
delRef (AnyStorage s) = liftIO . delRef s
calcChunks :: forall a b . (Integral a, Integral b)
=> Integer -- | block size
-> Integer -- | chunk size

41
hbs2-core/lib/HBS2/Storage/Operations/Missed.hs Normal file
View File

@ -0,0 +1,41 @@
module HBS2.Storage.Operations.Missed where
import HBS2.Prelude.Plated
import HBS2.Data.Detect
import HBS2.Data.Types.Refs
import HBS2.Hash
import HBS2.Merkle
import HBS2.Storage
import Streaming.Prelude qualified as S
import Control.Monad.Trans.Maybe
import Control.Monad
import Data.Maybe
-- TODO: slow-dangerous
findMissedBlocks :: (MonadIO m) => AnyStorage -> HashRef -> m [HashRef]
findMissedBlocks sto href = do
S.toList_ $
walkMerkle (fromHashRef href) (lift . getBlock sto) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
case hr of
-- FIXME: investigate-this-wtf
Left{} -> pure ()
Right (hrr :: [HashRef]) -> do
forM_ hrr $ \hx -> runMaybeT do
blk <- lift $ getBlock sto (fromHashRef hx)
unless (isJust blk) do
lift $ S.yield hx
maybe1 blk none $ \bs -> do
let w = tryDetect (fromHashRef hx) bs
r <- case w of
Merkle{} -> lift $ lift $ findMissedBlocks sto hx
MerkleAnn{} -> lift $ lift $ findMissedBlocks sto hx
_ -> pure mempty
lift $ mapM_ S.yield r

29
hbs2-git/lib/HBS2Git/Import.hs
View File

@ -9,6 +9,7 @@ import HBS2.Merkle
import HBS2.Hash
import HBS2.Storage
import HBS2.Storage.Operations.Class
import HBS2.Storage.Operations.Missed
import HBS2.Storage.Operations.ByteString(TreeKey(..))
import HBS2.Net.Auth.GroupKeySymm
import HBS2.Net.Proto.RefLog
@ -64,32 +65,6 @@ isRunImportDry :: RunImportOpts -> Bool
isRunImportDry o = view runImportDry o == Just True
findMissedBlocks :: (MonadIO m, HasStorage m) => HashRef -> m [HashRef]
findMissedBlocks href = do
sto <- getStorage
S.toList_ $
walkMerkle (fromHashRef href) (lift . getBlock sto) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
case hr of
-- FIXME: investigate-this-wtf
Left{} -> pure ()
Right (hrr :: [HashRef]) -> do
forM_ hrr $ \hx -> runMaybeT do
blk <- lift $ getBlock sto (fromHashRef hx)
unless (isJust blk) do
lift $ S.yield hx
maybe1 blk none $ \bs -> do
let w = tryDetect (fromHashRef hx) bs
r <- case w of
Merkle{} -> lift $ lift $ findMissedBlocks hx
MerkleAnn{} -> lift $ lift $ findMissedBlocks hx
_ -> pure mempty
lift $ mapM_ S.yield r
walkHashes :: (MonadIO m, HasStorage m) => TQueue HashRef -> Hash HbSync -> m ()
walkHashes q h = walkMerkle h (readBlock . HashRef) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
@ -197,7 +172,7 @@ importRefLogNew opts ref = runResourceT do
-- TODO: might-be-slow
entries <- S.toList_ $ forM_ entries' $ \e -> do
updateProgress pMiss 1
missed <- lift $ findMissedBlocks e
missed <- lift $ findMissedBlocks sto e
if null missed then do
S.yield e
else do

2
hbs2-git/lib/HBS2Git/Types.hs
View File

@ -16,7 +16,7 @@ import HBS2.Prelude.Plated
import HBS2.Hash
import HBS2.Clock
import HBS2.Git.Types
import HBS2.Actors.Peer.Types (HasStorage(..),AnyStorage(..))
import HBS2.Storage
import HBS2.Peer.RPC.Client.Unix hiding (Cookie)
import HBS2.Net.Proto.RefLog (RefLogKey(..))
import HBS2.Net.Auth.Credentials

3
hbs2-peer/app/PeerMain/Dialog/Server.hs
View File

@ -12,6 +12,7 @@ import Lens.Micro.Platform
import HBS2.Actors.Peer
import HBS2.Data.Types.Refs
import HBS2.Base58
import HBS2.Hash
import HBS2.Net.Dialog.Core
import HBS2.Net.Proto.RefLog
@ -66,6 +67,7 @@ dialogRoutes' :: forall m .
, Serialise (PubKey 'Sign (Encryption L4Proto))
, FromStringMaybe (PubKey 'Sign (Encryption L4Proto))
, Hashable (PubKey 'Sign (Encryption L4Proto))
, Pretty (AsBase58 (PubKey 'Sign (Encryption L4Proto)))
)
=> PeerEnv L4Proto
-> DialogRequestRouter m
@ -145,6 +147,7 @@ type Unconstraints =
( Serialise (PubKey 'Sign (Encryption L4Proto))
, Hashable (PubKey 'Sign (Encryption L4Proto))
, Show (PubKey 'Sign (Encryption L4Proto))
, Pretty (AsBase58 (PubKey 'Sign (Encryption L4Proto)))
, Typeable (PubKey 'Sign (Encryption L4Proto))
, FromStringMaybe (PubKey 'Sign (Encryption L4Proto))
)

10
hbs2-peer/app/PeerTypes.hs
View File

@ -23,6 +23,7 @@ import HBS2.Net.Proto.Definition
import HBS2.Net.Proto.Sessions
import HBS2.Prelude.Plated
import HBS2.Storage
import HBS2.Storage.Operations.Missed
import HBS2.Net.PeerLocator
import HBS2.Net.Proto.PeerMeta
import HBS2.System.Logger.Simple
@ -477,15 +478,10 @@ pingPeerWait pa = do
checkDownloaded :: forall m . (MonadIO m, HasStorage m) => HashRef -> m Bool
checkDownloaded hr = do
sto <- getStorage
let readBlock h = liftIO $ getBlock sto h
result <- S.toList_ $
deepScan ScanDeep (const $ S.yield Nothing) (fromHashRef hr) readBlock $ \ha -> do
unless (fromHashRef hr == ha) do
here <- liftIO $ hasBlock sto ha
S.yield here
missed <- findMissedBlocks sto hr
pure $ maybe False (not . List.null) $ sequence result
pure $ null missed
data Polling =
Polling

1
hbs2-peer/app/RPC2/Poll.hs
View File

@ -6,6 +6,7 @@ import HBS2.Prelude.Plated
import HBS2.Net.Proto.Service
import HBS2.Peer.Brains
import HBS2.System.Logger.Simple
import HBS2.Net.Proto.Definition()
import HBS2.Peer.RPC.API.Peer
import HBS2.Peer.RPC.Internal.Types

19
hbs2-peer/app/RefLog.hs
View File

@ -12,6 +12,7 @@ import HBS2.Net.PeerLocator
import HBS2.Net.Proto
import HBS2.Base58
import HBS2.Storage
import HBS2.Storage.Operations.Missed
import HBS2.Hash
import HBS2.Net.Proto.Peer
import HBS2.Net.Proto.RefLog
@ -169,11 +170,11 @@ reflogWorker conf brains adapter = do
trace $ "reflog worker. GOT REFLOG ANSWER" <+> pretty (AsBase58 reflog) <+> pretty h
reflogDownload adapter h
fix \next -> do
missed <- missedEntries sto h
missed <- findMissedBlocks sto (HashRef h)
if not (null missed) then do
for_ missed $ reflogDownload adapter
for_ missed $ reflogDownload adapter . fromHashRef
pause @'Seconds 1
trace $ "reflogWorker: missed refs for" <+> pretty h <+> pretty missed
debug $ "reflogWorker: MISSED REFS FOR" <+> pretty h <+> pretty missed
next
else do
trace $ "block" <+> pretty h <+> "is downloaded"
@ -264,17 +265,5 @@ reflogWorker conf brains adapter = do
re <- liftIO $ atomically $ flushTQueue treeQ
pure $ mconcat re
missedEntries sto h = do
missed <- liftIO $ newTVarIO mempty
walkMerkle h (getBlock sto) $ \hr -> do
case hr of
Left ha -> do
atomically $ modifyTVar missed (ha:)
Right (hs :: [HashRef]) -> do
w <- mapM ( hasBlock sto . fromHashRef ) hs <&> fmap isJust
let mi = [ hx | (False,hx) <- zip w hs ]
for_ mi $ \hx -> liftIO $ atomically $ modifyTVar missed (fromHashRef hx:)
liftIO $ readTVarIO missed

2
hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs
View File

@ -5,7 +5,7 @@ import HBS2.Actors.Peer
import HBS2.Net.Proto.Service
import HBS2.Net.Messaging.Unix
import HBS2.Peer.RPC.Internal.Types
import HBS2.Storage (Offset,Size)
import HBS2.Storage
import HBS2.Data.Types.Refs (HashRef(..),RefAlias(..))
import Control.Monad.Reader

1
hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs
View File

@ -6,6 +6,7 @@ module HBS2.Peer.RPC.Internal.Types
import HBS2.Actors.Peer
import HBS2.Net.Proto.Types
import HBS2.Storage
import HBS2.Data.Types.Refs (HashRef)
import HBS2.Data.Types.SignedBox
import HBS2.Net.Messaging.Unix

13
hbs2-storage-simple/lib/HBS2/Storage/Simple.hs
View File

@ -368,17 +368,18 @@ simpleWriteLinkRawRef ss h ref = do
`catchAny` \_ -> do
err $ "simpleWriteLinkRawRef" <+> pretty h <+> pretty ref <+> pretty fnr
simpleReadLinkRaw :: IsKey h
simpleReadLinkRaw :: forall r h . ( IsKey h, Hashed h r, Pretty r)
=> SimpleStorage h
-> Hash h
-> r
-> IO (Maybe LBS.ByteString)
simpleReadLinkRaw ss hash = do
simpleReadLinkRaw ss ref = do
let hash = hashObject @h ref
let fn = simpleRefFileName ss hash
rs <- spawnAndWait ss $ do
-- FIXME: log-this-situation
(Just <$> LBS.readFile fn) `catchAny` \e -> do
err $ "simpleReadLinkRaw" <+> pretty hash <+> pretty fn <+> viaShow e
err $ "simpleReadLinkRaw" <+> pretty ref <+> pretty fn <+> viaShow e
pure Nothing
pure $ fromMaybe Nothing rs
@ -426,9 +427,9 @@ instance ( MonadIO m, IsKey hash
void $ liftIO $ simpleWriteLinkRawRef ss refHash v
getRef ss ref = do
let refHash = hashObject @hash ref
runMaybeT do
bs <- MaybeT $ liftIO $ simpleReadLinkRaw ss refHash
-- debug $ "REF" <+> pretty (AsBase58 ref)
bs <- MaybeT $ liftIO $ simpleReadLinkRaw ss ref
let bss = LBS.toStrict bs
parsed <- MaybeT $ pure $ fromByteString bss
pure $ unAsBase58 parsed

8
hbs2-storage-simple/test/TestSimpleStorage.hs
View File

@ -1,9 +1,9 @@
module TestSimpleStorage where
import HBS2.Prelude.Plated
import HBS2.OrDie
import HBS2.Hash
import HBS2.Clock
import HBS2.Prelude.Plated
import HBS2.Data.Types.Refs
import HBS2.Storage
import HBS2.Storage.Simple
@ -195,20 +195,20 @@ testSimpleStorageRefs = do
link worker
let k = "JOPAKITA" :: LBS.ByteString
let k = SomeRefKey "JOPAKITA" -- :: LBS.ByteString
let v = "PECHENTRESKI" :: LBS.ByteString
vh <- putBlock storage v `orDie` "cant write"
updateRef storage k vh
qqq <- simpleReadLinkRaw storage (hashObject k)
qqq <- simpleReadLinkRaw storage k
pechen <- getRef storage k
assertEqual "kv1" (Just vh) pechen
non <- getRef storage ("QQQQQ" :: LBS.ByteString)
non <- getRef storage (SomeRefKey "QQQQQ")
assertEqual "kv2" Nothing non