From d4b603aaf6be5f09d839127892bbe15e84f5896c Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Wed, 11 Sep 2024 06:34:58 +0300 Subject: [PATCH] wip --- fixme-new/lib/Fixme/Run/Internal.hs | 30 +++++++++++------------- fixme-new/lib/Fixme/State.hs | 36 +++++++++++++++++++++++++---- 2 files changed, 45 insertions(+), 21 deletions(-) diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index becdc853..2431bb19 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -235,7 +235,7 @@ import_ = do fxs <- flip filterM fxs0 $ \fme -> do let fn = fixmeGet "file" fme <&> Text.unpack . coerce - seen <- maybe1 fn (pure False) selectIsAlreadyScanned + seen <- maybe1 fn (pure False) selectIsAlreadyScannedFile pure (not seen) hashes <- catMaybes <$> flip runContT pure do @@ -282,7 +282,7 @@ import_ = do || maybe False (`HS.member` commited) (HM.lookup f blobs) when add do - insertScanned f + insertScannedFile f cat_ :: FixmePerks m => Text -> FixmeM m () cat_ hash = do @@ -358,14 +358,6 @@ refchanExport = do let (pk,sk) = (view peerSignPk creds, view peerSignSk creds) - -- withRPC2 @RefChanAPI soname $ \caller -> do - -- for_ items $ \it -> do - -- let str = show (pretty it) - -- putStr str - -- let lbs = str & Text.pack & Text.encodeUtf8 - -- let box = makeSignedBox @L4Proto @BS.ByteString pk sk lbs - -- void $ callService @RpcRefChanPropose caller (chan, box) - withState do what <- select_ @_ @FixmeExported [qc|select o,w,k,cast (v as text) from object order by o, k, v|] @@ -396,24 +388,28 @@ refchanImport :: FixmePerks m => FixmeM m () refchanImport = do sto <- getStorage - rchanAPI <- getClientAPI @RefChanAPI @UNIX chan <- asks fixmeEnvRefChan >>= readTVarIO >>= orThrowUser "refchan not set" - ttsmap <- newTVarIO HM.empty + ttsmap <- newTVarIO HM.empty + accepts <- newTVarIO HM.empty tq <- newTQueueIO - walkRefChanTx @UNIX (const $ pure True) chan $ \txh u -> do + -- TODO: assume-huge-list + scanned <- listAllScanned + + walkRefChanTx @UNIX (pure . not . (`HS.member` scanned)) chan $ \txh u -> do case u of A (AcceptTran (Just ts) _ what) -> do debug $ red "ACCEPT" <+> pretty ts <+> pretty what atomically $ modifyTVar ttsmap (HM.insertWith max what (coerce @_ @Word64 ts)) + atomically $ modifyTVar accepts (HM.insertWith (<>) what (HS.singleton txh)) A _ -> none @@ -432,16 +428,18 @@ refchanImport = do & toMPlus for_ exported $ \exported -> do - atomically $ writeTQueue tq (orig, exported) + atomically $ writeTQueue tq (txh, orig, exported) imported <- atomically $ flushTQueue tq withState $ transactional do - for_ imported $ \(h, i) -> do + for_ imported $ \(txh, h, i) -> do w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h let item = i { exportedWeight = w } notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item) insertFixmeExported item - + atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup h + insertScanned txh + for_ atx insertScanned diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index e4a71336..1741e6d3 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Fixme.State ( evolve @@ -8,8 +9,11 @@ module Fixme.State , insertFixme , insertFixmeExported , modifyFixme + , insertScannedFile , insertScanned + , selectIsAlreadyScannedFile , selectIsAlreadyScanned + , listAllScanned , selectFixmeKey , getFixme , FixmeExported(..) @@ -21,6 +25,7 @@ import Fixme.Prelude hiding (key) import Fixme.Types import Fixme.Config +import HBS2.Base58 import HBS2.System.Dir import Data.Config.Suckless hiding (key) import Data.Config.Suckless.Syntax @@ -57,6 +62,15 @@ import System.TimeIt -- на лету бесплатно +newtype SomeHash h = SomeHash { fromSomeHash :: h } + deriving newtype (IsString) + +instance Pretty (AsBase58 h) => ToField (SomeHash h) where + toField (SomeHash h) = toField ( show $ pretty (AsBase58 h)) + +instance IsString (SomeHash h) => FromField (SomeHash h) where + fromField = fmap fromString . fromField @String + pattern Operand :: forall {c} . Text -> Syntax c pattern Operand what <- (operand -> Just what) @@ -245,15 +259,27 @@ scannedKeyForFile file = do w <- liftIO $ getModificationTime fn <&> round . utcTimeToPOSIXSeconds pure $ hashObject @HbSync ( serialise (magic,w,file) ) & HashRef -selectIsAlreadyScanned :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> m Bool -selectIsAlreadyScanned file = withState do - k <- lift $ scannedKeyForFile file +selectIsAlreadyScannedFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> m Bool +selectIsAlreadyScannedFile file = do + k <- scannedKeyForFile file + selectIsAlreadyScanned k + +selectIsAlreadyScanned :: (FixmePerks m, MonadReader FixmeEnv m) => HashRef -> m Bool +selectIsAlreadyScanned k = withState do what <- select @(Only Int) [qc|select 1 from scanned where hash = ? limit 1|] (Only k) pure $ not $ List.null what -insertScanned :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> DBPipeM m () -insertScanned file = do +listAllScanned :: (FixmePerks m, MonadReader FixmeEnv m) => m (HashSet HashRef) +listAllScanned = withState do + select_ [qc|select hash from scanned|] <&> HS.fromList . fmap ( fromSomeHash . fromOnly ) + +insertScannedFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> DBPipeM m () +insertScannedFile file = do k <- lift $ scannedKeyForFile file + insertScanned k + +insertScanned:: (FixmePerks m, MonadReader FixmeEnv m) => HashRef -> DBPipeM m () +insertScanned k = do insert [qc| insert into scanned (hash) values(?) on conflict (hash) do nothing|]