Add undelete function to hbs2-sync

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

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" "<href>"]
+    $ 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"]
                      ]

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
-
-

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]
+    File -> mkForm @c "F" [mkInt entryTimestamp, hash]
-    Dir  ->  mkForm @c "D " [mkInt entryTimestamp, hash]
+    Dir  -> mkForm @c "D" [mkInt entryTimestamp, hash]
-    Tomb ->  mkForm @c "T " [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
-
-

hbs2/Main.hs

@@ -1027,5 +1027,3 @@ main = join . customExecParser (prefs showHelpOnError) $
 
 
     pPubKey = maybeReader (fromStringMay @(PubKey 'Sign 'HBS2Basic))
-
-