if the webapp is started with a cwd the user can't write to, don't suggest it

Fall back to somewhere under $HOME instead.

I had a report that git-annex.app on OSX was coming up with "/" as the
suggested location on first run.
This commit is contained in:
Joey Hess 2012-09-28 16:04:49 -04:00
parent 1117583087
commit fede52ac05

View file

@ -90,19 +90,22 @@ checkRepositoryPath p = do
{- On first run, if run in the home directory, default to putting it in {- On first run, if run in the home directory, default to putting it in
- ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise. - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
- -
- If run in another directory, the user probably wants to put it there. -} - If run in another directory, that the user can write to,
- the user probably wants to put it there. -}
defaultRepositoryPath :: Bool -> IO FilePath defaultRepositoryPath :: Bool -> IO FilePath
defaultRepositoryPath firstrun = do defaultRepositoryPath firstrun = do
cwd <- liftIO $ getCurrentDirectory cwd <- liftIO $ getCurrentDirectory
home <- myHomeDir home <- myHomeDir
if home == cwd && firstrun if home == cwd && firstrun
then do then inhome
else ifM (canWrite cwd) ( return cwd, inhome )
where
inhome = do
desktop <- userDesktopDir desktop <- userDesktopDir
ifM (doesDirectoryExist desktop) ifM (doesDirectoryExist desktop)
( relHome $ desktop </> gitAnnexAssistantDefaultDir ( relHome $ desktop </> gitAnnexAssistantDefaultDir
, return $ "~" </> gitAnnexAssistantDefaultDir , return $ "~" </> gitAnnexAssistantDefaultDir
) )
else return cwd
newRepositoryForm :: FilePath -> Form RepositoryPath newRepositoryForm :: FilePath -> Form RepositoryPath
newRepositoryForm defpath msg = do newRepositoryForm defpath msg = do