summaryrefslogtreecommitdiff
path: root/Upgrade/V1.hs
blob: bc50b857c6243d3021d937d51d690fa88aa204f3 (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
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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
{- git-annex v1 -> v2 upgrade support
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Upgrade.V1 where

import System.IO.Error (try)
import System.Posix.Types
import Data.Char

import AnnexCommon
import Types.Key
import Content
import PresenceLog
import qualified AnnexQueue
import qualified Git
import qualified Git.LsFiles as LsFiles
import Backend
import Version
import Utility.FileMode
import qualified Upgrade.V2

-- v2 adds hashing of filenames of content and location log files.
-- Key information is encoded in filenames differently, so
-- both content and location log files move around, and symlinks
-- to content need to be changed.
-- 
-- When upgrading a v1 key to v2, file size metadata ought to be
-- added to the key (unless it is a WORM key, which encoded
-- mtime:size in v1). This can only be done when the file content
-- is present. Since upgrades need to happen consistently, 
-- (so that two repos get changed the same way by the upgrade, and
-- will merge), that metadata cannot be added on upgrade.
--
-- Note that file size metadata
-- will only be used for detecting situations where git-annex
-- would run out of disk space, so if some keys don't have it,
-- the impact is minor. At least initially. It could be used in the
-- future by smart auto-repo balancing code, etc.
--
-- Anyway, since v2 plans ahead for other metadata being included
-- in keys, there should probably be a way to update a key.
-- Something similar to the migrate subcommand could be used,
-- and users could then run that at their leisure.

upgrade :: Annex Bool
upgrade = do
	showAction "v1 to v2"

	g <- gitRepo
	if Git.repoIsLocalBare g
		then do
			moveContent
			setVersion
		else do
			moveContent
			updateSymlinks
			moveLocationLogs
	
			AnnexQueue.flush True
			setVersion
	
	Upgrade.V2.upgrade

moveContent :: Annex ()
moveContent = do
	showAction "moving content"
	files <- getKeyFilesPresent1
	forM_ files move
	where
		move f = do
			let k = fileKey1 (takeFileName f)
			let d = parentDir f
			liftIO $ allowWrite d
			liftIO $ allowWrite f
			moveAnnex k f
			liftIO $ removeDirectory d

updateSymlinks :: Annex ()
updateSymlinks = do
	showAction "updating symlinks"
	g <- gitRepo
	files <- liftIO $ LsFiles.inRepo g [Git.workTree g]
	forM_ files fixlink
	where
		fixlink f = do
			r <- lookupFile1 f
			case r of
				Nothing -> return ()
				Just (k, _) -> do
					link <- calcGitLink f k
					liftIO $ removeFile f
					liftIO $ createSymbolicLink link f
					AnnexQueue.add "add" [Param "--"] [f]

moveLocationLogs :: Annex ()
moveLocationLogs = do
	showAction "moving location logs"
	logkeys <- oldlocationlogs
	forM_ logkeys move
		where
			oldlocationlogs = do
				g <- gitRepo
				let dir = Upgrade.V2.gitStateDir g
				exists <- liftIO $ doesDirectoryExist dir
				if exists
					then do
						contents <- liftIO $ getDirectoryContents dir
						return $ mapMaybe oldlog2key contents
					else return []
			move (l, k) = do
				g <- gitRepo
				let dest = logFile2 g k
				let dir = Upgrade.V2.gitStateDir g
				let f = dir </> l
				liftIO $ createDirectoryIfMissing True (parentDir dest)
				-- could just git mv, but this way deals with
				-- log files that are not checked into git,
				-- as well as merging with already upgraded
				-- logs that have been pulled from elsewhere
				old <- liftIO $ readLog1 f
				new <- liftIO $ readLog1 dest
				liftIO $ writeLog1 dest (old++new)
				AnnexQueue.add "add" [Param "--"] [dest]
				AnnexQueue.add "add" [Param "--"] [f]
				AnnexQueue.add "rm" [Param "--quiet", Param "-f", Param "--"] [f]
		
oldlog2key :: FilePath -> Maybe (FilePath, Key)
oldlog2key l = 
	let len = length l - 4 in
		if drop len l == ".log"
		then let k = readKey1 (take len l) in
			if null (keyName k) || null (keyBackendName k)
			then Nothing
			else Just (l, k)
		else Nothing

-- WORM backend keys: "WORM:mtime:size:filename"
-- all the rest: "backend:key"
--
-- If the file looks like "WORM:XXX-...", then it was created by mixing
-- v2 and v1; that infelicity is worked around by treating the value
-- as the v2 key that it is.
readKey1 :: String -> Key
readKey1 v = 
	if mixup
		then fromJust $ readKey $ join ":" $ tail bits
		else Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t }
	where
		bits = split ":" v
		b = head bits
		n = join ":" $ drop (if wormy then 3 else 1) bits
		t = if wormy
			then Just (read (bits !! 1) :: EpochTime)
			else Nothing
		s = if wormy
			then Just (read (bits !! 2) :: Integer)
			else Nothing
		wormy = head bits == "WORM"
		mixup = wormy && isUpper (head $ bits !! 1)

showKey1 :: Key -> String
showKey1 Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } =
	join ":" $ filter (not . null) [b, showifhere t, showifhere s, n]
		where
			showifhere Nothing = ""
			showifhere (Just v) = show v

keyFile1 :: Key -> FilePath
keyFile1 key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a"  $ showKey1 key

fileKey1 :: FilePath -> Key
fileKey1 file = readKey1 $
	replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file

writeLog1 :: FilePath -> [LogLine] -> IO ()
writeLog1 file ls = viaTmp writeFile file (unlines $ map show ls)

readLog1 :: FilePath -> IO [LogLine]
readLog1 file = catch (parseLog <$> readFileStrict file) (const $ return [])

lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex))
lookupFile1 file = do
	tl <- liftIO $ try getsymlink
	case tl of
		Left _ -> return Nothing
		Right l -> makekey l
	where
		getsymlink = takeFileName <$> readSymbolicLink file
		makekey l = case maybeLookupBackendName bname of
			Nothing -> do
				unless (null kname || null bname ||
				        not (isLinkToAnnex l)) $
					warning skip
				return Nothing
			Just backend -> return $ Just (k, backend)
			where
				k = fileKey1 l
				bname = keyBackendName k
				kname = keyName k
				skip = "skipping " ++ file ++ 
					" (unknown backend " ++ bname ++ ")"

getKeyFilesPresent1 :: Annex [FilePath]
getKeyFilesPresent1  = do
	g <- gitRepo
	getKeyFilesPresent1' $ gitAnnexObjectDir g
getKeyFilesPresent1' :: FilePath -> Annex [FilePath]
getKeyFilesPresent1' dir = do
	exists <- liftIO $ doesDirectoryExist dir
	if not exists
		then return []
		else do
			dirs <- liftIO $ getDirectoryContents dir
			let files = map (\d -> dir ++ "/" ++ d ++ "/" ++ takeFileName d) dirs
			liftIO $ filterM present files
	where
		present f = do
			result <- try $ getFileStatus f
			case result of
				Right s -> return $ isRegularFile s
				Left _ -> return False

logFile1 :: Git.Repo -> Key -> String
logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"

logFile2 :: Git.Repo -> Key -> String
logFile2 = logFile' hashDirLower

logFile' :: (Key -> FilePath) -> Git.Repo -> Key -> String
logFile' hasher repo key =
	gitStateDir repo ++ hasher key ++ keyFile key ++ ".log"

stateDir :: FilePath
stateDir = addTrailingPathSeparator ".git-annex"

gitStateDir :: Git.Repo -> FilePath
gitStateDir repo = addTrailingPathSeparator $ Git.workTree repo </> stateDir