rename
This commit is contained in:
parent
fcdc4797a9
commit
4cd96ad2db
8 changed files with 36 additions and 36 deletions
2
Annex.hs
2
Annex.hs
|
@ -92,7 +92,7 @@ gitRepo :: Annex Git.Repo
|
||||||
gitRepo = getState repo
|
gitRepo = getState repo
|
||||||
|
|
||||||
{- Adds a git command to the queue. -}
|
{- Adds a git command to the queue. -}
|
||||||
queue :: String -> [ShellParam] -> FilePath -> Annex ()
|
queue :: String -> [CommandParam] -> FilePath -> Annex ()
|
||||||
queue command params file = do
|
queue command params file = do
|
||||||
state <- get
|
state <- get
|
||||||
let q = repoqueue state
|
let q = repoqueue state
|
||||||
|
|
|
@ -32,7 +32,7 @@ backend = Backend.File.backend {
|
||||||
sha1 :: FilePath -> Annex String
|
sha1 :: FilePath -> Annex String
|
||||||
sha1 file = do
|
sha1 file = do
|
||||||
showNote "checksum..."
|
showNote "checksum..."
|
||||||
liftIO $ pOpen ReadFromPipe "sha1sum" (toShell [File file]) $ \h -> do
|
liftIO $ pOpen ReadFromPipe "sha1sum" (toCommand [File file]) $ \h -> do
|
||||||
line <- hGetLine h
|
line <- hGetLine h
|
||||||
let bits = split " " line
|
let bits = split " " line
|
||||||
if null bits
|
if null bits
|
||||||
|
|
|
@ -198,7 +198,7 @@ tryScan r
|
||||||
Left _ -> return Nothing
|
Left _ -> return Nothing
|
||||||
Right r' -> return $ Just r'
|
Right r' -> return $ Just r'
|
||||||
pipedconfig cmd params = safely $
|
pipedconfig cmd params = safely $
|
||||||
pOpen ReadFromPipe cmd (toShell params) $
|
pOpen ReadFromPipe cmd (toCommand params) $
|
||||||
Git.hConfigRead r
|
Git.hConfigRead r
|
||||||
|
|
||||||
configlist =
|
configlist =
|
||||||
|
|
|
@ -25,7 +25,7 @@ import qualified GitRepo as Git
|
||||||
- is not included, and must be able to be appended after the params. -}
|
- is not included, and must be able to be appended after the params. -}
|
||||||
data Action = Action {
|
data Action = Action {
|
||||||
getSubcommand :: String,
|
getSubcommand :: String,
|
||||||
getParams :: [ShellParam]
|
getParams :: [CommandParam]
|
||||||
} deriving (Show, Eq, Ord)
|
} deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
{- A queue of actions to perform (in any order) on a git repository,
|
{- A queue of actions to perform (in any order) on a git repository,
|
||||||
|
@ -38,7 +38,7 @@ empty :: Queue
|
||||||
empty = M.empty
|
empty = M.empty
|
||||||
|
|
||||||
{- Adds an action to a queue. -}
|
{- Adds an action to a queue. -}
|
||||||
add :: Queue -> String -> [ShellParam] -> FilePath -> Queue
|
add :: Queue -> String -> [CommandParam] -> FilePath -> Queue
|
||||||
add queue subcommand params file = M.insertWith (++) action [file] queue
|
add queue subcommand params file = M.insertWith (++) action [file] queue
|
||||||
where
|
where
|
||||||
action = Action subcommand params
|
action = Action subcommand params
|
||||||
|
@ -57,6 +57,6 @@ runAction repo action files = do
|
||||||
unless (null files) runxargs
|
unless (null files) runxargs
|
||||||
where
|
where
|
||||||
runxargs = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
|
runxargs = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
|
||||||
params = toShell $ Git.gitCommandLine repo
|
params = toCommand $ Git.gitCommandLine repo
|
||||||
(Param (getSubcommand action):getParams action)
|
(Param (getSubcommand action):getParams action)
|
||||||
feedxargs h = hPutStr h $ join "\0" files
|
feedxargs h = hPutStr h $ join "\0" files
|
||||||
|
|
16
GitRepo.hs
16
GitRepo.hs
|
@ -243,7 +243,7 @@ urlPath Repo { location = Url u } = uriPath u
|
||||||
urlPath repo = assertUrl repo $ error "internal"
|
urlPath repo = assertUrl repo $ error "internal"
|
||||||
|
|
||||||
{- Constructs a git command line operating on the specified repo. -}
|
{- Constructs a git command line operating on the specified repo. -}
|
||||||
gitCommandLine :: Repo -> [ShellParam] -> [ShellParam]
|
gitCommandLine :: Repo -> [CommandParam] -> [CommandParam]
|
||||||
gitCommandLine repo@(Repo { location = Dir d} ) params =
|
gitCommandLine repo@(Repo { location = Dir d} ) params =
|
||||||
-- force use of specified repo via --git-dir and --work-tree
|
-- force use of specified repo via --git-dir and --work-tree
|
||||||
[ Param ("--git-dir=" ++ d ++ "/" ++ gitDir repo)
|
[ Param ("--git-dir=" ++ d ++ "/" ++ gitDir repo)
|
||||||
|
@ -252,7 +252,7 @@ gitCommandLine repo@(Repo { location = Dir d} ) params =
|
||||||
gitCommandLine repo _ = assertLocal repo $ error "internal"
|
gitCommandLine repo _ = assertLocal repo $ error "internal"
|
||||||
|
|
||||||
{- Runs git in the specified repo, throwing an error if it fails. -}
|
{- Runs git in the specified repo, throwing an error if it fails. -}
|
||||||
run :: Repo -> String -> [ShellParam] -> IO ()
|
run :: Repo -> String -> [CommandParam] -> IO ()
|
||||||
run repo subcommand params = assertLocal repo $ do
|
run repo subcommand params = assertLocal repo $ do
|
||||||
ok <- boolSystem "git" (gitCommandLine repo ((Param subcommand):params))
|
ok <- boolSystem "git" (gitCommandLine repo ((Param subcommand):params))
|
||||||
unless ok $ error $ "git " ++ show params ++ " failed"
|
unless ok $ error $ "git " ++ show params ++ " failed"
|
||||||
|
@ -262,9 +262,9 @@ run repo subcommand params = assertLocal repo $ do
|
||||||
- Note that this leaves the git process running, and so zombies will
|
- Note that this leaves the git process running, and so zombies will
|
||||||
- result unless reap is called.
|
- result unless reap is called.
|
||||||
-}
|
-}
|
||||||
pipeRead :: Repo -> [ShellParam] -> IO String
|
pipeRead :: Repo -> [CommandParam] -> IO String
|
||||||
pipeRead repo params = assertLocal repo $ do
|
pipeRead repo params = assertLocal repo $ do
|
||||||
(_, s) <- pipeFrom "git" $ toShell $ gitCommandLine repo params
|
(_, s) <- pipeFrom "git" $ toCommand $ gitCommandLine repo params
|
||||||
return s
|
return s
|
||||||
|
|
||||||
{- Reaps any zombie git processes. -}
|
{- Reaps any zombie git processes. -}
|
||||||
|
@ -296,7 +296,7 @@ stagedFiles repo l = stagedFiles' repo l []
|
||||||
stagedFilesNotDeleted :: Repo -> [FilePath] -> IO [FilePath]
|
stagedFilesNotDeleted :: Repo -> [FilePath] -> IO [FilePath]
|
||||||
stagedFilesNotDeleted repo l = stagedFiles' repo l [Param "--diff-filter=ACMRT"]
|
stagedFilesNotDeleted repo l = stagedFiles' repo l [Param "--diff-filter=ACMRT"]
|
||||||
|
|
||||||
stagedFiles' :: Repo -> [FilePath] -> [ShellParam] -> IO [FilePath]
|
stagedFiles' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath]
|
||||||
stagedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
|
stagedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
|
||||||
where
|
where
|
||||||
start = [Params "diff --cached --name-only -z"]
|
start = [Params "diff --cached --name-only -z"]
|
||||||
|
@ -317,7 +317,7 @@ typeChangedStagedFiles repo l = typeChangedFiles' repo l [Param "--cached"]
|
||||||
typeChangedFiles :: Repo -> [FilePath] -> IO [FilePath]
|
typeChangedFiles :: Repo -> [FilePath] -> IO [FilePath]
|
||||||
typeChangedFiles repo l = typeChangedFiles' repo l []
|
typeChangedFiles repo l = typeChangedFiles' repo l []
|
||||||
|
|
||||||
typeChangedFiles' :: Repo -> [FilePath] -> [ShellParam] -> IO [FilePath]
|
typeChangedFiles' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath]
|
||||||
typeChangedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
|
typeChangedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
|
||||||
where
|
where
|
||||||
start = [Params "diff --name-only --diff-filter=T -z"]
|
start = [Params "diff --name-only --diff-filter=T -z"]
|
||||||
|
@ -325,7 +325,7 @@ typeChangedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
|
||||||
|
|
||||||
{- Reads null terminated output of a git command (as enabled by the -z
|
{- Reads null terminated output of a git command (as enabled by the -z
|
||||||
- parameter), and splits it into a list of files. -}
|
- parameter), and splits it into a list of files. -}
|
||||||
pipeNullSplit :: Repo -> [ShellParam] -> IO [FilePath]
|
pipeNullSplit :: Repo -> [CommandParam] -> IO [FilePath]
|
||||||
pipeNullSplit repo params = do
|
pipeNullSplit repo params = do
|
||||||
fs0 <- pipeRead repo params
|
fs0 <- pipeRead repo params
|
||||||
return $ split0 fs0
|
return $ split0 fs0
|
||||||
|
@ -410,7 +410,7 @@ checkAttr repo attr files = do
|
||||||
-- directory. Convert to absolute, and then convert the filenames
|
-- directory. Convert to absolute, and then convert the filenames
|
||||||
-- in its output back to relative.
|
-- in its output back to relative.
|
||||||
absfiles <- mapM absPath files
|
absfiles <- mapM absPath files
|
||||||
(_, s) <- pipeBoth "git" (toShell params) $ join "\0" absfiles
|
(_, s) <- pipeBoth "git" (toCommand params) $ join "\0" absfiles
|
||||||
cwd <- getCurrentDirectory
|
cwd <- getCurrentDirectory
|
||||||
return $ map (topair $ cwd++"/") $ lines s
|
return $ map (topair $ cwd++"/") $ lines s
|
||||||
where
|
where
|
||||||
|
|
12
Remotes.hs
12
Remotes.hs
|
@ -64,7 +64,7 @@ tryGitConfigRead r
|
||||||
Left _ -> return r
|
Left _ -> return r
|
||||||
Right r' -> return r'
|
Right r' -> return r'
|
||||||
pipedconfig cmd params = safely $
|
pipedconfig cmd params = safely $
|
||||||
pOpen ReadFromPipe cmd (toShell params) $
|
pOpen ReadFromPipe cmd (toCommand params) $
|
||||||
Git.hConfigRead r
|
Git.hConfigRead r
|
||||||
store a = do
|
store a = do
|
||||||
r' <- a
|
r' <- a
|
||||||
|
@ -263,7 +263,7 @@ rsynchelper r sending key file = do
|
||||||
|
|
||||||
{- Generates rsync parameters that ssh to the remote and asks it
|
{- Generates rsync parameters that ssh to the remote and asks it
|
||||||
- to either receive or send the key's content. -}
|
- to either receive or send the key's content. -}
|
||||||
rsyncParams :: Git.Repo -> Bool -> Key -> FilePath -> Annex [ShellParam]
|
rsyncParams :: Git.Repo -> Bool -> Key -> FilePath -> Annex [CommandParam]
|
||||||
rsyncParams r sending key file = do
|
rsyncParams r sending key file = do
|
||||||
Just (shellcmd, shellparams) <- git_annex_shell r
|
Just (shellcmd, shellparams) <- git_annex_shell r
|
||||||
(if sending then "sendkey" else "recvkey")
|
(if sending then "sendkey" else "recvkey")
|
||||||
|
@ -295,9 +295,9 @@ rsyncParams r sending key file = do
|
||||||
- a specified error value. -}
|
- a specified error value. -}
|
||||||
onRemote
|
onRemote
|
||||||
:: Git.Repo
|
:: Git.Repo
|
||||||
-> (FilePath -> [ShellParam] -> IO a, a)
|
-> (FilePath -> [CommandParam] -> IO a, a)
|
||||||
-> String
|
-> String
|
||||||
-> [ShellParam]
|
-> [CommandParam]
|
||||||
-> Annex a
|
-> Annex a
|
||||||
onRemote r (with, errorval) command params = do
|
onRemote r (with, errorval) command params = do
|
||||||
s <- git_annex_shell r command params
|
s <- git_annex_shell r command params
|
||||||
|
@ -306,7 +306,7 @@ onRemote r (with, errorval) command params = do
|
||||||
Nothing -> return errorval
|
Nothing -> return errorval
|
||||||
|
|
||||||
{- Generates parameters to run a git-annex-shell command on a remote. -}
|
{- Generates parameters to run a git-annex-shell command on a remote. -}
|
||||||
git_annex_shell :: Git.Repo -> String -> [ShellParam] -> Annex (Maybe (FilePath, [ShellParam]))
|
git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePath, [CommandParam]))
|
||||||
git_annex_shell r command params
|
git_annex_shell r command params
|
||||||
| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts)
|
| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts)
|
||||||
| Git.repoIsSsh r = do
|
| Git.repoIsSsh r = do
|
||||||
|
@ -319,7 +319,7 @@ git_annex_shell r command params
|
||||||
shellcmd = "git-annex-shell"
|
shellcmd = "git-annex-shell"
|
||||||
shellopts = (Param command):(File dir):params
|
shellopts = (Param command):(File dir):params
|
||||||
sshcmd = shellcmd ++ " " ++
|
sshcmd = shellcmd ++ " " ++
|
||||||
unwords (map shellEscape $ toShell shellopts)
|
unwords (map shellEscape $ toCommand shellopts)
|
||||||
|
|
||||||
{- Looks up a per-remote config option in git config.
|
{- Looks up a per-remote config option in git config.
|
||||||
- Failing that, tries looking for a global config option. -}
|
- Failing that, tries looking for a global config option. -}
|
||||||
|
|
12
RsyncFile.hs
12
RsyncFile.hs
|
@ -14,8 +14,8 @@ import Utility
|
||||||
|
|
||||||
{- Generates parameters to make rsync use a specified command as its remote
|
{- Generates parameters to make rsync use a specified command as its remote
|
||||||
- shell. -}
|
- shell. -}
|
||||||
rsyncShell :: [ShellParam] -> [ShellParam]
|
rsyncShell :: [CommandParam] -> [CommandParam]
|
||||||
rsyncShell command = [Param "-e", Param $ unwords $ map escape (toShell command)]
|
rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand command)]
|
||||||
where
|
where
|
||||||
{- rsync requires some weird, non-shell like quoting in
|
{- rsync requires some weird, non-shell like quoting in
|
||||||
- here. A doubled single quote inside the single quoted
|
- here. A doubled single quote inside the single quoted
|
||||||
|
@ -31,7 +31,7 @@ rsyncServerSend file = rsyncExec $
|
||||||
rsyncServerReceive :: FilePath -> IO Bool
|
rsyncServerReceive :: FilePath -> IO Bool
|
||||||
rsyncServerReceive file = rsync $ rsyncServerParams ++ [File file]
|
rsyncServerReceive file = rsync $ rsyncServerParams ++ [File file]
|
||||||
|
|
||||||
rsyncServerParams :: [ShellParam]
|
rsyncServerParams :: [CommandParam]
|
||||||
rsyncServerParams =
|
rsyncServerParams =
|
||||||
[ Param "--server"
|
[ Param "--server"
|
||||||
-- preserve permissions
|
-- preserve permissions
|
||||||
|
@ -42,8 +42,8 @@ rsyncServerParams =
|
||||||
, Params "-e.Lsf ."
|
, Params "-e.Lsf ."
|
||||||
]
|
]
|
||||||
|
|
||||||
rsync :: [ShellParam] -> IO Bool
|
rsync :: [CommandParam] -> IO Bool
|
||||||
rsync = boolSystem "rsync"
|
rsync = boolSystem "rsync"
|
||||||
|
|
||||||
rsyncExec :: [ShellParam] -> IO ()
|
rsyncExec :: [CommandParam] -> IO ()
|
||||||
rsyncExec params = executeFile "rsync" True (toShell params) Nothing
|
rsyncExec params = executeFile "rsync" True (toCommand params) Nothing
|
||||||
|
|
20
Utility.hs
20
Utility.hs
|
@ -6,8 +6,8 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Utility (
|
module Utility (
|
||||||
ShellParam(..),
|
CommandParam(..),
|
||||||
toShell,
|
toCommand,
|
||||||
hGetContentsStrict,
|
hGetContentsStrict,
|
||||||
readFileStrict,
|
readFileStrict,
|
||||||
parentDir,
|
parentDir,
|
||||||
|
@ -47,18 +47,18 @@ import Control.Monad (liftM2)
|
||||||
- whitespace-separated, or a single Param (for when parameters contain
|
- whitespace-separated, or a single Param (for when parameters contain
|
||||||
- whitespace), or a File.
|
- whitespace), or a File.
|
||||||
-}
|
-}
|
||||||
data ShellParam = Params String | Param String | File FilePath
|
data CommandParam = Params String | Param String | File FilePath
|
||||||
deriving (Eq, Show, Ord)
|
deriving (Eq, Show, Ord)
|
||||||
|
|
||||||
{- Used to pass a list of ShellParams to a function that runs
|
{- Used to pass a list of CommandParams to a function that runs
|
||||||
- a shell command and expects Strings. -}
|
- a command and expects Strings. -}
|
||||||
toShell :: [ShellParam] -> [String]
|
toCommand :: [CommandParam] -> [String]
|
||||||
toShell l = concat $ map unwrap l
|
toCommand l = concat $ map unwrap l
|
||||||
where
|
where
|
||||||
unwrap (Param s) = [s]
|
unwrap (Param s) = [s]
|
||||||
unwrap (Params s) = filter (not . null) (split " " s)
|
unwrap (Params s) = filter (not . null) (split " " s)
|
||||||
-- Files that start with a dash are modified to avoid
|
-- Files that start with a dash are modified to avoid
|
||||||
-- the shell command interpreting them as options.
|
-- the command interpreting them as options.
|
||||||
unwrap (File ('-':s)) = ["./-" ++ s]
|
unwrap (File ('-':s)) = ["./-" ++ s]
|
||||||
unwrap (File s) = [s]
|
unwrap (File s) = [s]
|
||||||
|
|
||||||
|
@ -67,7 +67,7 @@ toShell l = concat $ map unwrap l
|
||||||
-
|
-
|
||||||
- SIGINT(ctrl-c) is allowed to propigate and will terminate the program.
|
- SIGINT(ctrl-c) is allowed to propigate and will terminate the program.
|
||||||
-}
|
-}
|
||||||
boolSystem :: FilePath -> [ShellParam] -> IO Bool
|
boolSystem :: FilePath -> [CommandParam] -> IO Bool
|
||||||
boolSystem command params = do
|
boolSystem command params = do
|
||||||
-- Going low-level because all the high-level system functions
|
-- Going low-level because all the high-level system functions
|
||||||
-- block SIGINT etc. We need to block SIGCHLD, but allow
|
-- block SIGINT etc. We need to block SIGCHLD, but allow
|
||||||
|
@ -88,7 +88,7 @@ boolSystem command params = do
|
||||||
setSignalMask oldset
|
setSignalMask oldset
|
||||||
childaction oldint oldset = do
|
childaction oldint oldset = do
|
||||||
restoresignals oldint oldset
|
restoresignals oldint oldset
|
||||||
executeFile command True (toShell params) Nothing
|
executeFile command True (toCommand params) Nothing
|
||||||
|
|
||||||
{- Escapes a filename to be safely able to be exposed to the shell. -}
|
{- Escapes a filename to be safely able to be exposed to the shell. -}
|
||||||
shellEscape :: FilePath -> String
|
shellEscape :: FilePath -> String
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue