blob: 1d887792ad90c3de20031b79b0fdc83c373f612f (
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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
{- git-annex core functions -}
module Core where
import Maybe
import System.IO
import System.Directory
import Control.Monad.State (liftIO)
import System.Path
import Data.String.Utils
import Types
import Locations
import LocationLog
import UUID
import qualified GitRepo as Git
import qualified Annex
import Utility
{- Sets up a git repo for git-annex. -}
startup :: Annex ()
startup = do
g <- Annex.gitRepo
liftIO $ gitAttributes g
prepUUID
{- When git-annex is done, it runs this. -}
shutdown :: Annex ()
shutdown = do
g <- Annex.gitRepo
liftIO $ Git.run g ["add", gitStateDir g]
-- clean up any files left in the temp directory
let tmp = annexTmpLocation g
exists <- liftIO $ doesDirectoryExist tmp
if (exists)
then liftIO $ removeDirectoryRecursive $ tmp
else return ()
{- 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
if (all (/= attrLine) (lines content))
then do
appendFile attributes $ attrLine ++ "\n"
commit
else return ()
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]
{- 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 g key
{- Updates the LocationLog when a key's presence changes. -}
logStatus :: Key -> LogStatus -> Annex ()
logStatus key status = do
g <- Annex.gitRepo
u <- getUUID g
liftIO $ logChange g key u status
{- 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
return False
{- Output logging -}
showStart :: String -> String -> Annex ()
showStart command file = do
liftIO $ putStr $ command ++ " " ++ file ++ " "
liftIO $ hFlush stdout
showNote :: String -> Annex ()
showNote s = do
liftIO $ putStr $ "(" ++ s ++ ") "
liftIO $ hFlush stdout
showLongNote :: String -> Annex ()
showLongNote s = do
liftIO $ putStr $ "\n" ++ (indent s)
where
indent s = join "\n" $ map (\l -> " " ++ l) $ lines s
showEndOk :: Annex ()
showEndOk = do
liftIO $ putStrLn "ok"
showEndFail :: Annex ()
showEndFail = do
liftIO $ putStrLn "\nfailed"
|
