summaryrefslogtreecommitdiff
path: root/UUID.hs
blob: 8cdee43de66f457e3c7813634508c329405b0a10 (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
{- git-annex uuids
 -
 - Each git repository used by git-annex has an annex.uuid setting that
 - uniquely identifies that repository.
 -
 -}

module UUID (
	UUID,
	getUUID,
	prepUUID,
	genUUID,
	reposByUUID,
	prettyPrintUUIDs,
	describeUUID
) where

import Control.Monad.State
import Maybe
import List
import System.Cmd.Utils
import System.IO
import qualified Data.Map as M
import qualified GitRepo as Git
import Types
import Locations
import qualified Annex

type UUID = 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 "uuid" ["-m"] $ \h -> hGetLine h

{- Looks up a repo's UUID. May return "" if none is known.
 -
 - UUIDs of remotes are cached in git config, using keys named
 - remote.<name>.annex-uuid
 -
 - -}
getUUID :: Git.Repo -> Annex UUID
getUUID r = do
	g <- Annex.gitRepo

	let c = cached r g
	let u = uncached r
			
	if (c /= u && u /= "")
		then do
			updatecache g r u
			return u
		else return c
	where
		uncached r = Git.configGet r "annex.uuid" ""
		cached r g = Git.configGet g (cachekey r) ""
		updatecache g r u = do
			if (g /= r)
				then setConfig (cachekey r) u
				else return ()
		cachekey r = "remote." ++ (Git.repoRemoteName r) ++ ".annex-uuid"

{- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: Annex ()
prepUUID = do
	g <- Annex.gitRepo
	u <- getUUID g
	if ("" == u)
		then do
			uuid <- liftIO $ genUUID
			setConfig configkey uuid
		else return ()

{- Changes a git config setting in both internal state and .git/config -}
setConfig :: String -> String -> Annex ()
setConfig key value = do
	g <- Annex.gitRepo
	liftIO $ Git.run g ["config", key, value]
	-- re-read git config and update the repo's state
	g' <- liftIO $ Git.configRead g
	Annex.gitRepoChange g'
	return ()

{- Filters a list of repos to ones that have listed UUIDs. -}
reposByUUID :: [Git.Repo] -> [UUID] -> Annex [Git.Repo]
reposByUUID repos uuids = do
	filterM match repos
	where
		match r = do
			u <- getUUID r
			return $ isJust $ elemIndex u uuids

{- Pretty-prints a list of UUIDs -}
prettyPrintUUIDs :: [UUID] -> Annex String
prettyPrintUUIDs uuids = do
	m <- uuidMap
	return $ unwords $ map (\u -> "  "++(prettify m u)++"\n") uuids
	where
		prettify m u =
			if (0 < (length $ findlog m u))
				then u ++ "  -- " ++ (findlog m u)
				else u
		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
	log <- uuidLog
	liftIO $ writeFile log $ 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
	log <- uuidLog
	s <- liftIO $ catch (readFile log) (\error -> return "")
	return $ M.fromList $ map (\l -> pair l) $ lines s
	where
		pair l =
			if (1 < (length $ words l))
				then ((words l) !! 0, unwords $ drop 1 $ words l)
				else ("", "")

{- Filename of uuid.log. -}
uuidLog :: Annex String
uuidLog = do
	g <- Annex.gitRepo
	return $ (gitStateDir g) ++ "uuid.log"