From f03adec793d378cc4807392400d09e70e293a991 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 12:36:55 -0400 Subject: Add build dep on libghc6-testpack-dev. --- debian/changelog | 6 ++++++ debian/control | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/debian/changelog b/debian/changelog index f9cec02c4..a363d442c 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +git-annex (0.04) UNRELEASED; urgency=low + + * Add build dep on libghc6-testpack-dev. + + -- Joey Hess Mon, 08 Nov 2010 12:36:39 -0400 + git-annex (0.03) unstable; urgency=low * Fix support for file:// remotes. diff --git a/debian/control b/debian/control index d8abc487c..3fba36742 100644 --- a/debian/control +++ b/debian/control @@ -1,7 +1,7 @@ Source: git-annex Section: utils Priority: optional -Build-Depends: debhelper (>= 7.0.50), ghc6, libghc6-missingh-dev, ikiwiki +Build-Depends: debhelper (>= 7.0.50), ghc6, libghc6-missingh-dev, libghc6-testpack-dev, ikiwiki Maintainer: Joey Hess Standards-Version: 3.9.1 Vcs-Git: git://git.kitenet.net/git-annex -- cgit v1.2.3 From ab4de454914954676aa1e05ef26dc8a85bd8f6f1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 14:39:12 -0400 Subject: Add annex.version, which will be used to automate upgrades. --- Annex.hs | 12 +++++++++++- Core.hs | 16 ++++++++++++++++ UUID.hs | 13 ++----------- debian/changelog | 1 + doc/git-annex.mdwn | 2 ++ 5 files changed, 32 insertions(+), 12 deletions(-) diff --git a/Annex.hs b/Annex.hs index e86e1967e..7c046b141 100644 --- a/Annex.hs +++ b/Annex.hs @@ -19,7 +19,8 @@ module Annex ( flagGet, Flag(..), queue, - queueGet + queueGet, + setConfig ) where import Control.Monad.State @@ -118,3 +119,12 @@ queueGet :: Annex GitQueue.Queue queueGet = do state <- get return (Internals.repoqueue state) + +{- Changes a git config setting in both internal state and .git/config -} +setConfig :: String -> String -> Annex () +setConfig key value = do + g <- Annex.gitRepo + liftIO $ Git.run g ["config", key, value] + -- re-read git config and update the repo's state + g' <- liftIO $ Git.configRead g Nothing + Annex.gitRepoChange g' diff --git a/Core.hs b/Core.hs index f34b2ebbe..347e63593 100644 --- a/Core.hs +++ b/Core.hs @@ -46,6 +46,7 @@ tryRun' _ errnum [] = startup :: Annex Bool startup = do prepUUID + autoUpgrade return True {- When git-annex is done, it runs this. -} @@ -151,6 +152,21 @@ getViaTmp key action = do -- to resume its transfer return False +{- Uses the annex.version git config setting to automate upgrades. -} +autoUpgrade :: Annex () +autoUpgrade = do + g <- Annex.gitRepo + + case Git.configGet g field "0" of + "0" -> do -- before there was repo versioning + setVersion + v | v == currentVersion -> return () + _ -> error "this version of git-annex is too old for this git repository!" + where + currentVersion = "1" + setVersion = Annex.setConfig field currentVersion + field = "annex.version" + {- Output logging -} verbose :: Annex () -> Annex () verbose a = do diff --git a/UUID.hs b/UUID.hs index ffd2cd46d..0f8a2173e 100644 --- a/UUID.hs +++ b/UUID.hs @@ -65,7 +65,7 @@ getUUID r = do where uncached = Git.configGet r "annex.uuid" "" cached g = Git.configGet g cachekey "" - updatecache g u = when (g /= r) $ setConfig cachekey u + updatecache g u = when (g /= r) $ Annex.setConfig cachekey u cachekey = "remote." ++ (Git.repoRemoteName r) ++ ".annex-uuid" {- Make sure that the repo has an annex.uuid setting. -} @@ -75,16 +75,7 @@ prepUUID = do u <- getUUID g when ("" == u) $ do uuid <- liftIO $ genUUID - setConfig configkey uuid - -{- Changes a git config setting in both internal state and .git/config -} -setConfig :: String -> String -> Annex () -setConfig key value = do - g <- Annex.gitRepo - liftIO $ Git.run g ["config", key, value] - -- re-read git config and update the repo's state - g' <- liftIO $ Git.configRead g Nothing - Annex.gitRepoChange g' + Annex.setConfig configkey uuid {- Filters a list of repos to ones that have listed UUIDs. -} reposByUUID :: [Git.Repo] -> [UUID] -> Annex [Git.Repo] diff --git a/debian/changelog b/debian/changelog index a363d442c..98b814eb9 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,7 @@ git-annex (0.04) UNRELEASED; urgency=low * Add build dep on libghc6-testpack-dev. + * Add annex.version, which will be used to automate upgrades. -- Joey Hess Mon, 08 Nov 2010 12:36:39 -0400 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 856b474e0..6f2c85d57 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -207,6 +207,8 @@ Here are all the supported configuration settings. to talk to this repository. * `annex.scp-options` and `annex.ssh-options` -- Default scp and ssh options to use if a remote does not have specific options. +* `annex.version` -- Automatically maintained, and used to automate upgrades + between versions. The backend used when adding a new file to the annex can be configured on a per-file-type basis via the `.gitattributes` file. In the file, -- cgit v1.2.3 From 02a21d7f274568a2e2f94498607955aab8713a24 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 15:14:54 -0400 Subject: reorg .git/annex --- Locations.hs | 13 ++++++++++--- debian/changelog | 2 ++ doc/backends.mdwn | 12 ++++++------ 3 files changed, 18 insertions(+), 9 deletions(-) diff --git a/Locations.hs b/Locations.hs index 951924c40..78c0bff4b 100644 --- a/Locations.hs +++ b/Locations.hs @@ -13,7 +13,8 @@ module Locations ( annexLocation, annexLocationRelative, annexTmpLocation, - annexDir + annexDir, + annexObjectDir ) where import Data.String.Utils @@ -29,7 +30,7 @@ gitStateDir :: Git.Repo -> FilePath gitStateDir repo = (Git.workTree repo) ++ "/" ++ stateLoc {- An annexed file's content is stored in - - /path/to/repo/.git/annex/, where is of the form + - /path/to/repo/.git/annex/objects//, where is of the form - - - That allows deriving the key and backend by looking at the symlink to it. @@ -42,7 +43,8 @@ annexLocation r key = - - Note: Assumes repo is NOT bare.-} annexLocationRelative :: Key -> FilePath -annexLocationRelative key = ".git/annex/" ++ (keyFile key) +annexLocationRelative key = ".git/annex/objects/" ++ f ++ f + where f = keyFile key {- The annex directory of a repository. - @@ -50,6 +52,11 @@ annexLocationRelative key = ".git/annex/" ++ (keyFile key) annexDir :: Git.Repo -> FilePath annexDir r = Git.workTree r ++ "/.git/annex" +{- The part of the annex directory where file contents are stored. + -} +annexObjectDir :: Git.Repo -> FilePath +annexObjectDir r = annexDir r ++ "/objects" + {- .git-annex/tmp is used for temp files -} annexTmpLocation :: Git.Repo -> FilePath annexTmpLocation r = annexDir r ++ "/tmp/" diff --git a/debian/changelog b/debian/changelog index 98b814eb9..49aa9829a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -2,6 +2,8 @@ git-annex (0.04) UNRELEASED; urgency=low * Add build dep on libghc6-testpack-dev. * Add annex.version, which will be used to automate upgrades. + * Reorganised the layout of .git/annex/ , moving cached file contents + to .git/annex/objects// -- Joey Hess Mon, 08 Nov 2010 12:36:39 -0400 diff --git a/doc/backends.mdwn b/doc/backends.mdwn index dc359174a..fde23df5e 100644 --- a/doc/backends.mdwn +++ b/doc/backends.mdwn @@ -10,13 +10,13 @@ Multiple pluggable backends are supported, and a single repository can use different backends for different files. * `WORM` ("Write Once, Read Many") This backend stores the file's content - only in `.git/annex/`, and assumes that any file with the same basename, - size, and modification time has the same content. So with this backend, - files can be moved around, but should never be added to or changed. - This is the default, and the least expensive backend. + only in `.git/annex/objects/`, and assumes that any file with the same + basename, size, and modification time has the same content. So with + this backend, files can be moved around, but should never be added to + or changed. This is the default, and the least expensive backend. * `SHA1` -- This backend stores the file's content in - `.git/annex/`, with a name based on its sha1 checksum. This backend allows - modifications of files to be tracked. Its need to generate checksums + `.git/annex/objects/`, with a name based on its sha1 checksum. This backend + allows modifications of files to be tracked. Its need to generate checksums can make it slower for large files. **Warning** this backend is not ready for use. * `URL` -- This backend downloads the file's content from an external URL. -- cgit v1.2.3 From 070e8530c1151dc96dec099eac8b967277751b10 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 15:15:21 -0400 Subject: refactoring, no code changes really --- Backend.hs | 2 +- Backend/File.hs | 1 + Backend/SHA1.hs | 2 +- Backend/URL.hs | 2 +- Command.hs | 2 +- Command/Add.hs | 1 + Command/Drop.hs | 1 + Command/DropKey.hs | 1 + Command/Fix.hs | 1 + Command/FromKey.hs | 1 + Command/Fsck.hs | 29 +----------------------- Command/Get.hs | 1 + Command/Init.hs | 1 + Command/Move.hs | 5 +++-- Command/SetKey.hs | 1 + Command/Unannex.hs | 1 + Core.hs | 66 ++++++++++++++++++++++++------------------------------ Messages.hs | 54 ++++++++++++++++++++++++++++++++++++++++++++ Remotes.hs | 7 +++--- 19 files changed, 105 insertions(+), 74 deletions(-) create mode 100644 Messages.hs diff --git a/Backend.hs b/Backend.hs index 456a98bd4..43b450736 100644 --- a/Backend.hs +++ b/Backend.hs @@ -31,13 +31,13 @@ import Control.Monad.State import IO (try) import System.FilePath import System.Posix.Files -import Core import Locations import qualified GitRepo as Git import qualified Annex import Types import qualified TypeInternals as Internals +import Messages {- List of backends in the order to try them when storing a new key. -} list :: Annex [Backend] diff --git a/Backend/File.hs b/Backend/File.hs index 5b93d8227..9178b830a 100644 --- a/Backend/File.hs +++ b/Backend/File.hs @@ -25,6 +25,7 @@ import qualified GitRepo as Git import Core import qualified Annex import UUID +import Messages backend :: Backend backend = Backend { diff --git a/Backend/SHA1.hs b/Backend/SHA1.hs index 485892258..5a232ec1d 100644 --- a/Backend/SHA1.hs +++ b/Backend/SHA1.hs @@ -14,7 +14,7 @@ import System.IO import qualified Backend.File import TypeInternals -import Core +import Messages backend :: Backend backend = Backend.File.backend { diff --git a/Backend/URL.hs b/Backend/URL.hs index e6d3eb1ae..830d343c5 100644 --- a/Backend/URL.hs +++ b/Backend/URL.hs @@ -11,8 +11,8 @@ import Control.Monad.State (liftIO) import Data.String.Utils import TypeInternals -import Core import Utility +import Messages backend :: Backend backend = Backend { diff --git a/Command.hs b/Command.hs index a0e3280d6..f896a53f6 100644 --- a/Command.hs +++ b/Command.hs @@ -9,7 +9,7 @@ module Command where import Types import qualified Backend -import Core +import Messages import qualified Annex {- A subcommand runs in four stages. diff --git a/Command/Add.hs b/Command/Add.hs index 825c1d8c1..3cc681f69 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -19,6 +19,7 @@ import qualified Backend import LocationLog import Types import Core +import Messages {- The add subcommand annexes a file, storing it in a backend, and then - moving it into the annex directory and setting up the symlink pointing diff --git a/Command/Drop.hs b/Command/Drop.hs index 6cdf216f4..d1ebd7f64 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -17,6 +17,7 @@ import qualified Backend import LocationLog import Types import Core +import Messages {- Indicates a file's content is not wanted anymore, and should be removed - if it's safe to do so. -} diff --git a/Command/DropKey.hs b/Command/DropKey.hs index bdd9b55b1..8076e6fd3 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -17,6 +17,7 @@ import qualified Backend import LocationLog import Types import Core +import Messages {- Drops cached content for a key. -} start :: SubCmdStartString diff --git a/Command/Fix.hs b/Command/Fix.hs index 90257a8a5..7963a1d2e 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -15,6 +15,7 @@ import Command import qualified Annex import Utility import Core +import Messages {- Fixes the symlink to an annexed file. -} start :: SubCmdStartString diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 3071f218f..de555475c 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -18,6 +18,7 @@ import Utility import qualified Backend import Types import Core +import Messages {- Adds a file pointing at a manually-specified key -} start :: SubCmdStartString diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 785aecd8a..5405ce120 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -8,19 +8,11 @@ module Command.Fsck where import qualified Data.Map as M -import System.Directory -import System.Posix.Files -import Monad (filterM) -import Control.Monad.State (liftIO) -import Data.Maybe import Command import Types import Core -import Locations -import qualified Annex -import qualified GitRepo as Git -import qualified Backend +import Messages {- Checks the whole annex for problems. -} start :: SubCmdStart @@ -71,22 +63,3 @@ unusedKeys = do existsMap :: Ord k => [k] -> M.Map k Int existsMap l = M.fromList $ map (\k -> (k, 1)) l - -getKeysPresent :: Annex [Key] -getKeysPresent = do - g <- Annex.gitRepo - let top = annexDir g - contents <- liftIO $ getDirectoryContents top - files <- liftIO $ filterM (isreg top) contents - return $ map fileKey files - where - isreg top f = do - s <- getFileStatus $ top ++ "/" ++ f - return $ isRegularFile s - -getKeysReferenced :: Annex [Key] -getKeysReferenced = do - g <- Annex.gitRepo - files <- liftIO $ Git.inRepo g $ Git.workTree g - keypairs <- mapM Backend.lookupFile files - return $ map fst $ catMaybes keypairs diff --git a/Command/Get.hs b/Command/Get.hs index 1433bc8d0..c50b5a377 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -11,6 +11,7 @@ import Command import qualified Backend import Types import Core +import Messages {- Gets an annexed file from one of the backends. -} start :: SubCmdStartString diff --git a/Command/Init.hs b/Command/Init.hs index b1e4e0e06..fd55242a4 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -15,6 +15,7 @@ import qualified Annex import Core import qualified GitRepo as Git import UUID +import Messages {- Stores description for the repository etc. -} start :: SubCmdStartString diff --git a/Command/Move.hs b/Command/Move.hs index cee941622..6ca923a31 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -20,6 +20,7 @@ import Core import qualified GitRepo as Git import qualified Remotes import UUID +import Messages {- Move a file either --to or --from a repository. - @@ -64,7 +65,7 @@ moveToPerform key = do showNote $ show err return Nothing Right False -> do - Core.showNote $ "moving to " ++ (Git.repoDescribe remote) ++ "..." + showNote $ "moving to " ++ (Git.repoDescribe remote) ++ "..." let tmpfile = (annexTmpLocation remote) ++ (keyFile key) ok <- Remotes.copyToRemote remote key tmpfile if (ok) @@ -112,7 +113,7 @@ moveFromPerform key = do if (ishere) then return $ Just $ moveFromCleanup remote key else do - Core.showNote $ "moving from " ++ (Git.repoDescribe remote) ++ "..." + showNote $ "moving from " ++ (Git.repoDescribe remote) ++ "..." ok <- getViaTmp key (Remotes.copyFromRemote remote key) if (ok) then return $ Just $ moveFromCleanup remote key diff --git a/Command/SetKey.hs b/Command/SetKey.hs index a5710643e..9286e740b 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -18,6 +18,7 @@ import qualified Backend import LocationLog import Types import Core +import Messages {- Sets cached content for a key. -} start :: SubCmdStartString diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 5cffb2d89..e0848cd4a 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -19,6 +19,7 @@ import LocationLog import Types import Core import qualified GitRepo as Git +import Messages {- The unannex subcommand undoes an add. -} start :: SubCmdStartString diff --git a/Core.hs b/Core.hs index 347e63593..7aadfb5fb 100644 --- a/Core.hs +++ b/Core.hs @@ -8,12 +8,12 @@ module Core where import IO (try) -import System.IO import System.Directory import Control.Monad.State (liftIO) import System.Path -import Data.String.Utils -import Control.Monad (when, unless) +import Control.Monad (when, unless, filterM) +import System.Posix.Files +import Data.Maybe import Types import Locations @@ -22,7 +22,9 @@ import UUID import qualified GitRepo as Git import qualified GitQueue import qualified Annex +import qualified Backend import Utility +import Messages {- Runs a list of Annex actions. Catches IO errors and continues - (but explicitly thrown errors terminate the whole command). @@ -152,6 +154,27 @@ getViaTmp key action = do -- to resume its transfer return False +{- List of keys whose content exists in .git/annex/objects/ -} +getKeysPresent :: Annex [Key] +getKeysPresent = do + g <- Annex.gitRepo + let top = annexObjectDir g + contents <- liftIO $ getDirectoryContents top + files <- liftIO $ filterM (isreg top) contents + return $ map fileKey files + where + isreg top f = do + s <- getFileStatus $ top ++ "/" ++ f + return $ isRegularFile s + +{- List of keys referenced by symlinks in the git repo. -} +getKeysReferenced :: Annex [Key] +getKeysReferenced = do + g <- Annex.gitRepo + 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 @@ -159,6 +182,8 @@ autoUpgrade = do case Git.configGet g field "0" of "0" -> do -- before there was repo versioning + upgradeNote "Upgrading object directory layout..." + setVersion v | v == currentVersion -> return () _ -> error "this version of git-annex is too old for this git repository!" @@ -166,37 +191,4 @@ autoUpgrade = do currentVersion = "1" setVersion = Annex.setConfig field currentVersion field = "annex.version" - -{- Output logging -} -verbose :: Annex () -> Annex () -verbose a = do - q <- Annex.flagIsSet "quiet" - unless q a -showStart :: String -> String -> Annex () -showStart command file = verbose $ do - liftIO $ putStr $ command ++ " " ++ file ++ " " - liftIO $ hFlush stdout -showNote :: String -> Annex () -showNote s = verbose $ do - liftIO $ putStr $ "(" ++ s ++ ") " - liftIO $ hFlush stdout -showProgress :: Annex () -showProgress = verbose $ liftIO $ putStr "\n" -showLongNote :: String -> Annex () -showLongNote s = verbose $ do - liftIO $ putStr $ "\n" ++ indented - where - indented = join "\n" $ map (\l -> " " ++ l) $ lines s -showEndOk :: Annex () -showEndOk = verbose $ do - liftIO $ putStrLn "ok" -showEndFail :: Annex () -showEndFail = verbose $ do - liftIO $ putStrLn "\nfailed" - -{- Exception pretty-printing. -} -showErr :: (Show a) => a -> Annex () -showErr e = warning $ show e - -warning :: String -> Annex () -warning s = liftIO $ hPutStrLn stderr $ "git-annex: " ++ s + upgradeNote s = verbose $ liftIO $ putStrLn $ "("++s++")" diff --git a/Messages.hs b/Messages.hs new file mode 100644 index 000000000..89f78e244 --- /dev/null +++ b/Messages.hs @@ -0,0 +1,54 @@ +{- git-annex output messages + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Messages where + +import Control.Monad.State (liftIO) +import System.IO +import Control.Monad (unless) +import Data.String.Utils + +import Types +import qualified Annex + +verbose :: Annex () -> Annex () +verbose a = do + q <- Annex.flagIsSet "quiet" + unless q a + +showStart :: String -> String -> Annex () +showStart command file = verbose $ do + liftIO $ putStr $ command ++ " " ++ file ++ " " + liftIO $ hFlush stdout + +showNote :: String -> Annex () +showNote s = verbose $ do + liftIO $ putStr $ "(" ++ s ++ ") " + liftIO $ hFlush stdout + +showProgress :: Annex () +showProgress = verbose $ liftIO $ putStr "\n" + +showLongNote :: String -> Annex () +showLongNote s = verbose $ do + liftIO $ putStr $ "\n" ++ indented + where + indented = join "\n" $ map (\l -> " " ++ l) $ lines s +showEndOk :: Annex () +showEndOk = verbose $ do + liftIO $ putStrLn "ok" + +showEndFail :: Annex () +showEndFail = verbose $ do + liftIO $ putStrLn "\nfailed" + +{- Exception pretty-printing. -} +showErr :: (Show a) => a -> Annex () +showErr e = warning $ show e + +warning :: String -> Annex () +warning s = liftIO $ hPutStrLn stderr $ "git-annex: " ++ s diff --git a/Remotes.hs b/Remotes.hs index 280543968..7aad6c2a0 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -36,6 +36,7 @@ import Locations import UUID import Utility import qualified Core +import Messages {- Human visible list of remotes. -} list :: [Git.Repo] -> String @@ -64,7 +65,7 @@ keyPossibilities key = do let expensive = filter Git.repoIsUrl allremotes doexpensive <- filterM cachedUUID expensive unless (null doexpensive) $ do - Core.showNote $ "getting UUID for " ++ + showNote $ "getting UUID for " ++ (list doexpensive) ++ "..." let todo = cheap ++ doexpensive if (not $ null todo) @@ -93,7 +94,7 @@ inAnnex r key = do a <- Annex.new r [] Annex.eval a (Core.inAnnex key) checkremote = do - Core.showNote ("checking " ++ Git.repoDescribe r ++ "...") + showNote ("checking " ++ Git.repoDescribe r ++ "...") inannex <- runCmd r "test" ["-e", annexLocation r key] -- XXX Note that ssh failing and the file not existing -- are not currently differentiated. @@ -228,7 +229,7 @@ sshLocation r file = (Git.urlHost r) ++ ":" ++ shellEscape file scp :: Git.Repo -> [String] -> Annex Bool scp r params = do scpoptions <- repoConfig r "scp-options" "" - Core.showProgress -- make way for scp progress bar + showProgress -- make way for scp progress bar liftIO $ boolSystem "scp" $ "-p":(words scpoptions) ++ params {- Runs a command in a remote, using ssh if necessary. -- cgit v1.2.3 From c281747b0eb39c10eb7bae0ea3202dca6077b74f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 16:40:02 -0400 Subject: add queueRun --- Annex.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/Annex.hs b/Annex.hs index 7c046b141..af761051d 100644 --- a/Annex.hs +++ b/Annex.hs @@ -20,6 +20,7 @@ module Annex ( Flag(..), queue, queueGet, + queueRun, setConfig ) where @@ -120,6 +121,15 @@ queueGet = do state <- get return (Internals.repoqueue state) +{- Runs (and empties) the queue. -} +queueRun :: Annex () +queueRun = do + state <- get + let q = Internals.repoqueue state + g <- gitRepo + liftIO $ GitQueue.run g q + put state { Internals.repoqueue = GitQueue.empty } + {- Changes a git config setting in both internal state and .git/config -} setConfig :: String -> String -> Annex () setConfig key value = do -- cgit v1.2.3 From 50ec22e322ecc0538a0629e32313c0d8ec4ffd45 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 16:40:28 -0400 Subject: set version on init --- Command/Init.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Command/Init.hs b/Command/Init.hs index fd55242a4..fa5725c48 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -15,6 +15,7 @@ import qualified Annex import Core import qualified GitRepo as Git import UUID +import Version import Messages {- Stores description for the repository etc. -} @@ -30,6 +31,7 @@ perform description = do g <- Annex.gitRepo u <- getUUID g describeUUID u description + setVersion liftIO $ gitAttributes g liftIO $ gitPreCommitHook g return $ Just $ cleanup -- cgit v1.2.3 From 98a77ab7256e484d29d67fcffc1f173fcb830f60 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 16:40:42 -0400 Subject: add --- Version.hs | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 Version.hs diff --git a/Version.hs b/Version.hs new file mode 100644 index 000000000..ce39c0c1b --- /dev/null +++ b/Version.hs @@ -0,0 +1,39 @@ +{- git-annex repository versioning + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Version where + +import Control.Monad.State (liftIO) +import System.Directory + +import Types +import qualified Annex +import qualified GitRepo as Git +import Locations + +currentVersion :: String +currentVersion = "1" + +versionField :: String +versionField = "annex.version" + +getVersion :: Annex (Maybe String) +getVersion = do + g <- Annex.gitRepo + let v = Git.configGet g versionField "" + if (not $ null v) + then return $ Just v + else do + -- version 0 was not recorded in .git/config; + -- such a repo should have an annexDir + d <- liftIO $ doesDirectoryExist $ annexDir g + if (d) + then return $ Just "0" + else return Nothing -- no version yet + +setVersion :: Annex () +setVersion = Annex.setConfig versionField currentVersion -- cgit v1.2.3 From ba59ac13b25d5be671e38cb7b4c40257f3fdac4f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 16:45:41 -0400 Subject: add showSideAction --- Messages.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Messages.hs b/Messages.hs index 89f78e244..ed4f3b90a 100644 --- a/Messages.hs +++ b/Messages.hs @@ -20,6 +20,9 @@ verbose a = do q <- Annex.flagIsSet "quiet" unless q a +showSideAction :: String -> Annex () +showSideAction s = verbose $ liftIO $ putStrLn $ "(" ++ s ++ ")" + showStart :: String -> String -> Annex () showStart command file = verbose $ do liftIO $ putStr $ command ++ " " ++ file ++ " " -- cgit v1.2.3 From 6395b790ce3d2f97803f0c642af71d1a9eb169c6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 16:47:36 -0400 Subject: Reorganised the layout of .git/annex/ --- Core.hs | 77 ++++++++++++++++++++++++++++++++++++++---------------- Locations.hs | 23 +++++++++------- debian/changelog | 10 ++++--- doc/git-annex.mdwn | 2 +- test.hs | 4 ++- 5 files changed, 78 insertions(+), 38 deletions(-) diff --git a/Core.hs b/Core.hs index 7aadfb5fb..90af62eb6 100644 --- a/Core.hs +++ b/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..." - liftIO $ GitQueue.run g q + showSideAction "Recording state in git..." + 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 - contents <- liftIO $ getDirectoryContents top - files <- liftIO $ filterM (isreg top) contents + getKeysPresent' $ annexObjectDir g +getKeysPresent' :: FilePath -> Annex [Key] +getKeysPresent' dir = do + contents <- liftIO $ getDirectoryContents dir + files <- liftIO $ filterM isreg contents return $ map fileKey files where - isreg top f = do - s <- getFileStatus $ top ++ "/" ++ f + isreg f = do + 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 - "0" -> do -- before there was repo versioning - upgradeNote "Upgrading object directory layout..." - - setVersion - v | v == currentVersion -> return () - _ -> error "this version of git-annex is too old for this git repository!" + -- do the reorganisation of the files + let olddir = annexDir g + keys <- getKeysPresent' olddir + _ <- mapM (\k -> moveToObjectDir 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 - currentVersion = "1" - setVersion = Annex.setConfig field currentVersion - field = "annex.version" - upgradeNote s = verbose $ liftIO $ putStrLn $ "("++s++")" + 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/Locations.hs b/Locations.hs index 78c0bff4b..e5f78a31c 100644 --- a/Locations.hs +++ b/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 - - /path/to/repo/.git/annex/objects//, where is of the form - - - - - - That allows deriving the key and backend by looking at the symlink to it. - -} +{- Annexed file's absolute location. -} 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 - where f = keyFile key +annexLocationRelative key = ".git/annex/objects/" ++ f ++ "/" ++ f + 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" diff --git a/debian/changelog b/debian/changelog index 49aa9829a..dc9dcedc2 100644 --- a/debian/changelog +++ b/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. - * Reorganised the layout of .git/annex/ , moving cached file contents - to .git/annex/objects// + * Add annex.version, which will be used to automate upgrades + between incompatable versions. + * 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 Mon, 08 Nov 2010 12:36:39 -0400 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 6f2c85d57..6a580f005 100644 --- a/doc/git-annex.mdwn +++ b/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 diff --git a/test.hs b/test.hs index 989723617..288532d7b 100644 --- a/test.hs +++ b/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) -- cgit v1.2.3 From 40a815d873a828fbccee453f45fc519feffe15fd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 17:44:08 -0400 Subject: add unsetFileMode --- Utility.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/Utility.hs b/Utility.hs index 4e56289e2..0053c687b 100644 --- a/Utility.hs +++ b/Utility.hs @@ -11,17 +11,21 @@ module Utility ( relPathCwdToDir, relPathDirToDir, boolSystem, - shellEscape + shellEscape, + unsetFileMode ) where import System.IO import System.Exit import System.Posix.Process import System.Posix.Signals +import System.Posix.Files +import System.Posix.Types import Data.String.Utils import System.Path import System.FilePath import System.Directory +import Foreign (complement) {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} @@ -115,3 +119,10 @@ shellEscape f = "'" ++ escaped ++ "'" where -- replace ' with '"'"' escaped = join "'\"'\"'" $ split "'" f + +{- Removes a FileMode from a file. + - For example, call with otherWriteMode to chmod o-w -} +unsetFileMode :: FilePath -> FileMode -> IO () +unsetFileMode f m = do + s <- getFileStatus f + setFileMode f $ (fileMode s) `intersectFileModes` (complement m) -- cgit v1.2.3 From 8dd9f8e49eae081e7503facff6d5a53285194c09 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 17:44:30 -0400 Subject: typo --- Locations.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Locations.hs b/Locations.hs index e5f78a31c..58244cef0 100644 --- a/Locations.hs +++ b/Locations.hs @@ -81,4 +81,4 @@ fileKey file = read $ {- for quickcheck -} prop_idempotent_fileKey :: String -> Bool prop_idempotent_fileKey s = k == (fileKey $ keyFile k) - where k = read "test:s" + where k = read $ "test:" ++ s -- cgit v1.2.3 From 1d32d902c95a49c53c46951641852c209476cb3d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 8 Nov 2010 19:26:37 -0400 Subject: Annexed file contents are now made unwritable and put in unwriteable directories, to avoid them accidentially being removed or modified. (Thanks Josh Triplett for the idea.) --- Command/Add.hs | 9 ++---- Command/Drop.hs | 17 +++-------- Command/DropKey.hs | 8 +----- Command/SetKey.hs | 22 +++++++-------- Command/Unannex.hs | 9 +++--- Core.hs | 53 ++++++++++++++++++++++++++++++----- debian/changelog | 3 ++ doc/todo/immutable_annexed_files.mdwn | 2 ++ 8 files changed, 74 insertions(+), 49 deletions(-) diff --git a/Command/Add.hs b/Command/Add.hs index 3cc681f69..6c5d24f84 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -9,12 +9,9 @@ module Command.Add where import Control.Monad.State (liftIO) import System.Posix.Files -import System.Directory import Command import qualified Annex -import Utility -import Locations import qualified Backend import LocationLog import Types @@ -42,11 +39,9 @@ perform (file, backend) = do cleanup :: FilePath -> Key -> SubCmdCleanup cleanup file key = do + moveAnnex key file logStatus key ValuePresent - g <- Annex.gitRepo - let dest = annexLocation g key - liftIO $ createDirectoryIfMissing True (parentDir dest) - liftIO $ renameFile file dest + link <- calcGitLink file key liftIO $ createSymbolicLink link file Annex.queue "add" [] file diff --git a/Command/Drop.hs b/Command/Drop.hs index d1ebd7f64..48433b14c 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -7,12 +7,9 @@ module Command.Drop where -import Control.Monad.State (liftIO) -import System.Directory +import Control.Monad (when) import Command -import qualified Annex -import Locations import qualified Backend import LocationLog import Types @@ -39,13 +36,7 @@ perform key backend = do cleanup :: Key -> SubCmdCleanup cleanup key = do - logStatus key ValueMissing inannex <- inAnnex key - if (inannex) - then do - g <- Annex.gitRepo - let loc = annexLocation g key - liftIO $ removeFile loc - return True - else return True - + when (inannex) $ removeAnnex key + logStatus key ValueMissing + return True diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 8076e6fd3..e0b20918c 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -7,12 +7,8 @@ module Command.DropKey where -import Control.Monad.State (liftIO) -import System.Directory - import Command import qualified Annex -import Locations import qualified Backend import LocationLog import Types @@ -36,9 +32,7 @@ start keyname = do perform :: Key -> SubCmdPerform perform key = do - g <- Annex.gitRepo - let loc = annexLocation g key - liftIO $ removeFile loc + removeAnnex key return $ Just $ cleanup key cleanup :: Key -> SubCmdCleanup diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 9286e740b..50e9a590b 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -13,7 +13,6 @@ import Control.Monad (when) import Command import qualified Annex import Utility -import Locations import qualified Backend import LocationLog import Types @@ -22,21 +21,22 @@ import Messages {- Sets cached content for a key. -} start :: SubCmdStartString -start tmpfile = do +start file = do keyname <- Annex.flagGet "key" when (null keyname) $ error "please specify the key with --key" backends <- Backend.list let key = genKey (backends !! 0) keyname - showStart "setkey" tmpfile - return $ Just $ perform tmpfile key + showStart "setkey" file + return $ Just $ perform file key perform :: FilePath -> Key -> SubCmdPerform -perform tmpfile key = do - g <- Annex.gitRepo - let loc = annexLocation g key - ok <- liftIO $ boolSystem "mv" [tmpfile, loc] - if (not ok) - then error "mv failed!" - else return $ Just $ cleanup key +perform file key = do + -- the file might be on a different filesystem, so mv is used + -- rather than simply calling moveToObjectDir key file + ok <- getViaTmp key $ \dest -> liftIO $ boolSystem "mv" [file, dest] + if ok + then return $ Just $ cleanup key + else error "mv failed!" + cleanup :: Key -> SubCmdCleanup cleanup key = do logStatus key ValuePresent diff --git a/Command/Unannex.hs b/Command/Unannex.hs index e0848cd4a..a9c18f765 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -13,7 +13,6 @@ import System.Directory import Command import qualified Annex import Utility -import Locations import qualified Backend import LocationLog import Types @@ -38,12 +37,14 @@ perform file key backend = do cleanup :: FilePath -> Key -> SubCmdCleanup cleanup file key = do - logStatus key ValueMissing g <- Annex.gitRepo - let src = annexLocation g key + liftIO $ removeFile file liftIO $ Git.run g ["rm", "--quiet", file] -- git rm deletes empty directories; put them back liftIO $ createDirectoryIfMissing True (parentDir file) - liftIO $ renameFile src file + + fromAnnex key file + logStatus key ValueMissing + return True diff --git a/Core.hs b/Core.hs index 90af62eb6..f04a3dfac 100644 --- a/Core.hs +++ b/Core.hs @@ -144,7 +144,7 @@ getViaTmp key action = do success <- action tmp if (success) then do - moveToObjectDir key tmp + moveAnnex key tmp logStatus key ValuePresent return True else do @@ -152,14 +152,53 @@ getViaTmp key action = do -- to resume its transfer return False +{- Removes the write bits from a file. -} +preventWrite :: FilePath -> IO () +preventWrite f = unsetFileMode f writebits + where + writebits = foldl unionFileModes ownerWriteMode + [groupWriteMode, otherWriteMode] + +{- Turns a file's write bit back on. -} +allowWrite :: FilePath -> IO () +allowWrite f = do + s <- getFileStatus f + setFileMode f $ (fileMode s) `unionFileModes` ownerWriteMode + {- Moves a file into .git/annex/objects/ -} -moveToObjectDir :: Key -> FilePath -> Annex () -moveToObjectDir key src = do +moveAnnex :: Key -> FilePath -> Annex () +moveAnnex 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 + let dir = parentDir dest + liftIO $ do + createDirectoryIfMissing True dir + renameFile src dest + preventWrite dest + preventWrite dir + +{- Removes a key's file from .git/annex/objects/ -} +removeAnnex :: Key -> Annex () +removeAnnex key = do + g <- Annex.gitRepo + let file = annexLocation g key + let dir = parentDir file + liftIO $ do + allowWrite dir + removeFile file + removeDirectory dir + +{- Moves a key's file out of .git/annex/objects/ -} +fromAnnex :: Key -> FilePath -> Annex () +fromAnnex key dest = do + g <- Annex.gitRepo + let file = annexLocation g key + let dir = parentDir file + liftIO $ do + allowWrite dir + allowWrite file + renameFile file dest + removeDirectory dir {- List of keys whose content exists in .git/annex/objects/ -} getKeysPresent :: Annex [Key] @@ -202,7 +241,7 @@ upgradeFrom0 = do -- do the reorganisation of the files let olddir = annexDir g keys <- getKeysPresent' olddir - _ <- mapM (\k -> moveToObjectDir k $ olddir ++ "/" ++ keyFile k) keys + _ <- mapM (\k -> moveAnnex k $ olddir ++ "/" ++ keyFile k) keys -- update the symlinks to the files files <- liftIO $ Git.inRepo g $ Git.workTree g diff --git a/debian/changelog b/debian/changelog index dc9dcedc2..1ce6a2deb 100644 --- a/debian/changelog +++ b/debian/changelog @@ -8,6 +8,9 @@ git-annex (0.04) UNRELEASED; urgency=low 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. + * Annexed file contents are now made unwritable and put in unwriteable + directories, to avoid them accidentially being removed or modified. + (Thanks Josh Triplett for the idea.) -- Joey Hess Mon, 08 Nov 2010 12:36:39 -0400 diff --git a/doc/todo/immutable_annexed_files.mdwn b/doc/todo/immutable_annexed_files.mdwn index e5207dc16..b26838e95 100644 --- a/doc/todo/immutable_annexed_files.mdwn +++ b/doc/todo/immutable_annexed_files.mdwn @@ -4,3 +4,5 @@ > josh: Oh, I just thought of another slightly crazy but handy idea. > josh: I'd hate to run into a program which somehow followed the symlink and then did an unlink to replace the file. > josh: To break that, you could create a new directory under annex's internal directory for each file, and make the directory have no write permission. + +[[done]] and done --[[Joey]] -- cgit v1.2.3 From 8d5374f4a33f398baa166035e5fafb716a78fd1d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 9 Nov 2010 15:04:13 -0400 Subject: tweak --- Core.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Core.hs b/Core.hs index f04a3dfac..304c8a923 100644 --- a/Core.hs +++ b/Core.hs @@ -235,7 +235,7 @@ autoUpgrade = do upgradeFrom0 :: Annex () upgradeFrom0 = do - showSideAction "Upgrading object directory layout for git-annex 0.04..." + showSideAction "Upgrading object directory layout..." g <- Annex.gitRepo -- do the reorganisation of the files -- cgit v1.2.3