diff options
author | JoeyHess <> | 2017-03-21 17:48:00 (GMT) |
---|---|---|
committer | hdiff <hdiff@hdiff.luite.com> | 2017-03-21 17:48:00 (GMT) |
commit | bc869851a7c9109143cf3364de43d2ac2c2aafce (patch) | |
tree | 85f69944ede69f5faa9f77b7b3e6dea03b5b6afb | |
parent | bdc8f414fd4dab9031053aae7e86537b95914b8c (diff) |
version 6.201703216.20170321
70 files changed, 580 insertions, 332 deletions
@@ -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 @@ -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 @@ -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)) @@ -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') @@ -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" "" @@ -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 → |