upgrade groundwork
pulled in old versions of functions for working with keys Wrote a parser from old key filenames to new keys.
This commit is contained in:
Joey Hess
parent
f1e010f42e
commit
e227c210ec
4 changed files with 241 additions and 115 deletions
|
|
@ -27,7 +27,8 @@ module Backend (
|
|||
lookupFile,
|
||||
chooseBackends,
|
||||
keyBackend,
|
||||
lookupBackendName
|
||||
lookupBackendName,
|
||||
maybeLookupBackendName
|
||||
) where
|
||||
|
||||
import Control.Monad.State
|
||||
|
|
|
|||
118
Upgrade.hs
118
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
|
||||
|
|
|
|||
80
Upgrade/V0.hs
Normal file
80
Upgrade/V0.hs
Normal file
|
|
@ -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
|
||||
155
Upgrade/V1.hs
Normal file
155
Upgrade/V1.hs
Normal file
|
|
@ -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
|
||||
Loading…
Reference in a new issue