e880d0d22c
Only fsck and reinject and the test suite used the Backend, and they can look it up as needed from the Key. This simplifies the code and also speeds it up. There is a small behavior change here. Before, all commands would warn when acting on an annexed file with an unknown backend. Now, only fsck and reinject show that warning.
110 lines
2.7 KiB
Haskell
110 lines
2.7 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.Indirect where
|
|
|
|
import Control.Exception.Extensible
|
|
|
|
import Common.Annex
|
|
import Command
|
|
import qualified Git
|
|
import qualified Git.Command
|
|
import qualified Git.LsFiles
|
|
import Git.FileMode
|
|
import Config
|
|
import qualified Annex
|
|
import Annex.Direct
|
|
import Annex.Content
|
|
import Annex.Content.Direct
|
|
import Annex.CatFile
|
|
import Annex.Exception
|
|
import Annex.Init
|
|
import qualified Command.Add
|
|
|
|
def :: [Command]
|
|
def = [notBareRepo $ noDaemonRunning $
|
|
command "indirect" paramNothing seek
|
|
SectionSetup "switch repository to indirect mode"]
|
|
|
|
seek :: CommandSeek
|
|
seek = withNothing start
|
|
|
|
start :: CommandStart
|
|
start = ifM isDirect
|
|
( do
|
|
unlessM (coreSymlinks <$> Annex.getGitConfig) $
|
|
error "Git is configured to not use symlinks, so you must use direct mode."
|
|
whenM probeCrippledFileSystem $
|
|
error "This repository seems to be on a crippled filesystem, you must use direct mode."
|
|
next perform
|
|
, stop
|
|
)
|
|
|
|
perform :: CommandPerform
|
|
perform = do
|
|
showStart "commit" ""
|
|
whenM stageDirect $ do
|
|
showOutput
|
|
void $ inRepo $ Git.Command.runBool
|
|
[ Param "commit"
|
|
, Param "-m"
|
|
, Param "commit before switching to indirect mode"
|
|
]
|
|
showEndOk
|
|
|
|
-- Note that we set indirect mode early, so that we can use
|
|
-- moveAnnex in indirect mode.
|
|
setDirect False
|
|
|
|
top <- fromRepo Git.repoPath
|
|
(l, clean) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
|
|
forM_ l go
|
|
void $ liftIO clean
|
|
next cleanup
|
|
where
|
|
{- Walk tree from top and move all present direct mode files into
|
|
- the annex, replacing with symlinks. Also delete direct mode
|
|
- caches and mappings. -}
|
|
go (f, Just sha, Just mode) | isSymLink mode = do
|
|
r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f
|
|
case r of
|
|
Just s
|
|
| isSymbolicLink s -> void $ flip whenAnnexed f $
|
|
\_ k -> do
|
|
removeInodeCache k
|
|
removeAssociatedFiles k
|
|
return Nothing
|
|
| otherwise ->
|
|
maybe noop (fromdirect f)
|
|
=<< catKey sha mode
|
|
_ -> noop
|
|
go _ = noop
|
|
|
|
fromdirect f k = do
|
|
showStart "indirect" f
|
|
removeInodeCache k
|
|
removeAssociatedFiles k
|
|
whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
|
|
v <-tryAnnexIO (moveAnnex k f)
|
|
case v of
|
|
Right _ -> do
|
|
l <- inRepo $ gitAnnexLink f k
|
|
liftIO $ createSymbolicLink l f
|
|
Left e -> catchAnnex (Command.Add.undo f k e)
|
|
warnlocked
|
|
showEndOk
|
|
|
|
warnlocked :: SomeException -> Annex ()
|
|
warnlocked e = do
|
|
warning $ show e
|
|
warning "leaving this file as-is; correct this problem and run git annex add on it"
|
|
|
|
cleanup :: CommandCleanup
|
|
cleanup = do
|
|
showStart "indirect" ""
|
|
showEndOk
|
|
return True
|