mirror of https://github.com/voidlizard/hbs2
parent
7e0305891b
commit
68c8c7bef3
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue