diff options
| -rw-r--r-- | Command/Init.hs | 40 | ||||
| -rw-r--r-- | Core.hs | 81 | ||||
| -rw-r--r-- | Upgrade.hs | 63 | ||||
| -rw-r--r-- | git-annex.hs | 3 |
4 files changed, 105 insertions, 82 deletions
diff --git a/Command/Init.hs b/Command/Init.hs index 8110948a4..c928647a5 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -9,14 +9,15 @@ module Command.Init where import Control.Monad.State (liftIO) import Control.Monad (when) +import System.Directory import Command import qualified Annex -import Core import qualified GitRepo as Git import UUID import Version import Messages +import Locations seek :: [SubCmdSeek] seek = [withString start] @@ -46,3 +47,40 @@ cleanup = do liftIO $ Git.run g ["add", logfile] liftIO $ Git.run g ["commit", "-m", "git annex init", logfile] return True + +{- configure git to use union merge driver on state files, if it is not + - already -} +gitAttributes :: Git.Repo -> IO () +gitAttributes repo = do + exists <- doesFileExist attributes + if (not exists) + then do + writeFile attributes $ attrLine ++ "\n" + commit + else do + content <- readFile attributes + when (all (/= attrLine) (lines content)) $ do + appendFile attributes $ attrLine ++ "\n" + commit + where + attrLine = stateLoc ++ "*.log merge=union" + attributes = Git.attributes repo + commit = do + Git.run repo ["add", attributes] + Git.run repo ["commit", "-m", "git-annex setup", + attributes] + +{- set up a git pre-commit hook, if one is not already present -} +gitPreCommitHook :: Git.Repo -> IO () +gitPreCommitHook repo = do + let hook = Git.workTree repo ++ "/" ++ Git.gitDir repo ++ + "/hooks/pre-commit" + exists <- doesFileExist hook + if (exists) + then putStrLn $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring" + else do + writeFile hook $ "#!/bin/sh\n" ++ + "# automatically configured by git-annex\n" ++ + "git annex pre-commit .\n" + p <- getPermissions hook + setPermissions hook $ p {executable = True} @@ -26,7 +26,6 @@ import qualified Annex import qualified Backend import Utility import Messages -import Version {- Runs a list of Annex actions. Catches IO errors and continues - (but explicitly thrown errors terminate the whole command). @@ -46,11 +45,10 @@ tryRun' state errnum (a:as) = do tryRun' _ errnum [] = when (errnum > 0) $ error $ show errnum ++ " failed" -{- Sets up a git repo for git-annex. -} +{- Actions to perform each time ran. -} startup :: Annex Bool startup = do prepUUID - autoUpgrade return True {- When git-annex is done, it runs this. -} @@ -71,43 +69,6 @@ shutdown = do return True -{- configure git to use union merge driver on state files, if it is not - - already -} -gitAttributes :: Git.Repo -> IO () -gitAttributes repo = do - exists <- doesFileExist attributes - if (not exists) - then do - writeFile attributes $ attrLine ++ "\n" - commit - else do - content <- readFile attributes - when (all (/= attrLine) (lines content)) $ do - appendFile attributes $ attrLine ++ "\n" - commit - where - attrLine = stateLoc ++ "*.log merge=union" - attributes = Git.attributes repo - commit = do - Git.run repo ["add", attributes] - Git.run repo ["commit", "-m", "git-annex setup", - attributes] - -{- set up a git pre-commit hook, if one is not already present -} -gitPreCommitHook :: Git.Repo -> IO () -gitPreCommitHook repo = do - let hook = Git.workTree repo ++ "/" ++ Git.gitDir repo ++ - "/hooks/pre-commit" - exists <- doesFileExist hook - if (exists) - then putStrLn $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring" - else do - writeFile hook $ "#!/bin/sh\n" ++ - "# automatically configured by git-annex\n" ++ - "git annex pre-commit .\n" - p <- getPermissions hook - setPermissions hook $ p {executable = True} - {- Checks if a given key is currently present in the annexLocation. -} inAnnex :: Key -> Annex Bool inAnnex key = do @@ -237,43 +198,3 @@ getKeysReferenced = do files <- liftIO $ Git.inRepo g $ Git.workTree g keypairs <- mapM Backend.lookupFile files return $ map fst $ catMaybes keypairs - -{- Uses the annex.version git config setting to automate upgrades. -} -autoUpgrade :: Annex () -autoUpgrade = do - version <- getVersion - case version of - Just "0" -> upgradeFrom0 - Nothing -> return () -- repo not initted yet, no version - Just v | v == currentVersion -> return () - Just _ -> error "this version of git-annex is too old for this git repository!" - -upgradeFrom0 :: Annex () -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 - - 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 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 <joey@kitenet.net> + - + - 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 diff --git a/git-annex.hs b/git-annex.hs index 098ccac2d..d111156f0 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -9,6 +9,7 @@ import System.Environment import qualified Annex import Core +import Upgrade import CmdLine import qualified GitRepo as Git import BackendList @@ -19,4 +20,4 @@ main = do gitrepo <- Git.repoFromCwd state <- Annex.new gitrepo allBackends (configure, actions) <- parseCmd args state - tryRun state $ [startup] ++ configure ++ actions ++ [shutdown] + tryRun state $ [startup, upgrade] ++ configure ++ actions ++ [shutdown] |