webapp: When adding a new local repository, fix bug that caused its group and preferred content to be set in the current repository, even when not combining.
There was a tricky bit here, when it does combine, the edit form is shown, and so the info needs to be committed to the new repository, but then pulled into the current one. And caches need to be invalidated for it to be visible in the edit form.
This commit is contained in:
parent
a4d760b700
commit
2dd274e4ca
6 changed files with 44 additions and 36 deletions
|
@ -218,7 +218,7 @@ set = setJournalFile
|
||||||
commit :: String -> Annex ()
|
commit :: String -> Annex ()
|
||||||
commit = whenM journalDirty . forceCommit
|
commit = whenM journalDirty . forceCommit
|
||||||
|
|
||||||
{- Commits the current index to the branch even without any journalleda
|
{- Commits the current index to the branch even without any journalled
|
||||||
- changes. -}
|
- changes. -}
|
||||||
forceCommit :: String -> Annex ()
|
forceCommit :: String -> Annex ()
|
||||||
forceCommit message = lockJournal $ \jl -> do
|
forceCommit message = lockJournal $ \jl -> do
|
||||||
|
|
|
@ -61,6 +61,10 @@ data RepoConfig = RepoConfig
|
||||||
|
|
||||||
getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
|
getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
|
||||||
getRepoConfig uuid mremote = do
|
getRepoConfig uuid mremote = do
|
||||||
|
-- Ensure we're editing current data by discarding caches.
|
||||||
|
void groupMapLoad
|
||||||
|
void uuidMapLoad
|
||||||
|
|
||||||
groups <- lookupGroups uuid
|
groups <- lookupGroups uuid
|
||||||
remoteconfig <- M.lookup uuid <$> readRemoteLog
|
remoteconfig <- M.lookup uuid <$> readRemoteLog
|
||||||
let (repogroup, associateddirectory) = case getStandardGroup groups of
|
let (repogroup, associateddirectory) = case getStandardGroup groups of
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
{- git-annex assistant webapp configurators for making local repositories
|
{- git-annex assistant webapp configurators for making local repositories
|
||||||
-
|
-
|
||||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
|
||||||
-
|
-
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
@ -19,6 +19,7 @@ import qualified Git
|
||||||
import qualified Git.Construct
|
import qualified Git.Construct
|
||||||
import qualified Git.Config
|
import qualified Git.Config
|
||||||
import qualified Git.Command
|
import qualified Git.Command
|
||||||
|
import qualified Git.Branch
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import Config.Files
|
import Config.Files
|
||||||
import Utility.FreeDesktop
|
import Utility.FreeDesktop
|
||||||
|
@ -196,8 +197,7 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
|
||||||
FormSuccess (RepositoryPath p) -> do
|
FormSuccess (RepositoryPath p) -> do
|
||||||
let path = T.unpack p
|
let path = T.unpack p
|
||||||
isnew <- liftIO $ makeRepo path False
|
isnew <- liftIO $ makeRepo path False
|
||||||
u <- liftIO $ initRepo isnew True path Nothing
|
u <- liftIO $ initRepo isnew True path Nothing (Just ClientGroup)
|
||||||
liftH $ liftAnnexOr () $ setStandardGroup u ClientGroup
|
|
||||||
liftIO $ addAutoStartFile path
|
liftIO $ addAutoStartFile path
|
||||||
liftIO $ startAssistant path
|
liftIO $ startAssistant path
|
||||||
askcombine u path
|
askcombine u path
|
||||||
|
@ -211,7 +211,13 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
|
||||||
getCombineRepositoryR :: FilePath -> UUID -> Handler Html
|
getCombineRepositoryR :: FilePath -> UUID -> Handler Html
|
||||||
getCombineRepositoryR newrepopath newrepouuid = do
|
getCombineRepositoryR newrepopath newrepouuid = do
|
||||||
r <- combineRepos newrepopath remotename
|
r <- combineRepos newrepopath remotename
|
||||||
liftAssistant $ syncRemote r
|
liftAssistant $ do
|
||||||
|
-- Manually pull from the remote, to ensure its description
|
||||||
|
-- and group etc are available before editing.
|
||||||
|
currentbranch <- liftAnnex (inRepo Git.Branch.current)
|
||||||
|
void $ manualPull currentbranch [r]
|
||||||
|
-- Sync with the remote to push to it as well.
|
||||||
|
syncRemote r
|
||||||
redirect $ EditRepositoryR $ RepoUUID newrepouuid
|
redirect $ EditRepositoryR $ RepoUUID newrepouuid
|
||||||
where
|
where
|
||||||
remotename = takeFileName newrepopath
|
remotename = takeFileName newrepopath
|
||||||
|
@ -321,7 +327,7 @@ getFinishAddDriveR drive = go
|
||||||
return (u, r)
|
return (u, r)
|
||||||
{- Making a new unencrypted repo, or combining with an existing one. -}
|
{- Making a new unencrypted repo, or combining with an existing one. -}
|
||||||
makeunencrypted = makewith $ \isnew -> (,)
|
makeunencrypted = makewith $ \isnew -> (,)
|
||||||
<$> liftIO (initRepo isnew False dir $ Just remotename)
|
<$> liftIO (initRepo isnew False dir (Just remotename) Nothing)
|
||||||
<*> combineRepos dir remotename
|
<*> combineRepos dir remotename
|
||||||
makewith a = do
|
makewith a = do
|
||||||
liftIO $ createDirectoryIfMissing True dir
|
liftIO $ createDirectoryIfMissing True dir
|
||||||
|
@ -398,10 +404,8 @@ startFullAssistant path repogroup setup = do
|
||||||
webapp <- getYesod
|
webapp <- getYesod
|
||||||
url <- liftIO $ do
|
url <- liftIO $ do
|
||||||
isnew <- makeRepo path False
|
isnew <- makeRepo path False
|
||||||
u <- initRepo isnew True path Nothing
|
void $ initRepo isnew True path Nothing (Just repogroup)
|
||||||
inDir path $ do
|
inDir path $ fromMaybe noop setup
|
||||||
setStandardGroup u repogroup
|
|
||||||
fromMaybe noop setup
|
|
||||||
addAutoStartFile path
|
addAutoStartFile path
|
||||||
setCurrentDirectory path
|
setCurrentDirectory path
|
||||||
fromJust $ postFirstRun webapp
|
fromJust $ postFirstRun webapp
|
||||||
|
@ -432,9 +436,9 @@ inDir dir a = do
|
||||||
Annex.eval state a
|
Annex.eval state a
|
||||||
|
|
||||||
{- Creates a new repository, and returns its UUID. -}
|
{- Creates a new repository, and returns its UUID. -}
|
||||||
initRepo :: Bool -> Bool -> FilePath -> Maybe String -> IO UUID
|
initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID
|
||||||
initRepo True primary_assistant_repo dir desc = inDir dir $ do
|
initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do
|
||||||
initRepo' desc
|
initRepo' desc mgroup
|
||||||
{- Initialize the master branch, so things that expect
|
{- Initialize the master branch, so things that expect
|
||||||
- to have it will work, before any files are added. -}
|
- to have it will work, before any files are added. -}
|
||||||
unlessM (Git.Config.isBare <$> gitRepo) $
|
unlessM (Git.Config.isBare <$> gitRepo) $
|
||||||
|
@ -456,16 +460,18 @@ initRepo True primary_assistant_repo dir desc = inDir dir $ do
|
||||||
[Param "config", Param "gc.auto", Param "0"]
|
[Param "config", Param "gc.auto", Param "0"]
|
||||||
getUUID
|
getUUID
|
||||||
{- Repo already exists, could be a non-git-annex repo though. -}
|
{- Repo already exists, could be a non-git-annex repo though. -}
|
||||||
initRepo False _ dir desc = inDir dir $ do
|
initRepo False _ dir desc mgroup = inDir dir $ do
|
||||||
initRepo' desc
|
initRepo' desc mgroup
|
||||||
getUUID
|
getUUID
|
||||||
|
|
||||||
initRepo' :: Maybe String -> Annex ()
|
initRepo' :: Maybe String -> Maybe StandardGroup -> Annex ()
|
||||||
initRepo' desc = unlessM isInitialized $ do
|
initRepo' desc mgroup = do
|
||||||
|
unlessM isInitialized $ do
|
||||||
initialize desc
|
initialize desc
|
||||||
|
u <- getUUID
|
||||||
|
maybe noop (setStandardGroup u) mgroup
|
||||||
{- Ensure branch gets committed right away so it is
|
{- Ensure branch gets committed right away so it is
|
||||||
- available for merging when a removable drive repo is being
|
- available for merging immediately. -}
|
||||||
- added. -}
|
|
||||||
Annex.Branch.commit "update"
|
Annex.Branch.commit "update"
|
||||||
|
|
||||||
{- Checks if the user can write to a directory.
|
{- Checks if the user can write to a directory.
|
||||||
|
|
|
@ -83,27 +83,15 @@ instance Yesod WebApp where
|
||||||
instance RenderMessage WebApp FormMessage where
|
instance RenderMessage WebApp FormMessage where
|
||||||
renderMessage _ _ = defaultFormMessage
|
renderMessage _ _ = defaultFormMessage
|
||||||
|
|
||||||
{- Runs an Annex action from the webapp.
|
|
||||||
-
|
|
||||||
- When the webapp is run outside a git-annex repository, the fallback
|
|
||||||
- value is returned.
|
|
||||||
-}
|
|
||||||
#if MIN_VERSION_yesod(1,2,0)
|
|
||||||
liftAnnexOr :: forall a. a -> Annex a -> Handler a
|
|
||||||
#else
|
|
||||||
liftAnnexOr :: forall sub a. a -> Annex a -> GHandler sub WebApp a
|
|
||||||
#endif
|
|
||||||
liftAnnexOr fallback a = ifM (noAnnex <$> getYesod)
|
|
||||||
( return fallback
|
|
||||||
, liftAssistant $ liftAnnex a
|
|
||||||
)
|
|
||||||
|
|
||||||
#if MIN_VERSION_yesod(1,2,0)
|
#if MIN_VERSION_yesod(1,2,0)
|
||||||
instance LiftAnnex Handler where
|
instance LiftAnnex Handler where
|
||||||
#else
|
#else
|
||||||
instance LiftAnnex (GHandler sub WebApp) where
|
instance LiftAnnex (GHandler sub WebApp) where
|
||||||
#endif
|
#endif
|
||||||
liftAnnex = liftAnnexOr $ error "internal liftAnnex"
|
liftAnnex a = ifM (noAnnex <$> getYesod)
|
||||||
|
( error "internal liftAnnex"
|
||||||
|
, liftAssistant $ liftAnnex a
|
||||||
|
)
|
||||||
|
|
||||||
#if MIN_VERSION_yesod(1,2,0)
|
#if MIN_VERSION_yesod(1,2,0)
|
||||||
instance LiftAnnex (WidgetT WebApp IO) where
|
instance LiftAnnex (WidgetT WebApp IO) where
|
||||||
|
|
8
debian/changelog
vendored
8
debian/changelog
vendored
|
@ -1,3 +1,11 @@
|
||||||
|
git-annex (5.20140530) UNRELEASED; urgency=medium
|
||||||
|
|
||||||
|
* webapp: When adding a new local repository, fix bug that caused its
|
||||||
|
group and preferred content to be set in the current repository,
|
||||||
|
even when not combining.
|
||||||
|
|
||||||
|
-- Joey Hess <joeyh@debian.org> Thu, 29 May 2014 20:10:59 -0400
|
||||||
|
|
||||||
git-annex (5.20140529) unstable; urgency=medium
|
git-annex (5.20140529) unstable; urgency=medium
|
||||||
|
|
||||||
* Fix encoding of data written to git-annex branch. Avoid truncating
|
* Fix encoding of data written to git-annex branch. Avoid truncating
|
||||||
|
|
|
@ -431,3 +431,5 @@ wanted f3b332fd-4b7a-4a5b-b077-8f13d3d9a407 = standard
|
||||||
# (for trh@r9-y3pll:~/bar)
|
# (for trh@r9-y3pll:~/bar)
|
||||||
#schedule 357eaef4-af1b-491a-a003-01c2d583056e =
|
#schedule 357eaef4-af1b-491a-a003-01c2d583056e =
|
||||||
</code></pre>
|
</code></pre>
|
||||||
|
|
||||||
|
> [[fixed|done]] --[[Joey]]
|
||||||
|
|
Loading…
Reference in a new issue