summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-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.hs1
-rw-r--r--Command/Drop.hs1
-rw-r--r--Command/DropKey.hs1
-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.hs1
-rw-r--r--Command/Move.hs5
-rw-r--r--Command/SetKey.hs1
-rw-r--r--Command/Unannex.hs1
-rw-r--r--Core.hs66
-rw-r--r--Messages.hs54
-rw-r--r--Remotes.hs7
19 files changed, 105 insertions, 74 deletions
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 <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
+
+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.