81 lines
1.9 KiB
Haskell
81 lines
1.9 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 Common.Annex
|
||
|
|
import Command
|
||
|
|
import qualified Git
|
||
|
|
import qualified Git.Command
|
||
|
|
import qualified Git.LsFiles
|
||
|
|
import Config
|
||
|
|
import Annex.Direct
|
||
|
|
import Annex.Content
|
||
|
|
import Annex.CatFile
|
||
|
|
|
||
|
|
def :: [Command]
|
||
|
|
def = [command "indirect" paramNothing seek "switch repository to indirect mode"]
|
||
|
|
|
||
|
|
seek :: [CommandSeek]
|
||
|
|
seek = [withNothing start]
|
||
|
|
|
||
|
|
start :: CommandStart
|
||
|
|
start = notBareRepo $
|
||
|
|
ifM isDirect
|
||
|
|
( next perform, stop )
|
||
|
|
|
||
|
|
perform :: CommandPerform
|
||
|
|
perform = do
|
||
|
|
showStart "commit" ""
|
||
|
|
whenM (stageDirect) $ do
|
||
|
|
showOutput
|
||
|
|
void $ inRepo $ Git.Command.runBool "commit"
|
||
|
|
[Param "-m", Param "commit before switching to indirect mode"]
|
||
|
|
|
||
|
|
-- 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.stagedDetails [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 (_, Nothing) = noop
|
||
|
|
go (f, Just sha) = do
|
||
|
|
r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f
|
||
|
|
case r of
|
||
|
|
Just s
|
||
|
|
| isSymbolicLink s -> void $ flip whenAnnexed f $
|
||
|
|
\_ (k, _) -> do
|
||
|
|
cleandirect k
|
||
|
|
return Nothing
|
||
|
|
| otherwise ->
|
||
|
|
maybe noop (fromdirect f)
|
||
|
|
=<< catKey sha
|
||
|
|
_ -> noop
|
||
|
|
|
||
|
|
fromdirect f k = do
|
||
|
|
showStart "indirect" f
|
||
|
|
cleandirect k -- clean before content directory gets frozen
|
||
|
|
whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
|
||
|
|
moveAnnex k f
|
||
|
|
l <- calcGitLink f k
|
||
|
|
liftIO $ createSymbolicLink l f
|
||
|
|
showEndOk
|
||
|
|
|
||
|
|
cleandirect k = do
|
||
|
|
liftIO . nukeFile =<< inRepo (gitAnnexCache k)
|
||
|
|
liftIO . nukeFile =<< inRepo (gitAnnexMapping k)
|
||
|
|
|
||
|
|
cleanup :: CommandCleanup
|
||
|
|
cleanup = return True
|