1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
{- git-annex assistant webapp repository deletion
-
- Copyright 2013 Joey Hess <id@joeyh.name>
-
- 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.DaemonStatus
import Assistant.ScanRemotes
import Assistant.Sync
import qualified Remote
import qualified Git
import Config.Files.AutoStart
import Logs.Trust
import Logs.Remote
import Logs.PreferredContent
import Types.StandardGroups
import Annex.UUID
import Command.Uninit (prepareRemoveAnnexDir)
import qualified Data.Text as T
import qualified Data.Map as M
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
getDeleteRepositoryR :: UUID -> Handler Html
getDeleteRepositoryR uuid = notCurrentRepo uuid $ do
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 <$> remoteConfigMap
$(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 downloadRemotes
((result, form), enctype) <- liftH $
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
sanityVerifierAForm $ SanityVerifier magicphrase
case result of
FormSuccess _ -> liftH $ do
dir <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath
liftIO $ removeAutoStartFile dir
{- Disable syncing to this repository, and all
- remotes. This stops all transfers, and all
- file watching. -}
liftAssistant $ do
changeSyncable Nothing False
rs <- syncRemotes <$> getDaemonStatus
mapM_ (\r -> changeSyncable (Just r) False) rs
liftAnnex $ prepareRemoveAnnexDir dir
liftIO $ removeDirectoryRecursive . fromRawFilePath
=<< absPath (toRawFilePath 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 (bfs "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!"
|
