summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Command/Init.hs40
-rw-r--r--Core.hs81
-rw-r--r--Upgrade.hs63
-rw-r--r--git-annex.hs3
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}
diff --git a/Core.hs b/Core.hs
index 9faaada56..2928dc06d 100644
--- a/Core.hs
+++ b/Core.hs
@@ -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]