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:
parent
e0c3958d9a
commit
e125ce74b8
7 changed files with 196 additions and 32 deletions
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
30
templates/configurators/adddrive.hamlet
Normal file
30
templates/configurators/adddrive.hamlet
Normal 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
|
|
@ -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 #
|
||||||
|
|
|
@ -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}
|
||||||
|
|
|
@ -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>
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue