Merge branch 'master' into assistant

This commit is contained in:
Joey Hess 2012-07-02 15:45:20 -04:00
commit 3ea708e03b
19 changed files with 205 additions and 92 deletions

View file

@ -30,8 +30,8 @@ type Params = [String]
type Flags = [Annex ()] type Flags = [Annex ()]
{- Runs the passed command line. -} {- Runs the passed command line. -}
dispatch :: Bool -> Params -> [Command] -> [Option] -> String -> IO Git.Repo -> IO () dispatch :: Bool -> Params -> [Command] -> [Option] -> [(String, String)] -> String -> IO Git.Repo -> IO ()
dispatch fuzzyok allargs allcmds commonoptions header getgitrepo = do dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
setupConsole setupConsole
r <- E.try getgitrepo :: IO (Either E.SomeException Git.Repo) r <- E.try getgitrepo :: IO (Either E.SomeException Git.Repo)
case r of case r of
@ -40,6 +40,7 @@ dispatch fuzzyok allargs allcmds commonoptions header getgitrepo = do
state <- Annex.new g state <- Annex.new g
(actions, state') <- Annex.run state $ do (actions, state') <- Annex.run state $ do
checkfuzzy checkfuzzy
forM_ fields $ \(f, v) -> Annex.setField f v
sequence_ flags sequence_ flags
prepCommand cmd params prepCommand cmd params
tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdoneshot cmd] tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdoneshot cmd]

View file

@ -203,7 +203,7 @@ tryScan r
Git.Config.hRead r Git.Config.hRead r
configlist = configlist =
onRemote r (pipedconfig, Nothing) "configlist" [] onRemote r (pipedconfig, Nothing) "configlist" [] []
manualconfiglist = do manualconfiglist = do
sshparams <- sshToRepo r [Param sshcmd] sshparams <- sshToRepo r [Param sshcmd]
liftIO $ pipedconfig "ssh" sshparams liftIO $ pipedconfig "ssh" sshparams

View file

@ -12,6 +12,7 @@ import Command
import CmdLine import CmdLine
import Annex.Content import Annex.Content
import Utility.RsyncFile import Utility.RsyncFile
import Logs.Transfer
def :: [Command] def :: [Command]
def = [oneShot $ command "recvkey" paramKey seek def = [oneShot $ command "recvkey" paramKey seek
@ -21,14 +22,15 @@ seek :: [CommandSeek]
seek = [withKeys start] seek = [withKeys start]
start :: Key -> CommandStart start :: Key -> CommandStart
start key = do start key = ifM (inAnnex key)
whenM (inAnnex key) $ error "key is already present in annex" ( error "key is already present in annex"
, fieldTransfer Download key $ do
ok <- getViaTmp key (liftIO . rsyncServerReceive) ifM (getViaTmp key $ liftIO . rsyncServerReceive)
if ok ( do
then do -- forcibly quit after receiving one key,
-- forcibly quit after receiving one key, -- and shutdown cleanly
-- and shutdown cleanly _ <- shutdown True
_ <- shutdown True liftIO exitSuccess
liftIO exitSuccess , liftIO exitFailure
else liftIO exitFailure )
)

View file

@ -1,6 +1,6 @@
{- git-annex command {- git-annex command
- -
- Copyright 2010 Joey Hess <joey@kitenet.net> - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -11,6 +11,7 @@ import Common.Annex
import Command import Command
import Annex.Content import Annex.Content
import Utility.RsyncFile import Utility.RsyncFile
import Logs.Transfer
def :: [Command] def :: [Command]
def = [oneShot $ command "sendkey" paramKey seek def = [oneShot $ command "sendkey" paramKey seek
@ -20,9 +21,12 @@ seek :: [CommandSeek]
seek = [withKeys start] seek = [withKeys start]
start :: Key -> CommandStart start :: Key -> CommandStart
start key = do start key = ifM (inAnnex key)
file <- inRepo $ gitAnnexLocation key ( fieldTransfer Upload key $ do
whenM (inAnnex key) $ file <- inRepo $ gitAnnexLocation key
liftIO $ rsyncServerSend file -- does not return liftIO $ ifM (rsyncServerSend file)
warning "requested key is not present" ( exitSuccess , exitFailure )
liftIO exitFailure , do
warning "requested key is not present"
liftIO exitFailure
)

32
Fields.hs Normal file
View file

@ -0,0 +1,32 @@
{- git-annex fields
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Fields where
import Common.Annex
import qualified Annex
import Data.Char
{- A field, stored in Annex state, with a value sanity checker. -}
data Field = Field
{ fieldName :: String
, fieldCheck :: String -> Bool
}
remoteUUID :: Field
remoteUUID = Field "remoteuuid" $
-- does it look like a UUID?
all (\c -> isAlphaNum c || c == '-')
associatedFile :: Field
associatedFile = Field "associatedfile" $ \f ->
-- is the file a safe relative filename?
not (isAbsolute f) && not ("../" `isPrefixOf` f)
getField :: Field -> Annex (Maybe String)
getField = Annex.getField . fieldName

View file

@ -145,4 +145,4 @@ header :: String
header = "Usage: git-annex command [option ..]" header = "Usage: git-annex command [option ..]"
run :: [String] -> IO () run :: [String] -> IO ()
run args = dispatch True args cmds options header Git.CurrentRepo.get run args = dispatch True args cmds options [] header Git.CurrentRepo.get

View file

@ -16,6 +16,7 @@ import CmdLine
import Command import Command
import Annex.UUID import Annex.UUID
import qualified Option import qualified Option
import Fields
import qualified Command.ConfigList import qualified Command.ConfigList
import qualified Command.InAnnex import qualified Command.InAnnex
@ -47,7 +48,7 @@ cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
options :: [OptDescr (Annex ())] options :: [OptDescr (Annex ())]
options = Option.common ++ options = Option.common ++
[ Option [] ["uuid"] (ReqArg checkuuid paramUUID) "repository uuid" [ Option [] ["uuid"] (ReqArg checkuuid paramUUID) "local repository uuid"
] ]
where where
checkuuid expected = getUUID >>= check checkuuid expected = getUUID >>= check
@ -83,21 +84,40 @@ builtins = map cmdname cmds
builtin :: String -> String -> [String] -> IO () builtin :: String -> String -> [String] -> IO ()
builtin cmd dir params = do builtin cmd dir params = do
checkNotReadOnly cmd checkNotReadOnly cmd
dispatch False (cmd : filterparams params) cmds options header $ let (params', fieldparams) = partitionParams params
let fields = filter checkField $ parseFields fieldparams
dispatch False (cmd : params') cmds options fields header $
Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
external :: [String] -> IO () external :: [String] -> IO ()
external params = do external params = do
checkNotLimited checkNotLimited
unlessM (boolSystem "git-shell" $ map Param $ "-c":filterparams params) $ unlessM (boolSystem "git-shell" $ map Param $ "-c":fst (partitionParams params)) $
error "git-shell failed" error "git-shell failed"
-- Drop all args after "--". {- Parameters between two -- markers are field settings, in the form:
-- These tend to be passed by rsync and not useful. - field=value field=value
filterparams :: [String] -> [String] -
filterparams [] = [] - Parameters after the last -- are ignored, these tend to be passed by
filterparams ("--":_) = [] - rsync and not be useful.
filterparams (a:as) = a:filterparams as -}
partitionParams :: [String] -> ([String], [String])
partitionParams params
| length segments < 2 = (segments !! 0, [])
| otherwise = (segments !! 0, segments !! 1)
where
segments = segment (== "--") params
parseFields :: [String] -> [(String, String)]
parseFields = map (separate (== '='))
{- Only allow known fields to be set, ignore others.
- Make sure that field values make sense. -}
checkField :: (String, String) -> Bool
checkField (field, value)
| field == fieldName remoteUUID = fieldCheck remoteUUID value
| field == fieldName associatedFile = fieldCheck associatedFile value
| otherwise = False
failure :: IO () failure :: IO ()
failure = error $ "bad parameters\n\n" ++ usage header cmds options failure = error $ "bad parameters\n\n" ++ usage header cmds options

View file

@ -12,6 +12,7 @@ import Annex.Perms
import Annex.Exception import Annex.Exception
import qualified Git import qualified Git
import Types.Remote import Types.Remote
import qualified Fields
import Control.Concurrent import Control.Concurrent
import System.Posix.Types import System.Posix.Types
@ -26,7 +27,12 @@ data Transfer = Transfer
} }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
{- Information about a Transfer, stored in the transfer information file. -} {- Information about a Transfer, stored in the transfer information file.
-
- Note that the associatedFile may not correspond to a file in the local
- git repository. It's some file, possibly relative to some directory,
- of some repository, that was acted on to initiate the transfer.
-}
data TransferInfo = TransferInfo data TransferInfo = TransferInfo
{ startedTime :: UTCTime { startedTime :: UTCTime
, transferPid :: Maybe ProcessID , transferPid :: Maybe ProcessID
@ -54,6 +60,12 @@ upload u key file a = transfer (Transfer Upload u key) file a
download :: UUID -> Key -> AssociatedFile -> Annex a -> Annex a download :: UUID -> Key -> AssociatedFile -> Annex a -> Annex a
download u key file a = transfer (Transfer Download u key) file a download u key file a = transfer (Transfer Download u key) file a
fieldTransfer :: Direction -> Key -> Annex a -> Annex a
fieldTransfer direction key a = do
afile <- Fields.getField Fields.associatedFile
maybe a (\u -> transfer (Transfer direction (toUUID u) key) afile a)
=<< Fields.getField Fields.remoteUUID
{- Runs a transfer action. Creates and locks the transfer information file {- Runs a transfer action. Creates and locks the transfer information file
- while the action is running. Will throw an error if the transfer is - while the action is running. Will throw an error if the transfer is
- already in progress. - already in progress.
@ -158,10 +170,8 @@ readTransferInfo pid s =
<*> pure (Just pid) <*> pure (Just pid)
<*> pure Nothing <*> pure Nothing
<*> pure Nothing <*> pure Nothing
<*> pure filename <*> pure (if null filename then Nothing else Just filename)
_ -> Nothing _ -> Nothing
where where
(bits, filebits) = splitAt 1 $ lines s (bits, filebits) = splitAt 1 $ lines s
filename filename = join "\n" filebits
| null filebits = Nothing
| otherwise = Just $ join "\n" filebits

View file

@ -76,4 +76,3 @@ field short opt paramdesc description =
{- The flag or field name used for an option. -} {- The flag or field name used for an option. -}
name :: Option -> String name :: Option -> String
name (Option _ o _ _) = Prelude.head o name (Option _ o _ _) = Prelude.head o

View file

@ -31,6 +31,7 @@ import Utility.TempFile
import Config import Config
import Init import Init
import Types.Key import Types.Key
import qualified Fields
remote :: RemoteType remote :: RemoteType
remote = RemoteType { remote = RemoteType {
@ -111,7 +112,7 @@ guardUsable r onerr a
tryGitConfigRead :: Git.Repo -> Annex Git.Repo tryGitConfigRead :: Git.Repo -> Annex Git.Repo
tryGitConfigRead r tryGitConfigRead r
| not $ M.null $ Git.config r = return r -- already read | not $ M.null $ Git.config r = return r -- already read
| Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" [] | Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" [] []
| Git.repoIsHttp r = do | Git.repoIsHttp r = do
headers <- getHttpHeaders headers <- getHttpHeaders
store $ safely $ geturlconfig headers store $ safely $ geturlconfig headers
@ -171,7 +172,7 @@ inAnnex r key
v -> return v v -> return v
checkremote = do checkremote = do
showAction $ "checking " ++ Git.repoDescribe r showAction $ "checking " ++ Git.repoDescribe r
onRemote r (check, unknown) "inannex" [Param (show key)] onRemote r (check, unknown) "inannex" [Param (show key)] []
where where
check c p = dispatch <$> safeSystem c p check c p = dispatch <$> safeSystem c p
dispatch ExitSuccess = Right True dispatch ExitSuccess = Right True
@ -218,6 +219,7 @@ dropKey r key
[ Params "--quiet --force" [ Params "--quiet --force"
, Param $ show key , Param $ show key
] ]
[]
{- Tries to copy a key's content from a remote's annex to a file. -} {- Tries to copy a key's content from a remote's annex to a file. -}
copyFromRemote :: Git.Repo -> Key -> AssociatedFile -> FilePath -> Annex Bool copyFromRemote :: Git.Repo -> Key -> AssociatedFile -> FilePath -> Annex Bool
@ -231,7 +233,7 @@ copyFromRemote r key file dest
loc <- inRepo $ gitAnnexLocation key loc <- inRepo $ gitAnnexLocation key
upload u key file $ upload u key file $
rsyncOrCopyFile params loc dest rsyncOrCopyFile params loc dest
| Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key dest | Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key dest file
| Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest | Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest
| otherwise = error "copying from non-ssh, non-http repo not supported" | otherwise = error "copying from non-ssh, non-http repo not supported"
@ -263,7 +265,7 @@ copyToRemote r key file
(rsyncOrCopyFile params keysrc) (rsyncOrCopyFile params keysrc)
| Git.repoIsSsh r = commitOnCleanup r $ do | Git.repoIsSsh r = commitOnCleanup r $ do
keysrc <- inRepo $ gitAnnexLocation key keysrc <- inRepo $ gitAnnexLocation key
rsyncHelper =<< rsyncParamsRemote r False key keysrc rsyncHelper =<< rsyncParamsRemote r False key keysrc file
| otherwise = error "copying to non-ssh repo not supported" | otherwise = error "copying to non-ssh repo not supported"
rsyncHelper :: [CommandParam] -> Annex Bool rsyncHelper :: [CommandParam] -> Annex Bool
@ -290,23 +292,26 @@ rsyncOrCopyFile rsyncparams src dest =
{- 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. -}
rsyncParamsRemote :: Git.Repo -> Bool -> Key -> FilePath -> Annex [CommandParam] rsyncParamsRemote :: Git.Repo -> Bool -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
rsyncParamsRemote r sending key file = do rsyncParamsRemote r sending key file afile = do
u <- getUUID
let fields = (Fields.remoteUUID, fromUUID u)
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
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")
[ Param $ show key [ Param $ show key ]
-- Command is terminated with "--", because fields
-- rsync will tack on its own options afterwards,
-- and they need to be ignored.
, Param "--"
]
-- Convert the ssh command into rsync command line. -- Convert the ssh command into rsync command line.
let eparam = rsyncShell (Param shellcmd:shellparams) let eparam = rsyncShell (Param shellcmd:shellparams)
o <- rsyncParams r o <- rsyncParams r
if sending if sending
then return $ o ++ eparam ++ [dummy, File file] then return $ o ++ rsyncopts eparam dummy (File file)
else return $ o ++ eparam ++ [File file, dummy] else return $ o ++ rsyncopts eparam (File file) dummy
where where
rsyncopts ps source dest
| end ps == [dashdash] = ps ++ [source, dest]
| otherwise = ps ++ [dashdash, source, dest]
dashdash = Param "--"
-- The rsync shell parameter controls where rsync -- The rsync shell parameter controls where rsync
-- goes, so the source/dest parameter can be a dummy value, -- goes, so the source/dest parameter can be a dummy value,
-- that just enables remote rsync mode. -- that just enables remote rsync mode.
@ -333,7 +338,7 @@ commitOnCleanup r a = go `after` a
Annex.Branch.commit "update" Annex.Branch.commit "update"
| otherwise = void $ do | otherwise = void $ do
Just (shellcmd, shellparams) <- Just (shellcmd, shellparams) <-
git_annex_shell r "commit" [] git_annex_shell r "commit" [] []
-- Throw away stderr, since the remote may not -- Throw away stderr, since the remote may not
-- have a new enough git-annex shell to -- have a new enough git-annex shell to
-- support committing. -- support committing.

View file

@ -1,6 +1,6 @@
{- git-annex remote access with ssh {- git-annex remote access with ssh
- -
- Copyright 2011 Joey Hess <joey@kitenet.net> - Copyright 2011.2012 Joey Hess <joey@kitenet.net>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -13,6 +13,7 @@ import qualified Git.Url
import Config import Config
import Annex.UUID import Annex.UUID
import Annex.Ssh import Annex.Ssh
import Fields
{- Generates parameters to ssh to a repository's host and run a command. {- Generates parameters to ssh to a repository's host and run a command.
- Caller is responsible for doing any neccessary shellEscaping of the - Caller is responsible for doing any neccessary shellEscaping of the
@ -25,9 +26,9 @@ sshToRepo repo sshcmd = do
{- Generates parameters to run a git-annex-shell command on a remote {- Generates parameters to run a git-annex-shell command on a remote
- repository. -} - repository. -}
git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePath, [CommandParam])) git_annex_shell :: Git.Repo -> String -> [CommandParam] -> [(Field, String)] -> Annex (Maybe (FilePath, [CommandParam]))
git_annex_shell r command params git_annex_shell r command params fields
| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts) | not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts ++ fieldopts)
| Git.repoIsSsh r = do | Git.repoIsSsh r = do
uuid <- getRepoUUID r uuid <- getRepoUUID r
sshparams <- sshToRepo r [Param $ sshcmd uuid ] sshparams <- sshToRepo r [Param $ sshcmd uuid ]
@ -39,9 +40,16 @@ git_annex_shell r command params
shellopts = Param command : File dir : params shellopts = Param command : File dir : params
sshcmd uuid = unwords $ sshcmd uuid = unwords $
shellcmd : map shellEscape (toCommand shellopts) ++ shellcmd : map shellEscape (toCommand shellopts) ++
uuidcheck uuid uuidcheck uuid ++
map shellEscape (toCommand fieldopts)
uuidcheck NoUUID = [] uuidcheck NoUUID = []
uuidcheck (UUID u) = ["--uuid", u] uuidcheck (UUID u) = ["--uuid", u]
fieldopts
| null fields = []
| otherwise = fieldsep : map fieldopt fields ++ [fieldsep]
fieldsep = Param "--"
fieldopt (field, value) = Param $
fieldName field ++ "=" ++ value
{- Uses a supplied function (such as boolSystem) to run a git-annex-shell {- Uses a supplied function (such as boolSystem) to run a git-annex-shell
- command on a remote. - command on a remote.
@ -53,9 +61,10 @@ onRemote
-> (FilePath -> [CommandParam] -> IO a, a) -> (FilePath -> [CommandParam] -> IO a, a)
-> String -> String
-> [CommandParam] -> [CommandParam]
-> [(Field, String)]
-> Annex a -> Annex a
onRemote r (with, errorval) command params = do onRemote r (with, errorval) command params fields = do
s <- git_annex_shell r command params s <- git_annex_shell r command params fields
case s of case s of
Just (c, ps) -> liftIO $ with c ps Just (c, ps) -> liftIO $ with c ps
Nothing -> return errorval Nothing -> return errorval

View file

@ -27,7 +27,7 @@ daemonize logfd pidfile changedirectory a = do
_ <- forkProcess child2 _ <- forkProcess child2
out out
child2 = do child2 = do
maybe noop (lockPidFile True alreadyrunning) pidfile maybe noop (lockPidFile alreadyrunning) pidfile
when changedirectory $ when changedirectory $
setCurrentDirectory "/" setCurrentDirectory "/"
nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
@ -42,31 +42,44 @@ daemonize logfd pidfile changedirectory a = do
alreadyrunning = error "Daemon is already running." alreadyrunning = error "Daemon is already running."
out = exitImmediately ExitSuccess out = exitImmediately ExitSuccess
lockPidFile :: Bool -> IO () -> FilePath -> IO () {- Locks the pid file, with an exclusive, non-blocking lock.
lockPidFile write onfailure file = do - Runs an action on failure. On success, writes the pid to the file,
fd <- openFd file ReadWrite (Just stdFileMode) - fully atomically. -}
defaultFileFlags { trunc = write } lockPidFile :: IO () -> FilePath -> IO ()
locked <- catchMaybeIO $ setLock fd (locktype, AbsoluteSeek, 0, 0) lockPidFile onfailure file = do
case locked of fd <- openFd file ReadWrite (Just stdFileMode) defaultFileFlags
Nothing -> onfailure locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
_ -> when write $ void $ fd' <- openFd newfile ReadWrite (Just stdFileMode) defaultFileFlags
fdWrite fd =<< show <$> getProcessID { trunc = True }
locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0)
case (locked, locked') of
(Nothing, _) -> onfailure
(_, Nothing) -> onfailure
_ -> do
_ <- fdWrite fd' =<< show <$> getProcessID
renameFile newfile file
closeFd fd
where where
locktype newfile = file ++ ".new"
| write = WriteLock
| otherwise = ReadLock
{- Stops the daemon. {- Stops the daemon.
- -
- The pid file is used to get the daemon's pid. - The pid file is used to get the daemon's pid.
- -
- To guard against a stale pid, try to take a nonblocking shared lock - To guard against a stale pid, check the lock of the pid file,
- of the pid file. If this *fails*, the daemon must be running, - and compare the process that has it locked with the file content.
- and have the exclusive lock, so the pid file is trustworthy.
-} -}
stopDaemon :: FilePath -> IO () stopDaemon :: FilePath -> IO ()
stopDaemon pidfile = lockPidFile False go pidfile stopDaemon pidfile = do
where fd <- openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags
go = do locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
pid <- readish <$> readFile pidfile p <- readish <$> readFile pidfile
maybe noop (signalProcess sigTERM) pid case (locked, p) of
(Nothing, _) -> noop
(_, Nothing) -> noop
(Just (pid, _), Just pid')
| pid == pid' -> signalProcess sigTERM pid
| otherwise -> error $
"stale pid in " ++ pidfile ++
" (got " ++ show pid' ++
"; expected" ++ show pid ++ " )"

View file

@ -35,14 +35,15 @@ dirContents :: FilePath -> IO [FilePath]
dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
{- Gets files in a directory, and then its subdirectories, recursively, {- Gets files in a directory, and then its subdirectories, recursively,
- and lazily. -} - and lazily. If the directory does not exist, no exception is thrown,
- instead, [] is returned. -}
dirContentsRecursive :: FilePath -> IO [FilePath] dirContentsRecursive :: FilePath -> IO [FilePath]
dirContentsRecursive topdir = dirContentsRecursive' topdir [""] dirContentsRecursive topdir = dirContentsRecursive' topdir [""]
dirContentsRecursive' :: FilePath -> [FilePath] -> IO [FilePath] dirContentsRecursive' :: FilePath -> [FilePath] -> IO [FilePath]
dirContentsRecursive' _ [] = return [] dirContentsRecursive' _ [] = return []
dirContentsRecursive' topdir (dir:dirs) = unsafeInterleaveIO $ do dirContentsRecursive' topdir (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< dirContents (topdir </> dir) (files, dirs') <- collect [] [] =<< catchDefaultIO (dirContents (topdir </> dir)) []
files' <- dirContentsRecursive' topdir (dirs' ++ dirs) files' <- dirContentsRecursive' topdir (dirs' ++ dirs)
return (files ++ files') return (files ++ files')
where where

View file

@ -35,3 +35,13 @@ separate c l = unbreak $ break c l
{- Breaks out the first line. -} {- Breaks out the first line. -}
firstLine :: String-> String firstLine :: String-> String
firstLine = takeWhile (/= '\n') firstLine = takeWhile (/= '\n')
{- Splits a list into segments that are delimited by items matching
- a predicate. (The delimiters are not included in the segments.) -}
segment :: (a -> Bool) -> [a] -> [[a]]
segment p l = map reverse $ go [] [] l
where
go c r [] = reverse $ c:r
go c r (i:is)
| p i = go [] (c:r) is
| otherwise = go (i:c) r is

View file

@ -22,9 +22,9 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman
- string is a single quote. -} - string is a single quote. -}
escape s = "'" ++ join "''" (split "'" s) ++ "'" escape s = "'" ++ join "''" (split "'" s) ++ "'"
{- Runs rsync in server mode to send a file, and exits. -} {- Runs rsync in server mode to send a file. -}
rsyncServerSend :: FilePath -> IO () rsyncServerSend :: FilePath -> IO Bool
rsyncServerSend file = rsyncExec $ rsyncServerSend file = rsync $
rsyncServerParams ++ [Param "--sender", File file] rsyncServerParams ++ [Param "--sender", File file]
{- Runs rsync in server mode to receive a file. -} {- Runs rsync in server mode to receive a file. -}
@ -47,11 +47,8 @@ rsyncServerParams =
rsync :: [CommandParam] -> IO Bool rsync :: [CommandParam] -> IO Bool
rsync = boolSystem "rsync" rsync = boolSystem "rsync"
rsyncExec :: [CommandParam] -> IO ()
rsyncExec params = executeFile "rsync" True (toCommand params) Nothing
{- Checks if an rsync url involves the remote shell (ssh or rsh). {- Checks if an rsync url involves the remote shell (ssh or rsh).
- Use of such urls with rsync or rsyncExec requires additional shell - Use of such urls with rsync requires additional shell
- escaping. -} - escaping. -}
rsyncUrlIsShell :: String -> Bool rsyncUrlIsShell :: String -> Bool
rsyncUrlIsShell s rsyncUrlIsShell s

1
debian/changelog vendored
View file

@ -3,6 +3,7 @@ git-annex (3.20120630) UNRELEASED; urgency=low
* get, move, copy: Now refuse to do anything when the requested file * get, move, copy: Now refuse to do anything when the requested file
transfer is already in progress by another process. transfer is already in progress by another process.
* status: Lists transfers that are currently in progress. * status: Lists transfers that are currently in progress.
* Fix passing --uuid to git-annex-shell.
-- Joey Hess <joeyh@debian.org> Sun, 01 Jul 2012 15:04:37 -0400 -- Joey Hess <joeyh@debian.org> Sun, 01 Jul 2012 15:04:37 -0400

View file

@ -7,8 +7,7 @@ all the other git clones, at both the git level and the key/value level.
**done** **done**
* locking for the files, so redundant transfer races can be detected, * locking for the files, so redundant transfer races can be detected,
and failed transfers noticed **done** and failed transfers noticed **done**
* transfer info for git-annex-shell (problem: how to add a switch * transfer info for git-annex-shell **done**
with the necessary info w/o breaking backwards compatability?)
* update files as transfers proceed. See [[progressbars]] * update files as transfers proceed. See [[progressbars]]
(updating for downloads is easy; for uploads is hard) (updating for downloads is easy; for uploads is hard)
* add Transfer queue TChan * add Transfer queue TChan

View file

@ -61,6 +61,14 @@ to git-annex-shell are:
git-annex uses this to specify the UUID of the repository it was expecting git-annex uses this to specify the UUID of the repository it was expecting
git-annex-shell to access, as a sanity check. git-annex-shell to access, as a sanity check.
* -- fields=val fields=val.. --
Additional fields may be specified this way, to retain compatability with
past versions of git-annex-shell (that ignore these, but would choke
on new dashed options).
Currently used fields include remoteuuid= and associatedfile=
# HOOK # HOOK
After content is received or dropped from the repository by git-annex-shell, After content is received or dropped from the repository by git-annex-shell,

View file

@ -15,4 +15,6 @@ cabal install --bindir=$HOME/bin
Note: You can't just use `cabal install git-annex`, because Fedora does Note: You can't just use `cabal install git-annex`, because Fedora does
not yet ship ghc 7.4. not yet ship ghc 7.4.
[Status of getting a Fedora package](https://bugzilla.redhat.com/show_bug.cgi?id=662259) * [Status of getting a Fedora package](https://bugzilla.redhat.com/show_bug.cgi?id=662259)a
* [Koji build for F17](http://koji.fedoraproject.org/koji/buildinfo?buildID=328654)
* [Koji build for F16](http://koji.fedoraproject.org/koji/buildinfo?buildID=328656)