diff options
| -rw-r--r-- | Assistant/WebApp/Configurators.hs | 163 | ||||
| -rw-r--r-- | Assistant/WebApp/routes | 1 | ||||
| -rw-r--r-- | Utility/Mounts.hsc | 2 | ||||
| -rw-r--r-- | templates/configurators/adddrive.hamlet | 30 | ||||
| -rw-r--r-- | templates/configurators/addrepository.hamlet | 4 | ||||
| -rw-r--r-- | templates/configurators/firstrepository.hamlet | 26 | ||||
| -rw-r--r-- | templates/page.hamlet | 2 |
7 files changed, 196 insertions, 32 deletions
diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 2771a2284..30c7c9330 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -23,12 +23,17 @@ import qualified Git.Config import qualified Annex import Locations.UserConfig import Utility.FreeDesktop +import Utility.Mounts +import Utility.DiskFree +import Utility.DataUnits import Yesod import Data.Text (Text) import qualified Data.Text as T import Data.Char import System.Posix.Directory +import System.Posix.User +import qualified Control.Exception as E {- The main configuration screen. -} getConfigR :: Handler RepHtml @@ -117,7 +122,8 @@ checkRepositoryPath p = do , (doesFileExist path, "A file already exists with that name.") , (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.") , (not <$> doesDirectoryExist parent, "Parent directory does not exist.") - , (cannotWrite path, "Cannot write a repository there.") + , (not <$> canWrite path, "Cannot write a repository there.") + , (not <$> canMakeSymlink path, "That directory is on a filesystem that does not support symlinks. Try a different location.") ] return $ case headMaybe problems of @@ -128,10 +134,6 @@ checkRepositoryPath p = do ( return $ Just msg , return Nothing ) - cannotWrite path = do - tocheck <- ifM (doesDirectoryExist path) - (return path, return $ parentDir path) - not <$> (catchBoolIO $ fileAccess tocheck False True False) expandTilde home ('~':'/':path) = home </> path expandTilde _ path = path @@ -150,8 +152,8 @@ defaultRepositoryPath firstrun = do (relHome (desktop </> "annex"), return "~/annex") else return cwd -addLocalRepositoryForm :: Form RepositoryPath -addLocalRepositoryForm msg = do +localRepositoryForm :: Form RepositoryPath +localRepositoryForm msg = do path <- T.pack . addTrailingPathSeparator <$> (liftIO . defaultRepositoryPath =<< lift inFirstRun) (pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path) @@ -164,16 +166,117 @@ addLocalRepositoryForm msg = do $(widgetFile "configurators/localrepositoryform") return (RepositoryPath <$> pathRes, form) +{- Making the first repository, when starting the webapp for the first time. -} getFirstRepositoryR :: Handler RepHtml getFirstRepositoryR = bootstrap (Just Config) $ do sideBarDisplay setTitle "Getting started" - ((res, form), enctype) <- lift $ runFormGet addLocalRepositoryForm + ((res, form), enctype) <- lift $ runFormGet localRepositoryForm case res of FormSuccess (RepositoryPath p) -> lift $ startFullAssistant $ T.unpack p _ -> $(widgetFile "configurators/firstrepository") +data RemovableDrive = RemovableDrive + { diskFree :: Maybe Integer + , mountPoint :: Text + } + deriving (Show, Eq, Ord) + +selectDriveForm :: [RemovableDrive] -> Maybe RemovableDrive -> Form RemovableDrive +selectDriveForm drives def = renderBootstrap $ RemovableDrive + <$> pure Nothing + <*> areq (selectFieldList pairs) "Select drive:" (mountPoint <$> def) + where + pairs = zip (map describe drives) (map mountPoint drives) + describe drive = case diskFree drive of + Nothing -> mountPoint drive + Just free -> + let sz = roughSize storageUnits True free + in T.unwords + [ mountPoint drive + , T.concat ["(", T.pack sz] + , "free)" + ] + +{- Making the first repository, when starting the webapp for the first time. -} +getAddDriveR :: Handler RepHtml +getAddDriveR = bootstrap (Just Config) $ do + sideBarDisplay + setTitle "Clone to a removable drive" + removabledrives <- liftIO $ driveList + writabledrives <- liftIO $ + filterM (canWrite . T.unpack . mountPoint) removabledrives + ((res, form), enctype) <- lift $ runFormGet $ + selectDriveForm (sort writabledrives) Nothing + case res of + FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do + liftIO $ go $ T.unpack d </> "annex" + setMessage $ toHtml $ T.unwords ["Added", d] + redirect ListRepositoriesR + _ -> do + let authtoken = webAppFormAuthToken + $(widgetFile "configurators/adddrive") + where + {- There may already be a git-annex repo on the drive. + - If so, avoid re-initualizing it; this will be the + - case if a user is adding the same removable drive + - to several computers. + - + - Some drives will have FAT or another horrible filesystem + - that does not support symlinks; make a bare repo on those. + - + - Use the basename of the mount point, along with the + - username (but without the hostname as this repo + - travels!), as the repo description, and use the basename + - of the mount point as the git remote name. + -} + go dir = do + r <- E.try getannex :: IO (Either E.SomeException Annex.AnnexState) + state <- case r of + Right state -> return state + Left _e -> do + createDirectoryIfMissing True dir + bare <- not <$> canMakeSymlink dir + makeRepo dir bare + getannex + desc <- getdesc + Annex.eval state $ + unlessM isInitialized $ + initialize $ Just desc + where + getannex = Annex.new =<< Git.Construct.fromAbsPath dir + remotename = takeFileName dir + getdesc = do + username <- userName <$> + (getUserEntryForID =<< getEffectiveUserID) + return $ concat + [ username + , ":" + , remotename + ] + +{- List of removable drives. -} +driveList :: IO [RemovableDrive] +driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts + where + gen dir = RemovableDrive + <$> getDiskFree dir + <*> pure (T.pack dir) + -- 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 + -- dummy mount points like proc or tmpfs or + -- gvfs-fuse-daemon + | not ('/' `elem` dev) = False + -- Just in case: These mount points are surely not + -- removable disks. + | dir == "/" = False + | dir == "/tmp" = False + | dir == "/run/shm" = False + | dir == "/run/lock" = False + | otherwise = True + {- Bootstraps from first run mode to a fully running assistant in a - repository, by running the postFirstRun callback, which returns the - url to the new webapp. -} @@ -181,19 +284,53 @@ startFullAssistant :: FilePath -> Handler () startFullAssistant path = do webapp <- getYesod url <- liftIO $ do - makeRepo path + makeRepo path False + initRepo path Nothing + addAutoStart path changeWorkingDirectory path fromJust $ postFirstRun webapp redirect $ T.pack url {- Makes a new git-annex repository. -} -makeRepo :: FilePath -> IO () -makeRepo path = do - unlessM (boolSystem "git" [Param "init", Param "--quiet", File path]) $ +makeRepo :: FilePath -> Bool -> IO () +makeRepo path bare = do + unlessM (boolSystem "git" params) $ error "git init failed!" + where + baseparams = [Param "init", Param "--quiet"] + params + | bare = baseparams ++ [Param "--bare", File path] + | otherwise = baseparams ++ [File path] + +{- Initializes a git-annex repository in a directory with a description. -} +initRepo :: FilePath -> Maybe String -> IO () +initRepo path desc = do g <- Git.Config.read =<< Git.Construct.fromPath path state <- Annex.new g - Annex.eval state $ initialize Nothing + Annex.eval state $ initialize desc + +{- Adds a directory to the autostart file. -} +addAutoStart :: FilePath -> IO () +addAutoStart path = do autostart <- autoStartFile createDirectoryIfMissing True (parentDir autostart) appendFile autostart $ path ++ "\n" + +{- Checks if the user can write to a directory. + - + - The directory may be in the process of being created; if so + - the parent directory is checked instead. -} +canWrite :: FilePath -> IO Bool +canWrite dir = do + tocheck <- ifM (doesDirectoryExist dir) + (return dir, return $ parentDir dir) + catchBoolIO $ fileAccess tocheck False True False + +{- Checks if a directory is on a filesystem that supports symlinks. -} +canMakeSymlink :: FilePath -> IO Bool +canMakeSymlink dir = catchBoolIO $ do + createSymbolicLink link link + removeLink link + return True + where + link = dir </> "delete.me" diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 12b9564ee..a53caf5ef 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -5,6 +5,7 @@ /config ConfigR GET /config/repository/add AddRepositoryR GET +/config/repository/add/drive AddDriveR GET /config/repository/first FirstRepositoryR GET /config/repository/list ListRepositoriesR GET diff --git a/Utility/Mounts.hsc b/Utility/Mounts.hsc index 6b69e844a..0b1468521 100644 --- a/Utility/Mounts.hsc +++ b/Utility/Mounts.hsc @@ -28,7 +28,7 @@ import Prelude hiding (catch) - fields available everywhere. -} data Mntent = Mntent { mnt_fsname :: String - , mnt_dir :: String + , mnt_dir :: FilePath , mnt_type :: String } deriving (Read, Show, Eq, Ord) diff --git a/templates/configurators/adddrive.hamlet b/templates/configurators/adddrive.hamlet new file mode 100644 index 000000000..030ef8a4c --- /dev/null +++ b/templates/configurators/adddrive.hamlet @@ -0,0 +1,30 @@ +<div .span9 .hero-unit> + <h2> + Adding a removable drive + <p> + Clone this repository to a USB drive, memory stick, or other # + removable media. + <p> + $if (null writabledrives) + <div .span6 .alert .alert-error .alert-block> + $if (null removabledrives) + <h4 .alert-heading> + No removable drives found + Please make sure you have a removable drive plugged in and mounted. + $else + <h4 .alert-heading> + No usable removable drives found + Seems you cannot write to any of the removable drives that are # + currently mounted. Try plugging in a removable drive that you can # + write to, or correcting the write permissions. + <p> + <a .btn .btn-primary href="@{AddDriveR}"> + Rescan for removable drives + $else + <form enctype=#{enctype}> + <fieldset> + ^{form} + ^{authtoken} + <button .btn .btn-primary type=submit>Use this drive</button> # + <a .btn href="@{AddDriveR}"> + Rescan for removable drives diff --git a/templates/configurators/addrepository.hamlet b/templates/configurators/addrepository.hamlet index d91286ad8..1ba4f94bf 100644 --- a/templates/configurators/addrepository.hamlet +++ b/templates/configurators/addrepository.hamlet @@ -1,10 +1,8 @@ <div .span9> - <h2> - Add repositories <div .row-fluid> <div .span4> <h3> - <a href=""> + <a href="@{AddDriveR}"> Clone to a removable drive <p> Clone this repository to a USB drive, memory stick, or other # diff --git a/templates/configurators/firstrepository.hamlet b/templates/configurators/firstrepository.hamlet index f4ffcf372..ac28119eb 100644 --- a/templates/configurators/firstrepository.hamlet +++ b/templates/configurators/firstrepository.hamlet @@ -1,14 +1,14 @@ <div .span9 .hero-unit> - <h2> - Welcome to git-annex! - <p> - There's just one thing to do before you can start using the power # - and convenience of git-annex. - <h2> - Create a git-annex repository - <p> - Files in this repository will managed by git-annex, # - and kept in sync with your repositories on other devices. - <p> - <form .form-inline enctype=#{enctype}> - ^{form} + <h2> + Welcome to git-annex! + <p> + There's just one thing to do before you can start using the power # + and convenience of git-annex. + <h2> + Create a git-annex repository + <p> + Files in this repository will managed by git-annex, # + and kept in sync with your repositories on other devices. + <p> + <form .form-inline enctype=#{enctype}> + ^{form} diff --git a/templates/page.hamlet b/templates/page.hamlet index 6321f7a18..5544221da 100644 --- a/templates/page.hamlet +++ b/templates/page.hamlet @@ -17,8 +17,6 @@ Current Repository: #{reldir} <b .caret></b> <ul .dropdown-menu> - <li><a href="#">#{reldir}</a></li> - <li .divider></li> <li><a href="@{AddRepositoryR}">Add another repository</a></li> $nothing <div .container-fluid> |