diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ2.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ2.hs index c70b8962..b2ffef21 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ2.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ2.hs @@ -159,9 +159,15 @@ ncqLookupEntrySTM ncq h = do v <- readTVar tv pure $ Just (v, tv) -ncqPutBS :: MonadUnliftIO m => NCQStorage2 -> ByteString -> m HashRef -ncqPutBS ncq@NCQStorage2{..} bs = do - let h = HashRef (hashObject @HbSync bs) +ncqPutBS :: MonadUnliftIO m + => NCQStorage2 + -> Maybe NCQSectionType + -> Maybe HashRef + -> ByteString + -> m HashRef +ncqPutBS ncq@NCQStorage2{..} mtp mhref bs' = do + let h = fromMaybe (HashRef (hashObject @HbSync bs')) mhref + let bs = ncqMakeSectionBS mtp h bs' atomically do waitTSem ncqWriteSem stop <- readTVar ncqStorageStopReq @@ -220,7 +226,7 @@ ncqStorageRun2 ncq@NCQStorage2{..} = flip runContT pure $ callCC \exit -> do sync <- readTVarIO ncqStorageSyncReq when (w > ncqFsync || sync) do - liftIO (appendEntry fh undefined (NCQEntryNew 0 "")) + -- liftIO (appendEntry fh undefined (NCQEntryNew 0 "")) liftIO (fileSynchronise fh) atomically do writeTVar ncqStorageSyncReq False @@ -241,26 +247,26 @@ ncqStorageRun2 ncq@NCQStorage2{..} = flip runContT pure $ callCC \exit -> do Right chu -> do ws <- for chu $ \h -> do atomically (ncqLookupEntrySTM ncq h) >>= \case - Nothing -> pure 0 - Just (r,t) -> lift (appendEntry fh h r) + Just (r@(NCQEntryNew n bs),t) -> do + n <- lift (appendSection fh h bs) + atomically (writeTVar t (NCQEntryJustWritten n fh bs)) + pure n + + _ -> pure 0 loop (fh, w + sum ws) where - appendEntry :: forall m . MonadUnliftIO m + appendSection :: forall m . MonadUnliftIO m => Fd -> HashRef - -> NCQEntry + -> ByteString -> m Int - appendEntry fh h (NCQEntryNew _ bs) = do - let section = ncqMakeSectionBS Nothing h bs + appendSection fh h section = do liftIO (Posix.fdWrite fh section) <&> fromIntegral - appendEntry fh h _ = do - pure 0 - - {-# INLINE appendEntry #-} + {-# INLINE appendSection #-} diff --git a/hbs2-tests/test/TestNCQ.hs b/hbs2-tests/test/TestNCQ.hs index 76a3843d..17918fb1 100644 --- a/hbs2-tests/test/TestNCQ.hs +++ b/hbs2-tests/test/TestNCQ.hs @@ -626,7 +626,7 @@ testNCQ2Concurrent1 noRead tn n TestEnv{..} = flip runContT pure do pooledForConcurrentlyN_ tnn fnv $ \(n,ha,_) -> do co <- BS.readFile n - ncqPutBS ncq1 co + ncqPutBS ncq1 (Just B) Nothing co ncqStorageStop2 ncq1 performMajorGC