wip

hbs2-storage-ncq/hbs2-storage-ncq.cabal

@@ -60,6 +60,7 @@ library
     exposed-modules:
       HBS2.Storage.NCQ
       HBS2.Storage.NCQ2
+      HBS2.Storage.NCQ.Types
     -- other-modules:
     -- other-extensions:
     build-depends:    base, hbs2-core, hbs2-log-structured, suckless-conf

hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs

@@ -1,6 +1,9 @@
 {-# Language MultiWayIf #-}
 {-# Language RecordWildCards #-}
-module HBS2.Storage.NCQ where
+module HBS2.Storage.NCQ
+  ( module HBS2.Storage.NCQ
+  , module HBS2.Storage.NCQ.Types
+  ) where
 
 import HBS2.Prelude.Plated
 import HBS2.Hash
@@ -9,9 +12,11 @@ import HBS2.Data.Types.Refs
 import HBS2.Base58
 import HBS2.Net.Auth.Credentials
 import HBS2.Storage
+import HBS2.Storage.NCQ.Types
 import HBS2.Misc.PrettyStuff
 import HBS2.System.Logger.Simple.ANSI
 
+
 import HBS2.Data.Log.Structured.NCQ
 import HBS2.Data.Log.Structured.SD
 
@@ -180,40 +185,6 @@ data NCQStorage =
   }
 
 
--- Log structure:
--- (SD)*
--- S      ::= word32be, section prefix
--- D      ::= HASH PREFIX DATA
--- HASH   ::= BYTESTRING(32)
--- PREFIX ::= BYTESTRING(4)
--- DATA   ::= BYTESTRING(n) | n == S - LEN(WORD32) - LEN(HASH) - LEN(PREFIX)
-
-newtype NCQFullRecordLen a =
-  NCQFullRecordLen a
-  deriving newtype (Num,Enum,Integral,Real,Ord,Eq)
-
--- including prefix
-ncqFullDataLen :: forall a . Integral a => NCQFullRecordLen a -> a
-ncqFullDataLen full = fromIntegral full - ncqKeyLen
-{-# INLINE ncqFullDataLen #-}
-
-ncqKeyLen :: forall a . Integral a => a
-ncqKeyLen = 32
-{-# INLINE ncqKeyLen #-}
-
--- 'S' in SD, i.e size, i.e section header
-ncqSLen:: forall a . Integral a => a
-ncqSLen = 4
-{-# INLINE ncqSLen #-}
-
-ncqDataOffset :: forall a b . (Integral a, Integral b) => a -> b
-ncqDataOffset base = fromIntegral base + ncqSLen + ncqKeyLen
-{-# INLINE ncqDataOffset #-}
-
-
-ncqFullTombLen :: forall a . Integral a => a
-ncqFullTombLen = ncqSLen + ncqKeyLen + ncqPrefixLen + 0
-{-# INLINE ncqFullTombLen #-}
 
 instance MonadUnliftIO m => Storage NCQStorage HbSync LBS.ByteString  m where
     putBlock ncq lbs = fmap coerce <$> ncqStoragePutBlock ncq lbs
@@ -848,27 +819,6 @@ ncqStorageGetBlock ncq h = do
     Just lbs | not (ncqIsTomb lbs) -> pure (Just $ LBS.drop ncqPrefixLen lbs)
     _ -> pure Nothing
 
-data NCQSectionType = B | R | T
-                      deriving stock (Eq,Ord,Show)
-
-instance Pretty NCQSectionType where
-  pretty = \case
-    B -> "B"
-    T -> "T"
-    R -> "R"
-
-ncqPrefixLen :: Integral a => a
-ncqPrefixLen = 4
-{-# INLINE ncqPrefixLen #-}
-
-ncqRefPrefix :: ByteString
-ncqRefPrefix = "R;;\x00"
-
-ncqBlockPrefix :: ByteString
-ncqBlockPrefix = "B;;\x00"
-
-ncqTombPrefix :: ByteString
-ncqTombPrefix = "T;;\x00"
 
 ncqLocatedSize :: Location -> Integer
 ncqLocatedSize = \case

hbs2-storage-ncq/lib/HBS2/Storage/NCQ/Types.hs

@@ -0,0 +1,90 @@
+module HBS2.Storage.NCQ.Types where
+
+import HBS2.Prelude
+import HBS2.Data.Types.Refs
+import HBS2.Hash
+
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Network.ByteOrder qualified as N
+import Data.Coerce
+
+-- Log structure:
+-- (SD)*
+-- S      ::= word32be, section prefix
+-- D      ::= HASH PREFIX DATA
+-- HASH   ::= BYTESTRING(32)
+-- PREFIX ::= BYTESTRING(4)
+-- DATA   ::= BYTESTRING(n) | n == S - LEN(WORD32) - LEN(HASH) - LEN(PREFIX)
+
+newtype NCQFullRecordLen a =
+  NCQFullRecordLen a
+  deriving newtype (Num,Enum,Integral,Real,Ord,Eq)
+
+-- including prefix
+ncqFullDataLen :: forall a . Integral a => NCQFullRecordLen a -> a
+ncqFullDataLen full = fromIntegral full - ncqKeyLen
+{-# INLINE ncqFullDataLen #-}
+
+ncqKeyLen :: forall a . Integral a => a
+ncqKeyLen = 32
+{-# INLINE ncqKeyLen #-}
+
+-- 'S' in SD, i.e size, i.e section header
+ncqSLen:: forall a . Integral a => a
+ncqSLen = 4
+{-# INLINE ncqSLen #-}
+
+ncqDataOffset :: forall a b . (Integral a, Integral b) => a -> b
+ncqDataOffset base = fromIntegral base + ncqSLen + ncqKeyLen
+{-# INLINE ncqDataOffset #-}
+
+
+ncqFullTombLen :: forall a . Integral a => a
+ncqFullTombLen = ncqSLen + ncqKeyLen + ncqPrefixLen + 0
+{-# INLINE ncqFullTombLen #-}
+
+
+data NCQSectionType = B | R | T
+                      deriving stock (Eq,Ord,Show)
+
+instance Pretty NCQSectionType where
+  pretty = \case
+    B -> "B"
+    T -> "T"
+    R -> "R"
+
+ncqPrefixLen :: Integral a => a
+ncqPrefixLen = 4
+{-# INLINE ncqPrefixLen #-}
+
+ncqRefPrefix :: ByteString
+ncqRefPrefix = "R;;\x00"
+
+ncqBlockPrefix :: ByteString
+ncqBlockPrefix = "B;;\x00"
+
+ncqTombPrefix :: ByteString
+ncqTombPrefix = "T;;\x00"
+
+ncqMakeSectionBS :: Maybe NCQSectionType
+                 -> HashRef
+                 -> ByteString
+                 -> ByteString
+ncqMakeSectionBS t h bs = do
+  let slen = ncqKeyLen + prefLen + fromIntegral (BS.length bs)
+  let ss = N.bytestring32 slen
+  let section = ss <> coerce h <> prefix <> bs
+  section
+
+  where
+    (prefLen, prefix) =
+      case t of
+        Nothing -> (0, mempty)
+        Just B  -> (ncqPrefixLen, ncqBlockPrefix)
+        Just T  -> (ncqPrefixLen, ncqTombPrefix)
+        Just R  -> (ncqPrefixLen, ncqRefPrefix)
+
+{-# INLINE ncqMakeSectionBS #-}
+
+

hbs2-storage-ncq/lib/HBS2/Storage/NCQ2.hs

@@ -1,6 +1,10 @@
 {-# Language MultiWayIf #-}
 {-# Language RecordWildCards #-}
-module HBS2.Storage.NCQ2 where
+module HBS2.Storage.NCQ2
+  ( module HBS2.Storage.NCQ2
+  , module HBS2.Storage.NCQ.Types
+  )
+  where
 
 import HBS2.Prelude.Plated
 import HBS2.Hash
@@ -15,6 +19,8 @@ import HBS2.System.Logger.Simple.ANSI
 import HBS2.Data.Log.Structured.NCQ
 import HBS2.Data.Log.Structured.SD
 
+import HBS2.Storage.NCQ.Types
+
 import Data.Config.Suckless.System
 import Data.Config.Suckless.Script hiding (void)
 
@@ -214,6 +220,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 (fileSynchronise fh)
       atomically do
         writeTVar   ncqStorageSyncReq False
@@ -241,11 +248,14 @@ ncqStorageRun2 ncq@NCQStorage2{..} = flip runContT pure $ callCC \exit -> do
 
   where
 
-    appendEntry :: Fd -> HashRef -> NCQEntry -> m Int
+    appendEntry :: forall m . MonadUnliftIO m
+                => Fd
+                -> HashRef
+                -> NCQEntry
+                -> m Int
 
     appendEntry fh h (NCQEntryNew _ bs) = do
-      let ss = N.bytestring32 (32 + fromIntegral (BS.length bs))
-      let section = ss <> coerce h <> bs
+      let section = ncqMakeSectionBS Nothing h bs
       liftIO (Posix.fdWrite fh section) <&> fromIntegral
 
     appendEntry fh h _ = do