S3: Added progress display for uploading and downloading.

Meters.hs

@@ -12,6 +12,7 @@ import Types.Meters
 import Utility.Observed
 
 import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString as S
 
 {- Sends the content of a file to an action, updating the meter as it's
  - consumed. -}
@@ -21,5 +22,19 @@ withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h ->
 
 {- Sends the content of a file to a Handle, updating the meter as it's
  - written. -}
-sendMeteredFile :: FilePath -> MeterUpdate -> Handle -> IO ()
-sendMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h
+streamMeteredFile :: FilePath -> MeterUpdate -> Handle -> IO ()
+streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h
+
+{- Writes a ByteString to a Handle, updating a meter as it's written. -}
+meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO ()
+meteredWrite meterupdate h = go . L.toChunks 
+  where
+	go [] = return ()
+	go (c:cs) = do
+		S.hPut h c
+		meterupdate $ toInteger $ S.length c
+		go cs
+
+meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()
+meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h ->
+	meteredWrite meterupdate h b

Remote/Directory.hs

@@ -11,6 +11,7 @@ import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString as S
 import qualified Data.Map as M
 import qualified Control.Exception as E
+import Data.Int
 
 import Common.Annex
 import Types.Remote
@@ -21,8 +22,8 @@ import Remote.Helper.Special
 import Remote.Helper.Encryptable
 import Remote.Helper.Chunked
 import Crypto
-import Data.Int
 import Annex.Content
+import Meters
 
 remote :: RemoteType
 remote = RemoteType {

Remote/Helper/Chunked.hs

@@ -10,10 +10,10 @@ module Remote.Helper.Chunked where
 import Common.Annex
 import Utility.DataUnits
 import Types.Remote
+import Meters
 
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString as S
 import Data.Int
 import qualified Control.Exception as E
 
@@ -121,25 +121,10 @@ storeChunked chunksize dests storer content =
 			storer d chunk
 			storechunks sz (d:useddests) ds b'
 
-{- Write a L.ByteString to a file, updating a progress meter
- - after each chunk of the L.ByteString, typically every 64 kb or so. -}
-meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()
-meteredWriteFile meterupdate dest b =
-	meteredWriteFileChunks meterupdate dest [b] return
-
-{- Writes a series of major chunks to a file. The feeder is called to get
- - each major chunk. Then each chunk of the L.ByteString is written,
- - with the meter updated after each chunk. -}
+{- Writes a series of chunks to a file. The feeder is called to get
+ - each chunk. -}
 meteredWriteFileChunks :: MeterUpdate -> FilePath -> [v] -> (v -> IO L.ByteString) -> IO ()
 meteredWriteFileChunks meterupdate dest chunks feeder =
-	E.bracket (openFile dest WriteMode) hClose (feed chunks [])
-  where
-	feed [] [] _ = noop
-	feed (c:cs) [] h = do
-		bs <- L.toChunks <$> feeder c
-		unless (null bs) $
-			feed cs bs h
-	feed cs (b:bs) h = do
-		S.hPut h b
-		meterupdate $ toInteger $ S.length b
-		feed cs bs h
+	withBinaryFile dest WriteMode $ \h ->
+		forM_ chunks $ \c ->
+			meteredWrite meterupdate h =<< feeder c

Remote/S3.hs

@@ -152,26 +152,29 @@ storeHelper (conn, bucket) r k p file = do
 	isxheader (h, _) = "x-amz-" `isPrefixOf` h
 
 retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
-retrieve r k _f d = s3Action r False $ \(conn, bucket) -> do
-	res <- liftIO $ getObject conn $ bucketKey r bucket k
-	case res of
-		Right o -> do
-			liftIO $ L.writeFile d $ obj_data o
-			return True
-		Left e -> s3Warning e
+retrieve r k _f d = s3Action r False $ \(conn, bucket) ->
+	metered Nothing k $ \meterupdate -> do
+		res <- liftIO $ getObject conn $ bucketKey r bucket k
+		case res of
+			Right o -> do
+				liftIO $ meteredWriteFile meterupdate d $
+					obj_data o
+				return True
+			Left e -> s3Warning e
 
 retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
 retrieveCheap _ _ _ = return False
 
 retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
-retrieveEncrypted r (cipher, enck) _ f = s3Action r False $ \(conn, bucket) -> do
-	res <- liftIO $ getObject conn $ bucketKey r bucket enck
-	case res of
-		Right o -> liftIO $ decrypt cipher (feedBytes $ obj_data o) $ 
-			readBytes $ \content -> do
-				L.writeFile f content
-				return True
-		Left e -> s3Warning e
+retrieveEncrypted r (cipher, enck) k d = s3Action r False $ \(conn, bucket) ->
+	metered Nothing k $ \meterupdate -> do
+		res <- liftIO $ getObject conn $ bucketKey r bucket enck
+		case res of
+			Right o -> liftIO $ decrypt cipher (\h -> meteredWrite meterupdate h $ obj_data o) $ 
+				readBytes $ \content -> do
+					L.writeFile d content
+					return True
+			Left e -> s3Warning e
 
 remove :: Remote -> Key -> Annex Bool
 remove r k = s3Action r False $ \(conn, bucket) -> do

Remote/WebDAV.hs

@@ -97,7 +97,7 @@ storeEncrypted r (cipher, enck) k p = metered (Just p) k $ \meterupdate ->
 	davAction r False $ \(baseurl, user, pass) -> do
 		let url = davLocation baseurl enck
 		f <- inRepo $ gitAnnexLocation k
-		liftIO $ encrypt cipher (sendMeteredFile f meterupdate) $
+		liftIO $ encrypt cipher (streamMeteredFile f meterupdate) $
 			readBytes $ storeHelper r url user pass
 
 storeHelper :: Remote -> DavUrl -> DavUser -> DavPass -> L.ByteString -> IO Bool

debian/changelog

@@ -9,6 +9,7 @@ git-annex (3.20121113) UNRELEASED; urgency=low
   * OSX: Fix RunAtLoad value in plist file.
   * Getting a file from chunked directory special remotes no longer buffers
     it all in memory.
+  * S3: Added progress display for uploading and downloading.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 13 Nov 2012 13:17:07 -0400
 

doc/design/assistant/progressbars.mdwn

@@ -23,7 +23,7 @@ the MeterUpdate callback as the upload progresses.
 * directory: **done**
 * web: Not applicable; does not upload 
 * webdav: **done**
-* S3: TODO
+* S3: **done**
 * bup: TODO
 * hook: Would require the hook interface to somehow do this, which seems
   too complicated. So skipping.