wip

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
 
 

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|]