diff --git a/examples/refchan-qblf/app/RefChanQBLFMain.hs b/examples/refchan-qblf/app/RefChanQBLFMain.hs index a754947b..47d7464b 100644 --- a/examples/refchan-qblf/app/RefChanQBLFMain.hs +++ b/examples/refchan-qblf/app/RefChanQBLFMain.hs @@ -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) diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index bcccd430..85b49bcb 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -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 diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 1199babf..a141dd4f 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -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) diff --git a/hbs2-core/lib/HBS2/Actors/Peer/Types.hs b/hbs2-core/lib/HBS2/Actors/Peer/Types.hs index 9fc6e280..6aaacefd 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer/Types.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer/Types.hs @@ -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 () diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index f032df44..9e2aab17 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -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) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs index 9dabb793..077840e8 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs @@ -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)) diff --git a/hbs2-core/lib/HBS2/Storage.hs b/hbs2-core/lib/HBS2/Storage.hs index e0f8398e..16f39852 100644 --- a/hbs2-core/lib/HBS2/Storage.hs +++ b/hbs2-core/lib/HBS2/Storage.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs b/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs new file mode 100644 index 00000000..b8676b42 --- /dev/null +++ b/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs @@ -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 + + diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs index c8a03438..ab199ae3 100644 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ b/hbs2-git/lib/HBS2Git/Import.hs @@ -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 diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index f08f512f..4e155f65 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/hbs2-git/lib/HBS2Git/Types.hs @@ -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 diff --git a/hbs2-peer/app/PeerMain/Dialog/Server.hs b/hbs2-peer/app/PeerMain/Dialog/Server.hs index f7c0bb5e..af3c786a 100644 --- a/hbs2-peer/app/PeerMain/Dialog/Server.hs +++ b/hbs2-peer/app/PeerMain/Dialog/Server.hs @@ -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)) ) diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index ef300096..496299f0 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -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 diff --git a/hbs2-peer/app/RPC2/Poll.hs b/hbs2-peer/app/RPC2/Poll.hs index 839c174e..59f2b1c1 100644 --- a/hbs2-peer/app/RPC2/Poll.hs +++ b/hbs2-peer/app/RPC2/Poll.hs @@ -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 diff --git a/hbs2-peer/app/RefLog.hs b/hbs2-peer/app/RefLog.hs index a8c0de69..d71ef8b4 100644 --- a/hbs2-peer/app/RefLog.hs +++ b/hbs2-peer/app/RefLog.hs @@ -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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs index a66a0d33..000d3c6a 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs @@ -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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs index 0cf6496f..a3d8efa2 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs @@ -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 diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 210c456d..1a6fd75c 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs @@ -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 diff --git a/hbs2-storage-simple/test/TestSimpleStorage.hs b/hbs2-storage-simple/test/TestSimpleStorage.hs index 1eee77aa..76a71505 100644 --- a/hbs2-storage-simple/test/TestSimpleStorage.hs +++ b/hbs2-storage-simple/test/TestSimpleStorage.hs @@ -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