mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
a7991c55d1
commit
29ba219454
|
|
@ -503,12 +503,34 @@ merge :: Entry -> Entry -> Entry
|
||||||
merge a b = do
|
merge a b = do
|
||||||
if getEntryTimestamp a > getEntryTimestamp b then a else b
|
if getEntryTimestamp a > getEntryTimestamp b then a else b
|
||||||
|
|
||||||
getStateFromDir :: MonadIO m
|
-- NOTE: getStateFromDir
|
||||||
=> FilePath -- ^ dir
|
-- что бы устранить противоречия в "удалённом" стейте и
|
||||||
|
-- локальном, мы должны о них узнать
|
||||||
|
--
|
||||||
|
-- Основное противоречие это file <=> dir
|
||||||
|
-- Так как мы не сохраняем каталоги, а только файлы
|
||||||
|
-- Каталоги выводим из файлов (таким образом, пустые каталоги будут игнорироваться)
|
||||||
|
--
|
||||||
|
-- Допустим, у нас есть файл, совпадающий по имени с каталогом в remote state
|
||||||
|
-- Мы должны тогда вывести этот каталог из remote state и проверить,
|
||||||
|
-- чем он является тут (каталогом или файлом)
|
||||||
|
--
|
||||||
|
-- Тогда функция устранения противоречий сможет что-то с этим сделать
|
||||||
|
-- впоследствии
|
||||||
|
--
|
||||||
|
|
||||||
|
getStateFromDir :: ( MonadIO m
|
||||||
|
, HasClientAPI RefChanAPI UNIX m
|
||||||
|
, HasClientAPI StorageAPI UNIX m
|
||||||
|
, HasStorage m
|
||||||
|
, HasRunDir m
|
||||||
|
)
|
||||||
|
=> Bool -- ^ use remote state as seed
|
||||||
|
-> FilePath -- ^ dir
|
||||||
-> [FilePattern] -- ^ include pattern
|
-> [FilePattern] -- ^ include pattern
|
||||||
-> [FilePattern] -- ^ exclude pattern
|
-> [FilePattern] -- ^ exclude pattern
|
||||||
-> m (Map FilePath Entry)
|
-> m [(FilePath, Entry)]
|
||||||
getStateFromDir path incl excl = do
|
getStateFromDir seed path incl excl = do
|
||||||
es' <- S.toList_ $ do
|
es' <- S.toList_ $ do
|
||||||
glob incl excl path $ \fn -> do
|
glob incl excl path $ \fn -> do
|
||||||
let fn0 = removePrefix path fn
|
let fn0 = removePrefix path fn
|
||||||
|
|
@ -516,7 +538,28 @@ getStateFromDir path incl excl = do
|
||||||
-- debug $ yellow "file" <+> viaShow ts <+> pretty fn0
|
-- debug $ yellow "file" <+> viaShow ts <+> pretty fn0
|
||||||
S.each es
|
S.each es
|
||||||
pure True
|
pure True
|
||||||
pure $ Map.fromList [ (p,e) | e@(DirEntry _ p) <- es' ]
|
|
||||||
|
let es0 = [ (entryPath e, e) | e <- es' ]
|
||||||
|
|
||||||
|
if not seed then do
|
||||||
|
pure es0
|
||||||
|
else do
|
||||||
|
dir <- getRunDir
|
||||||
|
fromMaybe es0 <$> runMaybeT do
|
||||||
|
env <- getRunDirEnv dir >>= toMPlus
|
||||||
|
rchan <- view dirSyncRefChan env & toMPlus
|
||||||
|
es2 <- lift $ getStateFromRefChan rchan
|
||||||
|
|
||||||
|
S.toList_ do
|
||||||
|
S.each es0
|
||||||
|
for_ es2 $ \(p, e) -> do
|
||||||
|
isDir <- liftIO $ doesDirectoryExist (path </> p)
|
||||||
|
ts <- liftIO $ getFileTimestamp (path </> p)
|
||||||
|
|
||||||
|
when isDir do
|
||||||
|
S.yield (p, DirEntry (EntryDesc Dir ts mzero) p)
|
||||||
|
|
||||||
|
S.yield (p,e)
|
||||||
|
|
||||||
|
|
||||||
getStateFromRefChan :: forall m . ( MonadIO m
|
getStateFromRefChan :: forall m . ( MonadIO m
|
||||||
|
|
@ -524,8 +567,8 @@ getStateFromRefChan :: forall m . ( MonadIO m
|
||||||
, HasClientAPI StorageAPI UNIX m
|
, HasClientAPI StorageAPI UNIX m
|
||||||
, HasStorage m
|
, HasStorage m
|
||||||
)
|
)
|
||||||
=> PubKey 'Sign 'HBS2Basic
|
=> MyRefChan
|
||||||
-> m (Map FilePath Entry)
|
-> m [(FilePath, Entry)]
|
||||||
getStateFromRefChan rchan = do
|
getStateFromRefChan rchan = do
|
||||||
|
|
||||||
debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan)
|
debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan)
|
||||||
|
|
@ -566,7 +609,7 @@ getStateFromRefChan rchan = do
|
||||||
let r = entriesFromFile (Just tree) ts (loc </> fn)
|
let r = entriesFromFile (Just tree) ts (loc </> fn)
|
||||||
lift $ S.yield r
|
lift $ S.yield r
|
||||||
|
|
||||||
pure $ Map.unionsWith merge ess0
|
pure $ Map.toList $ Map.unionsWith merge ess0
|
||||||
|
|
||||||
|
|
||||||
getTreeContents :: ( MonadUnliftIO m
|
getTreeContents :: ( MonadUnliftIO m
|
||||||
|
|
@ -723,7 +766,12 @@ syncEntries = do
|
||||||
w -> err $ "invalid sign key" <+> pretty (mkList w)
|
w -> err $ "invalid sign key" <+> pretty (mkList w)
|
||||||
|
|
||||||
|
|
||||||
entry $ bindMatch "dir:state:local:show" $ nil_ $ const do
|
entry $ bindMatch "dir:state:local:show" $ nil_ $ \syn -> do
|
||||||
|
|
||||||
|
let seed = case syn of
|
||||||
|
[StringLike "seed"] -> True
|
||||||
|
_ -> False
|
||||||
|
|
||||||
dir <- getRunDir
|
dir <- getRunDir
|
||||||
|
|
||||||
env <- getRunDirEnv dir >>= orThrow DirNotSet
|
env <- getRunDirEnv dir >>= orThrow DirNotSet
|
||||||
|
|
@ -731,9 +779,9 @@ syncEntries = do
|
||||||
let excl = view dirSyncExclude env
|
let excl = view dirSyncExclude env
|
||||||
let incl = view dirSyncInclude env
|
let incl = view dirSyncInclude env
|
||||||
|
|
||||||
state <- getStateFromDir dir incl excl
|
state <- getStateFromDir seed dir incl excl
|
||||||
|
|
||||||
liftIO $ print $ vcat (fmap (pretty . AsSexp @C) (Map.elems state))
|
liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) state)
|
||||||
|
|
||||||
|
|
||||||
entry $ bindMatch "dir:state:remote:show" $ nil_ $ const do
|
entry $ bindMatch "dir:state:remote:show" $ nil_ $ const do
|
||||||
|
|
@ -748,7 +796,7 @@ syncEntries = do
|
||||||
|
|
||||||
state <- lift $ getStateFromRefChan rchan
|
state <- lift $ getStateFromRefChan rchan
|
||||||
|
|
||||||
liftIO $ print $ vcat (fmap (pretty . AsSexp @C) (Map.elems state))
|
liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) state)
|
||||||
|
|
||||||
|
|
||||||
entry $ bindMatch "dir:config:show" $ nil_ $ const do
|
entry $ bindMatch "dir:config:show" $ nil_ $ const do
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue