From 0e55d6a907a39c3b7239268261edc2d5b5f55caf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 14 Nov 2010 14:44:24 -0400 Subject: move stuff out of Core --- Upgrade.hs | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 63 insertions(+) create mode 100644 Upgrade.hs (limited to 'Upgrade.hs') diff --git a/Upgrade.hs b/Upgrade.hs new file mode 100644 index 000000000..d64d5287d --- /dev/null +++ b/Upgrade.hs @@ -0,0 +1,63 @@ +{- git-annex upgrade support + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Upgrade where + +import System.Directory +import Control.Monad.State (liftIO) +import System.Posix.Files + +import Core +import Types +import Locations +import qualified GitRepo as Git +import qualified Annex +import qualified Backend +import Messages +import Version + +{- Uses the annex.version git config setting to automate upgrades. -} +upgrade :: Annex Bool +upgrade = do + version <- getVersion + case version of + Just "0" -> upgradeFrom0 + 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!" + +upgradeFrom0 :: Annex Bool +upgradeFrom0 = do + showSideAction "Upgrading object directory layout..." + g <- Annex.gitRepo + + -- do the reorganisation of the files + let olddir = annexDir g + keys <- getKeysPresent' olddir + _ <- mapM (\k -> moveAnnex k $ olddir ++ "/" ++ keyFile k) keys + + -- update the symlinks to the files + files <- liftIO $ Git.inRepo g $ Git.workTree g + fixlinks files + Annex.queueRun + + 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" ["--"] f + fixlinks fs -- cgit v1.2.3