work toward adding new repos on removable drives

This actually does add a new repo, but it doesn't yet set up
remotes, or sync to it.
This commit is contained in:
Joey Hess 2012-08-04 18:17:16 -04:00
parent e0c3958d9a
commit e125ce74b8
7 changed files with 196 additions and 32 deletions

View file

@ -23,12 +23,17 @@ import qualified Git.Config
import qualified Annex import qualified Annex
import Locations.UserConfig import Locations.UserConfig
import Utility.FreeDesktop import Utility.FreeDesktop
import Utility.Mounts
import Utility.DiskFree
import Utility.DataUnits
import Yesod import Yesod
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Char import Data.Char
import System.Posix.Directory import System.Posix.Directory
import System.Posix.User
import qualified Control.Exception as E
{- The main configuration screen. -} {- The main configuration screen. -}
getConfigR :: Handler RepHtml getConfigR :: Handler RepHtml
@ -117,7 +122,8 @@ checkRepositoryPath p = do
, (doesFileExist path, "A file already exists with that name.") , (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.") , (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
, (not <$> doesDirectoryExist parent, "Parent directory does not exist.") , (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 $ return $
case headMaybe problems of case headMaybe problems of
@ -128,10 +134,6 @@ checkRepositoryPath p = do
( return $ Just msg ( return $ Just msg
, return Nothing , 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 home ('~':'/':path) = home </> path
expandTilde _ path = path expandTilde _ path = path
@ -150,8 +152,8 @@ defaultRepositoryPath firstrun = do
(relHome (desktop </> "annex"), return "~/annex") (relHome (desktop </> "annex"), return "~/annex")
else return cwd else return cwd
addLocalRepositoryForm :: Form RepositoryPath localRepositoryForm :: Form RepositoryPath
addLocalRepositoryForm msg = do localRepositoryForm msg = do
path <- T.pack . addTrailingPathSeparator path <- T.pack . addTrailingPathSeparator
<$> (liftIO . defaultRepositoryPath =<< lift inFirstRun) <$> (liftIO . defaultRepositoryPath =<< lift inFirstRun)
(pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path) (pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path)
@ -164,16 +166,117 @@ addLocalRepositoryForm msg = do
$(widgetFile "configurators/localrepositoryform") $(widgetFile "configurators/localrepositoryform")
return (RepositoryPath <$> pathRes, form) return (RepositoryPath <$> pathRes, form)
{- Making the first repository, when starting the webapp for the first time. -}
getFirstRepositoryR :: Handler RepHtml getFirstRepositoryR :: Handler RepHtml
getFirstRepositoryR = bootstrap (Just Config) $ do getFirstRepositoryR = bootstrap (Just Config) $ do
sideBarDisplay sideBarDisplay
setTitle "Getting started" setTitle "Getting started"
((res, form), enctype) <- lift $ runFormGet addLocalRepositoryForm ((res, form), enctype) <- lift $ runFormGet localRepositoryForm
case res of case res of
FormSuccess (RepositoryPath p) -> lift $ FormSuccess (RepositoryPath p) -> lift $
startFullAssistant $ T.unpack p startFullAssistant $ T.unpack p
_ -> $(widgetFile "configurators/firstrepository") _ -> $(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 {- Bootstraps from first run mode to a fully running assistant in a
- repository, by running the postFirstRun callback, which returns the - repository, by running the postFirstRun callback, which returns the
- url to the new webapp. -} - url to the new webapp. -}
@ -181,19 +284,53 @@ startFullAssistant :: FilePath -> Handler ()
startFullAssistant path = do startFullAssistant path = do
webapp <- getYesod webapp <- getYesod
url <- liftIO $ do url <- liftIO $ do
makeRepo path makeRepo path False
initRepo path Nothing
addAutoStart path
changeWorkingDirectory path changeWorkingDirectory path
fromJust $ postFirstRun webapp fromJust $ postFirstRun webapp
redirect $ T.pack url redirect $ T.pack url
{- Makes a new git-annex repository. -} {- Makes a new git-annex repository. -}
makeRepo :: FilePath -> IO () makeRepo :: FilePath -> Bool -> IO ()
makeRepo path = do makeRepo path bare = do
unlessM (boolSystem "git" [Param "init", Param "--quiet", File path]) $ unlessM (boolSystem "git" params) $
error "git init failed!" 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 g <- Git.Config.read =<< Git.Construct.fromPath path
state <- Annex.new g 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 autostart <- autoStartFile
createDirectoryIfMissing True (parentDir autostart) createDirectoryIfMissing True (parentDir autostart)
appendFile autostart $ path ++ "\n" 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"

View file

@ -5,6 +5,7 @@
/config ConfigR GET /config ConfigR GET
/config/repository/add AddRepositoryR GET /config/repository/add AddRepositoryR GET
/config/repository/add/drive AddDriveR GET
/config/repository/first FirstRepositoryR GET /config/repository/first FirstRepositoryR GET
/config/repository/list ListRepositoriesR GET /config/repository/list ListRepositoriesR GET

View file

@ -28,7 +28,7 @@ import Prelude hiding (catch)
- fields available everywhere. -} - fields available everywhere. -}
data Mntent = Mntent data Mntent = Mntent
{ mnt_fsname :: String { mnt_fsname :: String
, mnt_dir :: String , mnt_dir :: FilePath
, mnt_type :: String , mnt_type :: String
} deriving (Read, Show, Eq, Ord) } deriving (Read, Show, Eq, Ord)

View file

@ -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

View file

@ -1,10 +1,8 @@
<div .span9> <div .span9>
<h2>
Add repositories
<div .row-fluid> <div .row-fluid>
<div .span4> <div .span4>
<h3> <h3>
<a href=""> <a href="@{AddDriveR}">
Clone to a removable drive Clone to a removable drive
<p> <p>
Clone this repository to a USB drive, memory stick, or other # Clone this repository to a USB drive, memory stick, or other #

View file

@ -1,14 +1,14 @@
<div .span9 .hero-unit> <div .span9 .hero-unit>
<h2> <h2>
Welcome to git-annex! Welcome to git-annex!
<p> <p>
There's just one thing to do before you can start using the power # There's just one thing to do before you can start using the power #
and convenience of git-annex. and convenience of git-annex.
<h2> <h2>
Create a git-annex repository Create a git-annex repository
<p> <p>
Files in this repository will managed by git-annex, # Files in this repository will managed by git-annex, #
and kept in sync with your repositories on other devices. and kept in sync with your repositories on other devices.
<p> <p>
<form .form-inline enctype=#{enctype}> <form .form-inline enctype=#{enctype}>
^{form} ^{form}

View file

@ -17,8 +17,6 @@
Current Repository: #{reldir} Current Repository: #{reldir}
<b .caret></b> <b .caret></b>
<ul .dropdown-menu> <ul .dropdown-menu>
<li><a href="#">#{reldir}</a></li>
<li .divider></li>
<li><a href="@{AddRepositoryR}">Add another repository</a></li> <li><a href="@{AddRepositoryR}">Add another repository</a></li>
$nothing $nothing
<div .container-fluid> <div .container-fluid>