2013-04-03 21:01:40 +00:00
|
|
|
{- git-annex assistant remote deletion utilities
|
|
|
|
-
|
2015-01-21 16:50:09 +00:00
|
|
|
- Copyright 2012 Joey Hess <id@joeyh.name>
|
2013-04-03 21:01:40 +00:00
|
|
|
-
|
2019-03-13 19:48:14 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2013-04-03 21:01:40 +00:00
|
|
|
-}
|
|
|
|
|
2013-04-03 21:44:34 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
|
2013-04-03 21:01:40 +00:00
|
|
|
module Assistant.DeleteRemote where
|
|
|
|
|
|
|
|
import Assistant.Common
|
2013-04-04 05:48:26 +00:00
|
|
|
import Assistant.Types.UrlRenderer
|
2013-04-03 23:03:16 +00:00
|
|
|
import Assistant.TransferQueue
|
2016-08-03 16:37:12 +00:00
|
|
|
import Types.Transfer
|
2013-04-03 23:03:16 +00:00
|
|
|
import Logs.Location
|
2013-04-03 21:01:40 +00:00
|
|
|
import Assistant.DaemonStatus
|
|
|
|
import qualified Remote
|
2020-05-27 15:54:39 +00:00
|
|
|
import Remote.List.Util
|
2014-10-27 15:24:21 +00:00
|
|
|
import qualified Git.Remote.Remove
|
2013-04-03 21:01:40 +00:00
|
|
|
import Logs.Trust
|
2013-04-03 23:03:16 +00:00
|
|
|
import qualified Annex
|
2013-04-03 21:01:40 +00:00
|
|
|
|
2013-04-04 05:48:26 +00:00
|
|
|
#ifdef WITH_WEBAPP
|
|
|
|
import Assistant.WebApp.Types
|
|
|
|
import Assistant.Alert
|
2013-04-03 21:01:40 +00:00
|
|
|
import qualified Data.Text as T
|
2013-04-04 05:48:26 +00:00
|
|
|
#endif
|
2013-04-03 21:01:40 +00:00
|
|
|
|
|
|
|
{- Removes a remote (but leave the repository as-is), and returns the old
|
|
|
|
- Remote data. -}
|
2013-04-04 00:54:53 +00:00
|
|
|
disableRemote :: UUID -> Assistant Remote
|
|
|
|
disableRemote uuid = do
|
2013-04-03 21:01:40 +00:00
|
|
|
remote <- fromMaybe (error "unknown remote")
|
|
|
|
<$> liftAnnex (Remote.remoteFromUUID uuid)
|
|
|
|
liftAnnex $ do
|
2014-10-27 15:24:21 +00:00
|
|
|
inRepo $ Git.Remote.Remove.remove (Remote.name remote)
|
2020-05-27 15:54:39 +00:00
|
|
|
remotesChanged
|
2013-04-03 21:01:40 +00:00
|
|
|
updateSyncRemotes
|
|
|
|
return remote
|
|
|
|
|
2013-04-04 00:54:53 +00:00
|
|
|
{- Removes a remote, marking it dead .-}
|
|
|
|
removeRemote :: UUID -> Assistant Remote
|
|
|
|
removeRemote uuid = do
|
|
|
|
liftAnnex $ trustSet uuid DeadTrusted
|
|
|
|
disableRemote uuid
|
|
|
|
|
2013-04-03 23:03:16 +00:00
|
|
|
{- 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 ()
|
2021-12-27 19:28:31 +00:00
|
|
|
removableRemote urlrenderer uuid = getkeys >>= \case
|
|
|
|
Just keys
|
|
|
|
| null keys -> finishRemovingRemote urlrenderer uuid
|
|
|
|
| otherwise -> do
|
2013-04-03 23:03:16 +00:00
|
|
|
r <- fromMaybe (error "unknown remote")
|
|
|
|
<$> liftAnnex (Remote.remoteFromUUID uuid)
|
|
|
|
mapM_ (queueremaining r) keys
|
2021-12-27 19:28:31 +00:00
|
|
|
Nothing -> noop
|
2013-04-03 23:03:16 +00:00
|
|
|
where
|
2014-10-09 18:53:13 +00:00
|
|
|
queueremaining r k =
|
2013-04-03 23:03:16 +00:00
|
|
|
queueTransferWhenSmall "remaining object in unwanted remote"
|
2019-11-22 20:24:04 +00:00
|
|
|
(AssociatedFile Nothing) (Transfer Download uuid (fromKey id k)) r
|
2013-04-03 23:03:16 +00:00
|
|
|
{- 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
|
|
|
|
|
2013-04-04 00:54:53 +00:00
|
|
|
{- 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.
|
|
|
|
-}
|
2013-04-03 21:01:40 +00:00
|
|
|
finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
|
2013-04-03 21:44:34 +00:00
|
|
|
#ifdef WITH_WEBAPP
|
2013-04-04 05:48:26 +00:00
|
|
|
finishRemovingRemote urlrenderer uuid = do
|
2013-04-03 21:01:40 +00:00
|
|
|
desc <- liftAnnex $ Remote.prettyUUID uuid
|
2013-10-10 22:02:33 +00:00
|
|
|
button <- mkAlertButton True (T.pack "Finish deletion process") urlrenderer $
|
2013-04-04 05:48:26 +00:00
|
|
|
FinishDeleteRepositoryR uuid
|
|
|
|
void $ addAlert $ remoteRemovalAlert desc button
|
2013-04-04 00:54:53 +00:00
|
|
|
#else
|
2013-04-04 05:48:26 +00:00
|
|
|
finishRemovingRemote _ uuid = void $ removeRemote uuid
|
2013-04-03 21:44:34 +00:00
|
|
|
#endif
|