From bfb63ea521f8622b1c0456284676e9b1f74913af Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 20 Mar 2013 16:46:35 -0400 Subject: [PATCH] adding removable drive improvements --- Assistant/WebApp/Configurators/Local.hs | 71 +++++++++++++------ Assistant/WebApp/Types.hs | 11 +++ Assistant/WebApp/routes | 2 + debian/changelog | 4 ++ templates/configurators/adddrive.hamlet | 9 +-- .../configurators/adddrive/clonemodal.hamlet | 8 +++ .../configurators/adddrive/confirm.hamlet | 19 +++++ 7 files changed, 95 insertions(+), 29 deletions(-) create mode 100644 templates/configurators/adddrive/clonemodal.hamlet create mode 100644 templates/configurators/adddrive/confirm.hamlet diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index a05952a6c4..1021c85a9a 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/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 diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index f5454466e5..693cf0e4a0 100644 --- a/Assistant/WebApp/Types.hs +++ b/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 diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 61a53569c4..24af53bea3 100644 --- a/Assistant/WebApp/routes +++ b/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 diff --git a/debian/changelog b/debian/changelog index c1a2b8229f..c5d612ffb2 100644 --- a/debian/changelog +++ b/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 Fri, 15 Mar 2013 00:10:07 -0400 diff --git a/templates/configurators/adddrive.hamlet b/templates/configurators/adddrive.hamlet index 67e300690e..99ebabd930 100644 --- a/templates/configurators/adddrive.hamlet +++ b/templates/configurators/adddrive.hamlet @@ -29,11 +29,4 @@ # Rescan for removable drives -
-
-

- Cloning to drive -
-

- Cloning the repository to the drive. This may take a few minutes; # - do not remove the drive. +^{cloneModal} diff --git a/templates/configurators/adddrive/clonemodal.hamlet b/templates/configurators/adddrive/clonemodal.hamlet new file mode 100644 index 0000000000..1a7a954aff --- /dev/null +++ b/templates/configurators/adddrive/clonemodal.hamlet @@ -0,0 +1,8 @@ +