adding removable drive improvements

Assistant/WebApp/Configurators/Local.hs

@@ -31,10 +31,12 @@ import Remote (prettyListUUIDs)
 import Annex.UUID
 import Types.StandardGroups
 import Logs.PreferredContent
+import Logs.UUID
 import Utility.UserInfo
 import Config
 
 import qualified Data.Text as T
+import qualified Data.Map as M
 import Data.Char
 import System.Posix.Directory
 
@@ -169,16 +171,12 @@ getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do
   where
 	remotename = takeFileName newrepopath
 
-data RemovableDrive = RemovableDrive 
-	{ diskFree :: Maybe Integer
-	, mountPoint :: Text
-	}
-	deriving (Show, Eq, Ord)
-
-selectDriveForm :: [RemovableDrive] -> Maybe RemovableDrive -> Form RemovableDrive
-selectDriveForm drives def = renderBootstrap $ RemovableDrive
+selectDriveForm :: [RemovableDrive] -> Form RemovableDrive
+selectDriveForm drives = renderBootstrap $ RemovableDrive
 	<$> pure Nothing
-	<*> areq (selectFieldList pairs) "Select drive:" (mountPoint <$> def)
+	<*> areq (selectFieldList pairs) "Select drive:" Nothing
+	<*> areq textField "Use this directory on the drive:"
+		(Just $ T.pack gitAnnexAssistantDefaultDir)
   where
 	pairs = zip (map describe drives) (map mountPoint drives)
 	describe drive = case diskFree drive of
@@ -191,11 +189,11 @@ selectDriveForm drives def = renderBootstrap $ RemovableDrive
 				, "free)"
 				]
 
-{- Adding a removable drive.
- -
- - The repo may already exist, when adding removable media
- - that has already been used elsewhere.
- -}
+removableDriveRepository :: RemovableDrive -> FilePath
+removableDriveRepository drive =
+	T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive)
+
+{- Adding a removable drive. -}
 getAddDriveR :: Handler RepHtml
 getAddDriveR = postAddDriveR
 postAddDriveR :: Handler RepHtml
@@ -204,13 +202,43 @@ postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
 	writabledrives <- liftIO $
 		filterM (canWrite . T.unpack . mountPoint) removabledrives
 	((res, form), enctype) <- lift $ runFormPost $
-		selectDriveForm (sort writabledrives) Nothing
+		selectDriveForm (sort writabledrives)
 	case res of
-		FormSuccess (RemovableDrive { mountPoint = d }) -> lift $
-			make (T.unpack d) >>= redirect . EditNewRepositoryR
+		FormSuccess drive -> lift $ redirect $ ConfirmAddDriveR drive
 		_ -> $(widgetFile "configurators/adddrive")
+
+{- The repo may already exist, when adding removable media
+ - that has already been used elsewhere. If so, check
+ - the UUID of the repo and see if it's one we know. If not,
+ - the user must confirm the repository merge. -}
+getConfirmAddDriveR :: RemovableDrive -> Handler RepHtml
+getConfirmAddDriveR drive = do
+	ifM (needconfirm)
+		( page "Combine repositories?" (Just Configuration) $
+			$(widgetFile "configurators/adddrive/confirm")
+		, do
+			getFinishAddDriveR drive
+		)
   where
-	make mountpoint = do
+  	dir = removableDriveRepository drive
+	needconfirm = ifM (liftIO $ doesDirectoryExist dir)
+		( liftAnnex $ do
+			mu <- liftIO $ catchMaybeIO $
+				inDir dir $ getUUID
+			case mu of
+				Nothing -> return False
+				Just driveuuid -> not .
+					M.member driveuuid <$> uuidMap
+		, return False
+		)
+
+cloneModal :: Widget
+cloneModal = $(widgetFile "configurators/adddrive/clonemodal")
+
+getFinishAddDriveR :: RemovableDrive -> Handler RepHtml
+getFinishAddDriveR drive = make >>= redirect . EditNewRepositoryR
+  where
+  	make = do
 		liftIO $ createDirectoryIfMissing True dir
 		isnew <- liftIO $ makeRepo dir True
 		u <- liftIO $ initRepo isnew False dir $ Just remotename
@@ -218,9 +246,9 @@ postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
 		liftAnnex $ setStandardGroup u TransferGroup
 		syncRemote r
 		return u
-	  where
-		dir = mountpoint </> gitAnnexAssistantDefaultDir
-		remotename = takeFileName mountpoint
+  	mountpoint = T.unpack (mountPoint drive)
+	dir = removableDriveRepository drive
+	remotename = takeFileName mountpoint
 
 {- Each repository is made a remote of the other.
  - Next call syncRemote to get them in sync. -}
@@ -245,6 +273,7 @@ driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts
 	gen dir = RemovableDrive
 		<$> getDiskFree dir
 		<*> pure (T.pack dir)
+		<*> pure (T.pack gitAnnexAssistantDefaultDir)
 	-- filter out some things that are surely not removable drives
 	sane Mntent { mnt_dir = dir, mnt_fsname = dev }
 		{- We want real disks like /dev/foo, not

Assistant/WebApp/Types.hs

@@ -112,6 +112,13 @@ data RepoSelector = RepoSelector
 data RepoListNotificationId = RepoListNotificationId NotificationId RepoSelector
 	deriving (Read, Show, Eq)
 
+data RemovableDrive = RemovableDrive 
+	{ diskFree :: Maybe Integer
+	, mountPoint :: Text
+	, driveRepoPath :: Text
+	}
+	deriving (Read, Show, Eq, Ord)
+
 {- Only needed to work around old-yesod bug that emits a warning message
  - when a route has two parameters. -}
 data FilePathAndUUID = FilePathAndUUID FilePath UUID
@@ -121,6 +128,10 @@ instance PathPiece FilePathAndUUID where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
 
+instance PathPiece RemovableDrive where
+	toPathPiece = pack . show
+	fromPathPiece = readish . unpack
+
 instance PathPiece SshData where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack

Assistant/WebApp/routes

@@ -31,6 +31,8 @@
 /config/repository/sync/enable/#UUID EnableSyncR GET
 
 /config/repository/add/drive AddDriveR GET POST
+/config/repository/add/drive/confirm/#RemovableDrive ConfirmAddDriveR GET
+/config/repository/add/drive/finish/#RemovableDrive FinishAddDriveR GET
 /config/repository/add/ssh AddSshR GET POST
 /config/repository/add/ssh/confirm/#SshData ConfirmSshR GET
 /config/repository/add/ssh/retry/#SshData RetrySshR GET

debian/changelog

@@ -31,6 +31,10 @@ git-annex (4.20130315) UNRELEASED; urgency=low
   * assistant: Several optimisations to file transfers.
   * OSX app and standalone Linux tarball now both support being added to
     PATH; no need to use runshell to start git-annex.
+  * webapp: When adding a removable drive, you can now specify the
+    directory inside it to use.
+  * webapp: Confirm whether user wants to combine repositories when
+    adding a removable drive that already has a repository on it.
 
  -- Joey Hess <joeyh@debian.org>  Fri, 15 Mar 2013 00:10:07 -0400
 

templates/configurators/adddrive.hamlet

@@ -29,11 +29,4 @@
         <button .btn .btn-primary type=submit onclick="$('#clonemodal').modal('show');">Use this drive</button> #
         <a .btn href="@{AddDriveR}">
           Rescan for removable drives
-<div .modal .fade #clonemodal>
-  <div .modal-header>
-    <h3>
-      Cloning to drive
-  <div .modal-body>
-    <p>
-      Cloning the repository to the drive. This may take a few minutes; #
-      do not remove the drive.
+^{cloneModal}

templates/configurators/adddrive/clonemodal.hamlet

@@ -0,0 +1,8 @@
+<div .modal .fade #clonemodal>
+  <div .modal-header>
+    <h3>
+      Cloning to drive
+  <div .modal-body>
+    <p>
+      Cloning the repository to the drive. This may take a few minutes; #
+      do not remove the drive.

templates/configurators/adddrive/confirm.hamlet

@@ -0,0 +1,19 @@
+<div .span9 .hero-unit>
+  <h2>
+    Combine repositories?
+  <p>
+    The removable drive at <tt>#{mountPoint drive}</tt> already
+    has files in its repository <tt>#{driveRepoPath drive}</tt>
+  <p>
+    Do you want to combine these files into your repository?
+  <p>
+    <a .btn href="@{FinishAddDriveR drive}">
+      <i .icon-resize-small></i> Combine the repositories #
+    The combined repositories will sync and share their files.
+  <p>
+  <p>
+    <a .btn href="@{AddDriveR}">
+      <i .icon-resize-full></i> Go back #
+    Use a different directory than <tt>#{driveRepoPath drive}</tt> to #
+    avoid combining the repositories.
+^{cloneModal}