summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Annex.hs4
-rw-r--r--Annex/Drop.hs12
-rw-r--r--Annex/FileMatcher.hs4
-rw-r--r--Annex/Notification.hs16
-rw-r--r--Annex/Ssh.hs49
-rw-r--r--Annex/Transfer.hs28
-rw-r--r--Assistant/DeleteRemote.hs2
-rw-r--r--Assistant/Threads/Committer.hs7
-rw-r--r--Assistant/Threads/Cronner.hs2
-rw-r--r--Assistant/Threads/SanityChecker.hs4
-rw-r--r--Assistant/Threads/TransferScanner.hs14
-rw-r--r--Assistant/TransferSlots.hs9
-rw-r--r--Assistant/Upgrade.hs2
-rw-r--r--Assistant/WebApp/DashBoard.hs3
-rw-r--r--Backend/Hash.hs4
-rw-r--r--Build/BundledPrograms.hs19
-rw-r--r--CHANGELOG31
-rw-r--r--COPYRIGHT4
-rw-r--r--CmdLine/GitAnnexShell.hs2
-rw-r--r--CmdLine/Seek.hs7
-rw-r--r--Command/AddUrl.hs15
-rw-r--r--Command/Copy.hs4
-rw-r--r--Command/Drop.hs7
-rw-r--r--Command/DropUnused.hs4
-rw-r--r--Command/Fsck.hs128
-rw-r--r--Command/Get.hs7
-rw-r--r--Command/ImportFeed.hs8
-rw-r--r--Command/Info.hs9
-rw-r--r--Command/Map.hs6
-rw-r--r--Command/MetaData.hs4
-rw-r--r--Command/Migrate.hs5
-rw-r--r--Command/Mirror.hs10
-rw-r--r--Command/Move.hs4
-rw-r--r--Command/SendKey.hs2
-rw-r--r--Command/Status.hs6
-rw-r--r--Command/Sync.hs31
-rw-r--r--Command/TestRemote.hs11
-rw-r--r--Command/TransferInfo.hs4
-rw-r--r--Command/TransferKey.hs4
-rw-r--r--Command/TransferKeys.hs8
-rw-r--r--Command/Whereis.hs2
-rw-r--r--Git/Ssh.hs74
-rw-r--r--Key.hs2
-rw-r--r--Limit/Wanted.hs10
-rw-r--r--Logs/Transfer.hs17
-rw-r--r--Logs/Unused.hs7
-rw-r--r--P2P/Protocol.hs9
-rw-r--r--Remote/Bup.hs8
-rw-r--r--Remote/Ddar.hs25
-rw-r--r--Remote/External.hs20
-rw-r--r--Remote/GCrypt.hs9
-rw-r--r--Remote/Git.hs3
-rw-r--r--Remote/Helper/Ssh.hs16
-rw-r--r--Remote/Rsync.hs1
-rw-r--r--Test.hs79
-rw-r--r--Types.hs2
-rw-r--r--Types/ActionItem.hs12
-rw-r--r--Types/Key.hs3
-rw-r--r--Types/Test.hs9
-rw-r--r--Types/Transfer.hs6
-rw-r--r--Utility/Gpg.hs2
-rw-r--r--Utility/Path.hs2
-rw-r--r--Utility/SRV.hs9
-rw-r--r--Utility/Shell.hs3
-rw-r--r--Utility/Url.hs16
-rw-r--r--doc/git-annex-get.mdwn9
-rw-r--r--doc/git-annex-sync.mdwn8
-rw-r--r--doc/git-annex.mdwn31
-rw-r--r--git-annex.cabal13
-rw-r--r--templates/dashboard/transfers.hamlet5
70 files changed, 580 insertions, 332 deletions
diff --git a/Annex.hs b/Annex.hs
index 1ee6e83..95709fa 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -136,7 +136,7 @@ data AnnexState = AnnexState
, existinghooks :: M.Map Git.Hook.Hook Bool
, desktopnotify :: DesktopNotify
, workers :: [Either AnnexState (Async AnnexState)]
- , activeremotes :: MVar (S.Set (Types.Remote.RemoteA Annex))
+ , activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)
, keysdbhandle :: Maybe Keys.DbHandle
, cachedcurrentbranch :: Maybe Git.Branch
, cachedgitenv :: Maybe [(String, String)]
@@ -144,7 +144,7 @@ data AnnexState = AnnexState
newState :: GitConfig -> Git.Repo -> IO AnnexState
newState c r = do
- emptyactiveremotes <- newMVar S.empty
+ emptyactiveremotes <- newMVar M.empty
return $ AnnexState
{ repo = r
, repoadjustment = return
diff --git a/Annex/Drop.hs b/Annex/Drop.hs
index cd0168a..1723bce 100644
--- a/Annex/Drop.hs
+++ b/Annex/Drop.hs
@@ -55,8 +55,8 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
)
let fs = case afile of
- Just f -> nub (f : l)
- Nothing -> l
+ AssociatedFile (Just f) -> nub (f : l)
+ AssociatedFile Nothing -> l
n <- getcopies fs
void $ if fromhere && checkcopies n Nothing
then go fs rs n >>= dropl fs
@@ -93,9 +93,9 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
checkdrop fs n u a
| null fs = check $ -- no associated files; unused content
- wantDrop True u (Just key) Nothing
+ wantDrop True u (Just key) (AssociatedFile Nothing)
| otherwise = check $
- allM (wantDrop True u (Just key) . Just) fs
+ allM (wantDrop True u (Just key) . AssociatedFile . Just) fs
where
check c = ifM c
( dodrop n u a
@@ -107,7 +107,9 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
( do
liftIO $ debugM "drop" $ unwords
[ "dropped"
- , fromMaybe (key2file key) afile
+ , case afile of
+ AssociatedFile Nothing -> key2file key
+ AssociatedFile (Just af) -> af
, "(from " ++ maybe "here" show u ++ ")"
, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
, ": " ++ reason
diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs
index 7a418cc..1e07a9d 100644
--- a/Annex/FileMatcher.hs
+++ b/Annex/FileMatcher.hs
@@ -44,13 +44,13 @@ type GetFileMatcher = FilePath -> Annex (FileMatcher Annex)
checkFileMatcher :: GetFileMatcher -> FilePath -> Annex Bool
checkFileMatcher getmatcher file = do
matcher <- getmatcher file
- checkMatcher matcher Nothing (Just file) S.empty True
+ checkMatcher matcher Nothing (AssociatedFile (Just file)) S.empty True
checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool
checkMatcher matcher mkey afile notpresent d
| isEmpty matcher = return d
| otherwise = case (mkey, afile) of
- (_, Just file) -> go =<< fileMatchInfo file
+ (_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file
(Just key, _) -> go (MatchingKey key)
_ -> return d
where
diff --git a/Annex/Notification.hs b/Annex/Notification.hs
index e61b362..0501c0d 100644
--- a/Annex/Notification.hs
+++ b/Annex/Notification.hs
@@ -28,10 +28,10 @@ noNotification = NotifyWitness
{- Wrap around an action that performs a transfer, which may run multiple
- attempts. Displays notification when supported and when the user asked
- for it. -}
-notifyTransfer :: Direction -> Maybe FilePath -> (NotifyWitness -> Annex Bool) -> Annex Bool
-notifyTransfer _ Nothing a = a NotifyWitness
+notifyTransfer :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> Annex Bool
+notifyTransfer _ (AssociatedFile Nothing) a = a NotifyWitness
#ifdef WITH_DBUS_NOTIFICATIONS
-notifyTransfer direction (Just f) a = do
+notifyTransfer direction (AssociatedFile (Just f)) a = do
wanted <- Annex.getState Annex.desktopnotify
if (notifyStart wanted || notifyFinish wanted)
then do
@@ -47,19 +47,19 @@ notifyTransfer direction (Just f) a = do
return ok
else a NotifyWitness
#else
-notifyTransfer _ (Just _) a = a NotifyWitness
+notifyTransfer _ (AssociatedFile (Just _)) a = a NotifyWitness
#endif
-notifyDrop :: Maybe FilePath -> Bool -> Annex ()
-notifyDrop Nothing _ = noop
+notifyDrop :: AssociatedFile -> Bool -> Annex ()
+notifyDrop (AssociatedFile Nothing) _ = noop
#ifdef WITH_DBUS_NOTIFICATIONS
-notifyDrop (Just f) ok = do
+notifyDrop (AssociatedFile (Just f)) ok = do
wanted <- Annex.getState Annex.desktopnotify
when (notifyFinish wanted) $ liftIO $ do
client <- DBus.Client.connectSession
void $ Notify.notify client (droppedNote ok f)
#else
-notifyDrop (Just _) _ = noop
+notifyDrop (AssociatedFile (Just _)) _ = noop
#endif
#ifdef WITH_DBUS_NOTIFICATIONS
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index f01cb64..aa35754 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -9,6 +9,8 @@
module Annex.Ssh (
ConsumeStdin(..),
+ SshCommand,
+ sshCommand,
sshOptions,
sshCacheDir,
sshReadPort,
@@ -37,6 +39,7 @@ import Utility.Env
import Utility.FileSystemEncoding
import Types.CleanupActions
import Git.Env
+import Git.Ssh
#ifndef mingw32_HOST_OS
import Annex.Perms
import Annex.LockPool
@@ -47,8 +50,21 @@ import Annex.LockPool
- not be allowed to consume the process's stdin. -}
data ConsumeStdin = ConsumeStdin | NoConsumeStdin
+{- Generates a command to ssh to a given host (or user@host) on a given
+ - port. This includes connection caching parameters, and any ssh-options.
+ - If GIT_SSH or GIT_SSH_COMMAND is set, they are used instead. -}
+sshCommand :: ConsumeStdin -> (SshHost, Maybe SshPort) -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam])
+sshCommand cs (host, port) gc remotecmd = maybe go return
+ =<< liftIO (gitSsh' host port remotecmd (consumeStdinParams cs))
+ where
+ go = do
+ ps <- sshOptions cs (host, port) gc []
+ return ("ssh", Param host:ps++[Param remotecmd])
+
{- Generates parameters to ssh to a given host (or user@host) on a given
- - port. This includes connection caching parameters, and any ssh-options. -}
+ - port. This includes connection caching parameters, and any
+ - ssh-options. Note that the host to ssh to and the command to run
+ - are not included in the returned options. -}
sshOptions :: ConsumeStdin -> (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]
sshOptions cs (host, port) gc opts = go =<< sshCachingInfo (host, port)
where
@@ -61,12 +77,14 @@ sshOptions cs (host, port) gc opts = go =<< sshCachingInfo (host, port)
, map Param (remoteAnnexSshOptions gc)
, opts
, portParams port
- , case cs of
- ConsumeStdin -> []
- NoConsumeStdin -> [Param "-n"]
+ , consumeStdinParams cs
, [Param "-T"]
]
+consumeStdinParams :: ConsumeStdin -> [CommandParam]
+consumeStdinParams ConsumeStdin = []
+consumeStdinParams NoConsumeStdin = [Param "-n"]
+
{- Returns a filename to use for a ssh connection caching socket, and
- parameters to enable ssh connection caching. -}
sshCachingInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
@@ -285,19 +303,24 @@ inRepoWithSshOptionsTo remote gc a =
{- To make any git commands be run with ssh caching enabled,
- and configured ssh-options alters the local Git.Repo's gitEnv
- to set GIT_SSH=git-annex, and set sshOptionsEnv when running git
- - commands. -}
+ - commands.
+ -
+ - If GIT_SSH or GIT_SSH_COMMAND are set, this has no effect. -}
sshOptionsTo :: Git.Repo -> RemoteGitConfig -> Git.Repo -> Annex Git.Repo
sshOptionsTo remote gc localr
| not (Git.repoIsUrl remote) || Git.repoIsHttp remote = unchanged
| otherwise = case Git.Url.hostuser remote of
Nothing -> unchanged
- Just host -> do
- (msockfile, _) <- sshCachingInfo (host, Git.Url.port remote)
- case msockfile of
- Nothing -> use []
- Just sockfile -> do
- prepSocket sockfile
- use (sshConnectionCachingParams sockfile)
+ Just host -> ifM (liftIO gitSshEnvSet)
+ ( unchanged
+ , do
+ (msockfile, _) <- sshCachingInfo (host, Git.Url.port remote)
+ case msockfile of
+ Nothing -> use []
+ Just sockfile -> do
+ prepSocket sockfile
+ use (sshConnectionCachingParams sockfile)
+ )
where
unchanged = return localr
@@ -313,7 +336,7 @@ sshOptionsTo remote gc localr
liftIO $ do
localr' <- addGitEnv localr sshOptionsEnv
(toSshOptionsEnv sshopts)
- addGitEnv localr' "GIT_SSH" command
+ addGitEnv localr' gitSshEnv command
runSshOptions :: [String] -> String -> IO ()
runSshOptions args s = do
diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index d6282cb..87480b2 100644
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -32,7 +32,8 @@ import qualified Types.Remote as Remote
import Types.Concurrency
import Control.Concurrent
-import qualified Data.Set as S
+import qualified Data.Map.Strict as M
+import Data.Ord
class Observable a where
observeBool :: a -> Bool
@@ -76,7 +77,7 @@ guardHaveUUID u a
- An upload can be run from a read-only filesystem, and in this case
- no transfer information or lock file is used.
-}
-runTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+runTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
runTransfer = runTransfer' False
{- Like runTransfer, but ignores any existing transfer lock file for the
@@ -84,12 +85,12 @@ runTransfer = runTransfer' False
-
- Note that this may result in confusing progress meter display in the
- webapp, if multiple processes are writing to the transfer info file. -}
-alwaysRunTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
alwaysRunTransfer = runTransfer' True
-runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
-runTransfer' ignorelock t file shouldretry transferaction = checkSecureHashes t $ do
- info <- liftIO $ startTransferInfo file
+runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t $ do
+ info <- liftIO $ startTransferInfo afile
(meter, tfile, metervar) <- mkProgressUpdater t info
mode <- annexFileMode
(lck, inprogress) <- prep tfile mode info
@@ -218,7 +219,7 @@ pickRemote l a = go l =<< Annex.getState Annex.concurrency
go rs (Concurrent n) | n > 1 = do
mv <- Annex.getState Annex.activeremotes
active <- liftIO $ takeMVar mv
- let rs' = sortBy (inactiveFirst active) rs
+ let rs' = sortBy (lessActiveFirst active) rs
goconcurrent mv active rs'
go (r:rs) _ = do
ok <- a r
@@ -229,11 +230,11 @@ pickRemote l a = go l =<< Annex.getState Annex.concurrency
liftIO $ putMVar mv active
return observeFailure
goconcurrent mv active (r:rs) = do
- let !active' = S.insert r active
+ let !active' = M.insertWith (+) r 1 active
liftIO $ putMVar mv active'
let getnewactive = do
active'' <- liftIO $ takeMVar mv
- let !active''' = S.delete r active''
+ let !active''' = M.update (\n -> if n > 1 then Just (n-1) else Nothing) r active''
return active'''
let removeactive = liftIO . putMVar mv =<< getnewactive
ok <- a r `onException` removeactive
@@ -246,11 +247,10 @@ pickRemote l a = go l =<< Annex.getState Annex.concurrency
-- Re-sort the remaining rs
-- because other threads could have
-- been assigned them in the meantime.
- let rs' = sortBy (inactiveFirst active'') rs
+ let rs' = sortBy (lessActiveFirst active'') rs
goconcurrent mv active'' rs'
-inactiveFirst :: S.Set Remote -> Remote -> Remote -> Ordering
-inactiveFirst active a b
- | Remote.cost a == Remote.cost b =
- if a `S.member` active then GT else LT
+lessActiveFirst :: M.Map Remote Integer -> Remote -> Remote -> Ordering
+lessActiveFirst active a b
+ | Remote.cost a == Remote.cost b = comparing (`M.lookup` active) a b
| otherwise = compare a b
diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs
index c69011e..6c88c61 100644
--- a/Assistant/DeleteRemote.hs
+++ b/Assistant/DeleteRemote.hs
@@ -64,7 +64,7 @@ removableRemote urlrenderer uuid = do
where
queueremaining r k =
queueTransferWhenSmall "remaining object in unwanted remote"
- Nothing (Transfer Download uuid k) r
+ (AssociatedFile Nothing) (Transfer Download uuid k) r
{- Scanning for keys can take a long time; do not tie up
- the Annex monad while doing it, so other threads continue to
- run. -}
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index dbd030b..d0acb8c 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -503,9 +503,10 @@ checkChangeContent change@(Change { changeInfo = i }) =
Just k -> whenM (scanComplete <$> getDaemonStatus) $ do
present <- liftAnnex $ inAnnex k
void $ if present
- then queueTransfers "new file created" Next k (Just f) Upload
- else queueTransfers "new or renamed file wanted" Next k (Just f) Download
- handleDrops "file renamed" present k (Just f) []
+ then queueTransfers "new file created" Next k af Upload
+ else queueTransfers "new or renamed file wanted" Next k af Download
+ handleDrops "file renamed" present k af []
where
f = changeFile change
+ af = AssociatedFile (Just f)
checkChangeContent _ = noop
diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs
index 0b505b8..145a76e 100644
--- a/Assistant/Threads/Cronner.hs
+++ b/Assistant/Threads/Cronner.hs
@@ -190,7 +190,7 @@ runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
void $ repairWhenNecessary urlrenderer u Nothing fsckresults
mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir)
where
- reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download
+ reget k = queueTransfers "fsck found bad file; redownloading" Next k (AssociatedFile Nothing) Download
runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (remoteFromUUID u)
where
dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index 0c79ef6..8169695 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -190,8 +190,8 @@ dailyCheck urlrenderer = do
unused <- liftAnnex unusedKeys'
void $ liftAnnex $ setUnusedKeys unused
forM_ unused $ \k -> do
- unlessM (queueTransfers "unused" Later k Nothing Upload) $
- handleDrops "unused" True k Nothing []
+ unlessM (queueTransfers "unused" Later k (AssociatedFile Nothing) Upload) $
+ handleDrops "unused" True k (AssociatedFile Nothing) []
return True
where
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index a55a349..4b6a90c 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -32,6 +32,7 @@ import Annex.Wanted
import CmdLine.Action
import qualified Data.Set as S
+import Control.Concurrent
{- This thread waits until a remote needs to be scanned, to find transfers
- that need to be made, to keep data in sync.
@@ -145,12 +146,17 @@ expensiveScan urlrenderer rs = batch <~> do
(findtransfers f unwanted)
=<< liftAnnex (lookupFile f)
mapM_ (enqueue f) ts
+
+ {- Delay for a short time to avoid using too much CPU. -}
+ liftIO $ threadDelay $ fromIntegral $ oneSecond `div` 200
+
scan unwanted' fs
enqueue f (r, t) =
queueTransferWhenSmall "expensive scan found missing object"
- (Just f) t r
+ (AssociatedFile (Just f)) t r
findtransfers f unwanted key = do
+ let af = AssociatedFile (Just f)
{- The syncable remotes may have changed since this
- scan began. -}
syncrs <- syncDataRemotes <$> getDaemonStatus
@@ -158,14 +164,14 @@ expensiveScan urlrenderer rs = batch <~> do
present <- liftAnnex $ inAnnex key
liftAnnex $ handleDropsFrom locs syncrs
"expensive scan found too many copies of object"
- present key (Just f) [] callCommandAction
+ present key af [] callCommandAction
liftAnnex $ do
let slocs = S.fromList locs
let use a = return $ mapMaybe (a key slocs) syncrs
ts <- if present
- then filterM (wantSend True (Just key) (Just f) . Remote.uuid . fst)
+ then filterM (wantSend True (Just key) af . Remote.uuid . fst)
=<< use (genTransfer Upload False)
- else ifM (wantGet True (Just key) (Just f))
+ else ifM (wantGet True (Just key) af)
( use (genTransfer Download True) , return [] )
let unwanted' = S.difference unwanted slocs
return (unwanted', ts)
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 25342f2..c80cf88 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -153,10 +153,11 @@ genTransfer t info = case transferRemote info of
-}
go remote transferrer = ifM (liftIO $ performTransfer transferrer t info)
( do
- maybe noop
- (void . addAlert . makeAlertFiller True
- . transferFileAlert direction True)
- (associatedFile info)
+ case associatedFile info of
+ AssociatedFile Nothing -> noop
+ AssociatedFile (Just af) -> void $
+ addAlert $ makeAlertFiller True $
+ transferFileAlert direction True af
unless isdownload $
handleDrops
("object uploaded to " ++ show remote)
diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs
index a2f6f9e..67a4d9f 100644
--- a/Assistant/Upgrade.hs
+++ b/Assistant/Upgrade.hs
@@ -85,7 +85,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol
hook <- asIO1 $ distributionDownloadComplete d dest cleanup
modifyDaemonStatus_ $ \s -> s
{ transferHook = M.insert k hook (transferHook s) }
- maybe noop (queueTransfer "upgrade" Next (Just f) t)
+ maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just f)) t)
=<< liftAnnex (remoteFromUUID webUUID)
startTransfer t
k = distributionKey d
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index 9e9787b..0ed6978 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -43,6 +43,9 @@ transfersDisplay = do
ident = "transfers"
isrunning info = not $
transferPaused info || isNothing (startedTime info)
+ desc transfer info = case associatedFile info of
+ AssociatedFile Nothing -> key2file $ transferKey transfer
+ AssociatedFile (Just af) -> af
{- Simplifies a list of transfers, avoiding display of redundant
- equivilant transfers. -}
diff --git a/Backend/Hash.hs b/Backend/Hash.hs
index 9b0e919..a5abc84 100644
--- a/Backend/Hash.hs
+++ b/Backend/Hash.hs
@@ -148,8 +148,8 @@ trivialMigrate oldkey newbackend afile
}
{- Fast migration from hash to hashE backend. -}
| migratable && hasExt oldvariety = case afile of
- Nothing -> Nothing
- Just file -> Just $ oldkey
+ AssociatedFile Nothing -> Nothing
+ AssociatedFile (Just file) -> Just $ oldkey
{ keyName = keyHash oldkey ++ selectExtension file
, keyVariety = newvariety
}
diff --git a/Build/BundledPrograms.hs b/Build/BundledPrograms.hs
index a9a29b6..271e1dd 100644
--- a/Build/BundledPrograms.hs
+++ b/Build/BundledPrograms.hs
@@ -32,6 +32,16 @@ extraBundledPrograms = catMaybes
#else
[
#endif
+#ifndef darwin_HOST_OS
+#ifndef mingw32_HOST_OS
+ -- OS X has ssh installed by default.
+ -- On Windows, git provides ssh.
+ -- Linux probably has ssh installed system wide,
+ -- and if so the user probably wants to use that one.
+ , Just "ssh"
+ , Just "ssh-keygen"
+#endif
+#endif
]
{- Programs that should be preferred for use from the bundle, over
@@ -57,15 +67,6 @@ preferredBundledPrograms = catMaybes
, Just "xargs"
#endif
, Just "rsync"
-#ifndef darwin_HOST_OS
-#ifndef mingw32_HOST_OS
- -- OS X has ssh installed by default.
- -- Linux probably has ssh, but not guaranteed.
- -- On Windows, git provides ssh.
- , Just "ssh"
- , Just "ssh-keygen"
-#endif
-#endif
#ifndef mingw32_HOST_OS
, Just "sh"
#endif
diff --git a/CHANGELOG b/CHANGELOG
index 410f64f..c1b589e 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,34 @@
+git-annex (6.20170321) unstable; urgency=medium
+
+ * Bugfix: Passing a command a filename that does not exist sometimes
+ did not display an error, when a path to a directory was also passed.
+ * status: Propigate nonzero exit code from git status.
+ * Linux standalone builds put the bundled ssh last in PATH,
+ so any system ssh will be preferred over it.
+ * assistant: Add 1/200th second delay between checking each file
+ in the full transfer scan, to avoid using too much CPU.
+ * get -J: Improve distribution of jobs amoung remotes when there are more
+ jobs than remotes.
+ * fsck -q: When a file has bad content, include the name of the file
+ in the warning message.
+ * Windows: Improve handling of shebang in external special remote
+ program, searching for the program in the PATH.
+ * Drop support for building with old versions of dns, http-conduit,
+ directory, feed, and http-types.
+ * Windows: Fix bug in shell script shebang lookup code that
+ caused a "delayed read on closed handle" error.
+ * git-annex-shell: Fix bug when used with a recently cloned repository,
+ where "merging" messages were included in the output of configlist
+ (and perhaps other commands) and caused a "Failed to get annex.uuid
+ configuration" error.
+ * Support GIT_SSH and GIT_SSH_COMMAND, which are handled close the same
+ as they are by git. However, unlike git, git-annex sometimes needs to
+ pass the -n parameter when using these.
+ * sync --content-of=path (-C path) added for when you want to sync
+ only some files' contents, not the whole working tree.
+
+ -- Joey Hess <id@joeyh.name> Tue, 21 Mar 2017 11:27:38 -0400
+
git-annex (6.20170301.1) unstable; urgency=medium
* Fix reversion in yesterday's release that made SHA1E and MD5E backends
diff --git a/COPYRIGHT b/COPYRIGHT
index 8f67761..d7a1881 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -24,10 +24,6 @@ Files: Utility/*
Copyright: 2012-2017 Joey Hess <id@joeyh.name>
License: BSD-2-clause
-Files: Utility/Gpg.hs Utility/DirWatcher*
-Copyright: © 2010-2014 Joey Hess <id@joeyh.name>
-License: GPL-3+
-
Files: doc/logo* */favicon.ico standalone/osx/git-annex.app/Contents/Resources/git-annex.icns standalone/android/icons/*
Copyright: 2007 Henrik Nyh <http://henrik.nyh.se/>
2010 Joey Hess <id@joeyh.name>
diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs
index 70c86ec..154bfeb 100644
--- a/CmdLine/GitAnnexShell.hs
+++ b/CmdLine/GitAnnexShell.hs
@@ -48,7 +48,7 @@ cmds_notreadonly =
]
cmds :: [Command]
-cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
+cmds = map (adddirparam . noMessages) (cmds_readonly ++ cmds_notreadonly)
where
adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }
diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs
index 7fc64c5..0afb0e6 100644
--- a/CmdLine/Seek.hs
+++ b/CmdLine/Seek.hs
@@ -243,13 +243,12 @@ seekActions gen = mapM_ commandAction =<< gen
seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath]
seekHelper a params = do
- ll <- inRepo $ \g -> concat <$> forM (segmentXargsOrdered params)
- (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g))
- forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p ->
+ forM_ params $ \p ->
unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ do
toplevelWarning False (p ++ " not found")
Annex.incError
- return $ concat ll
+ inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered params)
+ (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g))
notSymlink :: FilePath -> IO Bool
notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index a89a25e..866bfc4 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -171,7 +171,9 @@ downloadRemoteFile r relaxed uri file sz = checkCanAdd file $ do
-- so that the remote knows what url it
-- should use to download it.
setTempUrl urlkey loguri
- let downloader = \dest p -> fst <$> Remote.retrieveKeyFile r urlkey (Just file) dest p
+ let downloader = \dest p -> fst
+ <$> Remote.retrieveKeyFile r urlkey
+ (AssociatedFile (Just file)) dest p
ret <- downloadWith downloader urlkey (Remote.uuid r) loguri file
removeTempUrl urlkey
return ret
@@ -255,8 +257,8 @@ addUrlFileQuvi relaxed quviurl videourl file = checkCanAdd file $ do
checkDiskSpaceToGet sizedkey Nothing $ do
tmp <- fromRepo $ gitAnnexTmpObjectLocation key
showOutput
- ok <- Transfer.notifyTransfer Transfer.Download (Just file) $
- Transfer.download webUUID key (Just file) Transfer.forwardRetry $ \p -> do
+ ok <- Transfer.notifyTransfer Transfer.Download afile $
+ Transfer.download webUUID key afile Transfer.forwardRetry $ \p -> do
liftIO $ createDirectoryIfMissing True (parentDir tmp)
downloadUrl key p [videourl] tmp
if ok
@@ -265,6 +267,8 @@ addUrlFileQuvi relaxed quviurl videourl file = checkCanAdd file $ do
return (Just key)
else return Nothing
)
+ where
+ afile = AssociatedFile (Just file)
addUrlChecked :: Bool -> URLString -> UUID -> (Key -> Annex (Bool, Bool)) -> Key -> CommandPerform
addUrlChecked relaxed url u checkexistssize key
@@ -328,10 +332,11 @@ downloadWith downloader dummykey u url file =
, return Nothing
)
where
- runtransfer tmp = Transfer.notifyTransfer Transfer.Download (Just file) $
- Transfer.download u dummykey (Just file) Transfer.forwardRetry $ \p -> do
+ runtransfer tmp = Transfer.notifyTransfer Transfer.Download afile $
+ Transfer.download u dummykey afile Transfer.forwardRetry $ \p -> do
liftIO $ createDirectoryIfMissing True (parentDir tmp)
downloader tmp p
+ afile = AssociatedFile (Just file)
{- Adds the url size to the Key. -}
addSizeUrlKey :: Url.UrlInfo -> Key -> Key
diff --git a/Command/Copy.hs b/Command/Copy.hs
index 56278bd..9b41b17 100644
--- a/Command/Copy.hs
+++ b/Command/Copy.hs
@@ -53,6 +53,6 @@ start o file key = stopUnless shouldCopy $
| otherwise = return True
want = case Command.Move.fromToOptions (moveOptions o) of
ToRemote dest -> (Remote.uuid <$> getParsed dest) >>=
- wantSend False (Just key) (Just file)
+ wantSend False (Just key) (AssociatedFile (Just file))
FromRemote _ ->
- wantGet False (Just key) (Just file)
+ wantGet False (Just key) (AssociatedFile (Just file))
diff --git a/Command/Drop.hs b/Command/Drop.hs
index 129dce0..52b89b8 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -65,7 +65,7 @@ seek o = allowConcurrentOutput $
start :: DropOptions -> FilePath -> Key -> CommandStart
start o file key = start' o key afile (mkActionItem afile)
where
- afile = Just file
+ afile = AssociatedFile (Just file)
start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart
start' o key afile ai = do
@@ -85,7 +85,7 @@ start' o key afile ai = do
| otherwise = return True
startKeys :: DropOptions -> Key -> ActionItem -> CommandStart
-startKeys o key = start' o key Nothing
+startKeys o key = start' o key (AssociatedFile Nothing)
startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart
startLocal afile ai numcopies key preverified = stopUnless (inAnnex key) $ do
@@ -202,7 +202,8 @@ requiredContent = do
{- In auto mode, only runs the action if there are enough
- copies on other semitrusted repositories. -}
checkDropAuto :: Bool -> Maybe Remote -> AssociatedFile -> Key -> (NumCopies -> CommandStart) -> CommandStart
-checkDropAuto automode mremote afile key a = go =<< maybe getNumCopies getFileNumCopies afile
+checkDropAuto automode mremote (AssociatedFile afile) key a =
+ go =<< maybe getNumCopies getFileNumCopies afile
where
go numcopies
| automode = do
diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs
index edc11ea..840a8a4 100644
--- a/Command/DropUnused.hs
+++ b/Command/DropUnused.hs
@@ -46,9 +46,9 @@ perform :: Maybe Remote -> NumCopies -> Key -> CommandPerform
perform from numcopies key = case from of
Just r -> do
showAction $ "from " ++ Remote.name r
- Command.Drop.performRemote key Nothing numcopies r
+ Command.Drop.performRemote key (AssociatedFile Nothing) numcopies r
Nothing -> ifM (inAnnex key)
- ( Command.Drop.performLocal key Nothing numcopies []
+ ( Command.Drop.performLocal key (AssociatedFile Nothing) numcopies []
, next (return True)
)
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index f20059b..8ebc433 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -36,6 +36,7 @@ import qualified Database.Keys
import qualified Database.Fsck as FsckDb
import Types.CleanupActions
import Types.Key
+import Types.ActionItem
import Data.Time.Clock.POSIX
import System.Posix.Types (EpochTime)
@@ -110,9 +111,10 @@ start from inc file key = do
numcopies <- getFileNumCopies file
case from of
Nothing -> go $ perform key file backend numcopies
- Just r -> go $ performRemote key (Just file) backend numcopies r
+ Just r -> go $ performRemote key afile backend numcopies r
where
- go = runFsck inc (mkActionItem (Just file)) key
+ go = runFsck inc (mkActionItem afile) key
+ afile = AssociatedFile (Just file)
perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool
perform key file backend numcopies = do
@@ -120,13 +122,16 @@ perform key file backend numcopies = do
check
-- order matters
[ fixLink key file
- , verifyLocationLog key keystatus file
+ , verifyLocationLog key keystatus ai
, verifyAssociatedFiles key keystatus file
, verifyWorkTree key file
- , checkKeySize key keystatus
- , checkBackend backend key keystatus (Just file)
- , checkKeyNumCopies key (Just file) numcopies
+ , checkKeySize key keystatus ai
+ , checkBackend backend key keystatus afile
+ , checkKeyNumCopies key afile numcopies
]
+ where
+ afile = AssociatedFile (Just file)
+ ai = ActionItemAssociatedFile afile
{- To fsck a remote, the content is retrieved to a tmp file,
- and checked locally. -}
@@ -148,11 +153,12 @@ performRemote key afile backend numcopies remote =
return False
dispatch (Right False) = go False Nothing
go present localcopy = check
- [ verifyLocationLogRemote key (maybe (key2file key) id afile) remote present
- , checkKeySizeRemote key remote localcopy
- , checkBackendRemote backend key remote localcopy
+ [ verifyLocationLogRemote key ai remote present
+ , withLocalCopy localcopy $ checkKeySizeRemote key remote ai
+ , withLocalCopy localcopy $ checkBackendRemote backend key remote ai
, checkKeyNumCopies key afile numcopies
]
+ ai = ActionItemAssociatedFile afile
withtmp a = do
pid <- liftIO getPID
t <- fromRepo gitAnnexTmpObjectDir
@@ -167,7 +173,7 @@ performRemote key afile backend numcopies remote =
, ifM (Annex.getState Annex.fast)
( return Nothing
, Just . fst <$>
- Remote.retrieveKeyFile remote key Nothing tmp dummymeter
+ Remote.retrieveKeyFile remote key (AssociatedFile Nothing) tmp dummymeter
)
)
, return (Just False)
@@ -181,16 +187,16 @@ startKey from inc key ai numcopies =
Just backend -> runFsck inc ai key $
case from of
Nothing -> performKey key backend numcopies
- Just r -> performRemote key Nothing backend numcopies r
+ Just r -> performRemote key (AssociatedFile Nothing) backend numcopies r
performKey :: Key -> Backend -> NumCopies -> Annex Bool
performKey key backend numcopies = do
keystatus <- getKeyStatus key
check
- [ verifyLocationLog key keystatus (key2file key)
- , checkKeySize key keystatus
- , checkBackend backend key keystatus Nothing
- , checkKeyNumCopies key Nothing numcopies
+ [ verifyLocationLog key keystatus (mkActionItem key)
+ , checkKeySize key keystatus (mkActionItem key)
+ , checkBackend backend key keystatus (AssociatedFile Nothing)
+ , checkKeyNumCopies key (AssociatedFile Nothing) numcopies
]
check :: [Annex Bool] -> Annex Bool
@@ -215,8 +221,8 @@ fixLink key file = do
{- Checks that the location log reflects the current status of the key,
- in this repository only. -}
-verifyLocationLog :: Key -> KeyStatus -> String -> Annex Bool
-verifyLocationLog key keystatus desc = do
+verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool
+verifyLocationLog key keystatus ai = do
direct <- isDirect
obj <- calcRepo $ gitAnnexLocation key
present <- if not direct && isKeyUnlocked keystatus
@@ -247,15 +253,15 @@ verifyLocationLog key keystatus desc = do
- but that is expected and not something to do anything about. -}
if direct && not present
then return True
- else verifyLocationLog' key desc present u (logChange key u)
+ else verifyLocationLog' key ai present u (logChange key u)
-verifyLocationLogRemote :: Key -> String -> Remote -> Bool -> Annex Bool
-verifyLocationLogRemote key desc remote present =
- verifyLocationLog' key desc present (Remote.uuid remote)
+verifyLocationLogRemote :: Key -> ActionItem -> Remote -> Bool -> Annex Bool
+verifyLocationLogRemote key ai remote present =
+ verifyLocationLog' key ai present (Remote.uuid remote)
(Remote.logStatus remote key)
-verifyLocationLog' :: Key -> String -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool
-verifyLocationLog' key desc present u updatestatus = do
+verifyLocationLog' :: Key -> ActionItem -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool
+verifyLocationLog' key ai present u updatestatus = do
uuids <- loggedLocations key
case (present, u `elem` uuids) of
(True, False) -> do
@@ -265,8 +271,9 @@ verifyLocationLog' key desc present u updatestatus = do
(False, True) -> do
fix InfoMissing
warning $
- "** Based on the location log, " ++ desc
- ++ "\n** was expected to be present, " ++
+ "** Based on the location log, " ++
+ actionItemDesc ai key ++
+ "\n** was expected to be present, " ++
"but its content is missing."
return False
(False, False) -> do
@@ -338,22 +345,25 @@ verifyWorkTree key file = do
-
- Not checked when a file is unlocked, or in direct mode.
-}
-checkKeySize :: Key -> KeyStatus -> Annex Bool
-checkKeySize _ KeyUnlocked = return True
-checkKeySize key _ = do
+checkKeySize :: Key -> KeyStatus -> ActionItem -> Annex Bool
+checkKeySize _ KeyUnlocked _ = return True
+checkKeySize key _ ai = do
file <- calcRepo $ gitAnnexLocation key
ifM (liftIO $ doesFileExist file)
- ( checkKeySizeOr badContent key file
+ ( checkKeySizeOr badContent key file ai
, return True
)
-checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool
-checkKeySizeRemote _ _ Nothing = return True
-checkKeySizeRemote key remote (Just file) =
- checkKeySizeOr (badContentRemote remote file) key file
+withLocalCopy :: Maybe FilePath -> (FilePath -> Annex Bool) -> Annex Bool
+withLocalCopy Nothing _ = return True
+withLocalCopy (Just localcopy) f = f localcopy
-checkKeySizeOr :: (Key -> Annex String) -> Key -> FilePath -> Annex Bool
-checkKeySizeOr bad key file = case keySize key of
+checkKeySizeRemote :: Key -> Remote -> ActionItem -> FilePath -> Annex Bool
+checkKeySizeRemote key remote ai localcopy =
+ checkKeySizeOr (badContentRemote remote localcopy) key localcopy ai
+
+checkKeySizeOr :: (Key -> Annex String) -> Key -> FilePath -> ActionItem -> Annex Bool
+checkKeySizeOr bad key file ai = case keySize key of
Nothing -> return True
Just size -> do
size' <- liftIO $ getFileSize file
@@ -366,7 +376,8 @@ checkKeySizeOr bad key file = case keySize key of
badsize a b = do
msg <- bad key
warning $ concat
- [ "Bad file size ("
+ [ actionItemDesc ai key
+ , ": Bad file size ("
, compareSizes storageUnits True a b
, "); "
, msg
@@ -383,37 +394,38 @@ checkKeySizeOr bad key file = case keySize key of
- because modification of direct mode files is allowed. It's still done
- if the file does not appear modified, to catch disk corruption, etc.
-}
-checkBackend :: Backend -> Key -> KeyStatus -> Maybe FilePath -> Annex Bool
-checkBackend backend key keystatus mfile = go =<< isDirect
+checkBackend :: Backend -> Key -> KeyStatus -> AssociatedFile -> Annex Bool
+checkBackend backend key keystatus afile = go =<< isDirect
where
go False = do
content <- calcRepo $ gitAnnexLocation key
ifM (pure (isKeyUnlocked keystatus) <&&> (not <$> isUnmodified key content))
( nocheck
- , checkBackendOr badContent backend key content
+ , checkBackendOr badContent backend key content (mkActionItem afile)
)
- go True = maybe nocheck checkdirect mfile
+ go True = case afile of
+ AssociatedFile Nothing -> nocheck
+ AssociatedFile (Just f) -> checkdirect f
checkdirect file = ifM (Direct.goodContent key file)
- ( checkBackendOr' (badContentDirect file) backend key file
+ ( checkBackendOr' (badContentDirect file) backend key file (mkActionItem afile)
(Direct.goodContent key file)
, nocheck
)
nocheck = return True
-checkBackendRemote :: Backend -> Key -> Remote -> Maybe FilePath -> Annex Bool
-checkBackendRemote backend key remote = maybe (return True) go
- where
- go file = checkBackendOr (badContentRemote remote file) backend key file
+checkBackendRemote :: Backend -> Key -> Remote -> ActionItem -> FilePath -> Annex Bool
+checkBackendRemote backend key remote ai localcopy =
+ checkBackendOr (badContentRemote remote localcopy) backend key localcopy ai
-checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool
-checkBackendOr bad backend key file =
- checkBackendOr' bad backend key file (return True)
+checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> ActionItem -> Annex Bool
+checkBackendOr bad backend key file ai =
+ checkBackendOr' bad backend key file ai (return True)
-- The postcheck action is run after the content is verified,
-- in order to detect situations where the file is changed while being
-- verified (particularly in direct mode).
-checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool -> Annex Bool
-checkBackendOr' bad backend key file postcheck =
+checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> FilePath -> ActionItem -> Annex Bool -> Annex Bool
+checkBackendOr' bad backend key file ai postcheck =
case Types.Backend.verifyKeyContent backend of
Nothing -> return True
Just verifier -> do
@@ -422,28 +434,34 @@ checkBackendOr' bad backend key file postcheck =
( do
unless ok $ do
msg <- bad key
- warning $ "Bad file content; " ++ msg
+ warning $ concat
+ [ actionItemDesc ai key
+ , ": Bad file content; "
+ , msg
+ ]
return ok
, return True
)
checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool
checkKeyNumCopies key afile numcopies = do
- let file = fromMaybe (key2file key) afile
+ let (desc, hasafile) = case afile of
+ AssociatedFile Nothing -> (key2file key, False)
+ AssociatedFile (Just af) -> (af, True)
locs <- loggedLocations key
(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs
(deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations
let present = NumCopies (length safelocations)
if present < numcopies
- then ifM (pure (isNothing afile) <&&> checkDead key)
+ then ifM (pure (not hasafile) <&&> checkDead key)
( do
showLongNote $ "This key is dead, skipping."
return True
, do
untrusted <- Remote.prettyPrintUUIDs "untrusted" untrustedlocations
dead <- Remote.prettyPrintUUIDs "dead" deadlocations
- warning $ missingNote file present numcopies untrusted dead
- when (fromNumCopies present == 0 && isNothing afile) $
+ warning $ missingNote desc present numcopies untrusted dead
+ when (fromNumCopies present == 0 && not hasafile) $
showLongNote "(Avoid this check by running: git annex dead --key )"
return False
)
diff --git a/Command/Get.hs b/Command/Get.hs
index abf95e4..fc6ff73 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -51,14 +51,15 @@ seek o = allowConcurrentOutput $ do
start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart
start o from file key = start' expensivecheck from key afile (mkActionItem afile)
where
- afile = Just file
+ afile = AssociatedFile (Just file)
expensivecheck
- | autoMode o = numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file)
+ | autoMode o = numCopiesCheck file key (<)
+ <||> wantGet False (Just key) afile
| otherwise = return True
startKeys :: Maybe Remote -> Key -> ActionItem -> CommandStart
startKeys from key ai = checkFailedTransferDirection ai Download $
- start' (return True) from key Nothing ai
+ start' (return True) from key (AssociatedFile Nothing) ai
start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart
start' expensivecheck from key afile ai = stopUnless (not <$> inAnnex key) $
diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs
index ebc7638..6318136 100644
--- a/Command/ImportFeed.hs
+++ b/Command/ImportFeed.hs
@@ -272,24 +272,16 @@ feedFile tmpl i extension = Utility.Format.format tmpl $
, extractField "itempubdate" [pubdate $ item i]
]
where
-#if MIN_VERSION_feed(0,3,9)
pubdate itm = case getItemPublishDate itm :: Maybe (Maybe UTCTime) of
Just (Just d) -> Just $
formatTime defaultTimeLocale "%F" d
-- if date cannot be parsed, use the raw string
_ -> replace "/" "-" <$> getItemPublishDateString itm
-#else
- pubdate _ = Nothing
-#endif
extractMetaData :: ToDownload -> MetaData
-#if MIN_VERSION_feed(0,3,9)
extractMetaData i = case getItemPublishDate (item i) :: Maybe (Maybe UTCTime) of
Just (Just d) -> unionMetaData meta (dateMetaData d meta)
_ -> meta
-#else
-extractMetaData i = meta
-#endif
where
tometa (k, v) = (mkMetaFieldUnchecked k, S.singleton (toMetaValue v))
meta = MetaData $ M.fromList $ map tometa $ extractFields i
diff --git a/Command/Info.hs b/Command/Info.hs
index aaee08f..0867bf8 100644
--- a/Command/Info.hs
+++ b/Command/Info.hs
@@ -39,6 +39,7 @@ import Logs.Transfer
import Types.Key
import Types.TrustLevel
import Types.FileMatcher
+import Types.ActionItem
import qualified Limit
import Messages.JSON (DualDisp(..), ObjectMap(..))
import Annex.BloomFilter
@@ -420,7 +421,9 @@ transfer_list = stat desc $ nojson $ lift $ do
desc = "transfers in progress"
line uuidmap t i = unwords
[ formatDirection (transferDirection t) ++ "ing"
- , fromMaybe (key2file $ transferKey t) (associatedFile i)
+ , actionItemDesc
+ (ActionItemAssociatedFile (associatedFile i))
+ (transferKey t)
, if transferDirection t == Upload then "to" else "from"
, maybe (fromUUID $ transferUUID t) Remote.name $
M.lookup (transferUUID t) uuidmap
@@ -428,9 +431,11 @@ transfer_list = stat desc $ nojson $ lift $ do
jsonify t i = object $ map (\(k, v) -> (T.pack k, v)) $
[ ("transfer", toJSON (formatDirection (transferDirection t)))
, ("key", toJSON (key2file (transferKey t)))
- , ("file", toJSON (associatedFile i))
+ , ("file", toJSON afile)
, ("remote", toJSON (fromUUID (transferUUID t)))
]
+ where
+ AssociatedFile afile = associatedFile i
disk_size :: Stat
disk_size = simpleStat "available local disk space" $
diff --git a/Command/Map.hs b/Command/Map.hs
index eb08037..ae568f8 100644
--- a/Command/Map.hs
+++ b/Command/Map.hs
@@ -224,10 +224,10 @@ tryScan r
(pipedconfig, return Nothing) "configlist" [] []
manualconfiglist = do
gc <- Annex.getRemoteGitConfig r
- sshparams <- Ssh.toRepo NoConsumeStdin r gc [Param sshcmd]
- liftIO $ pipedconfig "ssh" sshparams
+ (sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r gc remotecmd
+ liftIO $ pipedconfig sshcmd sshparams
where
- sshcmd = "sh -c " ++ shellEscape
+ remotecmd = "sh -c " ++ shellEscape
(cddir ++ " && " ++ "git config --null --list")
dir = Git.repoPath r
cddir
diff --git a/Command/MetaData.hs b/Command/MetaData.hs
index ebb9d0f..617b291 100644
--- a/Command/MetaData.hs
+++ b/Command/MetaData.hs
@@ -86,7 +86,7 @@ seek o = case batchOption o of
start :: POSIXTime -> MetaDataOptions -> FilePath -> Key -> CommandStart
start now o file k = startKeys now o k (mkActionItem afile)
where
- afile = Just file
+ afile = AssociatedFile (Just file)
startKeys :: POSIXTime -> MetaDataOptions -> Key -> ActionItem -> CommandStart
startKeys now o k ai = case getSet o of
@@ -155,7 +155,7 @@ startBatch (i, (MetaData m)) = case i of
Left f -> do
mk <- lookupFile f
case mk of
- Just k -> go k (mkActionItem (Just f))
+ Just k -> go k (mkActionItem (AssociatedFile (Just f)))
Nothing -> giveup $ "not an annexed file: " ++ f
Right k -> go k (mkActionItem k)
where
diff --git a/Command/Migrate.hs b/Command/Migrate.hs
index 0ae6f7d..8dfee98 100644
--- a/Command/Migrate.hs
+++ b/Command/Migrate.hs
@@ -73,7 +73,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey
go (Just (newkey, knowngoodcontent))
| knowngoodcontent = finish newkey
| otherwise = stopUnless checkcontent $ finish newkey
- checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyLocked $ Just file
+ checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyLocked afile
finish newkey = ifM (Command.ReKey.linkKey file oldkey newkey)
( do
copyMetaData oldkey newkey
@@ -86,7 +86,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey
next $ Command.ReKey.cleanup file oldkey newkey
, error "failed"
)
- genkey = case maybe Nothing (\fm -> fm oldkey newbackend (Just file)) (fastMigrate oldbackend) of
+ genkey = case maybe Nothing (\fm -> fm oldkey newbackend afile) (fastMigrate oldbackend) of
Just newkey -> return $ Just (newkey, True)
Nothing -> do
content <- calcRepo $ gitAnnexLocation oldkey
@@ -99,3 +99,4 @@ perform file oldkey oldbackend newbackend = go =<< genkey
return $ case v of
Just (newkey, _) -> Just (newkey, False)
_ -> Nothing
+ afile = AssociatedFile (Just file)
diff --git a/Command/Mirror.hs b/Command/Mirror.hs
index d08555e..7d33d80 100644
--- a/Command/Mirror.hs
+++ b/Command/Mirror.hs
@@ -43,16 +43,16 @@ instance DeferredParseClass MirrorOptions where
seek :: MirrorOptions -> CommandSeek
seek o = allowConcurrentOutput $
withKeyOptions (keyOptions o) False
- (startKey o Nothing)
+ (startKey o (AssociatedFile Nothing))
(withFilesInGit $ whenAnnexed $ start o)
(mirrorFiles o)
start :: MirrorOptions -> FilePath -> Key -> CommandStart
start o file k = startKey o afile k (mkActionItem afile)
where
- afile = Just file
+ afile = AssociatedFile (Just file)
-startKey :: MirrorOptions -> Maybe FilePath -> Key -> ActionItem -> CommandStart
+startKey :: MirrorOptions -> AssociatedFile -> Key -> ActionItem -> CommandStart
startKey o afile key ai = case fromToOptions o of
ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key)
( Command.Move.toStart False afile key ai =<< getParsed r
@@ -72,4 +72,6 @@ startKey o afile key ai = case fromToOptions o of
, stop
)
where
- getnumcopies = maybe getNumCopies getFileNumCopies afile
+ getnumcopies = case afile of
+ AssociatedFile Nothing -> getNumCopies
+ AssociatedFile (Just af) -> getFileNumCopies af
diff --git a/Command/Move.hs b/Command/Move.hs
index d74eea9..ca4febe 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -53,10 +53,10 @@ seek o = allowConcurrentOutput $
start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart
start o move f k = start' o move afile k (mkActionItem afile)
where
- afile = Just f
+ afile = AssociatedFile (Just f)
startKey :: MoveOptions -> Bool -> Key -> ActionItem -> CommandStart
-startKey o move = start' o move Nothing
+startKey o move = start' o move (AssociatedFile Nothing)
start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart
start' o move afile key ai =
diff --git a/Command/SendKey.hs b/Command/SendKey.hs
index 3028103..670f0e4 100644
--- a/Command/SendKey.hs
+++ b/Command/SendKey.hs
@@ -46,7 +46,7 @@ start key = do
fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart
fieldTransfer direction key a = do
liftIO $ debugM "fieldTransfer" "transfer start"
- afile <- Fields.getField Fields.associatedFile
+ afile <- AssociatedFile <$> Fields.getField Fields.associatedFile
ok <- maybe (a $ const noop)
-- Using noRetry here because we're the sender.
(\u -> runner (Transfer direction (toUUID u) key) afile noRetry a)
diff --git a/Command/Status.hs b/Command/Status.hs
index 2e6b9f4..07024f3 100644
--- a/Command/Status.hs
+++ b/Command/Status.hs
@@ -47,8 +47,10 @@ start o locs = do
, return $ \s -> pure (Just s)
)
forM_ l $ \s -> maybe noop displayStatus =<< getstatus s
- void $ liftIO cleanup
- stop
+ ifM (liftIO cleanup)
+ ( stop
+ , giveup "git status failed"
+ )
where
ps = case ignoreSubmodules o of
Nothing -> []
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 0d5d46b..f2c1945 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -63,7 +63,7 @@ cmd :: Command
cmd = withGlobalOptions [jobsOption] $
command "sync" SectionCommon
"synchronize local repository with remotes"
- (paramRepeating paramRemote) (seek <$$> optParser)
+ (paramRepeating paramRemote) (seek <--< optParser)
data SyncOptions = SyncOptions
{ syncWith :: CmdParams
@@ -74,6 +74,7 @@ data SyncOptions = SyncOptions
, pushOption :: Bool
, contentOption :: Bool
, noContentOption :: Bool
+ , contentOfOption :: [FilePath]
, keyOptions :: Maybe KeyOptions
}
@@ -109,8 +110,29 @@ optParser desc = SyncOptions
( long "no-content"
<> help "do not transfer file contents"
)
+ <*> many (strOption
+ ( long "content-of"
+ <> short 'C'
+ <> help "transfer file contents of files in a given location"
+ <> metavar paramPath
+ ))
<*> optional parseAllOption
+-- Since prepMerge changes the working directory, FilePath options
+-- have to be adjusted.
+instance DeferredParseClass SyncOptions where
+ finishParse v = SyncOptions
+ <$> pure (syncWith v)
+ <*> pure (commitOption v)
+ <*> pure (noCommitOption v)
+ <*> pure (messageOption v)
+ <*> pure (pullOption v)
+ <*> pure (pushOption v)
+ <*> pure (contentOption v)
+ <*> pure (noContentOption v)
+ <*> liftIO (mapM absPath (contentOfOption v))
+ <*> pure (keyOptions v)
+
seek :: SyncOptions -> CommandSeek
seek o = allowConcurrentOutput $ do
prepMerge
@@ -148,6 +170,7 @@ seek o = allowConcurrentOutput $ do
mapM_ (commandAction . withbranch . pushRemote o) gitremotes
where
shouldsynccontent = pure (contentOption o)
+ <||> pure (not (null (contentOfOption o)))
<||> (pure (not (noContentOption o)) <&&> getGitConfigVal annexSyncContent)
type CurrBranch = (Maybe Git.Branch, Maybe Adjustment)
@@ -510,7 +533,7 @@ seekSyncContent o rs = do
mvar <- liftIO newEmptyMVar
bloom <- case keyOptions o of
Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar [])
- _ -> seekworktree mvar [] (const noop) >> pure Nothing
+ _ -> seekworktree mvar (contentOfOption o) (const noop) >> pure Nothing
withKeyOptions' (keyOptions o) False
(return (seekkeys mvar bloom))
(const noop)
@@ -519,8 +542,8 @@ seekSyncContent o rs = do
liftIO $ not <$> isEmptyMVar mvar
where
seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>=
- mapM_ (\f -> ifAnnexed f (go (Right bloomfeeder) mvar (Just f)) noop)
- seekkeys mvar bloom k _ = go (Left bloom) mvar Nothing k
+ mapM_ (\f -> ifAnnexed f (go (Right bloomfeeder) mvar (AssociatedFile (Just f))) noop)
+ seekkeys mvar bloom k _ = go (Left bloom) mvar (AssociatedFile Nothing) k
go ebloom mvar af k = commandAction $ do
whenM (syncFile ebloom rs af k) $
void $ liftIO $ tryPutMVar mvar ()
diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs
index c8a9936..8a21fdf 100644
--- a/Command/TestRemote.hs
+++ b/Command/TestRemote.hs
@@ -155,8 +155,9 @@ test st r k =
Nothing -> return True
Just verifier -> verifier k (key2file k)
get = getViaTmp (RemoteVerify r) k $ \dest ->
- Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate
- store = Remote.storeKey r k Nothing nullMeterUpdate
+ Remote.retrieveKeyFile r k (AssociatedFile Nothing)
+ dest nullMeterUpdate
+ store = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate
remove = Remote.removeKey r k
testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree]
@@ -164,15 +165,15 @@ testUnavailable st r k =
[ check (== Right False) "removeKey" $
Remote.removeKey r k
, check (== Right False) "storeKey" $
- Remote.storeKey r k Nothing nullMeterUpdate
+ Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate
, check (`notElem` [Right True, Right False]) "checkPresent" $
Remote.checkPresent r k
, check (== Right False) "retrieveKeyFile" $
getViaTmp (RemoteVerify r) k $ \dest ->
- Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate
+ Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate
, check (== Right False) "retrieveKeyFileCheap" $
getViaTmp (RemoteVerify r) k $ \dest -> unVerified $
- Remote.retrieveKeyFileCheap r k Nothing dest
+ Remote.retrieveKeyFileCheap r k (AssociatedFile Nothing) dest
]
where
check checkval desc a = testCase desc $ do
diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs
index 1db6334..3f352a8 100644
--- a/Command/TransferInfo.hs
+++ b/Command/TransferInfo.hs
@@ -41,7 +41,7 @@ start (k:[]) = do
case file2key k of
Nothing -> error "bad key"
(Just key) -> whenM (inAnnex key) $ do
- file <- Fields.getField Fields.associatedFile
+ afile <- AssociatedFile <$> Fields.getField Fields.associatedFile
u <- maybe (error "missing remoteuuid") toUUID
<$> Fields.getField Fields.remoteUUID
let t = Transfer
@@ -49,7 +49,7 @@ start (k:[]) = do
, transferUUID = u
, transferKey = key
}
- tinfo <- liftIO $ startTransferInfo file
+ tinfo <- liftIO $ startTransferInfo afile
(update, tfile, _) <- mkProgressUpdater t tinfo
liftIO $ mapM_ void
[ tryIO $ forever $ do
diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs
index 42a6a9e..aa6acbd 100644
--- a/Command/TransferKey.hs
+++ b/Command/TransferKey.hs
@@ -30,10 +30,10 @@ optParser :: CmdParamsDesc -> Parser TransferKeyOptions
optParser desc = TransferKeyOptions
<$> cmdParams desc
<*> parseFromToOptions
- <*> optional (strOption
+ <*> (AssociatedFile <$> optional (strOption
( long "file" <> metavar paramFile
<> help "the associated file"
- ))
+ )))
instance DeferredParseClass TransferKeyOptions where
finishParse v = TransferKeyOptions
diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs
index d875f49..855ca46 100644
--- a/Command/TransferKeys.hs
+++ b/Command/TransferKeys.hs
@@ -116,10 +116,10 @@ instance TCSerialized Direction where
deserialize _ = Nothing
instance TCSerialized AssociatedFile where
- serialize (Just f) = f
- serialize Nothing = ""
- deserialize "" = Just Nothing
- deserialize f = Just $ Just f
+ serialize (AssociatedFile (Just f)) = f
+ serialize (AssociatedFile Nothing) = ""
+ deserialize "" = Just (AssociatedFile Nothing)
+ deserialize f = Just (AssociatedFile (Just f))
instance TCSerialized RemoteName where
serialize n = n
diff --git a/Command/Whereis.hs b/Command/Whereis.hs
index bcc11aa..a08b944 100644
--- a/Command/Whereis.hs
+++ b/Command/Whereis.hs
@@ -49,7 +49,7 @@ seek o = do
start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart
start remotemap file key = startKeys remotemap key (mkActionItem afile)
where
- afile = Just file
+ afile = AssociatedFile (Just file)
startKeys :: M.Map UUID Remote -> Key -> ActionItem -> CommandStart
startKeys remotemap key ai = do
diff --git a/Git/Ssh.hs b/Git/Ssh.hs
new file mode 100644
index 0000000..206e721
--- /dev/null
+++ b/Git/Ssh.hs
@@ -0,0 +1,74 @@
+{- GIT_SSH and GIT_SSH_COMMAND support
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Ssh where
+
+import Common
+import Utility.Env
+
+import Data.Char
+
+gitSshEnv :: String
+gitSshEnv = "GIT_SSH"
+
+gitSshCommandEnv :: String
+gitSshCommandEnv = "GIT_SSH_COMMAND"
+
+gitSshEnvSet :: IO Bool
+gitSshEnvSet = anyM (isJust <$$> getEnv) [gitSshEnv, gitSshCommandEnv]
+
+-- Either a hostname, or user@host
+type SshHost = String
+
+type SshPort = Integer
+
+-- Command to run on the remote host. It is run by the shell
+-- there, so any necessary shell escaping of parameters in it should
+-- already be done.
+type SshCommand = String
+
+-- | Checks for GIT_SSH and GIT_SSH_COMMAND and if set, returns
+-- a command and parameters to run to ssh.
+gitSsh :: SshHost -> Maybe SshPort -> SshCommand -> IO (Maybe (FilePath, [CommandParam]))
+gitSsh host mp cmd = gitSsh' host mp cmd []
+
+gitSsh' :: SshHost -> Maybe SshPort -> SshCommand -> [CommandParam] -> IO (Maybe (FilePath, [CommandParam]))
+gitSsh' host mp cmd extrasshparams = do
+ gsc <- getEnv gitSshCommandEnv
+ case gsc of
+ Just c
+ -- git only runs the command with the shell
+ -- when it contains spaces; otherwise it's
+ -- treated the same as GIT_SSH
+ | any isSpace c -> ret "sh"
+ [ Param "-c"
+ , Param (shellcmd c sshps)
+ ]
+ | otherwise -> ret c sshps
+ Nothing -> do
+ gs <- getEnv gitSshEnv
+ case gs of
+ Just c -> ret c sshps
+ Nothing -> return Nothing
+ where
+ ret c l = return $ Just (c, l)
+
+ -- Git passes exactly these parameters to the ssh command.
+ gitps = map Param $ case mp of
+ Nothing -> [host, cmd]
+ Just p -> [host, "-p", show p, cmd]
+
+ -- Passing any extra parameters to the ssh command may
+ -- break some commands.
+ sshps = extrasshparams ++ gitps
+
+ -- The shell command to run with sh -c is constructed
+ -- this way, rather than using "$@" because there could be some
+ -- unwanted parameters passed to the command, and this way they
+ -- are ignored. For example, when Utility.Rsync.rsyncShell is
+ -- used, rsync adds some parameters after the command.
+ shellcmd c ps = c ++ " " ++ unwords (map shellEscape (toCommand ps))
diff --git a/Key.hs b/Key.hs
index d1669bf..8672c82 100644
--- a/Key.hs
+++ b/Key.hs
@@ -9,7 +9,7 @@
module Key (
Key(..),
- AssociatedFile,
+ AssociatedFile(..),
stubKey,
key2file,
file2key,
diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs
index c11e24b..a41398c 100644
--- a/Limit/Wanted.hs
+++ b/Limit/Wanted.hs
@@ -13,12 +13,14 @@ import Limit
import Types.FileMatcher
addWantGet :: Annex ()
-addWantGet = addLimit $ Right $ const $ checkWant $ wantGet False Nothing
+addWantGet = addLimit $ Right $ const $ checkWant $
+ wantGet False Nothing
addWantDrop :: Annex ()
-addWantDrop = addLimit $ Right $ const $ checkWant $ wantDrop False Nothing Nothing
+addWantDrop = addLimit $ Right $ const $ checkWant $
+ wantDrop False Nothing Nothing
-checkWant :: (Maybe FilePath -> Annex Bool) -> MatchInfo -> Annex Bool
-checkWant a (MatchingFile fi) = a (Just $ matchFile fi)
+checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool
+checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi))
checkWant _ (MatchingKey _) = return False
checkWant _ (MatchingInfo {}) = return False
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index ce2a7d2..aef233b 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -10,6 +10,7 @@
module Logs.Transfer where
import Types.Transfer
+import Types.ActionItem
import Annex.Common
import Annex.Perms
import qualified Git
@@ -27,7 +28,9 @@ describeTransfer :: Transfer -> TransferInfo -> String
describeTransfer t info = unwords
[ show $ transferDirection t
, show $ transferUUID t
- , fromMaybe (key2file $ transferKey t) (associatedFile info)
+ , actionItemDesc
+ (ActionItemAssociatedFile (associatedFile info))
+ (transferKey t)
, show $ bytesComplete info
]
@@ -67,8 +70,8 @@ mkProgressUpdater t info = do
Just sz -> sz `div` 100
Nothing -> 100 * 1024 -- arbitrarily, 100 kb
-startTransferInfo :: Maybe FilePath -> IO TransferInfo
-startTransferInfo file = TransferInfo
+startTransferInfo :: AssociatedFile -> IO TransferInfo
+startTransferInfo afile = TransferInfo
<$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime)
#ifndef mingw32_HOST_OS
<*> pure Nothing -- pid not stored in file, so omitted for speed
@@ -78,7 +81,7 @@ startTransferInfo file = TransferInfo
<*> pure Nothing -- tid ditto
<*> pure Nothing -- not 0; transfer may be resuming
<*> pure Nothing
- <*> pure file
+ <*> pure afile
<*> pure False
{- If a transfer is still running, returns its TransferInfo.
@@ -228,7 +231,9 @@ writeTransferInfo info = unlines
#ifdef mingw32_HOST_OS
, maybe "" show (transferPid info)
#endif
- , fromMaybe "" $ associatedFile info -- comes last; arbitrary content
+ -- comes last; arbitrary content
+ , let AssociatedFile afile = associatedFile info
+ in fromMaybe "" afile
]
readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo)
@@ -246,7 +251,7 @@ readTransferInfo mpid s = TransferInfo
<*> pure Nothing
<*> pure Nothing
<*> bytes
- <*> pure (if null filename then Nothing else Just filename)
+ <*> pure (AssociatedFile (if null filename then Nothing else Just filename))
<*> pure False
where
#ifdef mingw32_HOST_OS
diff --git a/Logs/Unused.hs b/Logs/Unused.hs
index 2361fed..a2f4041 100644
--- a/Logs/Unused.hs
+++ b/Logs/Unused.hs
@@ -15,8 +15,6 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-{-# LANGUAGE CPP #-}
-
module Logs.Unused (
UnusedMap,
updateUnusedLog,
@@ -93,14 +91,9 @@ readUnusedMap :: FilePath -> Annex UnusedMap
readUnusedMap = log2map <$$> readUnusedLog
dateUnusedLog :: FilePath -> Annex (Maybe UTCTime)
-#if MIN_VERSION_directory(1,2,0)
dateUnusedLog prefix = do
f <- fromRepo $ gitAnnexUnusedLog prefix
liftIO $ catchMaybeIO $ getModificationTime f
-#else
--- old ghc's getModificationTime returned a ClockTime
-dateUnusedLog _prefix = return Nothing
-#endif
{- Set of unused keys. This is cached for speed. -}
unusedKeys :: Annex (S.Set Key)
diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs
index 135409e..e749791 100644
--- a/P2P/Protocol.hs
+++ b/P2P/Protocol.hs
@@ -136,8 +136,9 @@ instance Proto.Serializable Service where
-- These mungings are ok, because an AssociatedFile is only ever displayed
-- to the user and does not need to match a file on disk.
instance Proto.Serializable AssociatedFile where
- serialize Nothing = ""
- serialize (Just af) = toInternalGitPath $ concatMap esc af
+ serialize (AssociatedFile Nothing) = ""
+ serialize (AssociatedFile (Just af)) =
+ toInternalGitPath $ concatMap esc af
where
esc '%' = "%%"
esc c
@@ -145,9 +146,9 @@ instance Proto.Serializable AssociatedFile where
| otherwise = [c]
deserialize s = case fromInternalGitPath $ deesc [] s of
- [] -> Just Nothing
+ [] -> Just (AssociatedFile Nothing)
f
- | isRelative f -> Just (Just f)
+ | isRelative f -> Just (AssociatedFile (Just f))
| otherwise -> Nothing
where
deesc b [] = reverse b
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 5594bac..3a2d67b 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -212,11 +212,11 @@ storeBupUUID u buprepo = do
v = fromUUID u
onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a
-onBupRemote r a command params = do
+onBupRemote r runner command params = do
c <- Annex.getRemoteGitConfig r
- sshparams <- Ssh.toRepo NoConsumeStdin r c [Param $
- "cd " ++ dir ++ " && " ++ unwords (command : toCommand params)]
- liftIO $ a "ssh" sshparams
+ let remotecmd = "cd " ++ dir ++ " && " ++ unwords (command : toCommand params)
+ (sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd
+ liftIO $ runner sshcmd sshparams
where
path = Git.repoPath r
base = fromMaybe path (stripPrefix "/~/" path)
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index 1469284..e1c2a21 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -121,13 +121,12 @@ splitRemoteDdarRepo ddarrepo =
ddarRemoteCall :: ConsumeStdin -> DdarRepo -> Char -> [CommandParam] -> Annex (String, [CommandParam])
ddarRemoteCall cs ddarrepo cmd params
| ddarLocal ddarrepo = return ("ddar", localParams)
- | otherwise = do
- os <- sshOptions cs (host, Nothing) (ddarRepoConfig ddarrepo) []
- return ("ssh", os ++ remoteParams)
+ | otherwise = sshCommand cs (host, Nothing) (ddarRepoConfig ddarrepo) remoteCommand
where
(host, ddarrepo') = splitRemoteDdarRepo ddarrepo
localParams = Param [cmd] : Param (ddarRepoLocation ddarrepo) : params
- remoteParams = Param host : Param "ddar" : Param [cmd] : Param ddarrepo' : params
+ remoteCommand = unwords $ map shellEscape $ toCommand $
+ [Param "ddar", Param [cmd], Param ddarrepo'] ++ params
{- Specialized ddarRemoteCall that includes extraction command and flags -}
ddarExtractRemoteCall :: ConsumeStdin -> DdarRepo -> Key -> Annex (String, [CommandParam])
@@ -159,23 +158,19 @@ ddarDirectoryExists ddarrepo
Left _ -> Right False
Right status -> Right $ isDirectory status
| otherwise = do
- ps <- sshOptions NoConsumeStdin (host, Nothing)
- (ddarRepoConfig ddarrepo) []
- exitCode <- liftIO $ safeSystem "ssh" (ps ++ params)
+ let remotecmd = unwords $ map shellEscape
+ [ "test", "-d", ddarrepo' ]
+ (sshcmd, sshps) <- sshCommand NoConsumeStdin (host, Nothing)
+ (ddarRepoConfig ddarrepo) remotecmd
+ exitCode <- liftIO $ safeSystem sshcmd sshps
case exitCode of
ExitSuccess -> return $ Right True
ExitFailure 1 -> return $ Right False
- ExitFailure code -> return $ Left $ "ssh call " ++
- show (unwords $ toCommand params) ++
+ ExitFailure code -> return $ Left $ "ssh " ++
+ show (unwords $ toCommand sshps) ++
" failed with status " ++ show code
where
(host, ddarrepo') = splitRemoteDdarRepo ddarrepo
- params =
- [ Param host
- , Param "test"
- , Param "-d"
- , Param ddarrepo'
- ]
{- Use "ddar t" to determine if a given key is present in a ddar archive -}
inDdarManifest :: DdarRepo -> Key -> Annex (Either String Bool)
diff --git a/Remote/External.hs b/Remote/External.hs
index b66e102..0ac381b 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -375,7 +375,8 @@ startExternal external = do
return st
where
start errrelayer g = liftIO $ do
- (cmd, ps) <- findShellCommand basecmd
+ cmdpath <- searchPath basecmd
+ (cmd, ps) <- maybe (pure (basecmd, [])) findShellCommand cmdpath
let basep = (proc cmd (toCommand ps))
{ std_in = CreatePipe
, std_out = CreatePipe
@@ -383,9 +384,8 @@ startExternal external = do
}
p <- propgit g basep
(Just hin, Just hout, Just herr, ph) <-
- createProcess p `catchIO` runerr
+ createProcess p `catchIO` runerr cmdpath
stderrelay <- async $ errrelayer herr
- checkearlytermination =<< getProcessExitCode ph
cv <- newTVarIO $ externalDefaultConfig external
pv <- newTVarIO Unprepared
pid <- atomically $ do
@@ -409,15 +409,11 @@ startExternal external = do
environ <- propGitEnv g
return $ p { env = Just environ }
- runerr _ = giveup ("Cannot run " ++ basecmd ++ " -- Make sure it's in your PATH and is executable.")
-
- checkearlytermination Nothing = noop
- checkearlytermination (Just exitcode) = ifM (inPath basecmd)
- ( giveup $ unwords [ "failed to run", basecmd, "(" ++ show exitcode ++ ")" ]
- , do
- path <- intercalate ":" <$> getSearchPath
- giveup $ basecmd ++ " is not installed in PATH (" ++ path ++ ")"
- )
+ runerr (Just cmd) _ =
+ giveup $ "Cannot run " ++ cmd ++ " -- Make sure it's executable and that its dependencies are installed."
+ runerr Nothing _ = do
+ path <- intercalate ":" <$> getSearchPath
+ giveup $ "Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"
stopExternal :: External -> Annex ()
stopExternal external = liftIO $ do
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 79020f4..ea101a7 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -326,7 +326,8 @@ store r rsyncopts
return True
| Git.repoIsSsh (repo r) = if accessShell r
then fileStorer $ \k f p -> Ssh.rsyncHelper (Just p)
- =<< Ssh.rsyncParamsRemote False r Upload k f Nothing
+ =<< Ssh.rsyncParamsRemote False r Upload k f
+ (AssociatedFile Nothing)
else fileStorer $ Remote.Rsync.store rsyncopts
| otherwise = unsupportedUrl
@@ -336,8 +337,10 @@ retrieve r rsyncopts
guardUsable (repo r) (return False) $
sink =<< liftIO (L.readFile $ gCryptLocation r k)
| Git.repoIsSsh (repo r) = if accessShell r
- then fileRetriever $ \f k p ->
- unlessM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download k f Nothing) $
+ then fileRetriever $ \f k p -> do
+ ps <- Ssh.rsyncParamsRemote False r Download k f
+ (AssociatedFile Nothing)
+ unlessM (Ssh.rsyncHelper (Just p) ps) $
giveup "rsync failed"
else fileRetriever $ Remote.Rsync.retrieve rsyncopts
| otherwise = unsupportedUrl
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 9cb369e..e5d85d2 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -479,8 +479,9 @@ copyFromRemote' r key file dest meterupdate
)
feedprogressback' a = do
u <- getUUID
+ let AssociatedFile afile = file
let fields = (Fields.remoteUUID, fromUUID u)
- : maybe [] (\f -> [(Fields.associatedFile, f)]) file
+ : maybe [] (\f -> [(Fields.associatedFile, f)]) afile
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
(repo r) "transferinfo"
[Param $ key2file key] fields
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 7f64b46..6dfadd1 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -23,15 +23,10 @@ import Types.Remote
import Types.Transfer
import Config
-{- Generates parameters to ssh to a repository's host and run a command.
- - Caller is responsible for doing any neccessary shellEscaping of the
- - passed command. -}
-toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]
-toRepo cs r gc sshcmd = do
- let opts = map Param $ remoteAnnexSshOptions gc
+toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam])
+toRepo cs r gc remotecmd = do
let host = fromMaybe (giveup "bad ssh url") $ Git.Url.hostuser r
- params <- sshOptions cs (host, Git.Url.port r) gc opts
- return $ params ++ Param host : sshcmd
+ sshCommand cs (host, Git.Url.port r) gc remotecmd
{- Generates parameters to run a git-annex-shell command on a remote
- repository. -}
@@ -49,8 +44,7 @@ git_annex_shell cs r command params fields
: map shellEscape (toCommand shellopts) ++
uuidcheck u ++
map shellEscape (toCommand fieldopts)
- sshparams <- toRepo cs r gc [Param sshcmd]
- return $ Just ("ssh", sshparams)
+ Just <$> toRepo cs r gc sshcmd
| otherwise = return Nothing
where
dir = Git.repoPath r
@@ -126,7 +120,7 @@ rsyncHelper m params = do
{- Generates rsync parameters that ssh to the remote and asks it
- to either receive or send the key's content. -}
rsyncParamsRemote :: Bool -> Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
-rsyncParamsRemote unlocked r direction key file afile = do
+rsyncParamsRemote unlocked r direction key file (AssociatedFile afile) = do
u <- getUUID
let fields = (Fields.remoteUUID, fromUUID u)
: (Fields.unlocked, if unlocked then "1" else "")
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 52ec901..681052e 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -121,7 +121,6 @@ rsyncTransport gc url
"ssh":sshopts -> do
let (port, sshopts') = sshReadPort sshopts
userhost = takeWhile (/=':') url
- -- Connection caching
(Param "ssh":) <$> sshOptions ConsumeStdin
(userhost, port) gc
(map Param $ loginopt ++ sshopts')
diff --git a/Test.hs b/Test.hs
index 7ef0cb5..259a604 100644
--- a/Test.hs
+++ b/Test.hs
@@ -1,6 +1,6 @@
{- git-annex test suite
-
- - Copyright 2010-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -29,13 +29,14 @@ import Test.Tasty.Runners
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Test.Tasty.Ingredients.Rerun
-import Options.Applicative (switch, long, help)
+import Options.Applicative (switch, long, help, internal)
import qualified Data.Map as M
import qualified Data.Aeson
import qualified Data.ByteString.Lazy.UTF8 as BU8
import Common
+import CmdLine.GitAnnex.Options
import qualified Utility.SafeCommand
import qualified Annex
@@ -112,21 +113,31 @@ optParser = TestOptions
<*> switch
( long "keep-failures"
<> help "preserve repositories on test failure"
- )
+ )
+ <*> switch
+ ( long "fakessh"
+ <> internal
+ )
+ <*> cmdParams "non-options are for internal use only"
runner :: Maybe (TestOptions -> IO ())
-runner = Just $ \opts -> isolateGitConfig $ do
- ensuretmpdir
- crippledfilesystem <- Annex.Init.probeCrippledFileSystem' tmpdir
- case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem opts) of
- Nothing -> error "No tests found!?"
- Just act -> ifM act
- ( exitSuccess
- , do
- putStrLn " (This could be due to a bug in git-annex, or an incompatibility"
- putStrLn " with utilities, such as git, installed on this system.)"
- exitFailure
- )
+runner = Just go
+ where
+ go opts
+ | fakeSsh opts = runFakeSsh (internalData opts)
+ | otherwise = runtests opts
+ runtests opts = isolateGitConfig $ do
+ ensuretmpdir
+ crippledfilesystem <- Annex.Init.probeCrippledFileSystem' tmpdir
+ case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem opts) of
+ Nothing -> error "No tests found!?"
+ Just act -> ifM act
+ ( exitSuccess
+ , do
+ putStrLn " (This could be due to a bug in git-annex, or an incompatibility"
+ putStrLn " with utilities, such as git, installed on this system.)"
+ exitFailure
+ )
ingredients :: [Ingredient]
ingredients =
@@ -211,7 +222,9 @@ unitTests note = testGroup ("Unit Tests " ++ note)
, testCase "drop (with remote)" test_drop_withremote
, testCase "drop (untrusted remote)" test_drop_untrustedremote
, testCase "get" test_get
+ , testCase "get (ssh remote)" test_get_ssh_remote
, testCase "move" test_move
+ , testCase "move (ssh remote)" test_move_ssh_remote
, testCase "copy" test_copy
, testCase "lock" test_lock
, testCase "lock (v6 --force)" test_lock_v6_force
@@ -458,7 +471,13 @@ test_drop_untrustedremote = intmpclonerepo $ do
inmainrepo $ annexed_present annexedfile
test_get :: Assertion
-test_get = intmpclonerepo $ do
+test_get = test_get' intmpclonerepo
+
+test_get_ssh_remote :: Assertion
+test_get_ssh_remote = test_get' (with_ssh_origin intmpclonerepo)
+
+test_get' :: (Assertion -> Assertion) -> Assertion
+test_get' setup = setup $ do
inmainrepo $ annexed_present annexedfile
annexed_notpresent annexedfile
git_annex "get" [annexedfile] @? "get of file failed"
@@ -475,7 +494,13 @@ test_get = intmpclonerepo $ do
unannexed ingitfile
test_move :: Assertion
-test_move = intmpclonerepo $ do
+test_move = test_move' intmpclonerepo
+
+test_move_ssh_remote :: Assertion
+test_move_ssh_remote = test_move' (with_ssh_origin intmpclonerepo)
+
+test_move' :: (Assertion -> Assertion) -> Assertion
+test_move' setup = setup $ do
annexed_notpresent annexedfile
inmainrepo $ annexed_present annexedfile
git_annex "move" ["--from", "origin", annexedfile] @? "move --from of file failed"
@@ -1740,6 +1765,16 @@ innewrepo a = withgitrepo $ \r -> indir r a
inmainrepo :: Assertion -> Assertion
inmainrepo = indir mainrepodir
+with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)
+with_ssh_origin cloner a = cloner $ do
+ origindir <- absPath
+ =<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null")
+ let originurl = "localhost:" ++ origindir
+ boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"
+ a
+ where
+ config = "remote.origin.url"
+
intmpclonerepo :: Assertion -> Assertion
intmpclonerepo a = withtmpclonerepo $ \r -> indir r a
@@ -2072,9 +2107,19 @@ setTestMode testmode = do
, ("GIT_COMMITTER_NAME", "git-annex test")
-- force gpg into batch mode for the tests
, ("GPG_BATCH", "1")
+ -- Make git and git-annex access ssh remotes on the local
+ -- filesystem, without using ssh at all.
+ , ("GIT_SSH_COMMAND", "git-annex test --fakessh --")
, ("TESTMODE", show testmode)
]
+runFakeSsh :: [String] -> IO ()
+runFakeSsh ("-n":ps) = runFakeSsh ps
+runFakeSsh (_host:cmd:[]) = do
+ (_, _, _, pid) <- createProcess (shell cmd)
+ exitWith =<< waitForProcess pid
+runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps
+
getTestMode :: IO TestMode
getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" ""
diff --git a/Types.hs b/Types.hs
index 09c8ade..884c91a 100644
--- a/Types.hs
+++ b/Types.hs
@@ -9,7 +9,7 @@ module Types (
Annex,
Backend,
Key,
- AssociatedFile,
+ AssociatedFile(..),
UUID(..),
GitConfig(..),
RemoteGitConfig(..),
diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs
index d9beb04..73d8451 100644
--- a/Types/ActionItem.hs
+++ b/Types/ActionItem.hs
@@ -13,8 +13,6 @@ import Key
import Types.Transfer
import Git.FilePath
-import Data.Maybe
-
data ActionItem
= ActionItemAssociatedFile AssociatedFile
| ActionItemKey
@@ -37,15 +35,15 @@ instance MkActionItem (Transfer, TransferInfo) where
mkActionItem = uncurry ActionItemFailedTransfer
actionItemDesc :: ActionItem -> Key -> String
-actionItemDesc (ActionItemAssociatedFile (Just f)) _ = f
-actionItemDesc (ActionItemAssociatedFile Nothing) k = key2file k
+actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f))) _ = f
+actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing)) k = key2file k
actionItemDesc ActionItemKey k = key2file k
actionItemDesc (ActionItemBranchFilePath bfp) _ = descBranchFilePath bfp
-actionItemDesc (ActionItemFailedTransfer _ i) k =
- fromMaybe (key2file k) (associatedFile i)
+actionItemDesc (ActionItemFailedTransfer _ i) k =
+ actionItemDesc (ActionItemAssociatedFile (associatedFile i)) k
actionItemWorkTreeFile :: ActionItem -> Maybe FilePath
-actionItemWorkTreeFile (ActionItemAssociatedFile af) = af
+actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af)) = af
actionItemWorkTreeFile _ = Nothing
actionItemTransferDirection :: ActionItem -> Maybe Direction
diff --git a/Types/Key.hs b/Types/Key.hs
index 9df1144..44ebe3c 100644
--- a/Types/Key.hs
+++ b/Types/Key.hs
@@ -23,7 +23,8 @@ data Key = Key
} deriving (Eq, Ord, Read, Show)
{- A filename may be associated with a Key. -}
-type AssociatedFile = Maybe FilePath
+newtype AssociatedFile = AssociatedFile (Maybe FilePath)
+ deriving (Show, Eq, Ord)
{- There are several different varieties of keys. -}
data KeyVariety
diff --git a/Types/Test.hs b/Types/Test.hs
index eadf6d2..66f263c 100644
--- a/Types/Test.hs
+++ b/Types/Test.hs
@@ -1,6 +1,6 @@
{- git-annex test data types.
-
- - Copyright 2011-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -13,19 +13,24 @@ module Types.Test where
import Test.Tasty.Options
import Data.Monoid
import Prelude
+import Types.Command
#endif
#ifdef WITH_TESTSUITE
data TestOptions = TestOptions
{ tastyOptionSet :: OptionSet
, keepFailuresOption :: Bool
+ , fakeSsh :: Bool
+ , internalData :: CmdParams
}
instance Monoid TestOptions where
- mempty = TestOptions mempty False
+ mempty = TestOptions mempty False False mempty
mappend a b = TestOptions
(tastyOptionSet a <> tastyOptionSet b)
(keepFailuresOption a || keepFailuresOption b)
+ (fakeSsh a || fakeSsh b)
+ (internalData a <> internalData b)
#else
type TestOptions = ()
diff --git a/Types/Transfer.hs b/Types/Transfer.hs
index 349eccf..ade8fc7 100644
--- a/Types/Transfer.hs
+++ b/Types/Transfer.hs
@@ -36,13 +36,13 @@ data TransferInfo = TransferInfo
, transferTid :: Maybe ThreadId
, transferRemote :: Maybe Remote
, bytesComplete :: Maybe Integer
- , associatedFile :: Maybe FilePath
+ , associatedFile :: AssociatedFile
, transferPaused :: Bool
}
deriving (Show, Eq, Ord)
stubTransferInfo :: TransferInfo
-stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False
+stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing (AssociatedFile Nothing) False
data Direction = Upload | Download
deriving (Eq, Ord, Show, Read)
@@ -64,5 +64,5 @@ instance Arbitrary TransferInfo where
<*> pure Nothing -- remote not needed
<*> arbitrary
-- associated file cannot be empty (but can be Nothing)
- <*> arbitrary `suchThat` (/= Just "")
+ <*> (AssociatedFile <$> arbitrary `suchThat` (/= Just ""))
<*> arbitrary
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index a5d3820..f6173cd 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -2,7 +2,7 @@
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
diff --git a/Utility/Path.hs b/Utility/Path.hs
index 3ee5ff3..cd9dc38 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -227,6 +227,8 @@ inPath command = isJust <$> searchPath command
-
- The command may be fully qualified already, in which case it will
- be returned if it exists.
+ -
+ - Note that this will find commands in PATH that are not executable.
-}
searchPath :: String -> IO (Maybe FilePath)
searchPath command
diff --git a/Utility/SRV.hs b/Utility/SRV.hs
index 033064a..64cca60 100644
--- a/Utility/SRV.hs
+++ b/Utility/SRV.hs
@@ -5,8 +5,6 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE CPP #-}
-
module Utility.SRV (
mkSRVTcp,
mkSRV,
@@ -42,12 +40,7 @@ lookupSRV :: SRV -> IO [HostPort]
lookupSRV (SRV srv) = do
seed <- makeResolvSeed defaultResolvConf
r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv
- return $
-#if MIN_VERSION_dns(1,0,0)
- either (const []) use r
-#else
- maybe [] use r
-#endif
+ return $ either (const []) use r
where
use = orderHosts . map tohosts
tohosts (priority, weight, port, hostname) =
diff --git a/Utility/Shell.hs b/Utility/Shell.hs
index 116ab61..b8a9491 100644
--- a/Utility/Shell.hs
+++ b/Utility/Shell.hs
@@ -49,8 +49,7 @@ findShellCommand f = do
#ifndef mingw32_HOST_OS
defcmd
#else
- l <- catchDefaultIO Nothing $ withFile f ReadMode $
- headMaybe . lines <$$> hGetContents
+ l <- catchDefaultIO Nothing $ headMaybe . lines <$> readFile f
case l of
Just ('#':'!':rest) -> case words rest of
[] -> defcmd
diff --git a/Utility/Url.hs b/Utility/Url.hs
index 1b68dce..27bccd1 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -67,11 +67,7 @@ data UrlOptions = UrlOptions
{ userAgent :: Maybe UserAgent
, reqHeaders :: Headers
, reqParams :: [CommandParam]
-#if MIN_VERSION_http_conduit(2,0,0)
, applyRequest :: Request -> Request
-#else
- , applyRequest :: forall m. Request m -> Request m
-#endif
}
instance Default UrlOptions
@@ -232,11 +228,7 @@ contentDispositionFilename s
drop 1 $ dropWhile (/= '"') s
| otherwise = Nothing
-#if MIN_VERSION_http_conduit(2,0,0)
headRequest :: Request -> Request
-#else
-headRequest :: Request m -> Request m
-#endif
headRequest r = r
{ method = methodHead
-- remove defaut Accept-Encoding header, to get actual,
@@ -350,14 +342,6 @@ hAcceptEncoding = "Accept-Encoding"
hContentDisposition :: CI.CI B.ByteString
hContentDisposition = "Content-Disposition"
-#if ! MIN_VERSION_http_types(0,7,0)
-hContentLength :: CI.CI B.ByteString
-hContentLength = "Content-Length"
-
-hUserAgent :: CI.CI B.ByteString
-hUserAgent = "User-Agent"
-#endif
-
{- Use with eg:
-
- > catchJust (matchStatusCodeException (== notFound404))
diff --git a/doc/git-annex-get.mdwn b/doc/git-annex-get.mdwn
index f30ee49..b7f2f74 100644
--- a/doc/git-annex-get.mdwn
+++ b/doc/git-annex-get.mdwn
@@ -23,7 +23,7 @@ or transferring them from some kind of key-value store.
* `--from=remote`
Normally git-annex will choose which remotes to get the content
- from, preferring less expensive remotes. Use this option to specify
+ from, preferring remotes with lower costs. Use this option to specify
which remote to use.
Any files that are not available on the remote will be silently skipped.
@@ -33,6 +33,13 @@ or transferring them from some kind of key-value store.
Enables parallel download with up to the specified number of jobs
running at once. For example: `-J10`
+ When files can be downloaded from multiple remotes, enabling parallel
+ downloads will split the load between the remotes. For example, if
+ the files are available on remotes A and B, then one file will be
+ downloaded from A, and another file will be downloaded from B in
+ parallel. (Remotes with lower costs are still preferred over higher cost
+ remotes.)
+
* file matching options
The [[git-annex-matching-options]](1)
diff --git a/doc/git-annex-sync.mdwn b/doc/git-annex-sync.mdwn
index e29698c..97c63d3 100644
--- a/doc/git-annex-sync.mdwn
+++ b/doc/git-annex-sync.mdwn
@@ -73,6 +73,14 @@ by running "git annex sync" on the remote.
This behavior can be overridden by configuring the preferred content
of a repository. See [[git-annex-preferred-content]](1).
+* `--content-of=path` `-C path`
+
+ While --content operates on all annexed files in the work tree,
+ --content-of allows limiting the transferred files to ones in a given
+ location.
+
+ This option can be repeated multiple times with different paths.
+
* `--all`
This option, when combined with `--content`, makes all available versions
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index e38d31e..0add5a5 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -1404,6 +1404,37 @@ specific failures. git-annex itself should return 0 on success and 1 on
failure, unless the `--time-limit=time` option is hit, in which case it
returns with exit code 101.
+# ENVIRONMENT
+
+These environment variables are used by git-annex when set:
+
+* `GIT_WORK_TREE`, `GIT_DIR`
+
+ Handled the same as they are by git, see git(1)
+
+* `GIT_SSH`, `GIT_SSH_COMMAND`
+
+ Handled similarly to the same as described in git(1).
+ The one difference is that git-annex will sometimes pass an additional
+ "-n" parameter to these, as the first parameter, to prevent ssh from
+ reading from stdin.
+
+ Note that setting either of these environment variables prevents
+ git-annex from automatically enabling ssh connection caching
+ (see `annex.sshcaching`), so it will slow down some operations with
+ remotes over ssh. It's up to you to enable ssh connection caching
+ if you need it; see ssh's documentation.
+
+ Also, `annex.ssh-options` and `remote.<name>.annex-ssh-options`
+ won't have any effect when these envionment variables are set.
+
+ Usually it's better to configure any desired options through your
+ ~/.ssh/config file, or by setting `annex.ssh-options`.
+
+Some special remotes use additional environment variables
+for authentication etc. For example, `AWS_ACCESS_KEY_ID`
+and `GIT_ANNEX_P2P_AUTHTOKEN`. See special remote documentation.
+
# FILES
These files are used by git-annex:
diff --git a/git-annex.cabal b/git-annex.cabal
index b9e3fec..db868d1 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1,5 +1,5 @@
Name: git-annex
-Version: 6.20170301.1
+Version: 6.20170321
Cabal-Version: >= 1.8
License: GPL-3
Maintainer: Joey Hess <id@joeyh.name>
@@ -326,7 +326,7 @@ Executable git-annex
unix-compat,
SafeSemaphore,
async,
- directory,
+ directory (>= 1.2),
filepath,
IfElse,
MissingH,
@@ -343,8 +343,8 @@ Executable git-annex
edit-distance,
resourcet,
http-client,
- http-types,
- http-conduit,
+ http-types (>= 0.7),
+ http-conduit (>= 2.0),
time,
old-locale,
esqueleto,
@@ -353,7 +353,7 @@ Executable git-annex
persistent-template,
aeson,
unordered-containers,
- feed,
+ feed (>= 0.3.9),
regex-tdfa,
socks,
byteable,
@@ -402,7 +402,7 @@ Executable git-annex
CPP-Options: -DWITH_WEBDAV
if flag(Assistant) && ! os(solaris)
- Build-Depends: dns, mountpoints
+ Build-Depends: dns (>= 1.0.0), mountpoints
CPP-Options: -DWITH_ASSISTANT
if flag(Assistant)
@@ -833,6 +833,7 @@ Executable git-annex
Git.Remote.Remove
Git.Repair
Git.Sha
+ Git.Ssh
Git.Status
Git.Tree
Git.Types
diff --git a/templates/dashboard/transfers.hamlet b/templates/dashboard/transfers.hamlet
index 9e2e532..ee8ddb8 100644
--- a/templates/dashboard/transfers.hamlet
+++ b/templates/dashboard/transfers.hamlet
@@ -6,10 +6,7 @@
<div .row>
<div .col-sm-10>
<h3 .forcewrap .small-margin-top .tiny-margin-bottom>
- $maybe file <- associatedFile info
- #{file}
- $nothing
- #{key2file $ transferKey transfer}
+ #{desc transfer info}
$case transferDirection transfer
$of Upload
&rarr;