summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex.hs3
-rw-r--r--Backend/File.hs5
-rw-r--r--Commands.hs54
-rw-r--r--Core.hs23
-rw-r--r--GitQueue.hs5
-rw-r--r--GitRepo.hs173
-rw-r--r--LocationLog.hs2
-rw-r--r--Remotes.hs29
-rw-r--r--UUID.hs14
-rw-r--r--Utility.hs34
-rw-r--r--debian/changelog8
-rw-r--r--doc/bugs/scp_interrupt_to_background.mdwn2
-rw-r--r--doc/git-annex.mdwn4
-rw-r--r--git-annex.hs11
14 files changed, 184 insertions, 183 deletions
diff --git a/Annex.hs b/Annex.hs
index 0e8ec2b7b..60ae91708 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -61,7 +61,6 @@ gitRepoChange :: Git.Repo -> Annex ()
gitRepoChange r = do
state <- get
put state { Internals.repo = r }
- return ()
{- Returns the backends being used. -}
backends :: Annex [Backend]
@@ -74,7 +73,6 @@ backendsChange :: [Backend] -> Annex ()
backendsChange b = do
state <- get
put state { Internals.backends = b }
- return ()
{- Returns the full list of supported backends. -}
supportedBackends :: Annex [Backend]
@@ -95,7 +93,6 @@ flagChange :: FlagName -> Flag -> Annex ()
flagChange name val = do
state <- get
put state { Internals.flags = M.insert name val $ Internals.flags state }
- return ()
{- Gets the value of a String flag (or "" if there is no such String flag) -}
flagGet :: FlagName -> Annex String
diff --git a/Backend/File.hs b/Backend/File.hs
index 4b9a3b45b..b45354752 100644
--- a/Backend/File.hs
+++ b/Backend/File.hs
@@ -129,7 +129,7 @@ checkRemoveKey key = do
"Could only verify the existence of " ++
(show have) ++ " out of " ++ (show need) ++
" necessary copies"
- if (not $ null bad) then showTriedRemotes bad else return ()
+ showTriedRemotes bad
showLocations key
hint
return False
@@ -146,7 +146,8 @@ showLocations key = do
if (null uuidsf)
then showLongNote $ "No other repository is known to contain the file."
else showLongNote $ "Try making some of these repositories available:\n" ++ ppuuids
-
+
+showTriedRemotes [] = return ()
showTriedRemotes remotes =
showLongNote $ "I was unable to access these remotes: " ++
(Remotes.list remotes)
diff --git a/Commands.hs b/Commands.hs
index 6974b697c..41e9ad54d 100644
--- a/Commands.hs
+++ b/Commands.hs
@@ -14,6 +14,7 @@ import System.Directory
import System.Path
import Data.String.Utils
import Control.Monad (filterM)
+import Monad (when, unless)
import List
import IO
@@ -115,6 +116,8 @@ options = [
"allow actions that may lose annexed data"
, Option ['q'] ["quiet"] (NoArg (storebool "quiet" True))
"avoid verbose output"
+ , Option ['v'] ["verbose"] (NoArg (storebool "quiet" False))
+ "allow verbose output"
, Option ['b'] ["backend"] (ReqArg (storestring "backend") "NAME")
"specify default key-value backend to use"
, Option ['k'] ["key"] (ReqArg (storestring "key") "KEY")
@@ -165,7 +168,7 @@ findWanted FilesMissing params repo = do
where
missing f = do
e <- doesFileExist f
- if (e) then return False else return True
+ return $ not e
findWanted Description params _ = do
return $ [unwords params]
findWanted FilesToBeCommitted params repo = do
@@ -188,19 +191,18 @@ findWanted _ params _ = return params
parseCmd :: [String] -> AnnexState -> IO ([Annex Bool], [Annex Bool])
parseCmd argv state = do
(flags, params) <- getopt
- if (null params)
- then error usage
- else case (lookupCmd (params !! 0)) of
- [] -> error usage
- [Command name action want _] -> do
- f <- findWanted want (drop 1 params)
- (TypeInternals.repo state)
- let actions = map (doSubCmd name action) $
- filter notstate f
- let configactions = map (\f -> do
- f
- return True) flags
- return (configactions, actions)
+ when (null params) $ error usage
+ case lookupCmd (params !! 0) of
+ [] -> error usage
+ [Command name action want _] -> do
+ f <- findWanted want (drop 1 params)
+ (TypeInternals.repo state)
+ let actions = map (doSubCmd name action) $
+ filter notstate f
+ let configactions = map (\f -> do
+ f
+ return True) flags
+ return (configactions, actions)
where
-- never include files from the state directory
notstate f = stateLoc /= take (length stateLoc) f
@@ -270,7 +272,7 @@ getPerform :: FilePath -> Key -> Backend -> Annex (Maybe SubCmdCleanup)
getPerform file key backend = do
ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
if (ok)
- then return $ Just $ return True
+ then return $ Just $ return True -- no cleanup needed
else return Nothing
{- Indicates a file's content is not wanted anymore, and should be removed
@@ -326,9 +328,7 @@ dropKeyCleanup key = do
setKeyStart :: FilePath -> Annex (Maybe SubCmdPerform)
setKeyStart tmpfile = do
keyname <- Annex.flagGet "key"
- if (null keyname)
- then error "please specify the key with --key"
- else return ()
+ when (null keyname) $ error "please specify the key with --key"
backends <- Backend.list
let key = genKey (backends !! 0) keyname
return $ Just $ setKeyPerform tmpfile key
@@ -367,11 +367,9 @@ fixCleanup file = do
{- Stores description for the repository etc. -}
initStart :: String -> Annex (Maybe SubCmdPerform)
initStart description = do
- if (null description)
- then error $
- "please specify a description of this repository\n" ++
- usage
- else return $ Just $ initPerform description
+ when (null description) $ error $
+ "please specify a description of this repository\n" ++ usage
+ return $ Just $ initPerform description
initPerform :: String -> Annex (Maybe SubCmdCleanup)
initPerform description = do
g <- Annex.gitRepo
@@ -392,16 +390,14 @@ initCleanup = do
fromKeyStart :: FilePath -> Annex (Maybe SubCmdPerform)
fromKeyStart file = do
keyname <- Annex.flagGet "key"
- if (null keyname)
- then error "please specify the key with --key"
- else return ()
+ when (null keyname) $ error "please specify the key with --key"
backends <- Backend.list
let key = genKey (backends !! 0) keyname
inbackend <- Backend.hasKey key
- if (not inbackend)
- then error $ "key ("++keyname++") is not present in backend"
- else return $ Just $ fromKeyPerform file key
+ unless (inbackend) $ error $
+ "key ("++keyname++") is not present in backend"
+ return $ Just $ fromKeyPerform file key
fromKeyPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
fromKeyPerform file key = do
link <- calcGitLink file key
diff --git a/Core.hs b/Core.hs
index e0993a53e..cf97768c7 100644
--- a/Core.hs
+++ b/Core.hs
@@ -13,6 +13,7 @@ import System.Directory
import Control.Monad.State (liftIO)
import System.Path
import Data.String.Utils
+import Monad (when, unless)
import Types
import Locations
@@ -37,19 +38,15 @@ shutdown = do
-- Runs all queued git commands.
q <- Annex.queueGet
- if (q == GitQueue.empty)
- then return ()
- else do
- verbose $ liftIO $ putStrLn "Recording state in git..."
- liftIO $ GitQueue.run g q
+ unless (q == GitQueue.empty) $ do
+ verbose $ liftIO $ putStrLn "Recording state in git..."
+ liftIO $ GitQueue.run g q
-- clean up any files left in the temp directory, but leave
-- the tmp directory itself
let tmp = annexTmpLocation g
exists <- liftIO $ doesDirectoryExist tmp
- if (exists)
- then liftIO $ removeDirectoryRecursive $ tmp
- else return ()
+ when (exists) $ liftIO $ removeDirectoryRecursive $ tmp
liftIO $ createDirectoryIfMissing True tmp
return True
@@ -65,11 +62,9 @@ gitAttributes repo = do
commit
else do
content <- readFile attributes
- if (all (/= attrLine) (lines content))
- then do
- appendFile attributes $ attrLine ++ "\n"
- commit
- else return ()
+ when (all (/= attrLine) (lines content)) $ do
+ appendFile attributes $ attrLine ++ "\n"
+ commit
where
attrLine = stateLoc ++ "*.log merge=union"
attributes = Git.attributes repo
@@ -150,7 +145,7 @@ getViaTmp key action = do
verbose :: Annex () -> Annex ()
verbose a = do
q <- Annex.flagIsSet "quiet"
- if (q) then return () else a
+ unless q a
showStart :: String -> String -> Annex ()
showStart command file = verbose $ do
liftIO $ putStr $ command ++ " " ++ file ++ " "
diff --git a/GitQueue.hs b/GitQueue.hs
index 6a68edb25..09b8037e6 100644
--- a/GitQueue.hs
+++ b/GitQueue.hs
@@ -16,6 +16,7 @@ import qualified Data.Map as M
import System.IO
import System.Cmd.Utils
import Data.String.Utils
+import Monad (unless)
import qualified GitRepo as Git
@@ -52,9 +53,7 @@ run repo queue = do
- Complicated by commandline length limits. -}
runAction :: Git.Repo -> Action -> [FilePath] -> IO ()
runAction repo action files = do
- if (null files)
- then return ()
- else runxargs
+ unless (null files) runxargs
where
runxargs = pOpen WriteToPipe "xargs"
(["-0", "git", subcommand action] ++ (params action))
diff --git a/GitRepo.hs b/GitRepo.hs
index 229b76847..fd69ec21a 100644
--- a/GitRepo.hs
+++ b/GitRepo.hs
@@ -24,6 +24,7 @@ module GitRepo (
configGet,
configMap,
configRead,
+ configTrue,
run,
pipeRead,
attributes,
@@ -47,52 +48,46 @@ import Data.String.Utils
import Data.Map as Map hiding (map, split)
import Network.URI
import Maybe
+import Char
import Utility
{- There are two types of repositories; those on local disk and those
- accessed via an URL. -}
-data Repo =
- Repo {
- top :: FilePath,
- config :: Map String String,
- remotes :: [Repo],
- -- remoteName holds the name used for this repo in remotes
- remoteName :: Maybe String
- } | UrlRepo {
- url :: URI,
- config :: Map String String,
- remotes :: [Repo],
- remoteName :: Maybe String
- } deriving (Show, Eq)
+data RepoLocation = Dir FilePath | Url URI
+ deriving (Show, Eq)
-{- Local Repo constructor. -}
-repoFromPath :: FilePath -> Repo
-repoFromPath dir =
+data Repo = Repo {
+ location :: RepoLocation,
+ config :: Map String String,
+ remotes :: [Repo],
+ -- remoteName holds the name used for this repo in remotes
+ remoteName :: Maybe String
+} deriving (Show, Eq)
+
+newFrom l =
Repo {
- top = dir,
+ location = l,
config = Map.empty,
remotes = [],
remoteName = Nothing
}
+{- Local Repo constructor. -}
+repoFromPath :: FilePath -> Repo
+repoFromPath dir = newFrom $ Dir dir
+
{- Remote Repo constructor. Throws exception on invalid url. -}
repoFromUrl :: String -> Repo
-repoFromUrl url =
- UrlRepo {
- url = fromJust $ parseURI url,
- config = Map.empty,
- remotes = [],
- remoteName = Nothing
- }
+repoFromUrl url
+ | startswith "file://" url = repoFromPath $ uriPath u
+ | otherwise = newFrom $ Url u
+ where u = fromJust $ parseURI url
{- User-visible description of a git repo. -}
-repoDescribe repo =
- if (isJust $ remoteName repo)
- then fromJust $ remoteName repo
- else if (not $ repoIsUrl repo)
- then top repo
- else show (url repo)
+repoDescribe Repo { remoteName = Just name } = name
+repoDescribe Repo { location = Url url } = show url
+repoDescribe Repo { location = Dir dir } = dir
{- Constructs and returns an updated version of a repo with
- different remotes list. -}
@@ -101,17 +96,19 @@ remotesAdd repo rs = repo { remotes = rs }
{- Returns the name of the remote that corresponds to the repo, if
- it is a remote. Otherwise, "" -}
-repoRemoteName r =
- if (isJust $ remoteName r)
- then fromJust $ remoteName r
- else ""
+repoRemoteName Repo { remoteName = Just name } = name
+repoRemoteName _ = ""
{- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -}
-repoIsUrl repo = case (repo) of
- UrlRepo {} -> True
- Repo {} -> False
-repoIsSsh repo = repoIsUrl repo && (uriScheme $ url repo) == "ssh:"
+repoIsUrl Repo { location = Url _ } = True
+repoIsUrl _ = False
+
+repoIsSsh Repo { location = Url url }
+ | uriScheme url == "ssh:" = True
+ | otherwise = False
+repoIsSsh _ = False
+
assertLocal repo action =
if (not $ repoIsUrl repo)
then action
@@ -122,77 +119,74 @@ assertUrl repo action =
then action
else error $ "acting on local git repo " ++ (repoDescribe repo) ++
" not supported"
-assertssh repo action =
+assertSsh repo action =
if (repoIsSsh repo)
then action
- else error $ "unsupported url " ++ (show $ url repo)
+ else error $ "unsupported url in repo " ++ (repoDescribe repo)
bare :: Repo -> Bool
-bare repo =
- if (member b (config repo))
- then ("true" == fromJust (Map.lookup b (config repo)))
- else error $ "it is not known if git repo " ++ (repoDescribe repo) ++
+bare repo = case Map.lookup "core.bare" $ config repo of
+ Just v -> configTrue v
+ Nothing -> error $ "it is not known if git repo " ++
+ (repoDescribe repo) ++
" is a bare repository; config not read"
- where
- b = "core.bare"
{- Path to a repository's gitattributes file. -}
attributes :: Repo -> String
-attributes repo = assertLocal repo $ do
- if (bare repo)
- then (top repo) ++ "/info/.gitattributes"
- else (top repo) ++ "/.gitattributes"
+attributes repo
+ | bare repo = (workTree repo) ++ "/info/.gitattributes"
+ | otherwise = (workTree repo) ++ "/.gitattributes"
{- Path to a repository's .git directory, relative to its workTree. -}
dir :: Repo -> String
-dir repo = if (bare repo) then "" else ".git"
+dir repo
+ | bare repo = ""
+ | otherwise = ".git"
{- Path to a repository's --work-tree, that is, its top.
-
- - Note that for URL repositories, this is relative to the urlHost -}
+ - Note that for URL repositories, this is the path on the remote host. -}
workTree :: Repo -> FilePath
-workTree repo =
- if (not $ repoIsUrl repo)
- then top repo
- else urlPath repo
+workTree r@(Repo { location = Url _ }) = urlPath r
+workTree (Repo { location = Dir d }) = d
{- Given a relative or absolute filename in a repository, calculates the
- name to use to refer to the file relative to a git repository's top.
- This is the same form displayed and used by git. -}
relative :: Repo -> String -> String
-relative repo file = assertLocal repo $ drop (length absrepo) absfile
+relative repo@(Repo { location = Dir d }) file = drop (length absrepo) absfile
where
-- normalize both repo and file, so that repo
-- will be substring of file
- absrepo = case (absNormPath "/" (top repo)) of
+ absrepo = case (absNormPath "/" d) of
Just f -> f ++ "/"
- Nothing -> error $ "bad repo" ++ (top repo)
+ Nothing -> error $ "bad repo" ++ (repoDescribe repo)
absfile = case (secureAbsNormPath absrepo file) of
Just f -> f
Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
+relative repo file = assertLocal repo $ error "internal"
{- Hostname of an URL repo. (May include a username and/or port too.) -}
urlHost :: Repo -> String
-urlHost repo = assertUrl repo $
- (uriUserInfo a) ++ (uriRegName a) ++ (uriPort a)
- where
- a = fromJust $ uriAuthority $ url repo
+urlHost Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a
+ where a = fromJust $ uriAuthority $ u
+urlHost repo = assertUrl repo $ error "internal"
{- Path of an URL repo. -}
urlPath :: Repo -> String
-urlPath repo = assertUrl repo $
- uriPath $ url repo
+urlPath Repo { location = Url u } = uriPath u
+urlPath repo = assertUrl repo $ error "internal"
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: Repo -> [String] -> [String]
-gitCommandLine repo params = assertLocal repo $
+gitCommandLine repo@(Repo { location = Dir d} ) params =
-- force use of specified repo via --git-dir and --work-tree
- ["--git-dir="++(top repo)++"/"++(dir repo), "--work-tree="++(top repo)] ++ params
+ ["--git-dir="++d++"/"++(dir repo), "--work-tree="++d] ++ params
+gitCommandLine repo _ = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -}
run :: Repo -> [String] -> IO ()
run repo params = assertLocal repo $ do
- r <- safeSystem "git" (gitCommandLine repo params)
- return ()
+ safeSystem "git" (gitCommandLine repo params)
{- Runs a git subcommand and returns its output. -}
pipeRead :: Repo -> [String] -> IO String
@@ -217,23 +211,27 @@ notInRepo repo location = do
{- Runs git config and populates a repo with its config. -}
configRead :: Repo -> IO Repo
-configRead repo =
- if (not $ repoIsUrl repo)
- then do
- {- Cannot use pipeRead because it relies on the config having
- been already read. Instead, chdir to the repo. -}
- cwd <- getCurrentDirectory
- bracket_ (changeWorkingDirectory (top repo))
- (\_ -> changeWorkingDirectory cwd) $
- pOpen ReadFromPipe "git" ["config", "--list"] proc
- else assertssh repo $ do
- pOpen ReadFromPipe "ssh" [urlHost repo, sshcommand] proc
+configRead repo@(Repo { location = Dir d }) = do
+ {- Cannot use pipeRead because it relies on the config having
+ been already read. Instead, chdir to the repo. -}
+ cwd <- getCurrentDirectory
+ bracket_ (changeWorkingDirectory d)
+ (\_ -> changeWorkingDirectory cwd) $
+ pOpen ReadFromPipe "git" ["config", "--list"] $
+ hConfigRead repo
+configRead repo = assertSsh repo $ do
+ pOpen ReadFromPipe "ssh" [urlHost repo, sshcommand] $ hConfigRead repo
where
- sshcommand = "cd " ++ (shellEscape $ urlPath repo) ++ " && git config --list"
- proc h = do
- val <- hGetContentsStrict h
- let r = repo { config = configParse val }
- return r { remotes = configRemotes r }
+ sshcommand = "cd " ++ (shellEscape $ urlPath repo) ++
+ " && git config --list"
+hConfigRead repo h = do
+ val <- hGetContentsStrict h
+ let r = repo { config = configParse val }
+ return r { remotes = configRemotes r }
+
+{- Checks if a string fron git config is a true value. -}
+configTrue :: String -> Bool
+configTrue s = map toLower s == "true"
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
configRemotes :: Repo -> [Repo]
@@ -244,9 +242,8 @@ configRemotes repo = map construct remotes
isremote k = (startswith "remote." k) && (endswith ".url" k)
remotename k = (split "." k) !! 1
construct (k,v) = (gen v) { remoteName = Just $ remotename k }
- gen v = if (isURI v)
- then repoFromUrl v
- else repoFromPath v
+ gen v | isURI v = repoFromUrl v
+ | otherwise = repoFromPath v
{- Parses git config --list output into a config map. -}
configParse :: String -> Map.Map String String
diff --git a/LocationLog.hs b/LocationLog.hs
index 10a637708..f92dee652 100644
--- a/LocationLog.hs
+++ b/LocationLog.hs
@@ -163,6 +163,6 @@ mapLog map log =
then Map.insert (uuid log) log map
else map
where
- better = case (Map.lookup (uuid log) map) of
+ better = case Map.lookup (uuid log) map of
Just l -> (date l <= date log)
Nothing -> True
diff --git a/Remotes.hs b/Remotes.hs
index 665de38ae..a432e1b5d 100644
--- a/Remotes.hs
+++ b/Remotes.hs
@@ -28,6 +28,7 @@ import System.Directory
import System.Posix.Directory
import List
import Maybe
+import Monad (when, unless)
import Types
import qualified GitRepo as Git
@@ -65,9 +66,9 @@ keyPossibilities key = do
let cheap = filter (not . Git.repoIsUrl) allremotes
let expensive = filter Git.repoIsUrl allremotes
doexpensive <- filterM cachedUUID expensive
- if (not $ null doexpensive)
- then Core.showNote $ "getting UUID for " ++ (list doexpensive) ++ "..."
- else return ()
+ unless (null doexpensive) $ do
+ Core.showNote $ "getting UUID for " ++
+ (list doexpensive) ++ "..."
let todo = cheap ++ doexpensive
if (not $ null todo)
then do
@@ -139,10 +140,10 @@ repoNotIgnored r = do
let name = if (not $ null fromName) then fromName else toName
if (not $ null name)
then return $ match name
- else return $ notignored g
+ else return $ not $ ignored g
where
match name = name == Git.repoRemoteName r
- notignored g = "true" /= config g
+ ignored g = Git.configTrue $ config g
config g = Git.configGet g configkey ""
configkey = "remote." ++ (Git.repoRemoteName r) ++ ".annex-ignore"
@@ -152,15 +153,13 @@ commandLineRemote = do
fromName <- Annex.flagGet "fromrepository"
toName <- Annex.flagGet "torepository"
let name = if (not $ null fromName) then fromName else toName
- if (null name)
- then error "no remote specified"
- else do
- g <- Annex.gitRepo
- let match = filter (\r -> name == Git.repoRemoteName r) $
- Git.remotes g
- if (null match)
- then error $ "there is no git remote named \"" ++ name ++ "\""
- else return $ match !! 0
+ when (null name) $ error "no remote specified"
+ g <- Annex.gitRepo
+ let match = filter (\r -> name == Git.repoRemoteName r) $
+ Git.remotes g
+ when (null match) $ error $
+ "there is no git remote named \"" ++ name ++ "\""
+ return $ match !! 0
{- The git configs for the git repo's remotes is not read on startup
- because reading it may be expensive. This function tries to read the
@@ -186,7 +185,7 @@ tryGitConfigRead r = do
where
exchange [] new = []
exchange (old:ls) new =
- if ((Git.repoRemoteName old) == (Git.repoRemoteName new))
+ if (Git.repoRemoteName old == Git.repoRemoteName new)
then new:(exchange ls new)
else old:(exchange ls new)
diff --git a/UUID.hs b/UUID.hs
index 79b2b55fa..f2235e4b6 100644
--- a/UUID.hs
+++ b/UUID.hs
@@ -63,10 +63,7 @@ getUUID r = do
where
uncached r = Git.configGet r "annex.uuid" ""
cached r g = Git.configGet g (cachekey r) ""
- updatecache g r u = do
- if (g /= r)
- then setConfig (cachekey r) u
- else return ()
+ updatecache g r u = when (g /= r) $ setConfig (cachekey r) u
cachekey r = "remote." ++ (Git.repoRemoteName r) ++ ".annex-uuid"
{- Make sure that the repo has an annex.uuid setting. -}
@@ -74,11 +71,9 @@ prepUUID :: Annex ()
prepUUID = do
g <- Annex.gitRepo
u <- getUUID g
- if ("" == u)
- then do
- uuid <- liftIO $ genUUID
- setConfig configkey uuid
- else return ()
+ 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 ()
@@ -88,7 +83,6 @@ setConfig key value = do
-- re-read git config and update the repo's state
g' <- liftIO $ Git.configRead g
Annex.gitRepoChange g'
- return ()
{- 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 ab90c5160..233825b65 100644
--- a/Utility.hs
+++ b/Utility.hs
@@ -16,10 +16,11 @@ module Utility (
) where
import System.IO
-import System.Cmd
+import System.Cmd.Utils
import System.Exit
+import System.Posix.Process
+import System.Posix.Process.Internals
import System.Posix.Signals
-import Data.Typeable
import System.Posix.IO
import Data.String.Utils
import System.Path
@@ -102,17 +103,30 @@ relPathDirToDir from to =
{- Run a system command, and returns True or False
- if it succeeded or failed.
-
- - An error is thrown if the command exits due to SIGINT,
- - to propigate ctrl-c.
+ - SIGINT(ctrl-c) is allowed to propigate and will terminate the program.
-}
boolSystem :: FilePath -> [String] -> IO Bool
boolSystem command params = do
- r <- rawSystem command params
- case r of
- ExitSuccess -> return True
- ExitFailure e -> if Just e == cast sigINT
- then error $ command ++ "interrupted"
- else return False
+ -- Going low-level because all the high-level system functions
+ -- block SIGINT etc. We need to block SIGCHLD, but allow
+ -- SIGINT to do its default program termination.
+ let sigset = addSignal sigCHLD emptySignalSet
+ oldint <- installHandler sigINT Default Nothing
+ oldset <- getSignalMask
+ blockSignals sigset
+ childpid <- forkProcess $ childaction oldint oldset
+ mps <- getProcessStatus True False childpid
+ restoresignals oldint oldset
+ case mps of
+ Just (Exited ExitSuccess) -> return True
+ _ -> return False
+ where
+ restoresignals oldint oldset = do
+ installHandler sigINT oldint Nothing
+ setSignalMask oldset
+ childaction oldint oldset = do
+ restoresignals oldint oldset
+ executeFile command True params Nothing
{- Escapes a filename to be safely able to be exposed to the shell. -}
shellEscape f = "'" ++ quote ++ "'"
diff --git a/debian/changelog b/debian/changelog
index 72ae91c02..77e01482f 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,11 @@
+git-annex (0.03) UNRELEASED; urgency=low
+
+ * Fix support for file:// remotes.
+ * Add --verbose
+ * Fix SIGINT handling.
+
+ -- Joey Hess <joeyh@debian.org> Thu, 28 Oct 2010 13:46:59 -0400
+
git-annex (0.02) unstable; urgency=low
* Can scp annexed files from remote hosts, and check remote hosts for
diff --git a/doc/bugs/scp_interrupt_to_background.mdwn b/doc/bugs/scp_interrupt_to_background.mdwn
index 700c81c65..381f5cd73 100644
--- a/doc/bugs/scp_interrupt_to_background.mdwn
+++ b/doc/bugs/scp_interrupt_to_background.mdwn
@@ -1,2 +1,2 @@
When getting a file with scp, SIGINT is blocked, exposing the git
-subcommand fork to background bug again.
+subcommand fork to background bug again. [[done]]
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index 3c48e9dc3..47fbb3760 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -153,6 +153,10 @@ Many git-annex subcommands will stage changes for later `git commit` by you.
Avoid the default verbose logging of what is done; only show errors
and progress displays.
+* --verbose
+
+ Enable verbose logging.
+
* --backend=name
Specify the default key-value backend to use, adding it to the front
diff --git a/git-annex.hs b/git-annex.hs
index e9e7ff027..5011fade2 100644
--- a/git-annex.hs
+++ b/git-annex.hs
@@ -8,6 +8,7 @@
import IO (try)
import System.IO
import System.Environment
+import Monad
import qualified Annex
import Types
@@ -42,12 +43,8 @@ tryRun' state errnum (a:as) = do
tryRun' state (errnum + 1) as
Right (True,state') -> tryRun' state' errnum as
Right (False,state') -> tryRun' state' (errnum + 1) as
-tryRun' state errnum [] = do
- if (errnum > 0)
- then error $ (show errnum) ++ " failed"
- else return ()
+tryRun' state errnum [] =
+ when (errnum > 0) $ error $ (show errnum) ++ " failed"
{- Exception pretty-printing. -}
-showErr e = do
- hPutStrLn stderr $ "git-annex: " ++ (show e)
- return ()
+showErr e = hPutStrLn stderr $ "git-annex: " ++ (show e)
generated by cgit v1.2.3 (git 2.39.1) at 2024-08-28 16:29:09 +0000