NCQv1 -> NCQ3 migration

hbs2-cli/app/Main.hs

@@ -16,6 +16,7 @@ import HBS2.CLI.Run.RefLog
 import HBS2.CLI.Run.RefChan
 import HBS2.CLI.Run.LWWRef
 import HBS2.CLI.Run.Mailbox
+import HBS2.CLI.NCQ3.Migrate
 
 import Data.Config.Suckless.Script.File as SF
 
@@ -37,6 +38,7 @@ setupLogger = do
   setLogging @ERROR  $ toStderr . logPrefix "[error] "
   setLogging @WARN   $ toStderr . logPrefix "[warn] "
   setLogging @NOTICE $ toStderr . logPrefix ""
+  setLogging @INFO   $ toStderr . logPrefix ""
   pure ()
 
 flushLoggers :: MonadIO m => m ()
@@ -79,6 +81,7 @@ main = do
         refchanEntries
         lwwRefEntries
         mailboxEntries
+        migrateEntries
         helpEntries
 
         SF.entries

hbs2-cli/hbs2-cli.cabal

@@ -57,6 +57,7 @@ common shared-properties
         hbs2-core
       , hbs2-peer
       , hbs2-storage-simple
+      , hbs2-storage-ncq
       , hbs2-keyman-direct-lib
       , db-pipe
       , suckless-conf
@@ -124,6 +125,7 @@ library
       HBS2.CLI.Run.Sigil
 
       HBS2.CLI.Run.Help
+      HBS2.CLI.NCQ3.Migrate
 
     build-depends:    base
                     , magic

hbs2-cli/lib/HBS2/CLI/NCQ3/Migrate.hs

@@ -0,0 +1,165 @@
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.CLI.NCQ3.Migrate where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Base58
+import HBS2.Data.Types.Refs
+import HBS2.Hash
+import HBS2.Net.Auth.Schema()
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.API.LWWRef
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefLog
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Storage
+import HBS2.Storage.NCQ3
+import HBS2.Storage.NCQ3.Internal.Files
+import HBS2.Storage.NCQ3.Internal.Fossil
+import HBS2.Storage.NCQ3.Internal.Index
+import HBS2.Storage.NCQ3.Internal.Prelude
+import HBS2.Peer.Proto.RefLog
+import HBS2.Peer.Proto.RefChan
+import HBS2.Peer.Proto.LWWRef
+
+import Data.Config.Suckless.System
+
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString qualified as BS
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import Data.HashSet (HashSet)
+import Data.HashSet qualified as HS
+import Data.Either
+import Data.List qualified as L
+import System.Directory (getModificationTime)
+import UnliftIO.IO
+
+import Streaming.Prelude qualified as S
+
+{- HLINT ignore "Functor law"-}
+
+data SomeRef = forall a . (Hashed HbSync a, Pretty a, RefMetaData a) => SomeRef a
+
+instance RefMetaData SomeRef where
+  refMetaData (SomeRef a) = refMetaData a
+
+instance Pretty SomeRef where
+  pretty (SomeRef wtf) = pretty wtf
+
+instance Hashed HbSync SomeRef where
+  hashObject (SomeRef a) = hashObject a
+
+legacyHashRefNCQ1 :: HashRef -> HashRef -> HashRef
+legacyHashRefNCQ1 salt h = HashRef (hashObject (coerce @_ @ByteString h <> coerce salt))
+
+legacyHashRefFor :: Hashed HbSync p => HashRef -> p -> HashRef
+legacyHashRefFor salt x = legacyHashRefNCQ1 salt (HashRef $ hashObject @HbSync $ x)
+
+migrateEntries :: forall c m . ( MonadUnliftIO m
+                               , IsContext c
+                               , Exception (BadFormException c)
+                               , HasClientAPI PeerAPI UNIX m
+                               , HasStorage m
+                               ) => MakeDictM c m ()
+migrateEntries = do
+  brief "migrate NCQv1 => NCQ3"
+   $ args [ arg "path" "src"
+          , arg "path" "dst"
+          ]
+
+   $ entry $ bindMatch "ncq3:migrate:ncq" $ nil_ $ \case
+       [ StringLike src, StringLike dst] -> do
+
+        sto <- getStorage
+
+        let a0 = src </> "0"
+        a0here <- doesPathExist a0
+
+        let a = if a0here then a0 else src
+
+        ncqSalt <- liftIO (try @_ @IOException (BS.readFile (a </> ".seed")))
+                     <&> fromRight mempty
+                     <&> HashRef . hashObject
+
+        api <- getClientAPI @PeerAPI  @UNIX
+
+        refs <- callRpcWaitMay @RpcPollList2 (1.0 :: Timeout 'Seconds) api (Nothing, Nothing)
+                  <&> fromMaybe mempty
+
+        rrefs <- S.toList_ <$> for refs $ \(pk, s, _) -> case s of
+                   "reflog"  -> S.yield (SomeRef $ RefLogKey @'HBS2Basic pk)
+                   "refchan" -> S.yield (SomeRef $ RefChanLogKey @'HBS2Basic pk)
+                   "lwwref"  -> S.yield (SomeRef $ LWWRefKey @'HBS2Basic pk)
+                   _         -> none
+
+        lift $ migrateNCQ1 nicelog sto rrefs a dst
+
+       e -> throwIO $ BadFormException (mkList e)
+
+nicelog :: forall m . MonadIO  m => Doc AnsiStyle -> m ()
+nicelog doc = liftIO $ hPutDoc stdout (doc <> line)
+
+migrateNCQ1 :: MonadUnliftIO m
+            => ( Doc AnsiStyle -> IO () )
+            -> AnyStorage
+            -> [SomeRef]
+            -> FilePath
+            -> FilePath
+            -> m ()
+migrateNCQ1 logger origSto refs a b = flip runContT pure do
+  debug "migrate NCQ to NCQ3"
+
+  ncq <- ContT $ ncqWithStorage b
+
+  let sto = AnyStorage ncq
+
+  let mlog = ncqGetFileName ncq "migrate-ncq1.log"
+
+  debug $ "set SOURCE dir" <+> pretty a
+
+  files <- do
+    fs <- dirFiles a <&> L.filter (\x -> takeExtension x == ".data")
+    mtimes <- liftIO $ mapM getModificationTime fs
+    pure [ f | (f,_) <- L.sortOn (Down . snd) (zip fs mtimes) ]
+
+  touch mlog
+
+  processed <- HS.fromList . lines <$> liftIO (readFile mlog)
+
+  for_ files $ \f -> void $ runMaybeT do
+
+    guard ( not $ HS.member f processed )
+
+    debug $ "processing" <+> pretty f
+
+    ncqStorageScanDataFile0 f $ \offset w key s -> void $ runMaybeT do
+      (t, bs) <- toMPlus (ncqEntryUnwrapValue s)
+
+      case t of
+        B -> do
+          h1 <- putBlock sto (LBS.fromStrict bs)
+          let okay = if Just key == (HashRef <$> h1) then green "ok" else red "fail"
+          liftIO $ logger $ okay <+> pretty t <+> pretty key <+> pretty offset <+> pretty (BS.length bs)
+
+        R -> do
+          debug $ "ommiting reference yet" <+> pretty key
+
+        _ -> none
+
+
+    liftIO $ appendFile mlog (f <> "\n")
+
+  for_ refs $ \(SomeRef r) -> void $ runMaybeT do
+    v  <- getRef origSto r >>= toMPlus
+    v0 <- hasBlock origSto v
+    v1 <- hasBlock sto v
+    updateRef sto r v
+    v3 <- getRef sto r
+    let okay = if v3  == Just v then green "ok" else red "fail"
+    liftIO $ logger $ okay <+> "update ref" <+> pretty r <+> pretty v <+> pretty v1 <+> parens (pretty v0)
+
+

hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs

@@ -215,6 +215,13 @@ ncqStorageScanDataFile :: MonadIO m
                        -> m ()
 ncqStorageScanDataFile ncq fp' action = do
   let fp = ncqGetFileName ncq fp'
+  ncqStorageScanDataFile0 fp action
+
+ncqStorageScanDataFile0 :: MonadIO m
+                        => FilePath
+                        -> ( Integer -> Integer -> HashRef -> ByteString -> m () )
+                        -> m ()
+ncqStorageScanDataFile0  fp action = do
   mmaped <- liftIO $ logErr "ncqStorageScanDataFile" (mmapFileByteString fp Nothing)
 
   flip runContT pure $ callCC \exit -> do

hbs2-tests/test/NCQ3.hs

@@ -864,6 +864,7 @@ ncq3Tests = do
   ncq3EnduranceTest
   ncq3EnduranceTestInProc
 
+
 testNCQ3Concurrent1 :: MonadUnliftIO m
          => Bool
          -> Int