1{- git-annex v1 -> v2 upgrade support
2 -
3 - Copyright 2011 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8module Upgrade.V1 where
9
10import System.Posix.Types
11import Data.Char
12import Data.Default
13import Data.ByteString.Builder
14import qualified Data.ByteString as S
15import qualified Data.ByteString.Lazy as L
16import qualified System.FilePath.ByteString as P
17
18import Annex.Common
19import Annex.Content
20import Annex.Link
21import Annex.Perms
22import Types.Key
23import Logs.Presence
24import qualified Annex.Queue
25import qualified Git
26import qualified Git.LsFiles as LsFiles
27import Backend
28import Utility.FileMode
29import Utility.Tmp
30import qualified Upgrade.V2
31
32-- v2 adds hashing of filenames of content and location log files.
33-- Key information is encoded in filenames differently, so
34-- both content and location log files move around, and symlinks
35-- to content need to be changed.
36--
37-- When upgrading a v1 key to v2, file size metadata ought to be
38-- added to the key (unless it is a WORM key, which encoded
39-- mtime:size in v1). This can only be done when the file content
40-- is present. Since upgrades need to happen consistently,
41-- (so that two repos get changed the same way by the upgrade, and
42-- will merge), that metadata cannot be added on upgrade.
43--
44-- Note that file size metadata
45-- will only be used for detecting situations where git-annex
46-- would run out of disk space, so if some keys don't have it,
47-- the impact is minor. At least initially. It could be used in the
48-- future by smart auto-repo balancing code, etc.
49--
50-- Anyway, since v2 plans ahead for other metadata being included
51-- in keys, there should probably be a way to update a key.
52-- Something similar to the migrate subcommand could be used,
53-- and users could then run that at their leisure.
54
55upgrade :: Annex Bool
56upgrade = do
57	showAction "v1 to v2"
58
59	ifM (fromRepo Git.repoIsLocalBare)
60		( moveContent
61		, do
62			moveContent
63			updateSymlinks
64			moveLocationLogs
65
66			Annex.Queue.flush
67		)
68
69	Upgrade.V2.upgrade
70
71moveContent :: Annex ()
72moveContent = do
73	showAction "moving content"
74	files <- getKeyFilesPresent1
75	forM_ files move
76  where
77	move f = do
78		let f' = toRawFilePath f
79		let k = fileKey1 (fromRawFilePath (P.takeFileName f'))
80		let d = parentDir f'
81		liftIO $ allowWrite d
82		liftIO $ allowWrite f'
83		_ <- moveAnnex k (AssociatedFile Nothing) f'
84		liftIO $ removeDirectory (fromRawFilePath d)
85
86updateSymlinks :: Annex ()
87updateSymlinks = do
88	showAction "updating symlinks"
89	top <- fromRepo Git.repoPath
90	(files, cleanup) <- inRepo $ LsFiles.inRepo [] [top]
91	forM_ files (fixlink . fromRawFilePath)
92	void $ liftIO cleanup
93  where
94	fixlink f = do
95		r <- lookupKey1 f
96		case r of
97			Nothing -> noop
98			Just (k, _) -> do
99				link <- fromRawFilePath
100					<$> calcRepo (gitAnnexLink (toRawFilePath f) k)
101				liftIO $ removeFile f
102				liftIO $ createSymbolicLink link f
103				Annex.Queue.addCommand [] "add" [Param "--"] [f]
104
105moveLocationLogs :: Annex ()
106moveLocationLogs = do
107	showAction "moving location logs"
108	logkeys <- oldlocationlogs
109	forM_ logkeys move
110  where
111	oldlocationlogs = do
112		dir <- fromRepo Upgrade.V2.gitStateDir
113		ifM (liftIO $ doesDirectoryExist dir)
114			( mapMaybe oldlog2key
115				<$> liftIO (getDirectoryContents dir)
116			, return []
117			)
118	move (l, k) = do
119		dest <- fromRepo (logFile2 k)
120		dir <- fromRepo Upgrade.V2.gitStateDir
121		let f = dir </> l
122		createWorkTreeDirectory (parentDir (toRawFilePath dest))
123		-- could just git mv, but this way deals with
124		-- log files that are not checked into git,
125		-- as well as merging with already upgraded
126		-- logs that have been pulled from elsewhere
127		old <- liftIO $ readLog1 f
128		new <- liftIO $ readLog1 dest
129		liftIO $ writeLog1 dest (old++new)
130		Annex.Queue.addCommand [] "add" [Param "--"] [dest]
131		Annex.Queue.addCommand [] "add" [Param "--"] [f]
132		Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] [f]
133
134oldlog2key :: FilePath -> Maybe (FilePath, Key)
135oldlog2key l
136	| drop len l == ".log" && sane = Just (l, k)
137	| otherwise = Nothing
138  where
139	len = length l - 4
140	k = readKey1 (take len l)
141	sane = (not . S.null $ fromKey keyName k) && (not . S.null $ formatKeyVariety $ fromKey keyVariety k)
142
143-- WORM backend keys: "WORM:mtime:size:filename"
144-- all the rest: "backend:key"
145--
146-- If the file looks like "WORM:XXX-...", then it was created by mixing
147-- v2 and v1; that infelicity is worked around by treating the value
148-- as the v2 key that it is.
149readKey1 :: String -> Key
150readKey1 v
151	| mixup = fromJust $ deserializeKey $ intercalate ":" $ Prelude.tail bits
152	| otherwise = mkKey $ \d -> d
153		{ keyName = encodeBS n
154		, keyVariety = parseKeyVariety (encodeBS b)
155		, keySize = s
156		, keyMtime = t
157		}
158  where
159	bits = splitc ':' v
160	b = Prelude.head bits
161	n = intercalate ":" $ drop (if wormy then 3 else 1) bits
162	t = if wormy
163		then Just (Prelude.read (bits !! 1) :: EpochTime)
164		else Nothing
165	s = if wormy
166		then Just (Prelude.read (bits !! 2) :: Integer)
167		else Nothing
168	wormy = Prelude.head bits == "WORM"
169	mixup = wormy && isUpper (Prelude.head $ bits !! 1)
170
171showKey1 :: Key -> String
172showKey1 k = intercalate ":" $ filter (not . null)
173	[b, showifhere t, showifhere s, decodeBS n]
174  where
175	showifhere Nothing = ""
176	showifhere (Just x) = show x
177	b = decodeBS $ formatKeyVariety v
178	n = fromKey keyName k
179	v = fromKey keyVariety k
180	s = fromKey keySize k
181	t = fromKey keyMtime k
182
183keyFile1 :: Key -> FilePath
184keyFile1 key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a"  $ showKey1 key
185
186fileKey1 :: FilePath -> Key
187fileKey1 file = readKey1 $
188	replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file
189
190writeLog1 :: FilePath -> [LogLine] -> IO ()
191writeLog1 file ls = viaTmp L.writeFile file (toLazyByteString $ buildLog ls)
192
193readLog1 :: FilePath -> IO [LogLine]
194readLog1 file = catchDefaultIO [] $
195	parseLog . encodeBL <$> readFileStrict file
196
197lookupKey1 :: FilePath -> Annex (Maybe (Key, Backend))
198lookupKey1 file = do
199	tl <- liftIO $ tryIO getsymlink
200	case tl of
201		Left _ -> return Nothing
202		Right l -> makekey l
203  where
204	getsymlink = takeFileName <$> readSymbolicLink file
205	makekey l = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
206		Nothing -> do
207			unless (null kname || null bname ||
208			        not (isLinkToAnnex (toRawFilePath l))) $
209				warning skip
210			return Nothing
211		Just backend -> return $ Just (k, backend)
212	  where
213		k = fileKey1 l
214		bname = decodeBS (formatKeyVariety (fromKey keyVariety k))
215		kname = decodeBS (fromKey keyName k)
216		skip = "skipping " ++ file ++
217			" (unknown backend " ++ bname ++ ")"
218
219getKeyFilesPresent1 :: Annex [FilePath]
220getKeyFilesPresent1  = getKeyFilesPresent1' . fromRawFilePath
221	=<< fromRepo gitAnnexObjectDir
222getKeyFilesPresent1' :: FilePath -> Annex [FilePath]
223getKeyFilesPresent1' dir =
224	ifM (liftIO $ doesDirectoryExist dir)
225		(  do
226			dirs <- liftIO $ getDirectoryContents dir
227			let files = map (\d -> dir ++ "/" ++ d ++ "/" ++ takeFileName d) dirs
228			liftIO $ filterM present files
229		, return []
230		)
231  where
232	present f = do
233		result <- tryIO $ getFileStatus f
234		case result of
235			Right s -> return $ isRegularFile s
236			Left _ -> return False
237
238logFile1 :: Git.Repo -> Key -> String
239logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"
240
241logFile2 :: Key -> Git.Repo -> String
242logFile2 = logFile' (hashDirLower def)
243
244logFile' :: (Key -> RawFilePath) -> Key -> Git.Repo -> String
245logFile' hasher key repo =
246	gitStateDir repo ++ fromRawFilePath (hasher key) ++ fromRawFilePath (keyFile key) ++ ".log"
247
248stateDir :: FilePath
249stateDir = addTrailingPathSeparator ".git-annex"
250
251gitStateDir :: Git.Repo -> FilePath
252gitStateDir repo = addTrailingPathSeparator $
253	fromRawFilePath (Git.repoPath repo) </> stateDir
254