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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
{- git-annex core functions
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Core where
import System.IO.Error (try)
import System.Directory
import Control.Monad.State (liftIO)
import System.Path
import Control.Monad (when, unless, filterM)
import System.Posix.Files
import Data.Maybe
import System.FilePath
import Types
import Locations
import LocationLog
import UUID
import qualified GitRepo as Git
import qualified GitQueue
import qualified Annex
import qualified Backend
import Utility
import Messages
{- Runs a list of Annex actions. Catches IO errors and continues
- (but explicitly thrown errors terminate the whole command).
- Propigates an overall error status at the end.
-}
tryRun :: AnnexState -> [Annex Bool] -> IO ()
tryRun state actions = tryRun' state 0 actions
tryRun' :: AnnexState -> Integer -> [Annex Bool] -> IO ()
tryRun' state errnum (a:as) = do
result <- try $ Annex.run state a
case result of
Left err -> do
Annex.eval state $ showErr err
tryRun' state (errnum + 1) as
Right (True,state') -> tryRun' state' errnum as
Right (False,state') -> tryRun' state' (errnum + 1) as
tryRun' _ errnum [] =
when (errnum > 0) $ error $ show errnum ++ " failed"
{- Actions to perform each time ran. -}
startup :: Annex Bool
startup = do
prepUUID
return True
{- When git-annex is done, it runs this. -}
shutdown :: Annex Bool
shutdown = do
q <- Annex.queueGet
unless (q == GitQueue.empty) $ do
showSideAction "Recording state in git..."
Annex.queueRun
-- clean up any files left in the temp directory, but leave
-- the tmp directory itself
g <- Annex.gitRepo
let tmp = annexTmpLocation g
exists <- liftIO $ doesDirectoryExist tmp
when exists $ liftIO $ removeDirectoryRecursive tmp
liftIO $ createDirectoryIfMissing True tmp
return True
{- Checks if a given key is currently present in the annexLocation. -}
inAnnex :: Key -> Annex Bool
inAnnex key = do
g <- Annex.gitRepo
when (Git.repoIsUrl g) $ error "inAnnex cannot check remote repo"
liftIO $ doesFileExist $ annexLocation g key
{- Calculates the relative path to use to link a file to a key. -}
calcGitLink :: FilePath -> Key -> Annex FilePath
calcGitLink file key = do
g <- Annex.gitRepo
cwd <- liftIO $ getCurrentDirectory
let absfile = case absNormPath cwd file of
Just f -> f
Nothing -> error $ "unable to normalize " ++ file
return $ relPathDirToDir (parentDir absfile) (Git.workTree g) ++
annexLocationRelative key
{- Updates the LocationLog when a key's presence changes. -}
logStatus :: Key -> LogStatus -> Annex ()
logStatus key status = do
g <- Annex.gitRepo
u <- getUUID g
logfile <- liftIO $ logChange g key u status
Annex.queue "add" ["--"] logfile
{- Runs an action, passing it a temporary filename to download,
- and if the action succeeds, moves the temp file into
- the annex as a key's content. -}
getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmp key action = do
g <- Annex.gitRepo
let tmp = annexTmpLocation g ++ keyFile key
liftIO $ createDirectoryIfMissing True (parentDir tmp)
success <- action tmp
if success
then do
moveAnnex key tmp
logStatus key ValuePresent
return True
else do
-- the tmp file is left behind, in case caller wants
-- to resume its transfer
return False
{- Removes the write bits from a file. -}
preventWrite :: FilePath -> IO ()
preventWrite f = unsetFileMode f writebits
where
writebits = foldl unionFileModes ownerWriteMode
[groupWriteMode, otherWriteMode]
{- Turns a file's write bit back on. -}
allowWrite :: FilePath -> IO ()
allowWrite f = do
s <- getFileStatus f
setFileMode f $ fileMode s `unionFileModes` ownerWriteMode
{- Moves a file into .git/annex/objects/ -}
moveAnnex :: Key -> FilePath -> Annex ()
moveAnnex key src = do
g <- Annex.gitRepo
let dest = annexLocation g key
let dir = parentDir dest
liftIO $ do
createDirectoryIfMissing True dir
allowWrite dir -- in case the directory already exists
renameFile src dest
preventWrite dest
preventWrite dir
{- Removes a key's file from .git/annex/objects/ -}
removeAnnex :: Key -> Annex ()
removeAnnex key = do
g <- Annex.gitRepo
let file = annexLocation g key
let dir = parentDir file
liftIO $ do
allowWrite dir
removeFile file
removeDirectory dir
{- Moves a key's file out of .git/annex/objects/ -}
fromAnnex :: Key -> FilePath -> Annex ()
fromAnnex key dest = do
g <- Annex.gitRepo
let file = annexLocation g key
let dir = parentDir file
liftIO $ do
allowWrite dir
allowWrite file
renameFile file dest
removeDirectory dir
{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
- returns the file it was moved to. -}
moveBad :: Key -> Annex FilePath
moveBad key = do
g <- Annex.gitRepo
let src = annexLocation g key
let dest = annexBadLocation g ++ takeFileName src
liftIO $ createDirectoryIfMissing True dest
liftIO $ renameFile src dest
liftIO $ removeDirectory (parentDir src)
return dest
{- List of keys whose content exists in .git/annex/objects/ -}
getKeysPresent :: Annex [Key]
getKeysPresent = do
g <- Annex.gitRepo
getKeysPresent' $ annexObjectDir g
getKeysPresent' :: FilePath -> Annex [Key]
getKeysPresent' dir = do
contents <- liftIO $ getDirectoryContents dir
files <- liftIO $ filterM present contents
return $ map fileKey files
where
present d = do
s <- getFileStatus $ dir ++ "/" ++ d ++ "/"
++ takeFileName d
return $ isRegularFile s
{- List of keys referenced by symlinks in the git repo. -}
getKeysReferenced :: Annex [Key]
getKeysReferenced = do
g <- Annex.gitRepo
files <- liftIO $ Git.inRepo g $ Git.workTree g
keypairs <- mapM Backend.lookupFile files
return $ map fst $ catMaybes keypairs
|
