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
|
{- git-annex location log
-
- git-annex keeps track of on which repository it last saw a file's content.
- This can be useful when using it for archiving with offline storage.
- When you indicate you --want a file, git-annex will tell you which
- repositories have the file's content.
-
- Location tracking information is stored in `.git-annex/filename.log`.
- Repositories record their name and the date when they --get or --drop
- a file's content. (Git is configured to use a union merge for this file,
- so the lines may be in arbitrary order, but it will never conflict.)
-
- A line of the log will look like: "date N reponame"
- Where N=1 when the repo has the file, and 0 otherwise.
-
-}
module LocationLog where
import Data.DateTime
import System.IO
import GitRepo
import Utility
data LogStatus = FilePresent | FileMissing | Undefined
deriving (Eq)
instance Show LogStatus where
show FilePresent = "1"
show FileMissing = "0"
show Undefined = "undefined"
instance Read LogStatus where
readsPrec _ "1" = [(FilePresent, "")]
readsPrec _ "0" = [(FileMissing, "")]
readsPrec _ _ = [(Undefined, "")]
data LogLine = LogLine {
date :: DateTime,
status :: LogStatus,
repo :: String
} deriving (Eq)
instance Show LogLine where
show (LogLine date status repo) = unwords
[(show (toSeconds date)), (show status), repo]
instance Read LogLine where
-- This parser is robust in that even unparsable log lines are
-- read without an exception being thrown.
-- Such lines have a status of Undefined.
readsPrec _ string = if (length w >= 3)
then [((LogLine date status repo), "")]
else [((LogLine (fromSeconds 0) Undefined ""), "")]
where
date = fromSeconds $ read $ w !! 0
status = read $ w !! 1
repo = unwords $ rest w
w = words string
rest (_:_:l) = l
{- Reads a log file -}
readLog :: String -> IO [LogLine]
readLog file = do
h <- openLocked file ReadMode
s <- hGetContents h
-- hClose handle' -- TODO disabled due to lazy IO issue
-- filter out any unparsable lines
return $ filter (\l -> (status l) /= Undefined ) $ map read $ lines s
{- Adds a LogLine to a log file -}
writeLog :: String -> LogLine -> IO ()
writeLog file line = do
h <- openLocked file AppendMode
hPutStrLn h $ show line
hClose h
{- Generates a new LogLine with the current date. -}
logNow :: LogStatus -> String -> IO LogLine
logNow status repo = do
now <- getCurrentTime
return $ LogLine now status repo
{- Returns the filename of the log file for a given annexed file. -}
logFile :: String -> IO String
logFile annexedFile = do
repo <- repoTop
return $ repo ++ "/.git-annex/" ++
(gitRelative repo annexedFile) ++ ".log"
{- Returns a list of repositories that, according to the log, have
- the content of a file -}
fileLocations :: String -> IO [String]
fileLocations file = do
log <- logFile file
lines <- readLog log
return $ map repo (filterPresent lines)
{- Filters the list of LogLines to find repositories where the file
- is (or should still be) present. -}
filterPresent :: [LogLine] -> [LogLine]
filterPresent lines =
|
