wip, NCQ3 failed

hbs2-peer/app/PeerMain.hs

@@ -31,7 +31,8 @@ import HBS2.Net.Proto.Notify
 import HBS2.Peer.Proto.Mailbox
 import HBS2.OrDie
 import HBS2.Storage.Simple
-import HBS2.Storage.NCQ3
+-- import HBS2.Storage.NCQ3
+import HBS2.Storage.NCQ
 import HBS2.Storage.Operations.Missed
 import HBS2.Data.Detect
 
@@ -785,9 +786,6 @@ runPeer opts = respawnOnError opts $ flip runContT pure do
 
   let pref = fromMaybe xdg (view storage opts <|> storConf)
 
-  let ncqPath = coerce pref </> "ncq3"
-
-  debug $ "storage prefix:" <+> pretty ncqPath
 
   liftIO $ print $ pretty "debug: " <+> pretty (show debugConf)
   liftIO $ print $ pretty "trace: " <+> pretty (show traceConf)
@@ -824,7 +822,13 @@ runPeer opts = respawnOnError opts $ flip runContT pure do
 
   -- error "STOP"
 
-  s <- ContT $ ncqWithStorage ncqPath
+  -- let ncqPath = coerce pref </> "ncq3"
+  let ncqPath = coerce pref </> "ncq"
+
+  debug $ "storage prefix:" <+> pretty ncqPath
+
+  -- s <- ContT $ ncqWithStorage ncqPath
+  s <- lift $ ncqStorageOpen ncqPath
 
   -- simpleStorageInit @HbSync (Just pref)
   let blk = liftIO . hasBlock s
@@ -1395,7 +1399,7 @@ checkMigration prefix  = flip runContT pure $ callCC \exit -> do
   already <- Sy.doesDirectoryExist migration
 
   when (L.null blocks && not already) do
-    checkNCQ1
+    -- checkNCQ1
     exit ()
 
   let reason = if already then
@@ -1413,14 +1417,14 @@ checkMigration prefix  = flip runContT pure $ callCC \exit -> do
 
 
   where
-    checkNCQ1 = do
-      let ncq1Dir =  prefix </> "ncq"
-      ncq1Here <- Sy.doesDirectoryExist ncq1Dir
-      when ncq1Here do
-        notice $ yellow "found NCQv1 storage"
-        notice $ red "Run" <+> "hbs2-peer migrate" <+> pretty prefix
-                 <> line
-                 <> "to migrate the storage to a new version"
-        notice $ "You may also: backup" <+> pretty ncq1Dir <+> "or move it or remove permanently"
-        liftIO exitFailure
+    -- checkNCQ1 = do
+    --   let ncq1Dir =  prefix </> "ncq"
+    --   ncq1Here <- Sy.doesDirectoryExist ncq1Dir
+    --   when ncq1Here do
+    --     notice $ yellow "found NCQv1 storage"
+    --     notice $ red "Run" <+> "hbs2-peer migrate" <+> pretty prefix
+    --              <> line
+    --              <> "to migrate the storage to a new version"
+    --     notice $ "You may also: backup" <+> pretty ncq1Dir <+> "or move it or remove permanently"
+    --     liftIO exitFailure
 

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

@@ -67,6 +67,7 @@ ncqStorageOpen fp upd = do
   ncqStateKey       <- newTVarIO (FileKey maxBound)
   ncqStateUse       <- newTVarIO mempty
   ncqServiceSem     <- atomically $ newTSem 1
+  ncqRunSem         <- atomically $ newTSem 1
   ncqFileLock       <- newTVarIO Nothing
   ncqCurrentFossils <- newTVarIO mempty
 

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

@@ -32,12 +32,15 @@ ncqStorageStop NCQStorage{..} = do
 ncqStorageRun :: forall m . MonadUnliftIO m
                => NCQStorage
                -> m ()
-ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
+ncqStorageRun ncq@NCQStorage{..} = withSem ncqRunSem $ flip runContT pure do
   ContT $ bracket setAlive (const unsetAlive)
 
   ContT $ bracket none $ const $ liftIO do
     readTVarIO ncqFileLock >>= mapM_  FL.unlockFile
 
+  ContT $ bracket none $ const $ liftIO do
+    debug "storage done"
+
   closeQ <- liftIO newTQueueIO
 
   closer <- spawnActivity $ liftIO $ fix \loop -> do

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

@@ -116,6 +116,7 @@ data NCQStorage =
   , ncqOnRunWriteIdle :: TVar (IO ())
   , ncqSyncNo         :: TVar Int
   , ncqServiceSem     :: TSem
+  , ncqRunSem         :: TSem
   , ncqFileLock       :: TVar (Maybe FileLock)
   }