diff --git a/.gitignore b/.gitignore index bcd3f9ac..b7f5ac53 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,4 @@ cabal.project.local .hbs2-git/ bin/ .fixme-new/current-stage.log +.hbs2-sync/ diff --git a/hbs2-core/lib/HBS2/System/Dir.hs b/hbs2-core/lib/HBS2/System/Dir.hs index 18a79a1e..c9bc2c58 100644 --- a/hbs2-core/lib/HBS2/System/Dir.hs +++ b/hbs2-core/lib/HBS2/System/Dir.hs @@ -69,6 +69,10 @@ expandPath = liftIO . D.canonicalizePath doesDirectoryExist :: MonadIO m => FilePath -> m Bool doesDirectoryExist = liftIO . D.doesDirectoryExist +doesFileExist :: MonadIO m => FilePath -> m Bool +doesFileExist = liftIO . D.doesFileExist + + fileSize :: MonadIO m => FilePath -> m Integer fileSize = liftIO . D.getFileSize diff --git a/hbs2-sync/app/Main.hs b/hbs2-sync/app/Main.hs index 3fc49dca..bf1936c1 100644 --- a/hbs2-sync/app/Main.hs +++ b/hbs2-sync/app/Main.hs @@ -1,14 +1,10 @@ -{-# Language ViewPatterns #-} -{-# Language PatternSynonyms #-} module Main where import HBS2.Sync.Prelude +import HBS2.Sync import HBS2.System.Dir import System.Environment -import System.Directory -import UnliftIO - helpEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m () helpEntries = do diff --git a/hbs2-sync/hbs2-sync.cabal b/hbs2-sync/hbs2-sync.cabal index a4c0abc3..4b7f3f2e 100644 --- a/hbs2-sync/hbs2-sync.cabal +++ b/hbs2-sync/hbs2-sync.cabal @@ -89,6 +89,9 @@ library exposed-modules: HBS2.Sync.Prelude + HBS2.Sync.State + HBS2.Sync.Internal + HBS2.Sync other-modules: diff --git a/hbs2-sync/src/HBS2/Sync.hs b/hbs2-sync/src/HBS2/Sync.hs new file mode 100644 index 00000000..34d2b598 --- /dev/null +++ b/hbs2-sync/src/HBS2/Sync.hs @@ -0,0 +1,9 @@ +module HBS2.Sync + ( module HBS2.Sync + , module Exported + ) where + +import HBS2.Sync.Internal as Exported +import HBS2.Sync.State as Exported + + diff --git a/hbs2-sync/src/HBS2/Sync/Internal.hs b/hbs2-sync/src/HBS2/Sync/Internal.hs new file mode 100644 index 00000000..0c020482 --- /dev/null +++ b/hbs2-sync/src/HBS2/Sync/Internal.hs @@ -0,0 +1,515 @@ +module HBS2.Sync.Internal + ( syncEntries + ) where + +import HBS2.Sync.Prelude +import HBS2.Sync.State + +import HBS2.Merkle.MetaData +import HBS2.System.Dir +import HBS2.Net.Auth.GroupKeySymm +import HBS2.Storage.Operations.Class +import HBS2.Storage.Compact as Compact +import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client.Unix (UNIX) +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.Client.RefChan as Client + +import HBS2.CLI.Run.Internal hiding (PeerNotConnectedException) + +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.Time.Clock.POSIX + + +import Control.Monad.Trans.Maybe +import Data.ByteString.Lazy qualified as LBS +import Data.List qualified as L +import Data.Map qualified as Map +import Lens.Micro.Platform +import System.Directory (setModificationTime,listDirectory) +import System.Directory (XdgDirectory(..),getXdgDirectory) +import Control.Monad.Except +import Data.Ord + +import Streaming.Prelude qualified as S +import UnliftIO.IO.File qualified as UIO + + +syncEntries :: forall c m . ( MonadUnliftIO m + , IsContext c + , Exception (BadFormException c) + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasRunDir m + , HasTombs m + , HasCache m + , MonadReader (Maybe SyncEnv) m + ) + => MakeDictM c m () +syncEntries = do + + entry $ bindMatch "--debug" $ nil_ $ \case + [SymbolVal "off"] -> do + setLoggingOff @DEBUG + + _ -> do + setLogging @DEBUG debugPrefix + + entry $ bindMatch "init" $ nil_ $ const do + pure () + + entry $ bindMatch "sync" $ nil_ $ \case + [StringLike d] -> do + + void $ evalTop [ mkList [mkSym "dir", mkStr d] + , mkList [mkSym "run"] + ] + + [] -> do + + void $ evalTop [ mkList [mkSym "dir", mkStr "."] + , mkList [mkSym "run"] + ] + + _ -> pure () + + brief "sets current directory" + $ args [ arg "string" "dir" ] + $ desc "useful for debugging" + $ entry $ bindMatch "dir" $ nil_ $ \case + [StringLike d] -> do + debug $ "set current directory" <+> pretty d + t <- lift ask >>= orThrow PeerNotConnectedException + atomically $ writeTVar (dirThis t) (Just d) + + alterRunDirEnv d $ \case + Nothing -> Just (mempty & set dirSyncPath (Just d)) + Just x -> Just (x & set dirSyncPath (Just d)) + + ins <- try @_ @IOError (liftIO $ readFile (d ".hbs2-sync/config")) + <&> fromRight mempty + <&> parseTop + <&> either mempty (fmap fixContext) + + void $ evalTop ins + + _ -> do + err "current dir not set" + + entry $ bindMatch "refchan" $ nil_ $ \case + [SignPubKeyLike puk] -> do + dir <- getRunDir + debug $ red "refchan" <+> pretty dir <+> pretty (AsBase58 puk) + alterRunDirEnv dir $ \case + Nothing -> Just (mempty & set dirSyncRefChan (Just puk)) + Just x -> Just (x & set dirSyncRefChan (Just puk)) + + x -> err $ "invalid refchan" <+> pretty (mkList x) + + entry $ bindMatch "exclude" $ nil_ $ \case + [StringLike excl] -> do + dir <- getRunDir + debug $ red "exclude" <+> pretty dir <+> pretty excl + alterRunDirEnv dir $ \case + Nothing -> Just (mempty & set dirSyncExclude [excl]) + Just x -> Just (x & over dirSyncExclude (mappend [excl])) + + _ -> pure () + + entry $ bindMatch "include" $ nil_ $ \case + [StringLike pat] -> do + dir <- getRunDir + debug $ red "include" <+> pretty dir <+> pretty pat + alterRunDirEnv dir $ \case + Nothing -> Just (mempty & set dirSyncInclude [pat]) + Just x -> Just (x & over dirSyncInclude (mappend [pat])) + + _ -> 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 + debug $ red "sign" <+> pretty (AsBase58 s) + creds <- liftIO (runKeymanClient $ loadCredentials s) + alterRunDirEnv dir $ \case + Nothing -> Just (mempty & set dirSyncCreds creds) + Just x -> Just (x & set dirSyncCreds creds) + + w -> err $ "invalid sign key" <+> pretty (mkList w) + + + brief "output file from remote state" + $ args [arg "string" "refchan", arg "string" "file"] + $ entry $ bindMatch "cat" $ nil_ $ \case + [SignPubKeyLike rchan, StringLike fn] -> do + sto <- getStorage + void $ runMaybeT do + h <- lift (getStateFromRefChan rchan) + <&> Map.fromList + <&> Map.lookup fn + >>= toMPlus + <&> getEntryHash + >>= toMPlus + + lbs <- lift $ runExceptT (getTreeContents sto h) + >>= orThrowPassIO + + liftIO $ LBS.putStr lbs + + _ -> none + + entry $ bindMatch "dir:state:merged:show" $ nil_ $ \_ -> do + state <- getStateFromDir0 True + + deleted <- findDeleted + merged <- mergeState deleted state + + liftIO $ print $ vcat (fmap (pretty . AsSexp @C) merged) + + + entry $ bindMatch "ls" $ nil_ $ \case + (StringLikeList _) -> do + state <- getStateFromDir0 False <&> Map.fromList + + for_ (Map.toList state) $ \(f,e) -> do + when (isFile e || isDir e ) do + liftIO $ putStrLn f + + _ -> pure () + + entry $ bindMatch "dir:state:local:show" $ nil_ $ \sy -> do + + let f = case sy of + [StringLike "F"] -> isFile + [StringLike "D"] -> isDir + _ -> const True + + state <- getStateFromDir0 True + + liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) (filter (f . snd) state)) + + entry $ bindMatch "dir:state:remote:show" $ nil_ $ \syn -> do + + let f = case syn of + [StringLike "F"] -> isFile + [StringLike "D"] -> isDir + _ -> const True + + dir <- getRunDir + + + env <- getRunDirEnv dir >>= orThrow DirNotSet + + runMaybeT do + + rchan <- view dirSyncRefChan env + & toMPlus + + state <- lift $ getStateFromRefChan rchan + + liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) (filter (f.snd) state)) + + + entry $ bindMatch "dir:config:show" $ nil_ $ const do + dir <- getRunDir + + void $ runMaybeT do + env <- getRunDirEnv dir >>= toMPlus + liftIO $ print $ pretty env + + entry $ bindMatch "run" $ nil_ \case + _ -> runDirectory + + entry $ bindMatch "prune" $ nil_ \case + [] -> do + + + path <- getRunDir + + env <- getRunDirEnv path >>= orThrow DirNotSet + + let excl = view dirSyncExclude env + + let skip p = or [ i ?== p | i <- excl ] + + dirs <- S.toList_ do + flip fix [path] $ \next -> \case + (d:ds) -> do + dirs <- liftIO (listDirectory d) + let es = [ path d x | x <- dirs, not (skip x) ] + dd <- liftIO $ filterM doesDirectoryExist es + S.each dd + next (ds <> dd) + + [] -> pure () + + for_ (L.sortBy (comparing Down) dirs) $ \d -> do + pu <- liftIO (listDirectory d) <&> L.null + when pu do + notice $ red "prune" <+> pretty d + rm d + + _ -> pure () + + + brief "posts tomb transaction for the current dir" + $ args [arg "string" "entry-path"] + $ desc ( "working dir must be set first" <> line + <> "see: dir, sync" + ) + $ entry $ bindMatch "tomb" $ nil_ \case + [StringLike p] -> do + + path <- getRunDir + env <- getRunDirEnv path >>= orThrow DirNotSet + + void $ runMaybeT do + + let fullPath = path p + + rchan <- view dirSyncRefChan env + & toMPlus + + here <- liftIO (doesFileExist fullPath) + guard here + + now <- liftIO getPOSIXTime <&> round + + notice $ red "ABOUT TO POST TOMB TX" <+> pretty p + lift $ postEntryTx Nothing Nothing rchan path (makeTomb now p mzero) + + _ -> pure () + + entry $ bindMatch "run-config" $ nil_ $ const do + cpath <- liftIO $ getXdgDirectory XdgConfig "hbs2-sync" <&> ( "config") + debug $ "run-config" <+> pretty cpath + try @_ @IOError (liftIO $ readFile cpath) + <&> fromRight mempty + <&> parseTop + <&> either mempty (fmap fixContext) + >>= evalTop + + entry $ bindMatch "timestamp" $ nil_ $ \case + [StringLike fn] -> do + liftIO (getFileTimestamp fn >>= print) + _ -> do + liftIO $ getPOSIXTime <&> round >>= print + + +runDirectory :: ( IsContext c + , SyncAppPerks m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasRunDir m + , HasTombs m + , HasCache m + , Exception (BadFormException c) + ) => RunM c m () +runDirectory = do + + path <- getRunDir + + runDir + `catch` \case + RefChanNotSetException -> do + err $ "no refchan set for" <+> pretty path + RefChanHeadNotFoundException -> do + err $ "no refchan head found for" <+> pretty path + EncryptionKeysNotDefined -> do + err $ "no readers defined in the refchan for " <+> pretty path + SignKeyNotSet -> do + err $ "sign key not set or not found " <+> pretty path + DirNotSet -> do + err $ "directory not set" + + `catch` \case + (e :: OperationError) -> do + err $ viaShow e + + `finally` do + closeTombs + closeCache + + where + + + writeEntry path e = do + + let p = entryPath e + let filePath = path p + + sto <- getStorage + + tombs <- getTombs + + void $ runMaybeT do + + dir <- getRunDir + backup <- getRunDirEnv dir + <&> fmap (view dirSyncBackup) + <&> fromMaybe False + + h <- getEntryHash e & toMPlus + + unless backup do + + notice $ green "write" <+> pretty h <+> pretty p + + lbs <- lift (runExceptT (getTreeContents sto h)) + >>= toMPlus + + mkdir (dropFileName filePath) + + liftIO $ UIO.withBinaryFileAtomic filePath WriteMode $ \fh -> do + LBS.hPutStr fh lbs >> hFlush fh + + let ts = getEntryTimestamp e + let timestamp = posixSecondsToUTCTime (fromIntegral ts) + + liftIO $ setModificationTime (path p) timestamp + + lift $ Compact.putVal tombs p (0 :: Integer) + + runDir = do + + sto <- getStorage + + path <- getRunDir + + env <- getRunDirEnv path >>= orThrow DirNotSet + + refchan <- view dirSyncRefChan env & orThrow RefChanNotSetException + + fetchRefChan @UNIX refchan + + -- FIXME: multiple-directory-scans + + local <- getStateFromDir0 True + + let hasRemoteHash = [ (p, h) | (p, WithRemoteHash e h) <- local] + + hasGK0 <- HM.fromList <$> S.toList_ do + for_ hasRemoteHash $ \(p,h) -> do + mgk0 <- lift $ loadGroupKeyForTree @HBS2Basic sto h + for_ mgk0 $ \gk0 -> S.yield (p,gk0) + + deleted <- findDeleted + + merged <- mergeState deleted local + + rch <- Client.getRefChanHead @UNIX refchan + >>= orThrow RefChanHeadNotFoundException + + let filesLast m = case mergedEntryType m of + Tomb -> 0 + Dir -> 1 + File -> 2 + + for_ (L.sortOn filesLast merged) $ \w -> do + case w of + N (p,TombEntry e) -> do + notice $ green "removed" <+> pretty p + + D (p,e) _ -> do + + tombs <- getTombs + + n <- Compact.getValEither @Integer tombs p + <&> fromRight (Just 0) + + notice $ "deleted locally" <+> pretty n <+> pretty p + + when (n < Just 1) do + notice $ "post tomb tx" <+> pretty n <+> pretty p + now <- liftIO $ getPOSIXTime <&> round <&> LBS.take 6 . serialise + postEntryTx (Just now) (HM.lookup p hasGK0) refchan path e + Compact.putVal tombs p (maybe 1 succ n) + + N (p,_) -> do + notice $ "?" <+> pretty p + + M (f,t,e) -> do + notice $ green "move" <+> pretty f <+> pretty t + mv (path f) (path t) + notice $ green "post renamed entry tx" <+> pretty f + postEntryTx Nothing (HM.lookup f hasGK0) refchan path e + + E (p,UpdatedFileEntry _ e) -> do + let fullPath = path p + here <- liftIO $ doesFileExist fullPath + writeEntry path e + notice $ red "updated" <+> pretty here <+> pretty p + postEntryTx Nothing (HM.lookup p hasGK0) refchan path e + + E (p,e@(FileEntry _)) -> do + let fullPath = path p + here <- liftIO $ doesFileExist fullPath + d <- liftIO $ doesDirectoryExist fullPath + + older <- if here then do + s <- getFileTimestamp fullPath + pure $ s < getEntryTimestamp e + else + pure False + + when (not here || older) do + writeEntry path e + + void $ runMaybeT do + gk0 <- HM.lookup p hasGK0 & toMPlus + let rcpt = recipients gk0 & HM.keys + let members = view refChanHeadReaders rch & HS.toList + when (rcpt /= members) do + notice $ red "update group key" <+> pretty p + lift $ postEntryTx Nothing (Just gk0) refchan path e + + E (p,TombEntry e) -> do + let fullPath = path p + here <- liftIO $ doesFileExist fullPath + when here do + + tombs <- getTombs + + n <- Compact.getValEither @Integer tombs p + <&> fromRight (Just 0) + + + when (n < Just 1) do + notice $ "post tomb tx" <+> pretty n <+> pretty p + postEntryTx Nothing (HM.lookup p hasGK0) refchan path e + + Compact.putVal tombs p (maybe 0 succ n) + + b <- backupMode + + unless b do + notice $ red "deleted" <+> pretty p + rm fullPath + + E (p,_) -> do + notice $ "skip entry" <+> pretty p + diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index 11754f51..c28cc31e 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -11,26 +11,18 @@ module HBS2.Sync.Prelude import HBS2.Prelude.Plated as Exported -import HBS2.Clock -import HBS2.Base58 -import HBS2.Data.Detect -import HBS2.Merkle -import HBS2.Merkle.MetaData +import HBS2.Base58 as Exported import HBS2.OrDie as Exported import HBS2.Data.Types.Refs as Exported -import HBS2.Data.Types.SignedBox -import HBS2.Net.Auth.Credentials -import HBS2.Net.Auth.GroupKeySymm as Symm -import HBS2.Net.Proto.Service -import HBS2.Storage +import HBS2.Net.Auth.Credentials as Exported hiding (encode,decode) +import HBS2.Net.Proto.Service hiding (encode,decode) +import HBS2.Peer.Proto.RefChan.Types as Exported +import HBS2.Net.Messaging.Unix (runMessagingUnix,newMessagingUnix) +import HBS2.Storage as Exported import HBS2.Storage.Compact as Compact -import HBS2.Storage.Operations.Class -import HBS2.Storage.Operations.ByteString -import HBS2.Peer.Proto.RefChan import HBS2.Peer.CLI.Detect -import HBS2.Peer.RPC.Client -import HBS2.Peer.RPC.Client.Unix -import HBS2.Peer.RPC.Client.RefChan as Client +import HBS2.Peer.RPC.Client hiding (encode,decode) -- as Exported +import HBS2.Peer.RPC.Client.Unix (UNIX) import HBS2.Peer.RPC.Client.StorageClient import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.API.RefChan @@ -40,10 +32,12 @@ import HBS2.System.Dir import HBS2.Misc.PrettyStuff as Exported import HBS2.CLI.Run hiding (PeerException(..)) -import HBS2.CLI.Run.MetaData --- import HBS2.CLI.Run.GroupKey -import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.Keys.Direct as Exported ( runKeymanClient + , loadCredentials + , loadKeyRingEntries + , extractGroupKeySecret + ) import Data.Config.Suckless as Exported import Data.Config.Suckless.Script as Exported @@ -60,11 +54,9 @@ import Control.Monad.Trans.Maybe import Control.Monad.Except import Data.Ord import Data.ByteString qualified as BS -import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy qualified as LBS -import Data.ByteString (ByteString) -import Data.Coerce -import Data.Either +import Data.Coerce as Exported +import Data.Either as Exported import Data.Fixed import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS @@ -72,7 +64,7 @@ import Data.List qualified as L import Data.List (stripPrefix) import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe +import Data.Maybe as Exported import Data.Text qualified as Text import Data.Set qualified as Set import Data.Time.Clock.POSIX @@ -86,6 +78,7 @@ import System.TimeIt import Text.InterpolatedString.Perl6 (qc) import UnliftIO.IO.File qualified as UIO +import UnliftIO as Exported {- HLINT ignore "Functor law" -} {- HLINT ignore "Eta reduce" -} @@ -325,16 +318,6 @@ class IsContext c => ToSexp c a where toSexp :: a -> Syntax c -data EntryType = File | Dir | Tomb - deriving stock (Eq,Ord,Show,Data,Generic) - -data EntryDesc = - EntryDesc - { entryType :: EntryType - , entryTimestamp :: Word64 - , entryRemoteHash :: Maybe HashRef - } - deriving stock (Eq,Ord,Show,Data,Generic) newtype AsSexp c a = AsSexp a @@ -350,99 +333,9 @@ tombLikeValue = \case LitBoolVal True -> True _ -> False -pattern WithRemoteHash :: Entry -> HashRef -> Entry -pattern WithRemoteHash e h <- e@(DirEntry (EntryDesc {entryRemoteHash = Just h}) _) - -pattern TombEntry :: Entry -> Entry -pattern TombEntry e <- e@(DirEntry (EntryDesc { entryType = Tomb }) _) - -pattern FileEntry :: Entry -> Entry -pattern FileEntry e <- e@(DirEntry (EntryDesc { entryType = File }) _) - -pattern UpdatedFileEntry :: Word64 -> Entry -> Entry -pattern UpdatedFileEntry t e <- e@(DirEntry (EntryDesc { entryType = File - , entryRemoteHash = Nothing - , entryTimestamp = t }) _) - instance (IsContext c, ToSexp c w) => Pretty (AsSexp c w) where pretty (AsSexp s) = pretty (toSexp @c s) -data Entry = - DirEntry EntryDesc FilePath - deriving stock (Eq,Ord,Show,Data,Generic) - - -instance Serialise Entry -instance Serialise EntryType -instance Serialise EntryDesc - -instance IsContext c => ToSexp c EntryType where - toSexp a = mkStr @c $ Text.toLower $ Text.pack $ show a - -instance IsContext c => ToSexp c EntryDesc where - toSexp EntryDesc{..} = case entryType of - File -> mkForm @c "F" [mkInt entryTimestamp, hash] - Dir -> mkForm @c "D " [mkInt entryTimestamp, hash] - Tomb -> mkForm @c "T " [mkInt entryTimestamp, hash] - - where - hash = case entryRemoteHash of - Nothing -> nil - Just x -> mkStr (show $ pretty x) - -instance IsContext c => ToSexp c Entry where - toSexp (DirEntry w p) = mkForm @c "entry" [toSexp w, mkStr p] - - -makeTomb :: Word64 -> FilePath -> Maybe HashRef -> Entry -makeTomb t n h = DirEntry (EntryDesc Tomb t h) n - -entryPath :: Entry -> FilePath -entryPath (DirEntry _ p) = p - -getEntryTimestamp :: Entry -> Word64 -getEntryTimestamp (DirEntry d _) = entryTimestamp d - -getEntryHash :: Entry -> Maybe HashRef -getEntryHash (DirEntry d _) = entryRemoteHash d - -isFile :: Entry -> Bool -isFile = \case - DirEntry (EntryDesc { entryType = File}) _ -> True - _ -> False - -isTomb :: Entry -> Bool -isTomb = \case - DirEntry (EntryDesc { entryType = Tomb}) _ -> 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 - ts <- getFileTimestamp fn - pure $ entriesFromFile Nothing ts fn0 - where - fn = normalise fn' - -entriesFromFile :: Maybe HashRef -> Word64 -> FilePath -> Map FilePath Entry -entriesFromFile h ts fn0 = do - let dirs = splitDirectories (dropFileName fn0) - & dropWhile (== ".") - let es = flip L.unfoldr ("",dirs) $ \case - (_,[]) -> Nothing - (p,d:ds) -> Just (dirEntry (p d), (p d, ds) ) - - Map.fromList [ (p, e) - | e@(DirEntry _ p) <- fileEntry fn0 : es - ] - where - 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 @@ -454,678 +347,9 @@ backupMode = do pure $ fromMaybe False b -runDirectory :: ( IsContext c - , SyncAppPerks m - , HasClientAPI RefChanAPI UNIX m - , HasClientAPI StorageAPI UNIX m - , HasStorage m - , HasRunDir m - , HasTombs m - , HasCache m - , Exception (BadFormException c) - ) => RunM c m () -runDirectory = do - path <- getRunDir - runDir - `catch` \case - RefChanNotSetException -> do - err $ "no refchan set for" <+> pretty path - RefChanHeadNotFoundException -> do - err $ "no refchan head found for" <+> pretty path - EncryptionKeysNotDefined -> do - err $ "no readers defined in the refchan for " <+> pretty path - SignKeyNotSet -> do - err $ "sign key not set or not found " <+> pretty path - DirNotSet -> do - err $ "directory not set" - `catch` \case - (e :: OperationError) -> do - err $ viaShow e - - `finally` do - closeTombs - closeCache - - where - - - writeEntry path e = do - - let p = entryPath e - let filePath = path p - - sto <- getStorage - - tombs <- getTombs - - void $ runMaybeT do - - dir <- getRunDir - backup <- getRunDirEnv dir - <&> fmap (view dirSyncBackup) - <&> fromMaybe False - - h <- getEntryHash e & toMPlus - - unless backup do - - notice $ green "write" <+> pretty h <+> pretty p - - lbs <- lift (runExceptT (getTreeContents sto h)) - >>= toMPlus - - mkdir (dropFileName filePath) - - liftIO $ UIO.withBinaryFileAtomic filePath WriteMode $ \fh -> do - LBS.hPutStr fh lbs >> hFlush fh - - let ts = getEntryTimestamp e - let timestamp = posixSecondsToUTCTime (fromIntegral ts) - - liftIO $ setModificationTime (path p) timestamp - - lift $ Compact.putVal tombs p (0 :: Integer) - - runDir = do - - sto <- getStorage - - path <- getRunDir - - env <- getRunDirEnv path >>= orThrow DirNotSet - - refchan <- view dirSyncRefChan env & orThrow RefChanNotSetException - - fetchRefChan @UNIX refchan - - -- FIXME: multiple-directory-scans - - local <- getStateFromDir0 True - - let hasRemoteHash = [ (p, h) | (p, WithRemoteHash e h) <- local] - - hasGK0 <- HM.fromList <$> S.toList_ do - for_ hasRemoteHash $ \(p,h) -> do - mgk0 <- lift $ loadGroupKeyForTree @HBS2Basic sto h - for_ mgk0 $ \gk0 -> S.yield (p,gk0) - - deleted <- findDeleted - - merged <- mergeState deleted local - - rch <- Client.getRefChanHead @UNIX refchan - >>= orThrow RefChanHeadNotFoundException - - let filesLast m = case mergedEntryType m of - Tomb -> 0 - Dir -> 1 - File -> 2 - - for_ (L.sortOn filesLast merged) $ \w -> do - case w of - N (p,TombEntry e) -> do - notice $ green "removed" <+> pretty p - - D (p,e) _ -> do - - tombs <- getTombs - - n <- Compact.getValEither @Integer tombs p - <&> fromRight (Just 0) - - notice $ "deleted locally" <+> pretty n <+> pretty p - - when (n < Just 1) do - notice $ "FUCKING POST TOMB TX" <+> pretty n <+> pretty p - now <- liftIO $ getPOSIXTime <&> round <&> LBS.take 6 . serialise - postEntryTx (Just now) (HM.lookup p hasGK0) refchan path e - Compact.putVal tombs p (maybe 1 succ n) - - N (p,_) -> do - notice $ "?" <+> pretty p - - M (f,t,e) -> do - notice $ green "move" <+> pretty f <+> pretty t - mv (path f) (path t) - notice $ green "post renamed entry tx" <+> pretty f - postEntryTx Nothing (HM.lookup f hasGK0) refchan path e - - E (p,UpdatedFileEntry _ e) -> do - let fullPath = path p - here <- liftIO $ doesFileExist fullPath - writeEntry path e - notice $ red "updated" <+> pretty here <+> pretty p - postEntryTx Nothing (HM.lookup p hasGK0) refchan path e - - E (p,e@(FileEntry _)) -> do - let fullPath = path p - here <- liftIO $ doesFileExist fullPath - d <- liftIO $ doesDirectoryExist fullPath - - older <- if here then do - s <- getFileTimestamp fullPath - pure $ s < getEntryTimestamp e - else - pure False - - when (not here || older) do - writeEntry path e - - void $ runMaybeT do - gk0 <- HM.lookup p hasGK0 & toMPlus - let rcpt = recipients gk0 & HM.keys - let members = view refChanHeadReaders rch & HS.toList - when (rcpt /= members) do - notice $ red "update group key" <+> pretty p - lift $ postEntryTx Nothing (Just gk0) refchan path e - - E (p,TombEntry e) -> do - let fullPath = path p - here <- liftIO $ doesFileExist fullPath - when here do - - tombs <- getTombs - - n <- Compact.getValEither @Integer tombs p - <&> fromRight (Just 0) - - - when (n < Just 1) do - notice $ red "YEAH, mttf!" <+> pretty n - postEntryTx Nothing (HM.lookup p hasGK0) refchan path e - - Compact.putVal tombs p (maybe 0 succ n) - - b <- backupMode - - unless b do - notice $ red "deleted" <+> pretty p - rm fullPath - - E (p,_) -> do - notice $ "skip entry" <+> pretty p - - -findDeleted :: (MonadIO m, HasRunDir m, HasTombs m) => m [Merged] -findDeleted = do - - dir <- getRunDir - - now <- liftIO $ getPOSIXTime <&> round - - tombs <- getTombs - -- TODO: check-if-non-latin-filenames-work - -- resolved: ok - seen <- Compact.keys tombs - <&> fmap (deserialiseOrFail @FilePath . LBS.fromStrict) - <&> rights - - S.toList_ do - for_ seen $ \f0 -> do - - let path = dir f0 - - here <- liftIO $ doesFileExist path - - n <- Compact.getValEither @Integer tombs f0 - <&> fromRight (Just 0) - - when (not here && isJust n) do - S.yield (D (f0, makeTomb now f0 Nothing) n) - trace $ "found deleted" <+> pretty n <+> pretty f0 - - -postEntryTx :: ( MonadUnliftIO m - , HasStorage m - , HasRunDir m - , HasClientAPI StorageAPI UNIX m - , HasClientAPI RefChanAPI UNIX m - ) - => Maybe (LBS.ByteString) - -> Maybe (GroupKey 'Symm 'HBS2Basic) - -> MyRefChan - -> FilePath - -> Entry - -> m () -postEntryTx nonce' mgk refchan path entry = do - - sto <- getStorage - - env <- getRunDirEnv path >>= orThrow DirNotSet - - creds <- view dirSyncCreds env & orThrow DirNotSet - - rch <- Client.getRefChanHead @UNIX refchan - >>= orThrow RefChanHeadNotFoundException - - void $ runMaybeT do - - guard (isFile entry || isTomb entry) - - let p = entryPath entry - lbs <- if isTomb entry then do pure mempty - else - -- FIXME: dangerous! - liftIO (LBS.readFile (path p)) - - let (dir,file) = splitFileName p - - let meta = HM.fromList [ ("file-name", fromString file) - ] - <> case dir of - "./" -> mempty - d -> HM.singleton "location" (fromString d) - <> if not (isTomb entry) then HM.empty - else HM.singleton "tomb" "#t" - - let members = view refChanHeadReaders rch & HS.toList - - -- FIXME: support-unencrypted? - when (L.null members) do - throwIO EncryptionKeysNotDefined - - let rcpt = maybe mempty (HM.keys . recipients) mgk - - gk <- case (members == rcpt, mgk) of - (True, Just g) -> pure g - (False,_) -> do - sec <- runMaybeT $ - toMPlus mgk >>= liftIO . runKeymanClient . extractGroupKeySecret >>= toMPlus - - case sec of - Just s -> Symm.generateGroupKey @'HBS2Basic (Just s) members - Nothing -> Symm.generateGroupKey @'HBS2Basic Nothing members - - _ -> Symm.generateGroupKey @'HBS2Basic Nothing members - - -- FIXME: survive-this-error? - href <- lift $ createTreeWithMetadata sto (Just gk) meta lbs - >>= orThrowPassIO - - let tx = AnnotatedHashRef Nothing href - let spk = view peerSignPk creds - let ssk = view peerSignSk creds - - -- FIXME: remove-nonce - -- пока что будем постить транзакцию всегда. - -- в дальнейшем стоит избавиться от нонса - nonce <- liftIO $ getPOSIXTime <&> round <&> BS.take 6 . coerce . hashObject @HbSync . serialise - let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx <> LBS.fromStrict nonce) - - notice $ red "post tree tx" <+> pretty p <+> pretty href - - lift $ postRefChanTx @UNIX refchan box - - -merge :: Entry -> Entry -> Entry -merge a b = do - if | getEntryTimestamp a > getEntryTimestamp b -> a - - | isFile a && isDir b -> a - - | isFile b && isDir a -> b - - | getEntryTimestamp a == getEntryTimestamp b -> - case (getEntryHash a, getEntryHash b) of - (Nothing,Nothing) -> b - (Just _,Nothing) -> a - (Nothing,Just _) -> b - (Just _, Just _) -> b - - | otherwise -> b - - -data Merged = N (FilePath, Entry) - | E (FilePath, Entry) - | D (FilePath, Entry) (Maybe Integer) - | M (FilePath,FilePath,Entry) -{-# COMPLETE N,E,M,D #-} - -pattern MergedEntryType :: EntryType -> Merged -pattern MergedEntryType t <- ( mergedEntryType -> t ) - -mergedEntryType :: Merged -> EntryType -mergedEntryType = \case - N (_,DirEntry d _) -> entryType d - E (_,DirEntry d _) -> entryType d - D (_,DirEntry d _) _ -> entryType d - M (_,_,DirEntry d _) -> entryType d - -instance (IsContext c) => ToSexp c Integer where - toSexp i = mkInt i - -instance (IsContext c, ToSexp c a) => ToSexp c (Maybe a) where - toSexp = \case - Nothing -> nil - Just x -> toSexp x - -instance IsContext c => ToSexp c Merged where - toSexp = \case - N (_, e) -> mkForm @c "N" [toSexp e] - E (_, e) -> mkForm @c "E" [toSexp e] - D (_, e) i -> mkForm @c "D" [toSexp e, toSexp i] - M (o, t, e) -> mkForm @c "M" [toSexp e,mkSym o,mkSym t] - -mergeState :: MonadUnliftIO m - => [Merged] - -> [(FilePath, Entry)] - -> m [Merged] - -mergeState seed orig = do - - let deleted = [ (p,d) | d@(D (p,e) c) <- seed, isTomb e, c < Just 1 ] & Map.fromList - - let dirs = [ (p,e) | (p,e) <- orig, isDir e ] & Map.fromListWith merge - - let files = [ (p, e) | D (p,e) _ <- Map.elems deleted] - <> [ (p,e) | (p,e) <- orig, isFile e ] - & Map.fromListWith merge - -- & Map.filterWithKey (\k ( -> not (Map.member k deleted)) - - let tombs = [ (p,e) | (p,e) <- orig, isTomb e ] & Map.fromListWith merge - - let names = Map.keysSet (dirs <> files) - - now <- liftIO $ getPOSIXTime <&> round - - S.toList_ do - for_ (Map.toList files) $ \(p,e@(DirEntry d _)) -> do - if - | Map.member p deleted -> do - for_ (Map.lookup p deleted) S.yield - - | Map.member p dirs -> do - let new = uniqName names p - S.yield $ M (p, new, DirEntry d new) - S.yield $ N (p, makeTomb now p Nothing) - - | Map.member p tombs -> do - let tomb = Map.lookup p tombs - case tomb of - Just t | getEntryTimestamp t >= getEntryTimestamp e -> do - S.yield $ E (p,t) - - _ -> S.yield $ E (p,e) - - | not (Map.member p deleted) -> do - S.yield $ E (p,e) - - | otherwise -> none - - 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 --- что бы устранить противоречия в "удалённом" стейте и --- локальном, мы должны о них узнать --- --- Основное противоречие это file <=> dir --- Так как мы не сохраняем каталоги, а только файлы --- Каталоги выводим из файлов (таким образом, пустые каталоги будут игнорироваться) --- --- Допустим, у нас есть файл, совпадающий по имени с каталогом в remote state --- Мы должны тогда вывести этот каталог из remote state и проверить, --- чем он является тут (каталогом или файлом) --- --- Тогда функция устранения противоречий сможет что-то с этим сделать --- впоследствии --- - -getStateFromDir0 :: ( MonadUnliftIO m - , HasClientAPI RefChanAPI UNIX m - , HasClientAPI StorageAPI UNIX m - , HasStorage m - , HasRunDir m - , HasCache 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 :: ( MonadUnliftIO m - , HasClientAPI RefChanAPI UNIX m - , HasClientAPI StorageAPI UNIX m - , HasStorage m - , HasRunDir m - , HasCache m - ) - => Bool -- ^ use remote state as seed - -> FilePath -- ^ dir - -> [FilePattern] -- ^ include pattern - -> [FilePattern] -- ^ exclude pattern - -> m [(FilePath, Entry)] -getStateFromDir seed path incl excl = do - es' <- S.toList_ $ do - glob incl excl path $ \fn -> do - let fn0 = removePrefix path fn - es <- liftIO (entriesFromLocalFile path fn) - -- debug $ yellow "file" <+> viaShow ts <+> pretty fn0 - S.each es - pure True - - 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 - d <- liftIO $ doesDirectoryExist (path p) - when d do - ts <- liftIO $ getFileTimestamp (path p) - S.yield (p, DirEntry (EntryDesc Dir ts mzero) p) - - S.yield (p,e) - - - - -- dbPath <- getStatePath - -- env <- liftIO newAppEnv - -- let db = appDb env - -- flip runContT pure $ do - -- void $ ContT $ bracket (async (runPipe db)) cancel - - -- here <- doesPathExist dbPath - - -- unless here do - -- withDB db $ populateState - - -getStateFromRefChan :: forall m . ( MonadUnliftIO m - , HasClientAPI RefChanAPI UNIX m - , HasClientAPI StorageAPI UNIX m - , HasStorage m - , HasRunDir m - , HasCache m - ) - => MyRefChan - -> m [(FilePath, Entry)] -getStateFromRefChan rchan = do - - dir <- getRunDir - - sto <- getStorage - - rch <- Client.getRefChanHead @UNIX rchan - >>= orThrow RefChanHeadNotFoundException - - let statePath = dir ".hbs2-sync" "state" - - db <- newDBPipeEnv dbPipeOptsDef (statePath "state.db") - - flip runContT pure do - - void $ ContT $ bracket (async (runPipe db)) cancel - - withDB db $ do - ddl [qc|create table if not exists entry (txhash text not null primary key, s blob not null)|] - ddl [qc|create table if not exists seen (txhash text not null primary key)|] - commitAll - - debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan) - - outq <- newTQueueIO - seen <- newTQueueIO - tss <- newTVarIO mempty - - let members = view refChanHeadReaders rch & HS.toList - - krl <- liftIO $ runKeymanClient $ loadKeyRingEntries members - <&> L.sortOn (Down . fst) - <&> fmap snd - - let krs = HM.fromList [ (pk,e) | e@(KeyringEntry pk _ _) <- krl ] - - let findKey gk = do - r <- S.toList_ do - forM_ (HM.toList $ recipients gk) $ \(pk,box) -> runMaybeT do - (KeyringEntry ppk ssk _) <- toMPlus $ HM.lookup pk krs - let s = Symm.lookupGroupKey @'HBS2Basic ssk ppk gk - for_ s $ lift . S.yield - pure $ headMay r - - -- let check hx = pure True - hseen <- withDB db (select_ [qc|select txhash from seen|]) - <&> fmap ((fromStringMay @HashRef) . fromOnly) - <&> HS.fromList . catMaybes - - let check hx = pure $ not $ HS.member hx hseen - - -- FIXME: may-be-slow - (a, _) <- timeItT do - lift $ walkRefChanTx @UNIX check rchan $ \txh u -> do - - atomically $ writeTQueue seen txh - - case u of - - A (AcceptTran ts _ what) -> do - -- debug $ red "ACCEPT" <+> pretty ts <+> pretty what - for_ ts $ \w -> do - atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 w)) - - P orig (ProposeTran _ box) -> void $ runMaybeT do - (_, bs) <- unboxSignedBox0 box & toMPlus - AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs) - & toMPlus . either (const Nothing) Just - - - runExceptT (extractMetaData @'HBS2Basic findKey sto href) - >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, ((href, meta), txh)) ) - - notice $ "walkRefChanTx complete in" <+> pretty (realToFrac a :: Fixed E6) - - trees <- atomically (flushTQueue outq) - - tsmap <- readTVarIO tss - - lift $ withDB db $ transactional do - - -- ess0 <- S.toList_ do - for_ trees $ \(txh, ((tree, meta),txxx)) -> do - let what = parseTop meta & fromRight mempty - let loc = headDef "" [ l | ListVal [StringLike "location:", StringLike l] <- what ] - - void $ runMaybeT do - fn <- toMPlus $ headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ] - ts <- toMPlus $ HM.lookup txh tsmap - let tomb = or [ True | TombLikeOpt <- what ] - let fullPath = loc fn - - trace $ red "META" <+> pretty what - - if tomb then do - let r = Map.singleton fullPath (makeTomb ts fullPath (Just tree)) - withDB db do - insert [qc| insert into entry (txhash,s) values(?,?) - on conflict (txhash) do update set s = excluded.s - |] (show $ pretty $ txxx, serialise r) - - else do - let r = entriesFromFile (Just tree) ts fullPath - - withDB db do - insert [qc| insert into entry (txhash,s) values(?,?) - on conflict (txhash) do update set s = excluded.s - |] (show $ pretty $ txxx, serialise r) - - -- lift $ S.yield r - - seenTx <- atomically $ flushTQueue seen - for_ seenTx $ \txh -> do - insert [qc|insert into seen (txhash) values(?) on conflict do nothing|] (Only (show $ pretty $ txh)) - - ess0 <- withDB db do - select_ [qc|select s from entry|] - <&> fmap (deserialiseOrFail @(Map FilePath Entry) . LBS.fromStrict . fromOnly) - <&> rights - - let r = Map.unionsWith merge ess0 - - pure (Map.toList r) - - -- pure $ Map.toList $ Map.unionsWith merge ess0 - - -getTreeContents :: ( MonadUnliftIO m - , MonadError OperationError m - ) - => AnyStorage - -> HashRef - -> m LBS.ByteString - -getTreeContents sto href = do - - blk <- getBlock sto (coerce href) - >>= orThrowError MissedBlockError - - let q = tryDetect (coerce href) blk - - case q of - - MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do - readFromMerkle sto (SimpleKey (coerce href)) - - MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do - - rcpts <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh) - >>= orThrowError (GroupKeyNotFound 11) - <&> HM.keys . Symm.recipients - - kre <- runKeymanClient do - loadKeyRingEntries rcpts <&> fmap snd - - readFromMerkle sto (ToDecryptBS kre (coerce href)) - - _ -> throwError UnsupportedFormat class MonadIO m => HasRunDir m where getRunDir :: m FilePath @@ -1187,286 +411,6 @@ instance (Monad m, HasCache m) => HasCache (RunM c m) where closeCache = lift closeCache -syncEntries :: forall c m . ( MonadUnliftIO m - , IsContext c - , Exception (BadFormException c) - , HasClientAPI RefChanAPI UNIX m - , HasClientAPI StorageAPI UNIX m - , HasStorage m - , HasRunDir m - , HasTombs m - , HasCache m - , MonadReader (Maybe SyncEnv) m - ) - => MakeDictM c m () -syncEntries = do - - entry $ bindMatch "--debug" $ nil_ $ \case - [SymbolVal "off"] -> do - setLoggingOff @DEBUG - - _ -> do - setLogging @DEBUG debugPrefix - - entry $ bindMatch "init" $ nil_ $ const do - pure () - - entry $ bindMatch "sync" $ nil_ $ \case - [StringLike d] -> do - - void $ evalTop [ mkList [mkSym "dir", mkStr d] - , mkList [mkSym "run"] - ] - - [] -> do - - void $ evalTop [ mkList [mkSym "dir", mkStr "."] - , mkList [mkSym "run"] - ] - - _ -> pure () - - brief "sets current directory" - $ args [ arg "string" "dir" ] - $ desc "useful for debugging" - $ entry $ bindMatch "dir" $ nil_ $ \case - [StringLike d] -> do - debug $ "set current directory" <+> pretty d - t <- lift ask >>= orThrow PeerNotConnectedException - atomically $ writeTVar (dirThis t) (Just d) - - alterRunDirEnv d $ \case - Nothing -> Just (mempty & set dirSyncPath (Just d)) - Just x -> Just (x & set dirSyncPath (Just d)) - - ins <- try @_ @IOError (liftIO $ readFile (d ".hbs2-sync/config")) - <&> fromRight mempty - <&> parseTop - <&> either mempty (fmap fixContext) - - void $ evalTop ins - - _ -> do - err "current dir not set" - - entry $ bindMatch "refchan" $ nil_ $ \case - [SignPubKeyLike puk] -> do - dir <- getRunDir - debug $ red "refchan" <+> pretty dir <+> pretty (AsBase58 puk) - alterRunDirEnv dir $ \case - Nothing -> Just (mempty & set dirSyncRefChan (Just puk)) - Just x -> Just (x & set dirSyncRefChan (Just puk)) - - x -> err $ "invalid refchan" <+> pretty (mkList x) - - entry $ bindMatch "exclude" $ nil_ $ \case - [StringLike excl] -> do - dir <- getRunDir - debug $ red "exclude" <+> pretty dir <+> pretty excl - alterRunDirEnv dir $ \case - Nothing -> Just (mempty & set dirSyncExclude [excl]) - Just x -> Just (x & over dirSyncExclude (mappend [excl])) - - _ -> pure () - - entry $ bindMatch "include" $ nil_ $ \case - [StringLike pat] -> do - dir <- getRunDir - debug $ red "include" <+> pretty dir <+> pretty pat - alterRunDirEnv dir $ \case - Nothing -> Just (mempty & set dirSyncInclude [pat]) - Just x -> Just (x & over dirSyncInclude (mappend [pat])) - - _ -> 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 - debug $ red "sign" <+> pretty (AsBase58 s) - creds <- liftIO (runKeymanClient $ loadCredentials s) - alterRunDirEnv dir $ \case - Nothing -> Just (mempty & set dirSyncCreds creds) - Just x -> Just (x & set dirSyncCreds creds) - - w -> err $ "invalid sign key" <+> pretty (mkList w) - - - brief "output file from remote state" - $ args [arg "string" "refchan", arg "string" "file"] - $ entry $ bindMatch "cat" $ nil_ $ \case - [SignPubKeyLike rchan, StringLike fn] -> do - sto <- getStorage - void $ runMaybeT do - h <- lift (getStateFromRefChan rchan) - <&> Map.fromList - <&> Map.lookup fn - >>= toMPlus - <&> getEntryHash - >>= toMPlus - - lbs <- lift $ runExceptT (getTreeContents sto h) - >>= orThrowPassIO - - liftIO $ LBS.putStr lbs - - _ -> none - - entry $ bindMatch "dir:state:merged:show" $ nil_ $ \_ -> do - state <- getStateFromDir0 True - - deleted <- findDeleted - merged <- mergeState deleted state - - liftIO $ print $ vcat (fmap (pretty . AsSexp @C) merged) - - - entry $ bindMatch "ls" $ nil_ $ \case - (StringLikeList _) -> do - state <- getStateFromDir0 False <&> Map.fromList - - for_ (Map.toList state) $ \(f,e) -> do - when (isFile e || isDir e ) do - liftIO $ putStrLn f - - _ -> pure () - - entry $ bindMatch "dir:state:local:show" $ nil_ $ \sy -> do - - let f = case sy of - [StringLike "F"] -> isFile - [StringLike "D"] -> isDir - _ -> const True - - state <- getStateFromDir0 True - - liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) (filter (f . snd) state)) - - entry $ bindMatch "dir:state:remote:show" $ nil_ $ \syn -> do - - let f = case syn of - [StringLike "F"] -> isFile - [StringLike "D"] -> isDir - _ -> const True - - dir <- getRunDir - - - env <- getRunDirEnv dir >>= orThrow DirNotSet - - runMaybeT do - - rchan <- view dirSyncRefChan env - & toMPlus - - state <- lift $ getStateFromRefChan rchan - - liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) (filter (f.snd) state)) - - - entry $ bindMatch "dir:config:show" $ nil_ $ const do - dir <- getRunDir - - void $ runMaybeT do - env <- getRunDirEnv dir >>= toMPlus - liftIO $ print $ pretty env - - entry $ bindMatch "run" $ nil_ \case - _ -> runDirectory - - entry $ bindMatch "prune" $ nil_ \case - [] -> do - - - path <- getRunDir - - env <- getRunDirEnv path >>= orThrow DirNotSet - - let excl = view dirSyncExclude env - - let skip p = or [ i ?== p | i <- excl ] - - dirs <- S.toList_ do - flip fix [path] $ \next -> \case - (d:ds) -> do - dirs <- liftIO (listDirectory d) - let es = [ path d x | x <- dirs, not (skip x) ] - dd <- liftIO $ filterM doesDirectoryExist es - S.each dd - next (ds <> dd) - - [] -> pure () - - for_ (L.sortBy (comparing Down) dirs) $ \d -> do - pu <- liftIO (listDirectory d) <&> L.null - when pu do - notice $ red "prune" <+> pretty d - rm d - - _ -> pure () - - - brief "posts tomb transaction for the current dir" - $ args [arg "string" "entry-path"] - $ desc ( "working dir must be set first" <> line - <> "see: dir, sync" - ) - $ entry $ bindMatch "tomb" $ nil_ \case - [StringLike p] -> do - - path <- getRunDir - env <- getRunDirEnv path >>= orThrow DirNotSet - - void $ runMaybeT do - - let fullPath = path p - - rchan <- view dirSyncRefChan env - & toMPlus - - here <- liftIO (doesFileExist fullPath) - guard here - - now <- liftIO getPOSIXTime <&> round - - notice $ red "ABOUT TO POST TOMB TX" <+> pretty p - lift $ postEntryTx Nothing Nothing rchan path (makeTomb now p mzero) - - _ -> pure () - - entry $ bindMatch "run-config" $ nil_ $ const do - cpath <- liftIO $ getXdgDirectory XdgConfig "hbs2-sync" <&> ( "config") - debug $ "run-config" <+> pretty cpath - try @_ @IOError (liftIO $ readFile cpath) - <&> fromRight mempty - <&> parseTop - <&> either mempty (fmap fixContext) - >>= evalTop - - entry $ bindMatch "timestamp" $ nil_ $ \case - [StringLike fn] -> do - liftIO (getFileTimestamp fn >>= print) - _ -> do - liftIO $ getPOSIXTime <&> round >>= print -- debugPrefix :: LoggerEntry -> LoggerEntry debugPrefix = toStderr . logPrefix "[debug] " diff --git a/hbs2-sync/src/HBS2/Sync/State.hs b/hbs2-sync/src/HBS2/Sync/State.hs new file mode 100644 index 00000000..854ddfb6 --- /dev/null +++ b/hbs2-sync/src/HBS2/Sync/State.hs @@ -0,0 +1,631 @@ +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} +{-# Language MultiWayIf #-} +module HBS2.Sync.State where + +import HBS2.Sync.Prelude + +import HBS2.System.Dir +import HBS2.Data.Types.SignedBox +import HBS2.Merkle +import HBS2.Data.Detect +import HBS2.Merkle.MetaData +import HBS2.Net.Auth.GroupKeySymm as Symm +import HBS2.Storage.Compact as Compact +import HBS2.Storage.Operations.Class +import HBS2.Storage.Operations.ByteString + +import HBS2.Peer.Proto.RefChan +import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client.Unix (UNIX) +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.Client.RefChan as Client + +import HBS2.CLI.Run.MetaData (createTreeWithMetadata) + +import DBPipe.SQLite +import Data.Config.Suckless.Script.File + +import Control.Concurrent.STM (flushTQueue) +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString qualified as BS +import Data.Fixed +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.List qualified as L +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Set qualified as Set +import Data.Ord +import Data.Word +import Streaming.Prelude qualified as S +import System.TimeIt +import Text.InterpolatedString.Perl6 (qc) +import Control.Monad.Trans.Maybe +import Control.Monad.Except +import Lens.Micro.Platform +import Data.Text qualified as Text + +data EntryType = File | Dir | Tomb + deriving stock (Eq,Ord,Show,Data,Generic) + +data EntryDesc = + EntryDesc + { entryType :: EntryType + , entryTimestamp :: Word64 + , entryRemoteHash :: Maybe HashRef + } + deriving stock (Eq,Ord,Show,Data,Generic) + +data Entry = + DirEntry EntryDesc FilePath + deriving stock (Eq,Ord,Show,Data,Generic) + + +instance Serialise Entry +instance Serialise EntryType +instance Serialise EntryDesc + +instance IsContext c => ToSexp c EntryType where + toSexp a = mkStr @c $ Text.toLower $ Text.pack $ show a + +instance IsContext c => ToSexp c EntryDesc where + toSexp EntryDesc{..} = case entryType of + File -> mkForm @c "F" [mkInt entryTimestamp, hash] + Dir -> mkForm @c "D " [mkInt entryTimestamp, hash] + Tomb -> mkForm @c "T " [mkInt entryTimestamp, hash] + + where + hash = case entryRemoteHash of + Nothing -> nil + Just x -> mkStr (show $ pretty x) + +instance IsContext c => ToSexp c Entry where + toSexp (DirEntry w p) = mkForm @c "entry" [toSexp w, mkStr p] + +pattern WithRemoteHash :: Entry -> HashRef -> Entry +pattern WithRemoteHash e h <- e@(DirEntry (EntryDesc {entryRemoteHash = Just h}) _) + +pattern TombEntry :: Entry -> Entry +pattern TombEntry e <- e@(DirEntry (EntryDesc { entryType = Tomb }) _) + +pattern FileEntry :: Entry -> Entry +pattern FileEntry e <- e@(DirEntry (EntryDesc { entryType = File }) _) + +pattern UpdatedFileEntry :: Word64 -> Entry -> Entry +pattern UpdatedFileEntry t e <- e@(DirEntry (EntryDesc { entryType = File + , entryRemoteHash = Nothing + , entryTimestamp = t }) _) + + + +makeTomb :: Word64 -> FilePath -> Maybe HashRef -> Entry +makeTomb t n h = DirEntry (EntryDesc Tomb t h) n + +entryPath :: Entry -> FilePath +entryPath (DirEntry _ p) = p + +getEntryTimestamp :: Entry -> Word64 +getEntryTimestamp (DirEntry d _) = entryTimestamp d + +getEntryHash :: Entry -> Maybe HashRef +getEntryHash (DirEntry d _) = entryRemoteHash d + +isFile :: Entry -> Bool +isFile = \case + DirEntry (EntryDesc { entryType = File}) _ -> True + _ -> False + +isTomb :: Entry -> Bool +isTomb = \case + DirEntry (EntryDesc { entryType = Tomb}) _ -> 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 + ts <- getFileTimestamp fn + pure $ entriesFromFile Nothing ts fn0 + where + fn = normalise fn' + +entriesFromFile :: Maybe HashRef -> Word64 -> FilePath -> Map FilePath Entry +entriesFromFile h ts fn0 = do + let dirs = splitDirectories (dropFileName fn0) + & dropWhile (== ".") + let es = flip L.unfoldr ("",dirs) $ \case + (_,[]) -> Nothing + (p,d:ds) -> Just (dirEntry (p d), (p d, ds) ) + + Map.fromList [ (p, e) + | e@(DirEntry _ p) <- fileEntry fn0 : es + ] + where + dirEntry p = DirEntry (EntryDesc Dir ts Nothing) p + fileEntry p = DirEntry (EntryDesc File ts h) p + +-- NOTE: getStateFromDir +-- что бы устранить противоречия в "удалённом" стейте и +-- локальном, мы должны о них узнать +-- +-- Основное противоречие это file <=> dir +-- Так как мы не сохраняем каталоги, а только файлы +-- Каталоги выводим из файлов (таким образом, пустые каталоги будут игнорироваться) +-- +-- Допустим, у нас есть файл, совпадающий по имени с каталогом в remote state +-- Мы должны тогда вывести этот каталог из remote state и проверить, +-- чем он является тут (каталогом или файлом) +-- +-- Тогда функция устранения противоречий сможет что-то с этим сделать +-- впоследствии +-- + + +getStateFromDir0 :: ( MonadUnliftIO m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasRunDir m + , HasCache 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 :: ( MonadUnliftIO m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasRunDir m + , HasCache m + ) + => Bool -- ^ use remote state as seed + -> FilePath -- ^ dir + -> [FilePattern] -- ^ include pattern + -> [FilePattern] -- ^ exclude pattern + -> m [(FilePath, Entry)] +getStateFromDir seed path incl excl = do + es' <- S.toList_ $ do + glob incl excl path $ \fn -> do + let fn0 = removePrefix path fn + es <- liftIO (entriesFromLocalFile path fn) + -- debug $ yellow "file" <+> viaShow ts <+> pretty fn0 + S.each es + pure True + + 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 + d <- doesDirectoryExist (path p) + when d do + ts <- liftIO $ getFileTimestamp (path p) + S.yield (p, DirEntry (EntryDesc Dir ts mzero) p) + + S.yield (p,e) + + + + -- dbPath <- getStatePath + -- env <- liftIO newAppEnv + -- let db = appDb env + -- flip runContT pure $ do + -- void $ ContT $ bracket (async (runPipe db)) cancel + + -- here <- doesPathExist dbPath + + -- unless here do + -- withDB db $ populateState + + +getStateFromRefChan :: forall m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasRunDir m + , HasCache m + ) + => MyRefChan + -> m [(FilePath, Entry)] +getStateFromRefChan rchan = do + + dir <- getRunDir + + sto <- getStorage + + rch <- Client.getRefChanHead @UNIX rchan + >>= orThrow RefChanHeadNotFoundException + + let statePath = dir ".hbs2-sync" "state" + + db <- newDBPipeEnv dbPipeOptsDef (statePath "state.db") + + flip runContT pure do + + void $ ContT $ bracket (async (runPipe db)) cancel + + withDB db $ do + ddl [qc|create table if not exists entry (txhash text not null primary key, s blob not null)|] + ddl [qc|create table if not exists seen (txhash text not null primary key)|] + commitAll + + debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan) + + outq <- newTQueueIO + seen <- newTQueueIO + tss <- newTVarIO mempty + + let members = view refChanHeadReaders rch & HS.toList + + krl <- liftIO $ runKeymanClient $ loadKeyRingEntries members + <&> L.sortOn (Down . fst) + <&> fmap snd + + let krs = HM.fromList [ (pk,e) | e@(KeyringEntry pk _ _) <- krl ] + + let findKey gk = do + r <- S.toList_ do + forM_ (HM.toList $ recipients gk) $ \(pk,box) -> runMaybeT do + (KeyringEntry ppk ssk _) <- toMPlus $ HM.lookup pk krs + let s = Symm.lookupGroupKey @'HBS2Basic ssk ppk gk + for_ s $ lift . S.yield + pure $ headMay r + + -- let check hx = pure True + hseen <- withDB db (select_ [qc|select txhash from seen|]) + <&> fmap ((fromStringMay @HashRef) . fromOnly) + <&> HS.fromList . catMaybes + + let check hx = pure $ not $ HS.member hx hseen + + -- FIXME: may-be-slow + (a, _) <- timeItT do + lift $ walkRefChanTx @UNIX check rchan $ \txh u -> do + + atomically $ writeTQueue seen txh + + case u of + + A (AcceptTran ts _ what) -> do + -- debug $ red "ACCEPT" <+> pretty ts <+> pretty what + for_ ts $ \w -> do + atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 w)) + + P orig (ProposeTran _ box) -> void $ runMaybeT do + (_, bs) <- unboxSignedBox0 box & toMPlus + AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs) + & toMPlus . either (const Nothing) Just + + + runExceptT (extractMetaData @'HBS2Basic findKey sto href) + >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, ((href, meta), txh)) ) + + notice $ "walkRefChanTx complete in" <+> pretty (realToFrac a :: Fixed E6) + + trees <- atomically (flushTQueue outq) + + tsmap <- readTVarIO tss + + lift $ withDB db $ transactional do + + -- ess0 <- S.toList_ do + for_ trees $ \(txh, ((tree, meta),txxx)) -> do + let what = parseTop meta & fromRight mempty + let loc = headDef "" [ l | ListVal [StringLike "location:", StringLike l] <- what ] + + void $ runMaybeT do + fn <- toMPlus $ headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ] + ts <- toMPlus $ HM.lookup txh tsmap + let tomb = or [ True | TombLikeOpt <- what ] + let fullPath = loc fn + + trace $ red "META" <+> pretty what + + if tomb then do + let r = Map.singleton fullPath (makeTomb ts fullPath (Just tree)) + withDB db do + insert [qc| insert into entry (txhash,s) values(?,?) + on conflict (txhash) do update set s = excluded.s + |] (show $ pretty $ txxx, serialise r) + + else do + let r = entriesFromFile (Just tree) ts fullPath + + withDB db do + insert [qc| insert into entry (txhash,s) values(?,?) + on conflict (txhash) do update set s = excluded.s + |] (show $ pretty $ txxx, serialise r) + + -- lift $ S.yield r + + seenTx <- atomically $ flushTQueue seen + for_ seenTx $ \txh -> do + insert [qc|insert into seen (txhash) values(?) on conflict do nothing|] (Only (show $ pretty $ txh)) + + ess0 <- withDB db do + select_ [qc|select s from entry|] + <&> fmap (deserialiseOrFail @(Map FilePath Entry) . LBS.fromStrict . fromOnly) + <&> rights + + let r = Map.unionsWith merge ess0 + + pure (Map.toList r) + + -- pure $ Map.toList $ Map.unionsWith merge ess0 + +findDeleted :: (MonadIO m, HasRunDir m, HasTombs m) => m [Merged] +findDeleted = do + + dir <- getRunDir + + now <- liftIO $ getPOSIXTime <&> round + + tombs <- getTombs + -- TODO: check-if-non-latin-filenames-work + -- resolved: ok + seen <- Compact.keys tombs + <&> fmap (deserialiseOrFail @FilePath . LBS.fromStrict) + <&> rights + + S.toList_ do + for_ seen $ \f0 -> do + + let path = dir f0 + + here <- liftIO $ doesFileExist path + + n <- Compact.getValEither @Integer tombs f0 + <&> fromRight (Just 0) + + when (not here && isJust n) do + S.yield (D (f0, makeTomb now f0 Nothing) n) + trace $ "found deleted" <+> pretty n <+> pretty f0 + + +postEntryTx :: ( MonadUnliftIO m + , HasStorage m + , HasRunDir m + , HasClientAPI StorageAPI UNIX m + , HasClientAPI RefChanAPI UNIX m + ) + => Maybe (LBS.ByteString) + -> Maybe (GroupKey 'Symm 'HBS2Basic) + -> MyRefChan + -> FilePath + -> Entry + -> m () +postEntryTx nonce' mgk refchan path entry = do + + sto <- getStorage + + env <- getRunDirEnv path >>= orThrow DirNotSet + + creds <- view dirSyncCreds env & orThrow DirNotSet + + rch <- Client.getRefChanHead @UNIX refchan + >>= orThrow RefChanHeadNotFoundException + + void $ runMaybeT do + + guard (isFile entry || isTomb entry) + + let p = entryPath entry + lbs <- if isTomb entry then do pure mempty + else + -- FIXME: dangerous! + liftIO (LBS.readFile (path p)) + + let (dir,file) = splitFileName p + + let meta = HM.fromList [ ("file-name", fromString file) + ] + <> case dir of + "./" -> mempty + d -> HM.singleton "location" (fromString d) + <> if not (isTomb entry) then HM.empty + else HM.singleton "tomb" "#t" + + let members = view refChanHeadReaders rch & HS.toList + + -- FIXME: support-unencrypted? + when (L.null members) do + throwIO EncryptionKeysNotDefined + + let rcpt = maybe mempty (HM.keys . recipients) mgk + + gk <- case (members == rcpt, mgk) of + (True, Just g) -> pure g + (False,_) -> do + sec <- runMaybeT $ + toMPlus mgk >>= liftIO . runKeymanClient . extractGroupKeySecret >>= toMPlus + + case sec of + Just s -> Symm.generateGroupKey @'HBS2Basic (Just s) members + Nothing -> Symm.generateGroupKey @'HBS2Basic Nothing members + + _ -> Symm.generateGroupKey @'HBS2Basic Nothing members + + -- FIXME: survive-this-error? + href <- lift $ createTreeWithMetadata sto (Just gk) meta lbs + >>= orThrowPassIO + + let tx = AnnotatedHashRef Nothing href + let spk = view peerSignPk creds + let ssk = view peerSignSk creds + + -- FIXME: remove-nonce + -- пока что будем постить транзакцию всегда. + -- в дальнейшем стоит избавиться от нонса + nonce <- liftIO $ getPOSIXTime <&> round <&> BS.take 6 . coerce . hashObject @HbSync . serialise + let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx <> LBS.fromStrict nonce) + + notice $ red "post tree tx" <+> pretty p <+> pretty href + + lift $ postRefChanTx @UNIX refchan box + + +merge :: Entry -> Entry -> Entry +merge a b = do + if | getEntryTimestamp a > getEntryTimestamp b -> a + + | isFile a && isDir b -> a + + | isFile b && isDir a -> b + + | getEntryTimestamp a == getEntryTimestamp b -> + case (getEntryHash a, getEntryHash b) of + (Nothing,Nothing) -> b + (Just _,Nothing) -> a + (Nothing,Just _) -> b + (Just _, Just _) -> b + + | otherwise -> b + + +data Merged = N (FilePath, Entry) + | E (FilePath, Entry) + | D (FilePath, Entry) (Maybe Integer) + | M (FilePath,FilePath,Entry) +{-# COMPLETE N,E,M,D #-} + +pattern MergedEntryType :: EntryType -> Merged +pattern MergedEntryType t <- ( mergedEntryType -> t ) + +mergedEntryType :: Merged -> EntryType +mergedEntryType = \case + N (_,DirEntry d _) -> entryType d + E (_,DirEntry d _) -> entryType d + D (_,DirEntry d _) _ -> entryType d + M (_,_,DirEntry d _) -> entryType d + +instance (IsContext c) => ToSexp c Integer where + toSexp i = mkInt i + +instance (IsContext c, ToSexp c a) => ToSexp c (Maybe a) where + toSexp = \case + Nothing -> nil + Just x -> toSexp x + +instance IsContext c => ToSexp c Merged where + toSexp = \case + N (_, e) -> mkForm @c "N" [toSexp e] + E (_, e) -> mkForm @c "E" [toSexp e] + D (_, e) i -> mkForm @c "D" [toSexp e, toSexp i] + M (o, t, e) -> mkForm @c "M" [toSexp e,mkSym o,mkSym t] + +mergeState :: MonadUnliftIO m + => [Merged] + -> [(FilePath, Entry)] + -> m [Merged] + +mergeState seed orig = do + + let deleted = [ (p,d) | d@(D (p,e) c) <- seed, isTomb e, c < Just 1 ] & Map.fromList + + let dirs = [ (p,e) | (p,e) <- orig, isDir e ] & Map.fromListWith merge + + let files = [ (p, e) | D (p,e) _ <- Map.elems deleted] + <> [ (p,e) | (p,e) <- orig, isFile e ] + & Map.fromListWith merge + -- & Map.filterWithKey (\k ( -> not (Map.member k deleted)) + + let tombs = [ (p,e) | (p,e) <- orig, isTomb e ] & Map.fromListWith merge + + let names = Map.keysSet (dirs <> files) + + now <- liftIO $ getPOSIXTime <&> round + + S.toList_ do + for_ (Map.toList files) $ \(p,e@(DirEntry d _)) -> do + if + | Map.member p deleted -> do + for_ (Map.lookup p deleted) S.yield + + | Map.member p dirs -> do + let new = uniqName names p + S.yield $ M (p, new, DirEntry d new) + S.yield $ N (p, makeTomb now p Nothing) + + | Map.member p tombs -> do + let tomb = Map.lookup p tombs + case tomb of + Just t | getEntryTimestamp t >= getEntryTimestamp e -> do + S.yield $ E (p,t) + + _ -> S.yield $ E (p,e) + + | not (Map.member p deleted) -> do + S.yield $ E (p,e) + + | otherwise -> none + + 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 + +getTreeContents :: ( MonadUnliftIO m + , MonadError OperationError m + ) + => AnyStorage + -> HashRef + -> m LBS.ByteString + +getTreeContents sto href = do + + blk <- getBlock sto (coerce href) + >>= orThrowError MissedBlockError + + let q = tryDetect (coerce href) blk + + case q of + + MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do + readFromMerkle sto (SimpleKey (coerce href)) + + MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do + + rcpts <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh) + >>= orThrowError (GroupKeyNotFound 11) + <&> HM.keys . Symm.recipients + + kre <- runKeymanClient do + loadKeyRingEntries rcpts <&> fmap snd + + readFromMerkle sto (ToDecryptBS kre (coerce href)) + + _ -> throwError UnsupportedFormat + +