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
|
{- 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
import System.Directory
import Control.Monad.State (liftIO)
import System.Path
import Data.String.Utils
import Monad (when, unless)
import Types
import Locations
import LocationLog
import UUID
import qualified GitRepo as Git
import qualified GitQueue
import qualified Annex
import Utility
{- Sets up a git repo for git-annex. -}
startup :: Annex Bool
startup = do
prepUUID
return True
{- When git-annex is done, it runs this. -}
shutdown :: Annex Bool
shutdown = do
g <- Annex.gitRepo
-- Runs all queued git commands.
q <- Annex.queueGet
unless (q == GitQueue.empty) $ do
verbose $ liftIO $ putStrLn "Recording state in git..."
liftIO $ GitQueue.run g q
-- clean up any files left in the temp directory, but leave
-- the tmp directory itself
let tmp = annexTmpLocation g
exists <- liftIO $ doesDirectoryExist tmp
when (exists) $ liftIO $ removeDirectoryRecursive $ tmp
liftIO $ createDirectoryIfMissing True tmp
return True
{- configure git to use union merge driver on state files, if it is not
- already -}
gitAttributes :: Git.Repo -> IO ()
gitAttributes repo = do
exists <- doesFileExist attributes
if (not exists)
then do
writeFile attributes $ attrLine ++ "\n"
commit
else do
content <- readFile attributes
when (all (/= attrLine) (lines content)) $ do
appendFile attributes $ attrLine ++ "\n"
commit
where
attrLine = stateLoc ++ "*.log merge=union"
attributes = Git.attributes repo
commit = do
Git.run repo ["add", attributes]
Git.run repo ["commit", "-m", "git-annex setup",
attributes]
{- set up a git pre-commit hook, if one is not already present -}
gitPreCommitHook :: Git.Repo -> IO ()
gitPreCommitHook repo = do
let hook = (Git.workTree repo) ++ "/" ++ (Git.gitDir repo) ++
"/hooks/pre-commit"
exists <- doesFileExist hook
if (exists)
then putStrLn $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
else do
writeFile hook $ "#!/bin/sh\n" ++
"# automatically configured by git-annex\n" ++
"git annex pre-commit .\n"
p <- getPermissions hook
setPermissions hook $ p {executable = True}
{- Checks if a given key is currently present in the annexLocation.
-
- This can be run against a remote repository to check the key there. -}
inAnnex :: Key -> Annex Bool
inAnnex key = do
g <- Annex.gitRepo
if (not $ Git.repoIsUrl g)
then liftIO $ doesFileExist $ annexLocation g key
else do
showNote ("checking " ++ Git.repoDescribe g ++ "...")
liftIO $ boolSystem "ssh" [Git.urlHost g,
"test -e " ++
(shellEscape $ 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 dest = annexLocation g key
let tmp = (annexTmpLocation g) ++ (keyFile key)
liftIO $ createDirectoryIfMissing True (parentDir tmp)
success <- action tmp
if (success)
then do
liftIO $ renameFile tmp dest
logStatus key ValuePresent
return True
else do
-- the tmp file is left behind, in case caller wants
-- to resume its transfer
return False
{- Output logging -}
verbose :: Annex () -> Annex ()
verbose a = do
q <- Annex.flagIsSet "quiet"
unless q a
showStart :: String -> String -> Annex ()
showStart command file = verbose $ do
liftIO $ putStr $ command ++ " " ++ file ++ " "
liftIO $ hFlush stdout
showNote :: String -> Annex ()
showNote s = verbose $ do
liftIO $ putStr $ "(" ++ s ++ ") "
liftIO $ hFlush stdout
showProgress :: Annex ()
showProgress = verbose $ liftIO $ putStr $ "\n"
showLongNote :: String -> Annex ()
showLongNote s = verbose $ do
liftIO $ putStr $ "\n" ++ indented
where
indented = join "\n" $ map (\l -> " " ++ l) $ lines s
showEndOk :: Annex ()
showEndOk = verbose $ do
liftIO $ putStrLn "ok"
showEndFail :: Annex ()
showEndFail = verbose $ do
liftIO $ putStrLn "\nfailed"
{- Exception pretty-printing. -}
showErr :: (Show a) => a -> Annex ()
showErr e = warning $ show e
warning :: String -> Annex ()
warning s = liftIO $ hPutStrLn stderr $ "git-annex: " ++ s
|
