diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index ab8fcb8d..b2796d7d 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -822,7 +822,7 @@ mergeState seed orig = do -- впоследствии -- -getStateFromDir0 :: ( MonadIO m +getStateFromDir0 :: ( MonadUnliftIO m , HasClientAPI RefChanAPI UNIX m , HasClientAPI StorageAPI UNIX m , HasStorage m @@ -841,7 +841,7 @@ getStateFromDir0 seed = do getStateFromDir seed dir incl excl -getStateFromDir :: ( MonadIO m +getStateFromDir :: ( MonadUnliftIO m , HasClientAPI RefChanAPI UNIX m , HasClientAPI StorageAPI UNIX m , HasStorage m @@ -883,10 +883,11 @@ getStateFromDir seed path incl excl = do S.yield (p,e) -getStateFromRefChan :: forall m . ( MonadIO m +getStateFromRefChan :: forall m . ( MonadUnliftIO m , HasClientAPI RefChanAPI UNIX m , HasClientAPI StorageAPI UNIX m , HasStorage m + , HasRunDir m ) => MyRefChan -> m [(FilePath, Entry)] @@ -899,6 +900,25 @@ getStateFromRefChan rchan = do outq <- newTQueueIO tss <- newTVarIO mempty + rch <- Client.getRefChanHead @UNIX rchan + >>= orThrow RefChanHeadNotFoundException + + let members = view refChanHeadReaders rch & HS.toList + + krl <- liftIO $ runKeymanClient $ loadKeyRingEntries members + <&> L.sortOn (Down . fst) + <&> fmap snd + + let krs = HM.fromList [ (pk,e) | e@(KeyringEntry pk _ _) <- krl ] + + let findKey gk = do + r <- S.toList_ do + forM_ (HM.toList $ recipients gk) $ \(pk,box) -> runMaybeT do + (KeyringEntry ppk ssk _) <- toMPlus $ HM.lookup pk krs + let s = Symm.lookupGroupKey @'HBS2Basic ssk ppk gk + for_ s $ lift . S.yield + pure $ headMay r + -- FIXME: may-be-slow walkRefChanTx @UNIX (const $ pure True) rchan $ \txh -> \case A (AcceptTran ts _ what) -> do @@ -911,8 +931,6 @@ getStateFromRefChan rchan = do AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs) & toMPlus . either (const Nothing) Just - let findKey gk = liftIO (runKeymanClient (extractGroupKeySecret gk)) - runExceptT (extractMetaData @'HBS2Basic findKey sto href) >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, (href, meta)) )