diff --git a/hbs2-sync/app/Main.hs b/hbs2-sync/app/Main.hs index f6bdd270..d3a5bc3a 100644 --- a/hbs2-sync/app/Main.hs +++ b/hbs2-sync/app/Main.hs @@ -36,7 +36,6 @@ helpBanner = liftIO do main :: IO () main = do - cli <- liftIO getArgs <&> unlines . fmap unwords . splitForms >>= either (error.show) pure . parseTop <&> \case diff --git a/hbs2-sync/src/HBS2/Sync/Internal.hs b/hbs2-sync/src/HBS2/Sync/Internal.hs index 69da36b1..66ed15e0 100644 --- a/hbs2-sync/src/HBS2/Sync/Internal.hs +++ b/hbs2-sync/src/HBS2/Sync/Internal.hs @@ -4,7 +4,6 @@ module HBS2.Sync.Internal import HBS2.Sync.Prelude import HBS2.Sync.State - import HBS2.System.Dir import HBS2.Storage.Operations.ByteString import HBS2.Peer.RPC.API.RefChan @@ -28,9 +27,11 @@ import Data.HashSet qualified as HS import Data.List qualified as L import Data.Map qualified as Map import Data.Ord +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Format (defaultTimeLocale, formatTime) import Lens.Micro.Platform import Streaming.Prelude qualified as S -import System.Directory (XdgDirectory(..),createDirectoryIfMissing,getXdgDirectory,listDirectory) +import System.Directory (XdgDirectory(..), createDirectoryIfMissing, getXdgDirectory, listDirectory) import Text.InterpolatedString.Perl6 (qc) data ConfigException @@ -180,7 +181,6 @@ syncEntries :: forall c m . ( MonadUnliftIO m ) => MakeDictM c m () syncEntries = do - entry $ bindMatch "--debug" $ nil_ $ \case [SymbolVal "off"] -> do setLoggingOff @DEBUG @@ -231,6 +231,72 @@ hbs2-sync init --refchan 94GF31TtD38yWG6iZLRy1xZBb1dxcAC7BRBJTMyAq8VF _ -> do err "unknown parameters, please use `help init` command" + brief "deleted entries" + $ desc "show deleted entries" + $ entry $ bindMatch "deleted" $ nil_ $ \_ -> do + dir <- getRunDir + env <- getRunDirEnv dir >>= orThrow DirNotSet + + refchan <- + view dirSyncRefChan env + & orThrowUser "refchan not found" + + state <- getStateFromRefChan refchan + let tombs = filter (isTomb . snd) state + for_ tombs $ \(path, entry) -> do + when (isTomb entry) do + liftIO $ putStrLn path + + brief "history" + $ desc "show history of changes, T - stands for Tomb, F - stands for file" + $ entry $ bindMatch "history" $ nil_ $ \_ -> do + dir <- getRunDir + env <- getRunDirEnv dir >>= orThrow DirNotSet + + refchan <- + view dirSyncRefChan env + & orThrowUser "refchan not found" + + accepted <- getAccepted refchan <&> L.sortOn getEntryTimestamp + + for_ accepted $ \entry -> do + let action = if isTomb entry then red "T" else green "F" + let utcTime = posixSecondsToUTCTime $ fromIntegral $ getEntryTimestamp entry + let datetime = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" utcTime + notice $ action <+> pretty datetime <+> pretty (getEntryHash entry) <+> pretty (entryPath entry) + + brief "revert file to a hash" + $ args [arg "hash" ""] + $ desc "revert file to a href, href is a hash of a merkle tree of a file, which can be obtained from history command" + $ examples [qc| +hbs2-sync revert F8ppALwrYEBKRqmu3KCadXN8pFgzn3JevaZoSTtn9KZG + |] + $ entry $ bindMatch "revert" $ nil_ $ \case + [StringLike stringHash] -> do + dir <- getRunDir + env <- getRunDirEnv dir >>= orThrow DirNotSet + + refchan <- + view dirSyncRefChan env + & orThrowUser "refchan not found" + + accepted <- getAccepted refchan <&> L.sortOn getEntryTimestamp + let maybeEntry = L.find (\entry -> show (pretty $ getEntryHash entry) == stringHash) accepted + case maybeEntry of + Nothing -> + err "entry not found" + + Just entry -> + repostFileTx refchan entry >>= \case + Right () -> + liftIO $ putStrLn "entry reverted" + + Left error -> + err (pretty error) + + _ -> + err "unknown parameters, please use `help revert` command" + entry $ bindMatch "sync" $ nil_ $ \case [StringLike d] -> do @@ -239,7 +305,6 @@ hbs2-sync init --refchan 94GF31TtD38yWG6iZLRy1xZBb1dxcAC7BRBJTMyAq8VF ] [] -> do - void $ evalTop [ mkList [mkSym "dir", mkStr "."] , mkList [mkSym "run"] ] diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index efaa8c03..7a45ab26 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -449,5 +449,3 @@ die :: forall a m . (MonadUnliftIO m, Pretty a) => a -> m () die what = liftIO do hPutDoc stderr (pretty what) Exit.exitFailure - - diff --git a/hbs2-sync/src/HBS2/Sync/State.hs b/hbs2-sync/src/HBS2/Sync/State.hs index 137e2128..04e9f658 100644 --- a/hbs2-sync/src/HBS2/Sync/State.hs +++ b/hbs2-sync/src/HBS2/Sync/State.hs @@ -7,13 +7,10 @@ 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 @@ -44,7 +41,7 @@ import Data.Ord import Data.Set qualified as Set import Data.Text qualified as Text import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Word +import Data.Word (Word64) import Lens.Micro.Platform import Streaming.Prelude qualified as S import System.TimeIt @@ -81,9 +78,9 @@ instance IsContext c => ToSexp c EntryType where 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] + 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 @@ -240,6 +237,62 @@ getStateFromDir seed path incl excl = do S.yield (p,e) +getAccepted :: + forall m . + ( MonadUnliftIO m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasKeyManClient m + ) + => MyRefChan + -> m [Entry] +getAccepted refchan = do + storage <- getStorage + keymanEnv <- getKeyManClientEnv + outq <- newTQueueIO + tss <- newTVarIO mempty + + let findKey = lift . lift . withKeymanClientRO keymanEnv . findMatchedGroupKeySecret storage + + walkRefChanTx @UNIX (const (pure True)) refchan $ \_ unpacked -> do + case unpacked of + A (AcceptTran acceptTime _ what) -> do + for_ acceptTime $ \timestamp -> do + atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 timestamp)) + + P proposeHash (ProposeTran _ box) -> void $ runMaybeT do + (_, unboxed) <- unboxSignedBox0 box & toMPlus + AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict unboxed) + & toMPlus . either (const Nothing) Just + + meta <- runExceptT (extractMetaData @'HBS2Basic findKey storage href) >>= toMPlus + atomically $ writeTQueue outq (proposeHash, href, meta) + + trees <- atomically (flushTQueue outq) + tsmap <- readTVarIO tss + + pure $ concatMap (makeEntry tsmap) trees + + where + makeEntry tsmap (hash, tree, meta) = do + let what = parseTop meta & fromRight mempty + let location = headDef "" [ l | ListVal [StringLike "location:", StringLike l] <- what ] + + let maybeFileName = headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ] + let maybeTimestamp = HM.lookup hash tsmap + case (maybeFileName, maybeTimestamp) of + (Just fileName, Just timestamp) -> do + let isTombSet = or [ True | TombLikeOpt <- what ] + let fullPath = location fileName + + if isTombSet then + [makeTomb timestamp fullPath (Just tree)] + else + [DirEntry (EntryDesc File timestamp (Just tree)) fullPath] + + _ -> + [] getStateFromRefChan :: forall m . ( MonadUnliftIO m , HasClientAPI RefChanAPI UNIX m @@ -410,6 +463,41 @@ findDeleted = do trace $ "found deleted" <+> pretty n <+> pretty f0 +repostFileTx :: + ( MonadUnliftIO m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasRunDir m + , HasStorage m + ) => + MyRefChan -> + Entry -> + m (Either String ()) +repostFileTx refchan entry = do + if isFile entry then + case getEntryHash entry of + Just href -> do + dir <- getRunDir + env <- getRunDirEnv dir >>= orThrow DirNotSet + creds <- view dirSyncCreds env & orThrow DirNotSet + + let tx = AnnotatedHashRef Nothing href + let spk = view peerSignPk creds + let ssk = view peerSignSk creds + + nonce <- liftIO $ getPOSIXTime <&> round <&> BS.take 6 . coerce . hashObject @HbSync . serialise + let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx <> LBS.fromStrict nonce) + + postRefChanTx @UNIX refchan box + pure (Right ()) + + _ -> + pure (Left "entry has no hash") + + else + pure (Left "entry is not a file") + + postEntryTx :: ( MonadUnliftIO m , HasStorage m , HasRunDir m @@ -794,5 +882,3 @@ runDirectory = do E (p,_) -> do notice $ "skip entry" <+> pretty p - - diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 0cab6176..8402df68 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -1027,5 +1027,3 @@ main = join . customExecParser (prefs showHelpOnError) $ pPubKey = maybeReader (fromStringMay @(PubKey 'Sign 'HBS2Basic)) - -