storage migration routine

hbs2-peer/app/Migrate.hs

@@ -0,0 +1,268 @@
+module Migrate where
+
+import HBS2.Prelude.Plated
+import HBS2.Misc.PrettyStuff
+import HBS2.Hash
+import HBS2.Data.Types.Refs
+import HBS2.OrDie
+import HBS2.Defaults
+import HBS2.Storage.NCQ
+import Log
+import PeerConfig
+
+import Data.Config.Suckless.Script hiding (optional)
+import Data.Config.Suckless.Script.File (glob)
+import Data.Config.Suckless.System as Sy
+import Data.Config.Suckless.Almost.RPC
+
+import Data.Char
+import Data.Coerce
+import Data.Maybe
+import System.FilePath
+import System.Directory
+import System.IO as IO
+import System.IO.Temp as Temp
+import System.Exit
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
+import Control.Exception
+import Control.Monad.Cont
+
+import UnliftIO
+-- import UnliftIO.Temporary
+
+migrate :: [Syntax C]-> IO ()
+migrate syn = flip runContT pure $ callCC \exit -> do
+
+  xdg <- liftIO $ getXdgDirectory XdgData defStorePath <&> fromString
+
+
+  let (opts, argz) = splitOpts [ ("-n",0)
+                               , ("--dry",0)
+                               , ("--no-refs",0)
+                               , ("--help",0)
+                               ] syn
+
+  prefix <- headMay [ p | StringLike p  <- argz ]
+            & orThrowUser ( "Storage dir not specified" <+> parens ("typically" <+> pretty xdg) <> line
+                            <> line
+                            <> "run hbs2-peer migrate"  <+> pretty xdg <> line
+                            <> "if this is it"
+                          )
+
+
+  let dry = or [ True | ListVal [StringLike s] <- opts, s `elem` ["--dry","-n"]]
+
+  let norefs = or [ True | ListVal [StringLike "--no-refs"] <- opts ]
+
+
+  let store = prefix
+
+  let migrateDir = store </> "migrate"
+  let ncqDir = store </> "ncq"
+
+  liftIO $ IO.hSetBuffering stdin  NoBuffering
+  liftIO $ IO.hSetBuffering stdout LineBuffering
+
+  already <- Sy.doesDirectoryExist migrateDir
+
+  when already do
+    liftIO $ hPutDoc stdout $ yellow "Found migration WIP" <+> pretty migrateDir <> "," <+> "continue" <> line
+
+  liftIO $ hPutDoc stdout $
+    yellow "Storage migration process is about to start" <> line
+     <> "It will convert the current storage structure to a new one (NCQ storage)" <> line
+     <> "to use with hbs2 0.26 and newer" <> line
+     <> "hbs2-peer 0.25 and earlier versions  don't work with the new storage." <> line
+     <> "If you want to backup your data first just for in case" <> line
+     <> "You may store the contents of directory" <> line
+     <> line
+     <> pretty prefix
+     <> line <> line
+     <> "specifically" <+> pretty (prefix </> "blocks") <+> "and" <+> pretty (prefix</> "refs")
+     <> line
+     <> "to roll back to the older version --- just restore them"
+     <> line
+
+  liftIO do
+    IO.hFlush stdout
+    IO.hFlush stderr
+    putStr  "Start the migration process? [y]: "
+    IO.hFlush stdout
+
+  y <- liftIO getChar
+
+  unless ( toUpper y == 'Y' ) $ exit ()
+
+  liftIO do
+    putStrLn ""
+
+  info $ "migration started" <+> pretty opts
+
+  info $ "create dir" <+> pretty migrateDir
+
+  mkdir migrateDir
+
+  wip <- Sy.doesDirectoryExist migrateDir
+
+  source <- if dry && not wip then do
+              pure store
+            else do
+              info $ yellow "Real migration," <+> "fasten the sit belts!"
+              let srcDir = migrateDir </> "source"
+              mkdir srcDir
+              let inBlk = store </> "blocks"
+              let inRefs = store </> "refs"
+
+              e1 <- Sy.doesDirectoryExist inBlk
+
+              when e1 $ mv  inBlk  (srcDir </> "blocks")
+
+              e2 <- Sy.doesDirectoryExist inRefs
+
+              when e2 $ mv  inRefs (srcDir </> "refs")
+
+              pure srcDir
+
+  tmp <- ContT $ Temp.withTempDirectory migrateDir "run"
+
+  info $ "create dir" <+> pretty tmp
+
+  let blkz  = source </> "blocks"
+  let refz  = source </> "refs"
+
+  let b = tmp </> "blocks"
+  let r = tmp </> "refs"
+
+  info $ "create directory links"
+  info $ pretty blkz <+> pretty b
+  liftIO $ createDirectoryLink blkz b
+
+  info $ pretty refz <+> pretty r
+  liftIO $ createDirectoryLink refz r
+
+  ncq <- ContT $ withNCQ id ncqDir
+
+  let nameToHash fn =
+        fromString @HashRef $ mconcat $ reverse $ take 2 $ reverse $ splitDirectories fn
+
+  let hashToPath ha = do
+        let (p,r) = splitAt 1 (show $ pretty ha)
+        p </> r
+
+  checkQ <- newTQueueIO
+  checkN <- newTVarIO 0
+
+  glob ["**/*"] [] b $ \fn -> flip runContT pure $ callCC \next -> do
+    sz <- liftIO $ getFileSize fn
+
+    when (sz >= 1024^3 ) do
+      err $ red "Block is too large; skipping" <+> pretty fn
+      next True
+
+    when (sz >= 1024^2 ) do
+      warn $ yellow "Block is too large; but okay" <+> pretty fn
+
+    let hs = nameToHash fn
+
+    bs <- liftIO $ BS.readFile fn
+    let h = HashRef $ hashObject @HbSync bs
+
+    unless ( h == hs ) do
+      err $ red "Hash doesn't match content" <+> pretty fn
+      next True
+
+    placed <- liftIO $ ncqStoragePutBlock ncq (LBS.fromStrict bs)
+
+    unless ( placed == Just hs ) do
+      err $ red "NCQ write error" <+> pretty fn
+      next True
+
+    for_ placed $ \hx -> atomically do
+      writeTQueue checkQ hx
+      modifyTVar checkN succ
+
+    info $ green "ok" <+> "B" <+> fill 44 (pretty placed) <+> pretty sz
+
+    pure True
+
+  unless norefs do
+    glob ["**/*"] [] r $ \fn -> flip runContT pure $ callCC \next -> do
+
+      let ref = nameToHash fn
+
+      ncqRef <- liftIO $ ncqStorageGetRef ncq ref
+
+      when (isJust ncqRef) do
+        info $ yellow "keep" <+> "R" <+> pretty ref
+        next True
+
+      refTo <- liftIO (readFile fn)
+                <&> coerce @_ @HashRef . fromString @(Hash HbSync)
+
+      here <- ncqLocate ncq refTo
+
+      if isJust here then         do
+        liftIO $ ncqStorageSetRef ncq ref refTo
+        info $ green "ok" <+> "R" <+> pretty ref <+> pretty refTo
+      else do
+        warn $ red "Missed block for ref" <+> pretty ref <+> pretty refTo
+
+      pure True
+
+  liftIO $ ncqIndexRightNow ncq
+
+  info $ "check migration"
+
+  num <- readTVarIO checkN
+
+  when (num == 0) $ exit ()
+
+  errors <- newTVarIO 0
+
+  fix \next -> do
+    what <- atomically $ readTQueue checkQ
+
+    toWipe <- ncqLocate ncq what >>= \case
+      Just (InCurrent{})    -> do
+        atomically $ modifyTVar checkN pred
+        pure True
+
+      Just (InFossil{})     -> do
+        atomically $ modifyTVar checkN pred
+        pure True
+
+      Just (InWriteQueue{}) -> do
+        atomically $ unGetTQueue checkQ what
+        pure False
+
+      Nothing               -> do
+        atomically $ modifyTVar errors succ
+        pure False
+
+    when toWipe do
+      let path = b </> hashToPath what
+      info $ yellow "d" <+> pretty what
+
+      unless dry do
+        rm path
+
+    mt <- atomically $ isEmptyTQueue checkQ
+    unless mt next
+
+  ee <- readTVarIO errors
+  rest <- readTVarIO checkN
+
+  liftIO $ hPutDoc stdout $ "errors" <+> pretty ee <+> "leftovers" <+> pretty rest
+
+  liftIO do
+    if ee == 0 && rest == 0 then do
+
+      unless dry do
+        rm migrateDir
+
+      exitSuccess
+
+    else
+      exitFailure
+

hbs2-peer/app/PeerMain.hs

@@ -69,6 +69,7 @@ import RefChan
 import RefChanNotifyLog
 import Fetch (fetchHash)
 import Log hiding (info)
+import Migrate
 
 import HBS2.Misc.PrettyStuff
 import HBS2.Peer.RPC.Internal.Types()
@@ -88,6 +89,8 @@ import HBS2.Peer.Proto.LWWRef.Internal
 import RPC2(RPC2Context(..))
 
 import Data.Config.Suckless.Script hiding (optional)
+import Data.Config.Suckless.Script.File (glob)
+import Data.Config.Suckless.System as Sy
 import Data.Config.Suckless.Almost.RPC
 
 import Codec.Serialise as Serialise
@@ -210,7 +213,7 @@ main = do
 
   sodiumInit
 
-  setLogging @INFO   defLog
+  setLogging @INFO   (logPrefix "" . toStdout)
   setLogging @ERROR  errorPrefix
   setLogging @WARN   warnPrefix
   setLogging @NOTICE noticePrefix
@@ -218,8 +221,8 @@ main = do
   setLoggingOff @TRACE
   setLoggingOff @TRACE1
 
-  withSimpleLogger runCLI
+  withSimpleLogger do
-
+    runCLI
 
 
 data GOpts =
@@ -271,6 +274,7 @@ runCLI = do
                 <> command "gc"        (info pRunGC (progDesc "run RAM garbage collector"))
                 <> command "probes"    (info pRunProbes (progDesc "show probes"))
                 <> command "do"        (info pDoScript (progDesc "execute a command in peer context"))
+                <> command "migrate"   (info pMigrate (progDesc "migrate storage"))
                 <> command "version"   (info pVersion (progDesc "show program version"))
                 )
 
@@ -669,6 +673,15 @@ runCLI = do
            for_ (parseTop r & fromRight mempty) \sexy -> do
              liftIO $ hPutDoc stdout (pretty sexy)
 
+    pMigrate = do
+      argz <- many (strArgument (metavar "TERM" <> help "script terms"))
+
+      pure do
+        s <- for argz $ \s ->
+                parseSyntax s & either (error.show) pure
+
+        migrate s
+
     refP :: ReadM (PubKey 'Sign 'HBS2Basic)
     refP = maybeReader fromStringMay
 
@@ -847,6 +860,8 @@ runPeer opts = respawnOnError opts $ flip runContT pure do
 
   notice $ red "STORAGE PREFIX" <+> pretty pref
 
+  checkMigration (coerce pref)
+
   -- error "STOP"
 
   s <- lift $ ncqStorageOpen ncqPath
@@ -1413,3 +1428,31 @@ runPeer opts = respawnOnError opts $ flip runContT pure do
   lift (throwIO GoAgainException)
 
 
+checkMigration :: forall m . MonadIO m => FilePath -> m ()
+checkMigration prefix  = flip runContT pure $ callCC \exit -> do
+
+  blocks <- S.toList_ do
+              glob ["**/*"] [] (prefix </> "blocks") $ \fn -> S.yield fn >> pure False
+
+
+  let migration = prefix </> "migrate"
+
+  already <- Sy.doesDirectoryExist migration
+
+  when (L.null blocks && not already) do
+    exit ()
+
+  let reason = if already then
+                 red "Migration WIP discovered" <+> pretty migration
+                else
+                 red "Legacy storage discovered" <+> pretty prefix
+
+  notice $ reason <> line
+           <> red "Run" <+> "hbs2-peer migrate" <+> pretty prefix
+           <> line
+           <> "to migrate the storage to a new version"
+
+  liftIO exitFailure
+
+
+

hbs2-peer/hbs2-peer.cabal

@@ -293,6 +293,7 @@ executable hbs2-peer
                     , Brains
                     , DispatchProxy
                     , Monkeys
+                    , Migrate
                     , CLI.Common
                     , CLI.RefChan
                     , CLI.LWWRef