fixed reflog sync bug

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)

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

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)

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

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)

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

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

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

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

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

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

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_ $
+  missed <- findMissedBlocks sto hr
-              deepScan ScanDeep (const $ S.yield Nothing) (fromHashRef hr) readBlock $ \ha -> do
-                unless (fromHashRef hr == ha) do
-                  here <- liftIO $ hasBlock sto ha
-                  S.yield here
 
-  pure $ maybe False (not . List.null)  $ sequence result
+  pure $ null missed
 
 data Polling =
   Polling

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

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
 
 

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

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

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

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