From afa2f9c967e7512e889edbe9fae9fb0c4dfa9fc9 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sun, 18 Nov 2012 20:06:28 -0400
Subject: [PATCH] upload progress bars for webdav!

---
 Crypto.hs                              |  8 +++++
 Remote/WebDAV.hs                       | 23 ++++++++------
 Utility/Observed.hs                    | 43 ++++++++++++++++++++++++++
 doc/design/assistant/progressbars.mdwn |  3 +-
 4 files changed, 66 insertions(+), 11 deletions(-)
 create mode 100644 Utility/Observed.hs

diff --git a/Crypto.hs b/Crypto.hs
index fe6c6d5cbf..99b17ce02c 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -19,6 +19,7 @@ module Crypto (
 	decryptCipher,		
 	encryptKey,
 	feedFile,
+	feedFileMetered,
 	feedBytes,
 	readBytes,
 	encrypt,
@@ -36,6 +37,8 @@ import Common.Annex
 import qualified Utility.Gpg as Gpg
 import Types.Key
 import Types.Crypto
+import Types.Remote
+import Utility.Observed
 
 {- The first half of a Cipher is used for HMAC; the remainder
  - is used as the GPG symmetric encryption passphrase.
@@ -122,6 +125,11 @@ type Reader a = Handle -> IO a
 feedFile :: FilePath -> Feeder
 feedFile f h = L.hPut h =<< L.readFile f
 
+feedFileMetered :: FilePath -> MeterUpdate -> Feeder
+feedFileMetered f m to = withBinaryFile f ReadMode $ \h -> do
+	b <- hGetContentsObserved h $ m . toInteger
+	L.hPut to b
+
 feedBytes :: L.ByteString -> Feeder
 feedBytes = flip L.hPut
 
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index ed7b82b642..2dce154993 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -31,6 +31,7 @@ import Remote.Helper.Encryptable
 import Remote.Helper.Chunked
 import Crypto
 import Creds
+import Utility.Observed
 
 type DavUrl = String
 type DavUser = B8.ByteString
@@ -84,17 +85,21 @@ webdavSetup u c = do
 	setRemoteCredPair c' (davCreds u)
 
 store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-store r k _f _p = davAction r False $ \(baseurl, user, pass) -> do
-	let url = davLocation baseurl k
-	f <- inRepo $ gitAnnexLocation k
-	liftIO $ storeHelper r url user pass =<< L.readFile f
+store r k _f p = metered (Just p) k $ \meterupdate ->
+	davAction r False $ \(baseurl, user, pass) -> do
+		let url = davLocation baseurl k
+		f <- inRepo $ gitAnnexLocation k
+		liftIO $ withBinaryFile f ReadMode $ \h -> do
+			b <- hGetContentsObserved h $ meterupdate . toInteger
+			storeHelper r url user pass b
 
 storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
-storeEncrypted r (cipher, enck) k _p = davAction r False $ \(baseurl, user, pass) -> do
-	let url = davLocation baseurl enck
-	f <- inRepo $ gitAnnexLocation k
-	liftIO $ encrypt cipher (feedFile f) $
-		readBytes $ storeHelper r url user pass
+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 (feedFileMetered f meterupdate) $
+			readBytes $ storeHelper r url user pass
 
 storeHelper :: Remote -> DavUrl -> DavUser -> DavPass -> L.ByteString -> IO Bool
 storeHelper r urlbase user pass b = catchBoolIO $ do
diff --git a/Utility/Observed.hs b/Utility/Observed.hs
new file mode 100644
index 0000000000..3ee9734298
--- /dev/null
+++ b/Utility/Observed.hs
@@ -0,0 +1,43 @@
+module Utility.Observed where
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString as S
+import System.IO
+import System.IO.Unsafe
+import Foreign.Storable (Storable(sizeOf))
+
+{- This is like L.hGetContents, but after each chunk is read, an action
+ - is run to observe the size of the chunk.
+ -
+ - Note that the observer is run in unsafeInterleaveIO, which means that
+ - it can be run at any time. It's even possible for observers to run out
+ - of order, as different parts of the ByteString are consumed.
+ -
+ - All the usual caveats about using unsafeInterleaveIO apply to the observers,
+ - so use caution.
+ -}
+hGetContentsObserved :: Handle -> (Int -> IO ()) -> IO L.ByteString
+hGetContentsObserved h observe = lazyRead
+  where
+	lazyRead = unsafeInterleaveIO loop
+
+	loop = do
+		c <- S.hGetSome h defaultChunkSize
+		if S.null c
+			then do
+				hClose h
+				return $ L.empty
+			else do
+				observe $ S.length c
+				{- unsafeInterleaveIO causes this to be
+				 - deferred until the data is read from the
+				 - ByteString. -}
+				cs <- lazyRead
+				return $ L.append (L.fromChunks [c]) cs
+
+{- Same default chunk size Lazy ByteStrings use. -}
+defaultChunkSize :: Int
+defaultChunkSize = 32 * k - chunkOverhead
+  where
+	k = 1024
+	chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific
diff --git a/doc/design/assistant/progressbars.mdwn b/doc/design/assistant/progressbars.mdwn
index 6228cb7f84..37dfe6f8cd 100644
--- a/doc/design/assistant/progressbars.mdwn
+++ b/doc/design/assistant/progressbars.mdwn
@@ -10,7 +10,6 @@ This is one of those potentially hidden but time consuming problems.
 ## downloads
 
 * Watch temp file as it's coming in and use its size.
-  This is the only option for some special remotes (ie, non-rsync).
   Can either poll every .5 seconds or so to check file size, or
   could use inotify. **done**
 
@@ -23,7 +22,7 @@ the MeterUpdate callback as the upload progresses.
 * rsync: **done**
 * directory: **done**
 * web: Not applicable; does not upload 
-* webdav: TODO
+* webdav: **done**
 * S3: TODO
 * bup: TODO
 * hook: Would require the hook interface to somehow do this, which seems