diff --git a/Annex/Content.hs b/Annex/Content.hs index 5990d194a9..90486f9128 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -56,6 +56,7 @@ import qualified Annex.Url as Url import Types.Key import Utility.DataUnits import Utility.CopyFile +import Utility.Metered import Config import Git.SharedRepository import Annex.Perms @@ -658,8 +659,11 @@ saveState nocommit = doSideAction $ do Annex.Branch.commit "update" {- Downloads content from any of a list of urls. -} -downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool -downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig +downloadUrl :: Key -> MeterUpdate -> [Url.URLString] -> FilePath -> Annex Bool +downloadUrl k p urls file = + concurrentMetered (Just p) k $ \p' -> + watchFileSize file p' $ + go =<< annexWebDownloadCommand <$> Annex.getGitConfig where go Nothing = do a <- ifM commandProgressDisabled diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 6ed4fb2e2d..78313f538f 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -252,9 +252,9 @@ addUrlFileQuvi relaxed quviurl videourl file = do tmp <- fromRepo $ gitAnnexTmpObjectLocation key showOutput ok <- Transfer.notifyTransfer Transfer.Download (Just file) $ - Transfer.download webUUID key (Just file) Transfer.forwardRetry Transfer.noObserver $ const $ do + Transfer.download webUUID key (Just file) Transfer.forwardRetry Transfer.noObserver $ \p -> do liftIO $ createDirectoryIfMissing True (parentDir tmp) - downloadUrl [videourl] tmp + downloadUrl key p [videourl] tmp if ok then do cleanup webUUID quviurl file key (Just tmp) @@ -294,9 +294,9 @@ addUrlFile relaxed url urlinfo file = do downloadWeb :: URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) downloadWeb url urlinfo file = do let dummykey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing - let downloader f _ = do + let downloader f p = do showOutput - downloadUrl [url] f + downloadUrl dummykey p [url] f showAction $ "downloading " ++ url ++ " " downloadWith downloader dummykey webUUID url file diff --git a/Messages/Progress.hs b/Messages/Progress.hs index 24a68c922a..c14e7e6b13 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -29,8 +29,8 @@ import Data.Quantity {- Shows a progress meter while performing a transfer of a key. - The action is passed a callback to use to update the meter. -} -metered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a -metered combinemeterupdate key _af a = case keySize key of +metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a +metered combinemeterupdate key a = case keySize key of Nothing -> nometer Just size -> withOutputType (go $ fromInteger size) where @@ -66,10 +66,10 @@ metered combinemeterupdate key _af a = case keySize key of {- Use when the progress meter is only desired for concurrent - output; as when a command's own progress output is preferred. -} -concurrentMetered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a -concurrentMetered combinemeterupdate key af a = withOutputType go +concurrentMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a +concurrentMetered combinemeterupdate key a = withOutputType go where - go (ConcurrentOutput _) = metered combinemeterupdate key af a + go (ConcurrentOutput _) = metered combinemeterupdate key a go _ = a (fromMaybe (const noop) combinemeterupdate) {- Progress dots. -} diff --git a/Remote/External.hs b/Remote/External.hs index 68237b939d..897a6a72b3 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -503,9 +503,9 @@ checkurl external url = mkmulti (u, s, f) = (u, s, mkSafeFilePath f) retrieveUrl :: Retriever -retrieveUrl = fileRetriever $ \f k _p -> do +retrieveUrl = fileRetriever $ \f k p -> do us <- getWebUrls k - unlessM (downloadUrl us f) $ + unlessM (downloadUrl k p us f) $ error "failed to download content" checkKeyUrl :: Git.Repo -> CheckPresent diff --git a/Remote/Git.hs b/Remote/Git.hs index d410db02fd..890e40b514 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -421,7 +421,7 @@ lockKey r key callback {- Tries to copy a key's content from a remote's annex to a file. -} copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) -copyFromRemote r key file dest p = concurrentMetered (Just p) key file $ +copyFromRemote r key file dest p = concurrentMetered (Just p) key $ copyFromRemote' r key file dest copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) @@ -445,7 +445,8 @@ copyFromRemote' r key file dest meterupdate direct <- isDirect Ssh.rsyncHelper (Just (combineMeterUpdate meterupdate p)) =<< Ssh.rsyncParamsRemote direct r Download key dest file - | Git.repoIsHttp (repo r) = unVerified $ Annex.Content.downloadUrl (keyUrls r key) dest + | Git.repoIsHttp (repo r) = unVerified $ + Annex.Content.downloadUrl key meterupdate (keyUrls r key) dest | otherwise = error "copying from non-ssh, non-http remote not supported" where {- Feed local rsync's progress info back to the remote, @@ -522,7 +523,7 @@ copyFromRemoteCheap r key af file ) | Git.repoIsSsh (repo r) = ifM (Annex.Content.preseedTmp key file) - ( fst <$> concurrentMetered Nothing key af + ( fst <$> concurrentMetered Nothing key (copyFromRemote' r key af file) , return False ) @@ -534,7 +535,7 @@ copyFromRemoteCheap _ _ _ _ = return False {- Tries to copy a key's content to a remote's annex. -} copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool copyToRemote r key file meterupdate = - concurrentMetered (Just meterupdate) key file $ + concurrentMetered (Just meterupdate) key $ copyToRemote' r key file copyToRemote' :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 7faf7a8a1d..d586d8c0a4 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -155,8 +155,8 @@ specialRemote' :: SpecialRemoteCfg -> RemoteModifier specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckpresent baser = encr where encr = baser - { storeKey = \k f p -> cip >>= storeKeyGen k f p - , retrieveKeyFile = \k f d p -> cip >>= unVerified . retrieveKeyFileGen k f d p + { storeKey = \k _f p -> cip >>= storeKeyGen k p + , retrieveKeyFile = \k _f d p -> cip >>= unVerified . retrieveKeyFileGen k d p , retrieveKeyFileCheap = \k f d -> cip >>= maybe (retrieveKeyFileCheap baser k f d) -- retrieval of encrypted keys is never cheap @@ -183,12 +183,12 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp safely a = catchNonAsync a (\e -> warning (show e) >> return False) -- chunk, then encrypt, then feed to the storer - storeKeyGen k f p enc = safely $ preparestorer k $ safely . go + storeKeyGen k p enc = safely $ preparestorer k $ safely . go where go (Just storer) = preparecheckpresent k $ safely . go' storer go Nothing = return False go' storer (Just checker) = sendAnnex k rollback $ \src -> - displayprogress p k f $ \p' -> + displayprogress p k $ \p' -> storeChunks (uuid baser) chunkconfig k src p' (storechunk enc storer) checker @@ -204,10 +204,10 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp storer (enck k) (ByteContent encb) p -- call retriever to get chunks; decrypt them; stream to dest file - retrieveKeyFileGen k f dest p enc = + retrieveKeyFileGen k dest p enc = safely $ prepareretriever k $ safely . go where - go (Just retriever) = displayprogress p k f $ \p' -> + go (Just retriever) = displayprogress p k $ \p' -> retrieveChunks retriever (uuid baser) chunkconfig enck k dest p' (sink dest enc) go Nothing = return False @@ -227,8 +227,8 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp chunkconfig = chunkConfig cfg - displayprogress p k f a - | displayProgress cfg = metered (Just p) k f a + displayprogress p k a + | displayProgress cfg = metered (Just p) k a | otherwise = a p {- Sink callback for retrieveChunks. Stores the file content into the diff --git a/Remote/S3.hs b/Remote/S3.hs index fb772825c5..ba30bffebd 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -249,8 +249,8 @@ retrieve r info Nothing = case getpublicurl info of Nothing -> \_ _ _ -> do warnMissingCredPairFor "S3" (AWS.creds $ uuid r) return False - Just geturl -> fileRetriever $ \f k _p -> - unlessM (downloadUrl [geturl k] f) $ + Just geturl -> fileRetriever $ \f k p -> + unlessM (downloadUrl k p [geturl k] f) $ error "failed to download content" retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool diff --git a/Remote/Web.hs b/Remote/Web.hs index 257eba2e1c..143bdb9978 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -72,7 +72,7 @@ gen r _ c gc = } downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) -downloadKey key _file dest _p = unVerified $ get =<< getWebUrls key +downloadKey key _af dest p = unVerified $ get =<< getWebUrls key where get [] = do warning "no known url" @@ -84,13 +84,13 @@ downloadKey key _file dest _p = unVerified $ get =<< getWebUrls key case downloader of QuviDownloader -> do #ifdef WITH_QUVI - flip downloadUrl dest + flip (downloadUrl key p) dest =<< withQuviOptions Quvi.queryLinks [Quvi.httponly, Quvi.quiet] u' #else warning "quvi support needed for this url" return False #endif - _ -> downloadUrl [u'] dest + _ -> downloadUrl key p [u'] dest downloadKeyCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool downloadKeyCheap _ _ _ = return False diff --git a/debian/changelog b/debian/changelog index 53a20717ca..4231f99891 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,6 +3,7 @@ git-annex (5.20151117) UNRELEASED; urgency=medium * Build with -j1 again to get reproducible build. * Display progress meter in -J mode when copying from a local git repo, to a local git repo, and from a remote git repo. + * Display progress meter in -J mode when downloading from the web. -- Joey Hess Mon, 16 Nov 2015 16:49:34 -0400