diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index 949d46d7..8a9113a3 100644 --- a/hbs2-cli/app/Main.hs +++ b/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 diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index 1920fc24..5a041b59 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/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 diff --git a/hbs2-cli/lib/HBS2/CLI/NCQ3/Migrate.hs b/hbs2-cli/lib/HBS2/CLI/NCQ3/Migrate.hs new file mode 100644 index 00000000..12f637ff --- /dev/null +++ b/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) + + diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs index 63e9a6c4..98795b21 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Index.hs +++ b/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 diff --git a/hbs2-tests/test/NCQ3.hs b/hbs2-tests/test/NCQ3.hs index 7da8b858..ec80d8fa 100644 --- a/hbs2-tests/test/NCQ3.hs +++ b/hbs2-tests/test/NCQ3.hs @@ -864,6 +864,7 @@ ncq3Tests = do ncq3EnduranceTest ncq3EnduranceTestInProc + testNCQ3Concurrent1 :: MonadUnliftIO m => Bool -> Int