wip, speedup

hbs2-cli/lib/Data/Config/Suckless/Script/File.hs

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

hbs2-sync/src/HBS2/Sync/Prelude.hs

@@ -92,13 +92,18 @@ data DirSyncEnv =
   , _dirSyncCreds    :: Maybe (PeerCredentials 'HBS2Basic)
   , _dirSyncInclude  :: [FilePattern]
   , _dirSyncExclude  :: [FilePattern]
+  , _dirSyncBackup   :: Bool
+  , _dirSyncFollowSymlinks :: Bool
   }
   deriving stock (Generic)
 
 makeLenses 'DirSyncEnv
 
 instance Monoid DirSyncEnv where
-  mempty = DirSyncEnv Nothing Nothing Nothing mempty ["**/*.hbs2-sync/state"]
+  mempty = DirSyncEnv Nothing Nothing Nothing mempty defExcl False False
+    where
+      defExcl = ["**/.hbs2-sync/*"]
+
 
 instance Semigroup DirSyncEnv where
   (<>) a b = DirSyncEnv ( view dirSyncPath b <|> view dirSyncPath a )
@@ -106,6 +111,8 @@ instance Semigroup DirSyncEnv where
                         ( view dirSyncCreds b  <|> view dirSyncCreds a )
                         (L.nub $  view dirSyncInclude a <> view dirSyncInclude 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
   pretty e = do
@@ -386,6 +393,16 @@ entriesFromFile h ts fn0 = do
     dirEntry p   = DirEntry (EntryDesc Dir ts Nothing) 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
                 , SyncAppPerks m
                 , HasClientAPI RefChanAPI UNIX m
@@ -432,22 +449,30 @@ runDirectory = do
       tombs <- getTombs
 
       void $ runMaybeT do
+
+        dir <- getRunDir
+        backup <- getRunDirEnv dir
+                     <&> fmap (view dirSyncBackup)
+                     <&> fromMaybe False
+
         h <- getEntryHash e & toMPlus
 
-        notice $ green "write" <+> pretty h <+> pretty p
+        unless backup do
 
-        lbs <- lift (runExceptT (getTreeContents sto h))
-                 >>= toMPlus
+          notice $ green "write" <+> pretty h <+> pretty p
 
-        mkdir (dropFileName filePath)
+          lbs <- lift (runExceptT (getTreeContents sto h))
+                   >>= toMPlus
 
-        liftIO $ UIO.withBinaryFileAtomic filePath WriteMode $ \fh -> do
-          LBS.hPutStr fh lbs >> hFlush fh
+          mkdir (dropFileName filePath)
 
-        let ts  = getEntryTimestamp e
-        let timestamp = posixSecondsToUTCTime (fromIntegral ts)
+          liftIO $ UIO.withBinaryFileAtomic filePath WriteMode $ \fh -> do
+            LBS.hPutStr fh lbs >> hFlush fh
 
-        liftIO $ setModificationTime (path </> p) timestamp
+          let ts  = getEntryTimestamp e
+          let timestamp = posixSecondsToUTCTime (fromIntegral ts)
+
+          liftIO $ setModificationTime (path </> p) timestamp
 
         lift $ Compact.putVal tombs p (0 :: Integer)
 
@@ -554,8 +579,11 @@ runDirectory = do
 
               Compact.putVal tombs p (maybe 0 succ n)
 
-              notice $ red "deleted" <+> pretty p
-              rm fullPath
+              b <- backupMode
+
+              unless b do
+                notice $ red "deleted" <+> pretty p
+                rm fullPath
 
           E (p,_) -> do
             notice $ "skip entry" <+> pretty p
@@ -1086,6 +1114,26 @@ syncEntries = do
 
         _ -> 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
         [SignPubKeyLike s] -> do
           dir <- getRunDir