mirror of https://github.com/voidlizard/hbs2
Add undelete function to hbs2-sync
This commit is contained in:
Dmitry Bushmelev
voidlizard
parent
016bf48b24
commit
cf0099cc12
|
|
@ -36,7 +36,6 @@ helpBanner = liftIO do
|
|||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
cli <- liftIO getArgs <&> unlines . fmap unwords . splitForms
|
||||
>>= either (error.show) pure . parseTop
|
||||
<&> \case
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
]
|
||||
|
|
|
|||
|
|
@ -449,5 +449,3 @@ die :: forall a m . (MonadUnliftIO m, Pretty a) => a -> m ()
|
|||
die what = liftIO do
|
||||
hPutDoc stderr (pretty what)
|
||||
Exit.exitFailure
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1027,5 +1027,3 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
|
||||
|
||||
pPubKey = maybeReader (fromStringMay @(PubKey 'Sign 'HBS2Basic))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue