diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index 71061361..78747d78 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -694,6 +694,29 @@ theDict = do liftIO $ print $ pretty hash <+> pretty ssize go (succ n) + entry $ bindMatch "test:reflog:index:search:binary:test:2" $ nil_ $ const $ lift do + r <- newTQueueIO + enumEntries $ \e -> do + let ha = GitHash $ coerce $ BS.take 20 e + atomically $ writeTQueue r ha + + hashes <- atomically $ STM.flushTQueue r + liftIO $ print (length hashes) + + mmaped <- listObjectIndexFiles <&> fmap fst + >>= \xs -> for xs $ \x -> liftIO $ mmapFileByteString x Nothing + + already_ <- newTVarIO (mempty :: HashSet GitHash) + + for_ hashes $ \h -> do + forConcurrently_ mmaped $ \bs -> do + here <- readTVarIO already_ <&> HS.member h + unless here do + found <- binarySearchBS 56 ( BS.take 20 . BS.drop 4 ) (coerce h) bs + when (isJust found) do + atomically $ modifyTVar already_ (HS.insert h) + notice $ pretty h <+> "True" + entry $ bindMatch "test:reflog:index:search:binary:test" $ nil_ $ const $ lift do files <- listObjectIndexFiles @@ -738,7 +761,7 @@ theDict = do answ_ <- newEmptyTMVarIO - atomically $ writeTQueue rq (hash,answ_) + atomically $ writeTQueue rq (coerce hash, const True, answ_) answ <- atomically $ readTMVar answ_ diff --git a/hbs2-git3/lib/HBS2/Git3/State/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Index.hs index 95fa86e1..8abb3472 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Index.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Index.hs @@ -50,9 +50,6 @@ readLogFileLBS _ action = flip fix 0 \go n -> do indexPath :: forall m . ( Git3Perks m , MonadReader Git3Env m - , HasClientAPI PeerAPI UNIX m - , HasClientAPI RefLogAPI UNIX m - , HasStorage m ) => m FilePath indexPath = do reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet @@ -60,9 +57,6 @@ indexPath = do listObjectIndexFiles :: forall m . ( Git3Perks m , MonadReader Git3Env m - , HasClientAPI PeerAPI UNIX m - , HasClientAPI RefLogAPI UNIX m - , HasStorage m ) => m [(FilePath, Natural)] listObjectIndexFiles = do @@ -73,13 +67,25 @@ listObjectIndexFiles = do z <- fileSize f <&> fromIntegral pure (f,z) -startReflogIndexQueryQueue :: forall m . ( Git3Perks m - , MonadReader Git3Env m - , HasClientAPI PeerAPI UNIX m - , HasClientAPI RefLogAPI UNIX m - , HasStorage m - ) - => TQueue (GitHash, TMVar [HashRef]) + + +enumEntries :: forall m . ( Git3Perks m + , MonadReader Git3Env m + ) => ( BS.ByteString -> m () ) -> m () + +enumEntries action = do + files <- listObjectIndexFiles <&> fmap fst + forConcurrently_ files $ \f -> do + bs <- liftIO $ mmapFileByteString f Nothing + scanBS bs action + +startReflogIndexQueryQueue :: forall a m . ( Git3Perks m + , MonadReader Git3Env m + , HasClientAPI PeerAPI UNIX m + , HasClientAPI RefLogAPI UNIX m + , HasStorage m + ) + => TQueue (BS.ByteString, BS.ByteString -> a, TMVar (Maybe a)) -> m () startReflogIndexQueryQueue rq = flip runContT pure do @@ -94,21 +100,19 @@ startReflogIndexQueryQueue rq = flip runContT pure do mmaped <- liftIO $ for files (liftIO . flip mmapFileByteString Nothing) forever $ liftIO do - (githash, answ) <- atomically $ readTQueue rq - - let s = coerce githash + (s, f, answ) <- atomically $ readTQueue rq found <- forConcurrently mmaped $ \bs -> runMaybeT do -- FIXME: size-hardcodes w <- binarySearchBS 56 ( BS.take 20 . BS.drop 4 ) s bs >>= toMPlus - let v = BS.drop ( w * 56 ) bs & BS.take 32 + let v = BS.drop ( w * 56 ) bs - pure $ coerce @_ @HashRef v - - atomically $ writeTMVar answ ( catMaybes found ) + pure $ f v + let what = headMay (catMaybes found) + atomically $ writeTMVar answ what writeReflogIndex :: forall m . ( Git3Perks m , MonadReader Git3Env m