diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Class.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Class.hs index 280a4a6e..a805925f 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Class.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Class.hs @@ -107,6 +107,17 @@ ncqRefHash NCQStorage{..} h = HashRef (hashObject (coerce @_ @ByteString h <> coerce ncqSalt)) {-# INLINE ncqRefHash #-} + +-- R: Reference format +-- SALTED_HASH:BYTES(32) VALUE:BYTES(32) ORIG_HASH:BYTES(32) +-- ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +-- KEY VALUE +-- LEN(PAYLOAD) = 2 * LEN(KEY) +-- +-- We may need this ORIG_HASH in order to restore original +-- reference hash during migrations, fsck or something like +-- this, according to NCQv1 experience. + -- | Get ref value (hash) by logical ref key. -- Returns Nothing for tomb/absent/invalid. ncqStorageGetRef :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe HashRef) @@ -116,8 +127,8 @@ ncqStorageGetRef ncq ref = runMaybeT $ do guard (not $ ncqIsTomb loc) bs <- lift (ncqGetEntryBS ncq loc) >>= toMPlus case snd (ncqEntryUnwrap bs) of - Right (R, payload) | BS.length payload == ncqKeyLen - -> pure (coerce payload) + Right (R, payload) | BS.length payload == 2*ncqKeyLen + -> pure (coerce $ BS.take ncqKeyLen payload) _ -> mzero {-# INLINE ncqStorageGetRef #-} @@ -127,9 +138,10 @@ ncqStorageSetRef ncq ref val = do cur <- ncqStorageGetRef ncq ref unless (cur == Just val) $ do let rkey = ncqRefHash ncq ref + orig = coerce @_ @ByteString ref payload = coerce @_ @ByteString val -- Section type R, fixed key = rkey, payload = value hash bytes - void $ ncqPutBS ncq (Just R) (Just rkey) payload + void $ ncqPutBS ncq (Just R) (Just rkey) (payload <> orig) {-# INLINE ncqStorageSetRef #-} -- | Delete ref (write tomb for ref key), no-op if absent. diff --git a/hbs2-tests/test/NCQ3.hs b/hbs2-tests/test/NCQ3.hs index 65e6a209..a63625ac 100644 --- a/hbs2-tests/test/NCQ3.hs +++ b/hbs2-tests/test/NCQ3.hs @@ -67,6 +67,8 @@ import Streaming.Prelude qualified as S {-HLINT ignore "Functor law"-} +failure :: forall a m . (Show a, MonadIO m) => Doc a -> m () +failure = liftIO . assertFailure . show ncq3Tests :: forall m . MonadUnliftIO m => MakeDictM C m () ncq3Tests = do @@ -681,6 +683,37 @@ ncq3Tests = do liftIO $ assertBool (show $ "hash eq" <+> pretty h0 <+> pretty lbs1) (h0 == lbs1) + entry $ bindMatch "test:ncq3:refs:shape" $ nil_ $ \_ -> runTest $ \TestEnv{..} -> do + ncqWithStorage testEnvDir $ \sto -> do + -- random 32B ref & val + g <- liftIO MWC.createSystemRandom + ref <- HashRef . coerce <$> liftIO (genRandomBS g ncqKeyLen) + val <- HashRef . coerce <$> liftIO (genRandomBS g ncqKeyLen) + + -- roundtrip via API + ncqStorageSetRef sto ref val + m <- ncqStorageGetRef sto ref + when (m /= Just val) $ + failure "refs:shape: getRef mismatch (expected Just val)" + + -- raw check + let rkey = ncqRefHash sto ref + loc <- ncqLocate sto rkey >>= orThrowUser "refs:shape: locate failed" + bs <- ncqGetEntryBS sto loc >>= orThrowUser "refs:shape: ncqGetEntryBS failed" + + payload <- case snd (ncqEntryUnwrap bs) of + Right (R, p) -> pure p + _ -> error "refs:shape: unexpected section type (not R)" + + when (BS.length payload /= 2 * ncqKeyLen) $ + failure "refs:shape: payload length != 64" + + let (val', raw) = BS.splitAt ncqKeyLen payload + when (val' /= coerce val) $ + failure "refs:shape: first 32B != VAL_HASH" + when (raw /= coerce ref) $ + failure "refs:shape: last 32B != RAW_REF_KEY" + entry $ bindMatch "test:ncq3:storage:basic" $ nil_ $ \e -> do let (opts,args) = splitOpts [] e