diff options
| -rw-r--r-- | Backend.hs | 2 | ||||
| -rw-r--r-- | Backend/File.hs | 1 | ||||
| -rw-r--r-- | Backend/SHA1.hs | 2 | ||||
| -rw-r--r-- | Backend/URL.hs | 2 | ||||
| -rw-r--r-- | Command.hs | 2 | ||||
| -rw-r--r-- | Command/Add.hs | 1 | ||||
| -rw-r--r-- | Command/Drop.hs | 1 | ||||
| -rw-r--r-- | Command/DropKey.hs | 1 | ||||
| -rw-r--r-- | Command/Fix.hs | 1 | ||||
| -rw-r--r-- | Command/FromKey.hs | 1 | ||||
| -rw-r--r-- | Command/Fsck.hs | 29 | ||||
| -rw-r--r-- | Command/Get.hs | 1 | ||||
| -rw-r--r-- | Command/Init.hs | 1 | ||||
| -rw-r--r-- | Command/Move.hs | 5 | ||||
| -rw-r--r-- | Command/SetKey.hs | 1 | ||||
| -rw-r--r-- | Command/Unannex.hs | 1 | ||||
| -rw-r--r-- | Core.hs | 66 | ||||
| -rw-r--r-- | Messages.hs | 54 | ||||
| -rw-r--r-- | Remotes.hs | 7 |
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 @@ -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. |