diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index be966ef0..a5eaf03f 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -290,6 +290,11 @@ isFile = \case DirEntry (EntryDesc { entryType = File}) _ -> True _ -> False +isDir :: Entry -> Bool +isDir = \case + DirEntry (EntryDesc { entryType = Dir}) _ -> True + _ -> False + entriesFromLocalFile :: MonadUnliftIO m => FilePath -> FilePath -> m (Map FilePath Entry) entriesFromLocalFile prefix fn' = do let fn0 = removePrefix prefix fn @@ -503,6 +508,38 @@ merge :: Entry -> Entry -> Entry merge a b = do if getEntryTimestamp a > getEntryTimestamp b then a else b +mergeState :: MonadUnliftIO m + => [(FilePath, Entry)] + -> m [(FilePath, Entry)] + +mergeState orig = do + + let dirs = [ (p,e) | (p,e) <- orig, isDir e ] & Map.fromListWith merge + + let files = [ (p,e) | (p,e) <- orig, isFile e ] & Map.fromListWith merge + + let names = Map.keysSet (dirs <> files) + + S.toList_ do + for_ (Map.toList files) $ \(p,e@(DirEntry d _)) -> do + if Map.member p dirs then do + let new = uniqName names p + S.yield (new, DirEntry d new) + else + S.yield (p,e) + + where + uniqName names0 name = do + + flip fix (names0,0) $ \next (names,n) -> do + let suff = hashObject @HbSync (serialise (names, name, n)) + & pretty & show & drop 2 & take 4 + let new = name <> "~" <> suff + if Set.member new names then + next (Set.insert new names, succ n) + else + new + -- NOTE: getStateFromDir -- что бы устранить противоречия в "удалённом" стейте и -- локальном, мы должны о них узнать @@ -519,6 +556,25 @@ merge a b = do -- впоследствии -- +getStateFromDir0 :: ( MonadIO m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasRunDir m + ) + => Bool + -> m [(FilePath, Entry)] +getStateFromDir0 seed = do + + dir <- getRunDir + + env <- getRunDirEnv dir >>= orThrow DirNotSet + + let excl = view dirSyncExclude env + let incl = view dirSyncInclude env + + getStateFromDir seed dir incl excl + getStateFromDir :: ( MonadIO m , HasClientAPI RefChanAPI UNIX m , HasClientAPI StorageAPI UNIX m @@ -766,23 +822,23 @@ syncEntries = do w -> err $ "invalid sign key" <+> pretty (mkList w) - entry $ bindMatch "dir:state:local:show" $ nil_ $ \syn -> do + entry $ bindMatch "dir:state:merged:show" $ nil_ $ \_ -> do + state <- getStateFromDir0 True - let seed = case syn of - [StringLike "seed"] -> True - _ -> False + merged <- mergeState state - dir <- getRunDir + liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) merged) - env <- getRunDirEnv dir >>= orThrow DirNotSet + entry $ bindMatch "dir:state:local:show" $ nil_ $ \sy -> do - let excl = view dirSyncExclude env - let incl = view dirSyncInclude env + let f = case sy of + [StringLike "F"] -> isFile + [StringLike "D"] -> isDir + _ -> const True - state <- getStateFromDir seed dir incl excl - - liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) state) + state <- getStateFromDir0 False + liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) (filter (f . snd) state)) entry $ bindMatch "dir:state:remote:show" $ nil_ $ const do dir <- getRunDir