blob: 0da10c5795549962c85741a82d922b14b07235c5 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
{- git-annex command
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.Indirect where
import System.PosixCompat.Files
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
|
