diff options
| -rw-r--r-- | Backend.hs | 3 | ||||
| -rw-r--r-- | Upgrade.hs | 118 | ||||
| -rw-r--r-- | Upgrade/V0.hs | 80 | ||||
| -rw-r--r-- | Upgrade/V1.hs | 155 |
4 files changed, 241 insertions, 115 deletions
diff --git a/Backend.hs b/Backend.hs index e1f8f388b..cd14ce50e 100644 --- a/Backend.hs +++ b/Backend.hs @@ -27,7 +27,8 @@ module Backend ( lookupFile, chooseBackends, keyBackend, - lookupBackendName + lookupBackendName, + maybeLookupBackendName ) where import Control.Monad.State diff --git a/Upgrade.hs b/Upgrade.hs index d63397ce0..a15258204 100644 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -7,128 +7,18 @@ module Upgrade where -import System.IO.Error (try) -import System.Directory -import Control.Monad.State (liftIO) -import Control.Monad (filterM, forM_) -import System.Posix.Files -import System.FilePath -import Data.Maybe - -import Content import Types -import Locations -import qualified GitRepo as Git -import qualified Annex -import qualified Backend -import Messages import Version -import Utility +import qualified Upgrade.V0 +import qualified Upgrade.V1 {- Uses the annex.version git config setting to automate upgrades. -} upgrade :: Annex Bool upgrade = do version <- getVersion case version of - Just "0" -> upgradeFrom0 - Just "1" -> upgradeFrom1 + Just "0" -> Upgrade.V0.upgrade + Just "1" -> Upgrade.V1.upgrade Nothing -> return True -- repo not initted yet, no version Just v | v == currentVersion -> return True Just _ -> error "this version of git-annex is too old for this git repository!" - -upgradeFrom1 :: Annex Bool -upgradeFrom1 = do - showSideAction "Upgrading object directory layout v1 to v2..." - error "upgradeFrom1 TODO FIXME" - - -- v2 adds hashing of filenames of content and location log files. - -- - -- Key information is encoded in filenames differently. - -- - -- When upgrading a v1 key to v2, file size metadata needs 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. - -- - -- So there are two approaches -- either upgrade - -- everything, leaving out file size information for files not - -- present in the current repo; or upgrade peicemeil, only - -- upgrading keys whose content is present. - -- - -- The latter approach would mean that, until every clone of an - -- annex is upgraded, git annex would refuse to operate on annexed - -- files that had not yet been committed. Unless it were taught to - -- work with both v1 and v2 keys in the same repo. - -- - -- Another problem with the latter approach might involve content - -- being moved between repos while the conversion is still - -- incomplete. If repo A has already upgraded, and B has not, and B - -- has K, moving K from B -> A would result in it lurking - -- unconverted on A. Unless A upgraded it in passing. But that's - -- getting really complex, and would mean a constant trickle of - -- upgrade commits, which users would find annoying. - -- - -- So, the former option it is! 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 small. 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. Or, this upgrade - -- could to that key update for all keys that have been converted - -- and have content in the repo. - -upgradeFrom0 :: Annex Bool -upgradeFrom0 = do - showSideAction "Upgrading object directory layout v0 to v1..." - g <- Annex.gitRepo - - -- do the reorganisation of the files - let olddir = gitAnnexDir g - keys <- getKeysPresent0' olddir - forM_ keys $ \k -> moveAnnex k $ olddir </> keyFile k - - -- update the symlinks to the files - files <- liftIO $ Git.inRepo g [Git.workTree g] - fixlinks files - Annex.queueRun - - -- Few people had v0 repos, so go the long way around from 0 -> 1 -> 2 - upgradeFrom1 - - setVersion - - return True - - where - fixlinks [] = return () - fixlinks (f:fs) = do - r <- Backend.lookupFile f - case r of - Nothing -> return () - Just (k, _) -> do - link <- calcGitLink f k - liftIO $ removeFile f - liftIO $ createSymbolicLink link f - Annex.queue "add" [Param "--"] f - fixlinks fs - -getKeysPresent0' :: FilePath -> Annex [Key] -getKeysPresent0' dir = do - exists <- liftIO $ doesDirectoryExist dir - if (not exists) - then return [] - else do - contents <- liftIO $ getDirectoryContents dir - files <- liftIO $ filterM present contents - return $ catMaybes $ map fileKey files - where - present d = do - result <- try $ - getFileStatus $ dir ++ "/" ++ takeFileName d - case result of - Right s -> return $ isRegularFile s - Left _ -> return False diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs new file mode 100644 index 000000000..25b6f2763 --- /dev/null +++ b/Upgrade/V0.hs @@ -0,0 +1,80 @@ +{- git-annex v0 -> v1 upgrade support + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Upgrade.V0 where + +import System.IO.Error (try) +import System.Directory +import Control.Monad.State (liftIO) +import Control.Monad (filterM, forM_) +import System.Posix.Files +import System.FilePath + +import Content +import Types +import Locations +import qualified GitRepo as Git +import qualified Annex +import Messages +import Utility +import qualified Upgrade.V1 + +upgrade :: Annex Bool +upgrade = do + showSideAction "Upgrading object directory layout v0 to v1..." + g <- Annex.gitRepo + + -- do the reorganisation of the key files + let olddir = gitAnnexDir g + keys <- getKeysPresent0 olddir + forM_ keys $ \k -> moveAnnex k $ olddir </> keyFile0 k + + -- update the symlinks to the key files + files <- liftIO $ Git.inRepo g [Git.workTree g] + fixlinks files + Annex.queueRun + + -- Few people had v0 repos, so go the long way around from 0 -> 1 -> 2 + Upgrade.V1.upgrade + + where + fixlinks [] = return () + fixlinks (f:fs) = do + r <- lookupFile0 f + case r of + Nothing -> return () + Just (k, _) -> do + link <- calcGitLink f k + liftIO $ removeFile f + liftIO $ createSymbolicLink link f + Annex.queue "add" [Param "--"] f + fixlinks fs + +-- these stayed unchanged between v0 and v1 +keyFile0 :: Key -> FilePath +keyFile0 = Upgrade.V1.keyFile1 +fileKey0 :: FilePath -> Key +fileKey0 = Upgrade.V1.fileKey1 +lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend Annex)) +lookupFile0 = Upgrade.V1.lookupFile1 + +getKeysPresent0 :: FilePath -> Annex [Key] +getKeysPresent0 dir = do + exists <- liftIO $ doesDirectoryExist dir + if (not exists) + then return [] + else do + contents <- liftIO $ getDirectoryContents dir + files <- liftIO $ filterM present contents + return $ map fileKey0 files + where + present d = do + result <- try $ + getFileStatus $ dir ++ "/" ++ takeFileName d + case result of + Right s -> return $ isRegularFile s + Left _ -> return False diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs new file mode 100644 index 000000000..dd51206b3 --- /dev/null +++ b/Upgrade/V1.hs @@ -0,0 +1,155 @@ +{- 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.Directory +import Control.Monad.State (liftIO) +import Control.Monad (filterM, forM_, unless) +import System.Posix.Files +import System.FilePath +import Data.String.Utils +import Key +import System.Posix.Types + +import Content +import Types +import Locations +import qualified Annex +import Backend +import Messages +import Version + +upgrade :: Annex Bool +upgrade = do + showSideAction "Upgrading object directory layout v1 to v2..." + error "upgradeFrom1 TODO FIXME" + + -- v2 adds hashing of filenames of content and location log files. + -- + -- Key information is encoded in filenames differently. + -- + -- When upgrading a v1 key to v2, file size metadata needs 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. + -- + -- So there are two approaches -- either upgrade + -- everything, leaving out file size information for files not + -- present in the current repo; or upgrade peicemeil, only + -- upgrading keys whose content is present. + -- + -- The latter approach would mean that, until every clone of an + -- annex is upgraded, git annex would refuse to operate on annexed + -- files that had not yet been committed. Unless it were taught to + -- work with both v1 and v2 keys in the same repo. + -- + -- Another problem with the latter approach might involve content + -- being moved between repos while the conversion is still + -- incomplete. If repo A has already upgraded, and B has not, and B + -- has K, moving K from B -> A would result in it lurking + -- unconverted on A. Unless A upgraded it in passing. But that's + -- getting really complex, and would mean a constant trickle of + -- upgrade commits, which users would find annoying. + -- + -- So, the former option it is! 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 small. 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. Or, this upgrade + -- could to that key update for all keys that have been converted + -- and have content in the repo. + + -- do the reorganisation of the log files + + -- do the reorganisation of the key files + g <- Annex.gitRepo + let olddir = gitAnnexDir g + keys <- getKeysPresent1 + forM_ keys $ \k -> moveAnnex k $ olddir </> keyFile1 k + + -- update the symlinks to the key files + + Annex.queueRun + + setVersion + + return True + +keyFile1 :: Key -> FilePath +keyFile1 key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a" $ show key + +fileKey1 :: FilePath -> Key +fileKey1 file = readKey1 $ + replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file + +readKey1 :: String -> Key +readKey1 v = 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 = b == "WORM" + +lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex)) +lookupFile1 file = do + bs <- Annex.getState Annex.supportedBackends + tl <- liftIO $ try getsymlink + case tl of + Left _ -> return Nothing + Right l -> makekey bs l + where + getsymlink = do + l <- readSymbolicLink file + return $ takeFileName l + makekey bs l = do + case maybeLookupBackendName bs 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 ++ ")" + +getKeysPresent1 :: Annex [Key] +getKeysPresent1 = do + g <- Annex.gitRepo + getKeysPresent1' $ gitAnnexObjectDir g +getKeysPresent1' :: FilePath -> Annex [Key] +getKeysPresent1' dir = do + exists <- liftIO $ doesDirectoryExist dir + if (not exists) + then return [] + else do + contents <- liftIO $ getDirectoryContents dir + files <- liftIO $ filterM present contents + return $ map fileKey1 files + where + present d = do + result <- try $ + getFileStatus $ dir ++ "/" ++ d ++ "/" ++ takeFileName d + case result of + Right s -> return $ isRegularFile s + Left _ -> return False |