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
|
{- git-annex uuids
-
- Each git repository used by git-annex has an annex.uuid setting that
- uniquely identifies that repository.
-
- UUIDs of remotes are cached in git config, using keys named
- remote.<name>.annex-uuid
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module UUID (
UUID,
getUUID,
getUncachedUUID,
prepUUID,
genUUID,
prettyPrintUUIDs,
describeUUID,
uuidLog,
uuidMap
) where
import Control.Monad.State
import System.Cmd.Utils
import System.IO
import qualified Data.Map as M
import Data.Maybe
import qualified GitRepo as Git
import Types
import Locations
import qualified Annex
import Utility
import qualified SysConfig
import Config
type UUID = String
configkey :: String
configkey = "annex.uuid"
{- Generates a UUID. There is a library for this, but it's not packaged,
- so use the command line tool. -}
genUUID :: IO UUID
genUUID = liftIO $ pOpen ReadFromPipe command params $ \h -> hGetLine h
where
command = SysConfig.uuid
params = if (command == "uuid")
-- request a random uuid be generated
then ["-m"]
-- uuidgen generates random uuid by default
else []
{- Looks up a repo's UUID. May return "" if none is known.
-}
getUUID :: Git.Repo -> Annex UUID
getUUID r = do
g <- Annex.gitRepo
let c = cached g
let u = getUncachedUUID r
if c /= u && u /= ""
then do
updatecache g u
return u
else return c
where
cached g = Git.configGet g cachekey ""
updatecache g u = when (g /= r) $ setConfig cachekey u
cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid"
getUncachedUUID :: Git.Repo -> UUID
getUncachedUUID r = Git.configGet r configkey ""
{- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: Annex ()
prepUUID = do
g <- Annex.gitRepo
u <- getUUID g
when ("" == u) $ do
uuid <- liftIO $ genUUID
setConfig configkey uuid
{- Pretty-prints a list of UUIDs -}
prettyPrintUUIDs :: [UUID] -> Annex String
prettyPrintUUIDs uuids = do
g <- Annex.gitRepo
here <- getUUID g
m <- uuidMap
return $ unwords $ map (\u -> "\t" ++ prettify m u here ++ "\n") uuids
where
prettify m u here = base ++ ishere
where
base = if not $ null $ findlog m u
then u ++ " -- " ++ findlog m u
else u
ishere = if here == u then " <-- here" else ""
findlog m u = M.findWithDefault "" u m
{- Records a description for a uuid in the uuidLog. -}
describeUUID :: UUID -> String -> Annex ()
describeUUID uuid desc = do
m <- uuidMap
let m' = M.insert uuid desc m
logfile <- uuidLog
liftIO $ safeWriteFile logfile (serialize m')
where
serialize m = unlines $ map (\(u, d) -> u++" "++d) $ M.toList m
{- Read and parse the uuidLog into a Map -}
uuidMap :: Annex (M.Map UUID String)
uuidMap = do
logfile <- uuidLog
s <- liftIO $ catch (readFile logfile) ignoreerror
return $ M.fromList $ map pair $ lines s
where
pair l =
if 1 < length (words l)
then (head $ words l, unwords $ drop 1 $ words l)
else ("", "")
ignoreerror _ = return ""
{- Filename of uuid.log. -}
uuidLog :: Annex FilePath
uuidLog = do
g <- Annex.gitRepo
return $ gitStateDir g ++ "uuid.log"
|
