mirror of https://github.com/voidlizard/hbs2
147 lines
4.1 KiB
Haskell
147 lines
4.1 KiB
Haskell
module HBS2.Peer.NCQ3.Migrate.NCQ where
|
|
|
|
|
|
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.Config.Suckless.Script
|
|
|
|
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.HashMap.Strict qualified as HM
|
|
import Data.HashMap.Strict (HashMap)
|
|
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 WrapRef = forall a . ( Hashed HbSync a
|
|
, Pretty a
|
|
, RefMetaData a
|
|
)
|
|
=> WrapRef a
|
|
|
|
instance RefMetaData WrapRef where
|
|
refMetaData (WrapRef a) = refMetaData a
|
|
|
|
instance Pretty WrapRef where
|
|
pretty (WrapRef wtf) = pretty wtf
|
|
|
|
instance Hashed HbSync WrapRef where
|
|
hashObject (WrapRef 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)
|
|
|
|
migrateNCQ1 :: MonadUnliftIO m
|
|
=> ( Doc AnsiStyle -> IO () )
|
|
-> [WrapRef]
|
|
-> FilePath
|
|
-> FilePath
|
|
-> m ()
|
|
migrateNCQ1 logger refs src b = flip runContT pure do
|
|
debug "migrate NCQ to NCQ3"
|
|
|
|
let a0 = src </> "0"
|
|
a0here <- doesPathExist a0
|
|
|
|
let a = if a0here then a0 else src
|
|
|
|
ncq <- ContT $ ncqWithStorage b
|
|
|
|
let sto = AnyStorage ncq
|
|
|
|
let mlog = ncqGetFileName ncq "migrate-ncq1.log"
|
|
|
|
info $ "set SOURCE dir" <+> pretty a
|
|
|
|
ncqSalt <- liftIO (try @_ @IOException (BS.readFile (src </> ".seed")))
|
|
<&> fromRight mempty
|
|
<&> HashRef . hashObject
|
|
|
|
notice $ "ref. salt" <+> pretty ncqSalt
|
|
|
|
files <- do
|
|
fs <- dirFiles a <&> L.filter (\x -> takeExtension x == ".data")
|
|
mtimes <- liftIO $ mapM getModificationTime fs
|
|
pure [ f | (f,_) <- L.sortOn snd (zip fs mtimes) ]
|
|
|
|
touch mlog
|
|
|
|
processed <- HS.fromList . lines <$> liftIO (readFile mlog)
|
|
|
|
let refz = HM.fromList [ (legacyHashRefFor ncqSalt r, WrapRef r) | WrapRef r <- refs ]
|
|
|
|
rv <- newTVarIO ( mempty :: HashMap HashRef (WrapRef, HashRef) )
|
|
nblk <- newTVarIO 0
|
|
|
|
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
|
|
let h0 = hashObject @HbSync bs
|
|
if h0 /= coerce key then do
|
|
err $ red "damaged block" <+> pretty key <+> "skip"
|
|
else do
|
|
void $ putBlock sto (LBS.fromStrict bs)
|
|
atomically $ modifyTVar nblk succ
|
|
|
|
R -> do
|
|
case HM.lookup key refz of
|
|
Nothing -> none
|
|
Just r -> do
|
|
atomically $ modifyTVar rv (HM.insert (HashRef $ hashObject r) (r, HashRef (coerce bs)))
|
|
|
|
_ -> none
|
|
|
|
|
|
liftIO $ appendFile mlog (f <> "\n")
|
|
|
|
nb <- readTVarIO nblk
|
|
liftIO $ logger $ "moved" <+> pretty nb <+> "blocks"
|
|
|
|
foundRefs <- readTVarIO rv <&> HM.toList
|
|
for_ foundRefs $ \(_, (r, v)) -> do
|
|
blk <- hasBlock sto (coerce v)
|
|
when (isJust blk) do
|
|
liftIO $ logger $ green "update ref" <+> pretty r <+> pretty v
|
|
updateRef sto r (coerce v)
|
|
|