summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2010-11-09 15:05:08 -0400
committerGravatar Joey Hess <joey@kitenet.net>2010-11-09 15:05:08 -0400
commit75d29250823326c8b4894a855927f65b5fdf4e13 (patch)
treea888b86d8e0569b9e1c388700dd6717aaa175834
parent377bf24d9a951186b374cd7a3f920b6bc9deb8f1 (diff)
parent8d5374f4a33f398baa166035e5fafb716a78fd1d (diff)
Merge branch 'master' into checkout
Conflicts: debian/changelog doc/backends.mdwn
-rw-r--r--Annex.hs22
-rw-r--r--Backend.hs2
-rw-r--r--Backend/File.hs1
-rw-r--r--Backend/SHA1.hs2
-rw-r--r--Backend/URL.hs2
-rw-r--r--Command.hs2
-rw-r--r--Command/Add.hs10
-rw-r--r--Command/Drop.hs18
-rw-r--r--Command/DropKey.hs9
-rw-r--r--Command/Fix.hs1
-rw-r--r--Command/FromKey.hs1
-rw-r--r--Command/Fsck.hs29
-rw-r--r--Command/Get.hs1
-rw-r--r--Command/Init.hs3
-rw-r--r--Command/Move.hs5
-rw-r--r--Command/SetKey.hs23
-rw-r--r--Command/Unannex.hs10
-rw-r--r--Core.hs162
-rw-r--r--Locations.hs28
-rw-r--r--Messages.hs57
-rw-r--r--Remotes.hs7
-rw-r--r--UUID.hs13
-rw-r--r--Utility.hs13
-rw-r--r--Version.hs39
-rw-r--r--debian/changelog13
-rw-r--r--debian/control2
-rw-r--r--doc/backends.mdwn13
-rw-r--r--doc/git-annex.mdwn4
-rw-r--r--doc/todo/immutable_annexed_files.mdwn2
-rw-r--r--test.hs4
30 files changed, 345 insertions, 153 deletions
diff --git a/Annex.hs b/Annex.hs
index e86e1967e..af761051d 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -19,7 +19,9 @@ module Annex (
flagGet,
Flag(..),
queue,
- queueGet
+ queueGet,
+ queueRun,
+ setConfig
) where
import Control.Monad.State
@@ -118,3 +120,21 @@ queueGet :: Annex GitQueue.Queue
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
+ 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/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..6c5d24f84 100644
--- a/Command/Add.hs
+++ b/Command/Add.hs
@@ -9,16 +9,14 @@ 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
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
@@ -41,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 6cdf216f4..48433b14c 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -7,16 +7,14 @@
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
import Core
+import Messages
{- Indicates a file's content is not wanted anymore, and should be removed
- if it's safe to do so. -}
@@ -38,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 bdd9b55b1..e0b20918c 100644
--- a/Command/DropKey.hs
+++ b/Command/DropKey.hs
@@ -7,16 +7,13 @@
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
import Core
+import Messages
{- Drops cached content for a key. -}
start :: SubCmdStartString
@@ -35,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/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..fa5725c48 100644
--- a/Command/Init.hs
+++ b/Command/Init.hs
@@ -15,6 +15,8 @@ import qualified Annex
import Core
import qualified GitRepo as Git
import UUID
+import Version
+import Messages
{- Stores description for the repository etc. -}
start :: SubCmdStartString
@@ -29,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
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..50e9a590b 100644
--- a/Command/SetKey.hs
+++ b/Command/SetKey.hs
@@ -13,29 +13,30 @@ import Control.Monad (when)
import Command
import qualified Annex
import Utility
-import Locations
import qualified Backend
import LocationLog
import Types
import Core
+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 5cffb2d89..a9c18f765 100644
--- a/Command/Unannex.hs
+++ b/Command/Unannex.hs
@@ -13,12 +13,12 @@ import System.Directory
import Command
import qualified Annex
import Utility
-import Locations
import qualified Backend
import LocationLog
import Types
import Core
import qualified GitRepo as Git
+import Messages
{- The unannex subcommand undoes an add. -}
start :: SubCmdStartString
@@ -37,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 f34b2ebbe..304c8a923 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,10 @@ import UUID
import qualified GitRepo as Git
import qualified GitQueue
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,21 +49,20 @@ tryRun' _ errnum [] =
startup :: Annex Bool
startup = do
prepUUID
+ autoUpgrade
return True
{- 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
@@ -137,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
+ moveAnnex key tmp
logStatus key ValuePresent
return True
else do
@@ -151,36 +152,113 @@ getViaTmp key action = do
-- to resume its transfer
return False
-{- 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
+{- 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/ -}
+moveAnnex :: Key -> FilePath -> Annex ()
+moveAnnex key src = do
+ g <- Annex.gitRepo
+ let dest = annexLocation g key
+ 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]
+getKeysPresent = do
+ g <- Annex.gitRepo
+ 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 f = do
+ s <- getFileStatus $ dir ++ "/" ++ 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
+ 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
- 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
+ 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 951924c40..58244cef0 100644
--- a/Locations.hs
+++ b/Locations.hs
@@ -13,7 +13,10 @@ module Locations (
annexLocation,
annexLocationRelative,
annexTmpLocation,
- annexDir
+ annexDir,
+ annexObjectDir,
+
+ prop_idempotent_fileKey
) where
import Data.String.Utils
@@ -28,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/<key>, where <key> is of the form
- - <backend:fragment>
- -
- - 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)
@@ -42,7 +40,9 @@ 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 +50,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/"
@@ -65,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/Messages.hs b/Messages.hs
new file mode 100644
index 000000000..ed4f3b90a
--- /dev/null
+++ b/Messages.hs
@@ -0,0 +1,57 @@
+{- git-annex output messages
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - 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
+
+showSideAction :: String -> Annex ()
+showSideAction s = verbose $ liftIO $ putStrLn $ "(" ++ s ++ ")"
+
+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.
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/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)
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 <joey@kitenet.net>
+ -
+ - 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
diff --git a/debian/changelog b/debian/changelog
index 9205dbe06..fa8bb0f93 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -3,8 +3,19 @@ git-annex (0.04) UNRELEASED; urgency=low
* Add checkout subcommand, which allows checking out file content
in preparation of changing it.
* Add uncheckout subcommand.
+ * Add build dep on libghc6-testpack-dev.
+ * 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.
+ * 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 <joeyh@debian.org> Sun, 07 Nov 2010 21:01:29 -0400
+ -- Joey Hess <joeyh@debian.org> Mon, 08 Nov 2010 12:36:39 -0400
git-annex (0.03) unstable; urgency=low
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 <joeyh@debian.org>
Standards-Version: 3.9.1
Vcs-Git: git://git.kitenet.net/git-annex
diff --git a/doc/backends.mdwn b/doc/backends.mdwn
index 69c17649a..be4eac723 100644
--- a/doc/backends.mdwn
+++ b/doc/backends.mdwn
@@ -10,14 +10,15 @@ 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.
+ for use.
* `URL` -- This backend downloads the file's content from an external URL.
The `annex.backends` git-config setting can be used to list the backends
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index 80680820f..3bb3b0835 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -219,6 +219,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,
@@ -233,7 +235,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/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]]
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)