44e1524be5
This happened because the transferrer process did not know about the new remote. remoteFromUUID crashed, which crashed the transferrer. When it was restarted, the new one knew about the new remote so all further files would transfer, but the one file would temporarily not be, until transfers retried. Fixed by making remoteFromUUID not crash, and try reloading the remote list if it does not know about a remote. Note that this means that remoteFromUUID does not only return Nothing anymore when the UUID is the UUID of the local repository. So had to change some code that dependend on that assumption.
131 lines
4 KiB
Haskell
131 lines
4 KiB
Haskell
{- git-annex assistant webapp repository deletion
|
|
-
|
|
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
|
|
|
|
module Assistant.WebApp.Configurators.Delete where
|
|
|
|
import Assistant.WebApp.Common
|
|
import Assistant.DeleteRemote
|
|
import Assistant.WebApp.Utility
|
|
import Assistant.DaemonStatus
|
|
import Assistant.ScanRemotes
|
|
import qualified Remote
|
|
import qualified Git
|
|
import Config.Files
|
|
import Utility.FileMode
|
|
import Logs.Trust
|
|
import Logs.Remote
|
|
import Logs.PreferredContent
|
|
import Types.StandardGroups
|
|
import Annex.UUID
|
|
|
|
import System.IO.HVFS (SystemFS(..))
|
|
import qualified Data.Text as T
|
|
import qualified Data.Map as M
|
|
import System.Path
|
|
|
|
notCurrentRepo :: UUID -> Handler Html -> Handler Html
|
|
notCurrentRepo uuid a = do
|
|
u <- liftAnnex getUUID
|
|
if u == uuid
|
|
then redirect DeleteCurrentRepositoryR
|
|
else go =<< liftAnnex (Remote.remoteFromUUID uuid)
|
|
where
|
|
go Nothing = error "Unknown UUID"
|
|
go (Just _) = a
|
|
|
|
getDisableRepositoryR :: UUID -> Handler Html
|
|
getDisableRepositoryR uuid = notCurrentRepo uuid $ do
|
|
void $ liftAssistant $ disableRemote uuid
|
|
redirect DashboardR
|
|
|
|
getDeleteRepositoryR :: UUID -> Handler Html
|
|
getDeleteRepositoryR uuid = notCurrentRepo uuid $
|
|
deletionPage $ do
|
|
reponame <- liftAnnex $ Remote.prettyUUID uuid
|
|
$(widgetFile "configurators/delete/start")
|
|
|
|
getStartDeleteRepositoryR :: UUID -> Handler Html
|
|
getStartDeleteRepositoryR uuid = do
|
|
remote <- fromMaybe (error "unknown remote")
|
|
<$> liftAnnex (Remote.remoteFromUUID uuid)
|
|
liftAnnex $ do
|
|
trustSet uuid UnTrusted
|
|
setStandardGroup uuid UnwantedGroup
|
|
liftAssistant $ addScanRemotes True [remote]
|
|
redirect DashboardR
|
|
|
|
getFinishDeleteRepositoryR :: UUID -> Handler Html
|
|
getFinishDeleteRepositoryR uuid = deletionPage $ do
|
|
void $ liftAssistant $ removeRemote uuid
|
|
|
|
reponame <- liftAnnex $ Remote.prettyUUID uuid
|
|
{- If it's not listed in the remote log, it must be a git repo. -}
|
|
gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog
|
|
$(widgetFile "configurators/delete/finished")
|
|
|
|
getDeleteCurrentRepositoryR :: Handler Html
|
|
getDeleteCurrentRepositoryR = deleteCurrentRepository
|
|
|
|
postDeleteCurrentRepositoryR :: Handler Html
|
|
postDeleteCurrentRepositoryR = deleteCurrentRepository
|
|
|
|
deleteCurrentRepository :: Handler Html
|
|
deleteCurrentRepository = dangerPage $ do
|
|
reldir <- fromJust . relDir <$> liftH getYesod
|
|
havegitremotes <- haveremotes syncGitRemotes
|
|
havedataremotes <- haveremotes syncDataRemotes
|
|
((result, form), enctype) <- liftH $
|
|
runFormPost $ renderBootstrap $ sanityVerifierAForm $
|
|
SanityVerifier magicphrase
|
|
case result of
|
|
FormSuccess _ -> liftH $ do
|
|
dir <- liftAnnex $ fromRepo Git.repoPath
|
|
liftIO $ removeAutoStartFile dir
|
|
|
|
{- Disable syncing to this repository, and all
|
|
- remotes. This stops all transfers, and all
|
|
- file watching. -}
|
|
changeSyncable Nothing False
|
|
rs <- liftAssistant $ syncRemotes <$> getDaemonStatus
|
|
mapM_ (\r -> changeSyncable (Just r) False) rs
|
|
|
|
{- Make all directories writable, so all annexed
|
|
- content can be deleted. -}
|
|
liftIO $ do
|
|
recurseDir SystemFS dir >>=
|
|
filterM doesDirectoryExist >>=
|
|
mapM_ allowWrite
|
|
removeDirectoryRecursive dir
|
|
|
|
redirect ShutdownConfirmedR
|
|
_ -> $(widgetFile "configurators/delete/currentrepository")
|
|
where
|
|
haveremotes selector = not . null . selector
|
|
<$> liftAssistant getDaemonStatus
|
|
|
|
data SanityVerifier = SanityVerifier T.Text
|
|
deriving (Eq)
|
|
|
|
sanityVerifierAForm :: SanityVerifier -> MkAForm SanityVerifier
|
|
sanityVerifierAForm template = SanityVerifier
|
|
<$> areq checksanity "Confirm deletion?" Nothing
|
|
where
|
|
checksanity = checkBool (\input -> SanityVerifier input == template)
|
|
insane textField
|
|
|
|
insane = "Maybe this is not a good idea..." :: Text
|
|
|
|
deletionPage :: Widget -> Handler Html
|
|
deletionPage = page "Delete repository" (Just Configuration)
|
|
|
|
dangerPage :: Widget -> Handler Html
|
|
dangerPage = page "Danger danger danger" (Just Configuration)
|
|
|
|
magicphrase :: Text
|
|
magicphrase = "Yes, please do as I say!"
|