cd544e548b
giveup changed to filter out control characters. (It is too low level to make it use StringContainingQuotedPath.) error still does not, but it should only be used for internal errors, where the message is not attacker-controlled. Changed a lot of existing error to giveup when it is not strictly an internal error. Of course, other exceptions can still be thrown, either by code in git-annex, or a library, that include some attacker-controlled value. This does not guard against those. Sponsored-by: Noam Kremen on Patreon
89 lines
2.7 KiB
Haskell
89 lines
2.7 KiB
Haskell
{- git-annex assistant remote deletion utilities
|
|
-
|
|
- Copyright 2012 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Assistant.DeleteRemote where
|
|
|
|
import Assistant.Common
|
|
import Assistant.Types.UrlRenderer
|
|
import Assistant.TransferQueue
|
|
import Types.Transfer
|
|
import Logs.Location
|
|
import Assistant.DaemonStatus
|
|
import qualified Remote
|
|
import Remote.List.Util
|
|
import qualified Git.Remote.Remove
|
|
import Logs.Trust
|
|
import qualified Annex
|
|
|
|
#ifdef WITH_WEBAPP
|
|
import Assistant.WebApp.Types
|
|
import Assistant.Alert
|
|
import qualified Data.Text as T
|
|
#endif
|
|
|
|
{- Removes a remote (but leave the repository as-is), and returns the old
|
|
- Remote data. -}
|
|
disableRemote :: UUID -> Assistant Remote
|
|
disableRemote uuid = do
|
|
remote <- fromMaybe (giveup "unknown remote")
|
|
<$> liftAnnex (Remote.remoteFromUUID uuid)
|
|
liftAnnex $ do
|
|
inRepo $ Git.Remote.Remove.remove (Remote.name remote)
|
|
remotesChanged
|
|
updateSyncRemotes
|
|
return remote
|
|
|
|
{- Removes a remote, marking it dead .-}
|
|
removeRemote :: UUID -> Assistant Remote
|
|
removeRemote uuid = do
|
|
liftAnnex $ trustSet uuid DeadTrusted
|
|
disableRemote uuid
|
|
|
|
{- Called when a Remote is probably empty, to remove it.
|
|
-
|
|
- This does one last check for any objects remaining in the Remote,
|
|
- and if there are any, queues Downloads of them, and defers removing
|
|
- the remote for later. This is to catch any objects not referred to
|
|
- in keys in the current branch.
|
|
-}
|
|
removableRemote :: UrlRenderer -> UUID -> Assistant ()
|
|
removableRemote urlrenderer uuid = getkeys >>= \case
|
|
Just keys
|
|
| null keys -> finishRemovingRemote urlrenderer uuid
|
|
| otherwise -> do
|
|
r <- fromMaybe (giveup "unknown remote")
|
|
<$> liftAnnex (Remote.remoteFromUUID uuid)
|
|
mapM_ (queueremaining r) keys
|
|
Nothing -> noop
|
|
where
|
|
queueremaining r k =
|
|
queueTransferWhenSmall "remaining object in unwanted remote"
|
|
(AssociatedFile Nothing) (Transfer Download uuid (fromKey id k)) r
|
|
{- Scanning for keys can take a long time; do not tie up
|
|
- the Annex monad while doing it, so other threads continue to
|
|
- run. -}
|
|
getkeys = do
|
|
a <- liftAnnex $ Annex.withCurrentState $ loggedKeysFor uuid
|
|
liftIO a
|
|
|
|
{- With the webapp, this asks the user to click on a button to finish
|
|
- removing the remote.
|
|
-
|
|
- Without the webapp, just do the removal now.
|
|
-}
|
|
finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
|
|
#ifdef WITH_WEBAPP
|
|
finishRemovingRemote urlrenderer uuid = do
|
|
desc <- liftAnnex $ Remote.prettyUUID uuid
|
|
button <- mkAlertButton True (T.pack "Finish deletion process") urlrenderer $
|
|
FinishDeleteRepositoryR uuid
|
|
void $ addAlert $ remoteRemovalAlert desc button
|
|
#else
|
|
finishRemovingRemote _ uuid = void $ removeRemote uuid
|
|
#endif
|