Revert "wip, speedup"

This reverts commit 7b69d85dd9.
This commit is contained in:
Dmitry Zuikov 2024-08-08 05:26:13 +03:00
parent 7e0305891b
commit 68c8c7bef3
2 changed files with 12 additions and 61 deletions

View File

@ -20,7 +20,6 @@ import UnliftIO
import Control.Concurrent.STM qualified as STM import Control.Concurrent.STM qualified as STM
import Streaming.Prelude qualified as S import Streaming.Prelude qualified as S
-- FIXME: skip-symlink
glob :: forall m . MonadIO m glob :: forall m . MonadIO m
=> [FilePattern] -- ^ search patterns => [FilePattern] -- ^ search patterns
-> [FilePattern] -- ^ ignore patterns -> [FilePattern] -- ^ ignore patterns

View File

@ -92,18 +92,13 @@ data DirSyncEnv =
, _dirSyncCreds :: Maybe (PeerCredentials 'HBS2Basic) , _dirSyncCreds :: Maybe (PeerCredentials 'HBS2Basic)
, _dirSyncInclude :: [FilePattern] , _dirSyncInclude :: [FilePattern]
, _dirSyncExclude :: [FilePattern] , _dirSyncExclude :: [FilePattern]
, _dirSyncBackup :: Bool
, _dirSyncFollowSymlinks :: Bool
} }
deriving stock (Generic) deriving stock (Generic)
makeLenses 'DirSyncEnv makeLenses 'DirSyncEnv
instance Monoid DirSyncEnv where instance Monoid DirSyncEnv where
mempty = DirSyncEnv Nothing Nothing Nothing mempty defExcl False False mempty = DirSyncEnv Nothing Nothing Nothing mempty ["**/*.hbs2-sync/state"]
where
defExcl = ["**/.hbs2-sync/*"]
instance Semigroup DirSyncEnv where instance Semigroup DirSyncEnv where
(<>) a b = DirSyncEnv ( view dirSyncPath b <|> view dirSyncPath a ) (<>) a b = DirSyncEnv ( view dirSyncPath b <|> view dirSyncPath a )
@ -111,8 +106,6 @@ instance Semigroup DirSyncEnv where
( view dirSyncCreds b <|> view dirSyncCreds a ) ( view dirSyncCreds b <|> view dirSyncCreds a )
(L.nub $ view dirSyncInclude a <> view dirSyncInclude b ) (L.nub $ view dirSyncInclude a <> view dirSyncInclude b )
(L.nub $ view dirSyncExclude a <> view dirSyncExclude b ) (L.nub $ view dirSyncExclude a <> view dirSyncExclude b )
( view dirSyncBackup b || view dirSyncBackup a )
( view dirSyncFollowSymlinks b || view dirSyncFollowSymlinks a )
instance Pretty DirSyncEnv where instance Pretty DirSyncEnv where
pretty e = do pretty e = do
@ -393,16 +386,6 @@ entriesFromFile h ts fn0 = do
dirEntry p = DirEntry (EntryDesc Dir ts Nothing) p dirEntry p = DirEntry (EntryDesc Dir ts Nothing) p
fileEntry p = DirEntry (EntryDesc File ts h) p fileEntry p = DirEntry (EntryDesc File ts h) p
backupMode :: (MonadUnliftIO m, HasRunDir m) => m Bool
backupMode = do
d <- getRunDir
b <- runMaybeT do
env <- getRunDirEnv d >>= toMPlus
pure $ view dirSyncBackup env
pure $ fromMaybe False b
runDirectory :: ( IsContext c runDirectory :: ( IsContext c
, SyncAppPerks m , SyncAppPerks m
, HasClientAPI RefChanAPI UNIX m , HasClientAPI RefChanAPI UNIX m
@ -449,16 +432,8 @@ runDirectory = do
tombs <- getTombs tombs <- getTombs
void $ runMaybeT do void $ runMaybeT do
dir <- getRunDir
backup <- getRunDirEnv dir
<&> fmap (view dirSyncBackup)
<&> fromMaybe False
h <- getEntryHash e & toMPlus h <- getEntryHash e & toMPlus
unless backup do
notice $ green "write" <+> pretty h <+> pretty p notice $ green "write" <+> pretty h <+> pretty p
lbs <- lift (runExceptT (getTreeContents sto h)) lbs <- lift (runExceptT (getTreeContents sto h))
@ -579,9 +554,6 @@ runDirectory = do
Compact.putVal tombs p (maybe 0 succ n) Compact.putVal tombs p (maybe 0 succ n)
b <- backupMode
unless b do
notice $ red "deleted" <+> pretty p notice $ red "deleted" <+> pretty p
rm fullPath rm fullPath
@ -1134,26 +1106,6 @@ syncEntries = do
_ -> pure () _ -> pure ()
entry $ bindMatch "backup-mode" $ nil_ $ \case
[] -> do
dir <- getRunDir
debug $ red "backup-mode" <+> pretty dir
alterRunDirEnv dir $ \case
Nothing -> Just (mempty & set dirSyncBackup True)
Just x -> Just (x & set dirSyncBackup True)
_ -> pure ()
entry $ bindMatch "follow-symlinks" $ nil_ $ \case
[] -> do
dir <- getRunDir
debug $ red "follow-symlinks" <+> pretty dir
alterRunDirEnv dir $ \case
Nothing -> Just (mempty & set dirSyncFollowSymlinks True)
Just x -> Just (x & set dirSyncFollowSymlinks True)
_ -> pure ()
entry $ bindMatch "sign" $ nil_ $ \case entry $ bindMatch "sign" $ nil_ $ \case
[SignPubKeyLike s] -> do [SignPubKeyLike s] -> do
dir <- getRunDir dir <- getRunDir