webapp: Added UI to delete repositories. Closes: #689847

Assistant/Threads/WebApp.hs

@@ -18,7 +18,6 @@ import Assistant.WebApp.SideBar
 import Assistant.WebApp.Notifications
 import Assistant.WebApp.RepoList
 import Assistant.WebApp.Configurators
-import Assistant.WebApp.Configurators.Edit
 import Assistant.WebApp.Configurators.Local
 import Assistant.WebApp.Configurators.Ssh
 import Assistant.WebApp.Configurators.Pairing
@@ -26,6 +25,8 @@ import Assistant.WebApp.Configurators.AWS
 import Assistant.WebApp.Configurators.WebDAV
 import Assistant.WebApp.Configurators.XMPP
 import Assistant.WebApp.Configurators.Preferences
+import Assistant.WebApp.Configurators.Edit
+import Assistant.WebApp.Configurators.Delete
 import Assistant.WebApp.Documentation
 import Assistant.WebApp.Control
 import Assistant.WebApp.OtherRepos

Assistant/WebApp/Configurators/Delete.hs

@@ -0,0 +1,129 @@
+{- git-annex assistant webapp repository deletion
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.Configurators.Delete where
+
+import Assistant.WebApp.Common
+import Assistant.WebApp.Utility
+import Assistant.DaemonStatus
+import qualified Remote
+import qualified Types.Remote as Remote
+import Remote.List (remoteListRefresh)
+import Command.Dead (markDead)
+import qualified Git.Command
+import qualified Git
+import Locations.UserConfig
+import Utility.FileMode
+
+import qualified Data.Text as T
+import System.IO.HVFS (SystemFS(..))
+
+getDeleteRepositoryR :: UUID -> Handler RepHtml
+getDeleteRepositoryR uuid = go =<< liftAnnex (Remote.remoteFromUUID uuid)
+  where
+  	go Nothing = redirect DeleteCurrentRepositoryR
+	go (Just r) = page "Delete repository" (Just Configuration) $ do
+		reponame <- liftAnnex $ concat <$> Remote.prettyListUUIDs [uuid]
+		$(widgetFile "configurators/delete/choose")
+
+getDeleteRepositoryFromListR :: UUID -> Handler RepHtml
+getDeleteRepositoryFromListR uuid = do
+	void $ liftAssistant $ removeRemote uuid
+	redirect DashboardR
+
+removeRemote :: UUID -> Assistant Remote
+removeRemote uuid = do
+	remote <- fromMaybe (error "unknown remote")
+		<$> liftAnnex (Remote.remoteFromUUID uuid)
+	liftAnnex $ do
+		inRepo $ Git.Command.run
+			[ Param "remote"
+			, Param "remove"
+			, Param (Remote.name remote)
+			]
+		void $ remoteListRefresh
+	updateSyncRemotes
+	return remote
+
+getDeleteRepositoryContentsR :: UUID -> Handler RepHtml
+getDeleteRepositoryContentsR = deleteRepositoryContents
+
+postDeleteRepositoryContentsR :: UUID -> Handler RepHtml
+postDeleteRepositoryContentsR = deleteRepositoryContents
+
+deleteRepositoryContents :: UUID -> Handler RepHtml
+deleteRepositoryContents uuid = dangerPage $ do
+	reponame <- liftAnnex $ concat <$> Remote.prettyListUUIDs [uuid]
+	((result, form), enctype) <- lift $
+		runFormPost $ renderBootstrap $ sanityVerifierAForm $
+			SanityVerifier magicphrase
+	case result of
+		FormSuccess _ -> do
+			liftAnnex $ markDead uuid
+			oldremote <- liftAssistant $ removeRemote uuid
+			$(widgetFile "configurators/delete/repositorycontents/nextstep")
+		_ -> $(widgetFile "configurators/delete/repositorycontents")
+
+getDeleteCurrentRepositoryR :: Handler RepHtml
+getDeleteCurrentRepositoryR = deleteCurrentRepository
+
+postDeleteCurrentRepositoryR :: Handler RepHtml
+postDeleteCurrentRepositoryR = deleteCurrentRepository
+
+deleteCurrentRepository :: Handler RepHtml
+deleteCurrentRepository = dangerPage $ do
+	reldir <- fromJust . relDir <$> lift getYesod
+	havegitremotes <- haveremotes syncGitRemotes
+	havedataremotes <- haveremotes syncDataRemotes
+	((result, form), enctype) <- lift $
+		runFormPost $ renderBootstrap $ sanityVerifierAForm $
+			SanityVerifier magicphrase
+	case result of
+		FormSuccess _ -> lift $ 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 -> AForm WebApp WebApp 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
+
+dangerPage :: Widget -> Handler RepHtml
+dangerPage = page "Danger danger danger" (Just Configuration)
+
+magicphrase :: Text
+magicphrase = "Yes, please do as I say!"

Assistant/WebApp/routes

@@ -29,6 +29,10 @@
 /config/repository/edit/new/cloud/#UUID EditNewCloudRepositoryR GET POST
 /config/repository/sync/disable/#UUID DisableSyncR GET
 /config/repository/sync/enable/#UUID EnableSyncR GET
+/config/repository/delete/choose/#UUID DeleteRepositoryR GET
+/config/repository/delete/fromlist/#UUID DeleteRepositoryFromListR GET
+/config/repository/delete/contents/#UUID DeleteRepositoryContentsR GET POST
+/config/repository/delete/here DeleteCurrentRepositoryR GET POST
 
 /config/repository/add/drive AddDriveR GET POST
 /config/repository/add/drive/confirm/#RemovableDrive ConfirmAddDriveR GET

Command/Dead.hs

@@ -31,6 +31,10 @@ start ws = do
 
 perform :: UUID -> CommandPerform
 perform uuid = do
+	markDead uuid
+	next $ return True
+
+markDead :: UUID -> Annex ()
+markDead uuid = do
 	trustSet uuid DeadTrusted
 	groupSet uuid S.empty
-	next $ return True

Test.hs

@@ -851,7 +851,7 @@ cleanup dir = do
 		-- removed via directory permissions; undo
 		recurseDir SystemFS dir >>=
 			filterM doesDirectoryExist >>=
-			mapM_ Utility.FileMode.allowWrite
+				mapM_ Utility.FileMode.allowWrite
 		removeDirectoryRecursive dir
 	
 checklink :: FilePath -> Assertion

debian/changelog

@@ -18,6 +18,7 @@ git-annex (4.20130324) UNRELEASED; urgency=low
     Thanks, guilhem for the patch.
   * git-annex-shell: Passes rsync --bwlimit options on rsync.
     Thanks, guilhem for the patch.
+  * webapp: Added UI to delete repositories. Closes: #689847
 
  -- Joey Hess <joeyh@debian.org>  Mon, 25 Mar 2013 10:21:46 -0400
 

templates/configurators/delete/choose.hamlet

@@ -0,0 +1,21 @@
+<div .span9 .hero-unit>
+  <h2>
+    Delete repository #
+    <small>
+      #{reponame}
+  <p>
+    There are two ways you can choose to delete the repository:
+  <p>
+    The repository can be removed from the list of repositories, #
+    but its contents left as-is. This prevents further syncing #
+    to the repository. You can add the repository back at any time.
+    <br>
+    <a .btn .btn-default href="@{DeleteRepositoryFromListR uuid}">
+      <i .icon-minus></i> Remove repository from list
+  <p style="text-align: center">
+    -or-
+  <p>
+    All data in the repository can be deleted. This is dangerous!
+    <br>
+     <a .btn .btn-danger  href="@{DeleteRepositoryContentsR uuid}">
+       <i .icon-warning-sign></i> Remove repository and all its contents

templates/configurators/delete/currentrepository.hamlet

@@ -0,0 +1,34 @@
+<div .span9 .hero-unit>
+  <h2>
+    Deleting #{reldir}
+  <p>
+    Deleting this repository will remove <tt>#{reldir}</tt> and all its #
+    ^{actionButton FileBrowserR (Just "files") (Just "Click to open a file browser") "" "icon-folder-open"}.
+  $if havegitremotes
+    $if havedataremotes
+      <div .alert>
+        Since this repository is currently configured to sync to other #
+        repositories, you may be able to remove this repository without #
+        losing any data, if all files have been synced to them. #
+        No guarantees -- It's up to you to make sure before you continue.
+    $else
+      <div .alert .alert-error>
+        This repository is not uploading its files to other repositories,
+        so you will lose data if you delete it!
+  $else
+    <div .alert .alert-error>
+      This repository is not syncing to other git repositories, #
+      so you will lose data if you delete it!
+  <p>
+    If you choose to delete this repository, and potentially lose #
+    data, enter "#{magicphrase}" into the box.
+  <p>
+    <form method="post" .form-horizontal enctype=#{enctype}>
+      <fieldset>
+        ^{form}
+        ^{webAppFormAuthToken}
+        <div .form-actions>
+          <button .btn .btn-danger type=submit>
+            <i .icon-warning-sign></i> Delete this repository #
+          <a .btn .btn-primary href="@{DashboardR}">
+            Cancel

templates/configurators/delete/repositorycontents.hamlet

@@ -0,0 +1,20 @@
+<div .span9 .hero-unit>
+  <h2>
+    Delete repository contents?
+  <p>
+    Deleting the contents of the repository "#{reponame}" could cause #
+    you to lose data. Some files might <em>only</em> be stored in #
+    that repository.
+  <p>
+    If you choose to delete the repository, and potentially lose #
+    data, enter "#{magicphrase}" into the box.
+  <p>
+    <form method="post" .form-horizontal enctype=#{enctype}>
+      <fieldset>
+        ^{form}
+        ^{webAppFormAuthToken}
+        <div .form-actions>
+          <button .btn .btn-danger type=submit>
+            <i .icon-warning-sign></i> Delete repository #
+          <a .btn .btn-primary href="@{DashboardR}">
+            Cancel

templates/configurators/delete/repositorycontents/nextstep.hamlet

@@ -0,0 +1,23 @@
+<div .span9 .hero-unit>
+  <h2>
+    Deleting repository contents
+  <p>
+    The repository "#{reponame}" has now been removed from the list, and #
+    marked as a dead repository. But, this program is not currently #
+    able to delete the contents of remote repositories.
+  $maybe path <- Remote.localpath oldremote
+    <p>
+      <i .icon-warning-sign></i> #
+      To delete the repository, remove everything in <tt>#{path}</tt>
+    <p>
+      (If the repository is on a removable drive, make sure it's mounted #
+      first.)
+  $nothing
+    $if Git.repoIsUrl (Remote.repo oldremote)
+      <p>
+        <i .icon-warning-sign></i> #
+        To delete the repository, remove everything in <tt>#{Git.repoLocation (Remote.repo oldremote)}</tt>
+    $else
+      <p>
+        <i .icon-warning-sign></i> #
+        It's up to you to finish deleting the contents of the repository.

templates/configurators/editrepository.hamlet

@@ -19,9 +19,11 @@
         ^{webAppFormAuthToken}
         <div .form-actions>
           <button .btn .btn-primary type=submit>
-            Save Changes
-          <a .btn href="@{DashboardR}">
-            Cancel
+            Save Changes #
+          <a href="@{DashboardR}">
+            Cancel #
+          <a href="@{DeleteRepositoryR uuid}">
+            Delete repository
   $if new
     <p>
       In a hurry? Feel free to skip this step! You can always come back #