voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip, broken state + broken code

This commit is contained in:
Dmitry Zuikov 2024-08-04 16:06:37 +03:00
parent fbb723512b
commit 18c39566a0
1 changed files with 16 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
hbs2-sync/src/HBS2/Sync/Prelude.hs
View File

@ -70,7 +70,7 @@ import Data.Time.LocalTime (utcToLocalTime, getCurrentTimeZone, utc)
import Data.Word import Data.Word
import Lens.Micro.Platform import Lens.Micro.Platform
import Streaming.Prelude qualified as S import Streaming.Prelude qualified as S
import System.Directory (getModificationTime,setModificationTime) import System.Directory (getModificationTime,setModificationTime,doesFileExist)
import System.FilePath.Posix import System.FilePath.Posix
import UnliftIO import UnliftIO
@ -371,13 +371,21 @@ runDirectory path = do
let merged = Map.unionWith merge local remote let merged = Map.unionWith merge local remote
for_ (Map.toList merged) $ \(k,v) -> do
debug $ red "LOCAL MERGED" <+> pretty k <+> viaShow v
flip runContT pure do flip runContT pure do
for_ (Map.toList merged) $ \(p,e) -> do for_ (Map.toList merged) $ \(p,e) -> do
let filePath = path </> p
debug $ yellow "entry" <+> pretty p <+> viaShow e debug $ yellow "entry" <+> pretty p <+> viaShow e
callCC $ \next -> do callCC $ \next -> do
-- actuallyFile <- liftIO $ doesFileExist filePath
when (freshIn p e remote) do when (freshIn p e remote) do
-- FIXME: dangerous! -- FIXME: dangerous!
@ -471,9 +479,15 @@ runDirectory path = do
fn <- toMPlus $ headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ] fn <- toMPlus $ headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ]
ts <- toMPlus $ HM.lookup txh tsmap ts <- toMPlus $ HM.lookup txh tsmap
let r = entriesFromFile (Just tree) ts (loc </> fn) let r = entriesFromFile (Just tree) ts (loc </> fn)
debug $ green "AAAA ZZZ" <+> pretty (loc </> fn) <+> pretty tree
lift $ S.yield r lift $ S.yield r
pure $ Map.unionsWith merge ess0 let ess1 = Map.unionsWith merge ess0
for_ (Map.toList ess1) $ \(k,v) -> do
debug $ blue "MERGED" <+> pretty k <+> viaShow v
pure ess1
getTreeContents :: ( MonadUnliftIO m getTreeContents :: ( MonadUnliftIO m