Reorganised the layout of .git/annex/

Core.hs

@@ -25,6 +25,7 @@ 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).
@@ -54,16 +55,14 @@ startup = do
 {- When git-annex is done, it runs this. -}
 shutdown :: Annex Bool
 shutdown = do
-	g <- Annex.gitRepo
-
-	-- Runs all queued git commands.
 	q <- Annex.queueGet
 	unless (q == GitQueue.empty) $ do
-		verbose $ liftIO $ putStrLn "Recording state in git..."
+		showSideAction "Recording state in git..."
-		liftIO $ GitQueue.run g q
+		Annex.queueRun
 
 	-- clean up any files left in the temp directory, but leave
 	-- the tmp directory itself
+	g <- Annex.gitRepo
 	let tmp = annexTmpLocation g
 	exists <- liftIO $ doesDirectoryExist tmp
 	when (exists) $ liftIO $ removeDirectoryRecursive tmp
@@ -140,13 +139,12 @@ logStatus key status = do
 getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
 getViaTmp key action = do
 	g <- Annex.gitRepo
-	let dest = annexLocation g key
 	let tmp = annexTmpLocation g ++ keyFile key
 	liftIO $ createDirectoryIfMissing True (parentDir tmp)
 	success <- action tmp
 	if (success)
 		then do
-			liftIO $ renameFile tmp dest
+			moveToObjectDir key tmp
 			logStatus key ValuePresent
 			return True
 		else do
@@ -154,17 +152,28 @@ getViaTmp key action = do
 			-- to resume its transfer
 			return False
 
+{- Moves a file into .git/annex/objects/ -}
+moveToObjectDir :: Key -> FilePath -> Annex ()
+moveToObjectDir key src = do
+	g <- Annex.gitRepo
+	let dest = annexLocation g key
+	liftIO $ createDirectoryIfMissing True (parentDir dest)
+	liftIO $ renameFile src dest
+	-- TODO directory and file mode tweaks
+
 {- List of keys whose content exists in .git/annex/objects/ -}
 getKeysPresent :: Annex [Key]
 getKeysPresent = do
 	g <- Annex.gitRepo
-	let top = annexObjectDir g
+	getKeysPresent' $ annexObjectDir g
-	contents <- liftIO $ getDirectoryContents top
+getKeysPresent' :: FilePath -> Annex [Key]
-	files <- liftIO $ filterM (isreg top) contents
+getKeysPresent' dir = do
+	contents <- liftIO $ getDirectoryContents dir
+	files <- liftIO $ filterM isreg contents
 	return $ map fileKey files
 	where
-		isreg top f = do
+		isreg f = do
-			s <- getFileStatus $ top ++ "/" ++ f
+			s <- getFileStatus $ dir ++ "/" ++ f
 			return $ isRegularFile s
 
 {- List of keys referenced by symlinks in the git repo. -}
@@ -178,17 +187,39 @@ getKeysReferenced = do
 {- 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 for git-annex 0.04..."
 	g <- Annex.gitRepo
 
-	case Git.configGet g field "0" of
+	-- do the reorganisation of the files
-		"0" -> do -- before there was repo versioning
+	let olddir = annexDir g
-			upgradeNote "Upgrading object directory layout..."
+	keys <- getKeysPresent' olddir
-			
+	_ <- mapM (\k -> moveToObjectDir k $ olddir ++ "/" ++ keyFile k) keys
-			setVersion
+
-		v | v == currentVersion -> return ()
+	-- update the symlinks to the files
-		_ -> error "this version of git-annex is too old for this git repository!"
+	files <- liftIO $ Git.inRepo g $ Git.workTree g
+	fixlinks files
+	Annex.queueRun
+
+	setVersion
+
 	where
-		currentVersion = "1"
+		fixlinks [] = return ()
-		setVersion = Annex.setConfig field currentVersion
+		fixlinks (f:fs) = do
-		field = "annex.version"
+			r <- Backend.lookupFile f
-		upgradeNote s = verbose $ liftIO $ putStrLn $ "("++s++")"
+			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

Locations.hs

@@ -14,7 +14,9 @@ module Locations (
 	annexLocationRelative,
 	annexTmpLocation,
 	annexDir,
-	annexObjectDir
+	annexObjectDir,
+
+	prop_idempotent_fileKey
 ) where
 
 import Data.String.Utils
@@ -29,12 +31,7 @@ stateLoc = ".git-annex/"
 gitStateDir :: Git.Repo -> FilePath
 gitStateDir repo = (Git.workTree repo) ++ "/" ++ stateLoc
 
-{- An annexed file's content is stored in 
+{- Annexed file's absolute location. -}
- - /path/to/repo/.git/annex/objects/<key>/<key>, where <key> is of the form
- - <backend:fragment>
- -
- - That allows deriving the key and backend by looking at the symlink to it.
- -}
 annexLocation :: Git.Repo -> Key -> FilePath
 annexLocation r key = 
 	(Git.workTree r) ++ "/" ++ (annexLocationRelative key)
@@ -43,8 +40,9 @@ annexLocation r key =
  -
  - Note: Assumes repo is NOT bare.-}
 annexLocationRelative :: Key -> FilePath
-annexLocationRelative key = ".git/annex/objects/" ++ f ++ f
+annexLocationRelative key = ".git/annex/objects/" ++ f ++ "/" ++ f
-	where f = keyFile key
+	where
+		f = keyFile key
 
 {- The annex directory of a repository.
  -
@@ -72,10 +70,15 @@ annexTmpLocation r = annexDir r ++ "/tmp/"
  -     is one to one.
  - -}
 keyFile :: Key -> FilePath
-keyFile key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a" $ show key
+keyFile key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a"  $ show key
 
 {- Reverses keyFile, converting a filename fragment (ie, the basename of
  - the symlink target) into a key. -}
 fileKey :: FilePath -> Key
 fileKey file = read $
 	replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file
+
+{- for quickcheck -}
+prop_idempotent_fileKey :: String -> Bool
+prop_idempotent_fileKey s = k == (fileKey $ keyFile k)
+	where k = read "test:s"

debian/changelog

@@ -1,9 +1,13 @@
 git-annex (0.04) UNRELEASED; urgency=low
 
   * Add build dep on libghc6-testpack-dev.
-  * Add annex.version, which will be used to automate upgrades.
+  * Add annex.version, which will be used to automate upgrades
-  * Reorganised the layout of .git/annex/ , moving cached file contents
+    between incompatable versions.
-    to .git/annex/objects/<key>/<key>
+  * Reorganised the layout of .git/annex/
+  * The new layout will be automatically upgraded to the first time
+    git-annex is used in a repository with the old layout.
+  * Note that git-annex 0.04 cannot transfer content from old repositories
+    that have not yet been upgraded.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 08 Nov 2010 12:36:39 -0400
 

doc/git-annex.mdwn

@@ -223,7 +223,7 @@ but the SHA1 backend for ogg files:
 
 These files are used, in your git repository:
 
-`.git/annex/` contains the annexed file contents that are currently
+`.git/annex/objects/` contains the annexed file contents that are currently
 available. Annexed files in your git repository symlink to that content.
 
 `.git-annex/uuid.log` is used to map between repository UUID and

test.hs

@@ -5,9 +5,11 @@ import Test.HUnit
 import Test.HUnit.Tools
 
 import GitRepo
+import Locations
 
 alltests = [
-	qctest "prop_idempotent_deencode" prop_idempotent_deencode
+	qctest "prop_idempotent_deencode" prop_idempotent_deencode,
+	qctest "prop_idempotent_fileKey" prop_idempotent_fileKey
 	]
 
 main = runVerboseTests (TestList alltests)