summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Remote/Helper/Http.hs39
-rw-r--r--Remote/WebDAV.hs45
-rw-r--r--debian/changelog1
3 files changed, 63 insertions, 22 deletions
diff --git a/Remote/Helper/Http.hs b/Remote/Helper/Http.hs
new file mode 100644
index 000000000..945e5cd99
--- /dev/null
+++ b/Remote/Helper/Http.hs
@@ -0,0 +1,39 @@
+{- helpers for remotes using http
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.Http where
+
+import Common.Annex
+import Types.StoreRetrieve
+import Utility.Metered
+import Remote.Helper.Special
+import Network.HTTP.Client (RequestBody(..))
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString as S
+import Control.Concurrent
+
+-- A storer that expects to be provided with a http RequestBody containing
+-- the content to store.
+--
+-- Implemented as a fileStorer, so that the content can be streamed
+-- from the file in constant space.
+httpStorer :: (Key -> RequestBody -> Annex Bool) -> Storer
+httpStorer a = fileStorer $ \k f m -> do
+ size <- liftIO $ (fromIntegral . fileSize <$> getFileStatus f :: IO Integer)
+ let streamer sink = withMeteredFile f m $ \b -> do
+ mvar <- newMVar $ L.toChunks b
+ let getnextchunk = modifyMVar mvar $ pure . pop
+ sink getnextchunk
+ let body = RequestBodyStream (fromInteger size) streamer
+ a k body
+ where
+ pop [] = ([], S.empty)
+ pop (c:cs) = (cs, c)
+
+--httpRetriever :: (Key -> Annex Response) -> Retriever
+--httpRetriever a = byteRetriever $ \k sink
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index d81b76510..b70001ddb 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -25,6 +25,7 @@ import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
+import Remote.Helper.Http
import qualified Remote.Helper.Chunked.Legacy as Legacy
import Creds
import Utility.Metered
@@ -93,29 +94,29 @@ prepareDAV = resourcePrepare . const . withDAVHandle
store :: ChunkConfig -> Maybe DavHandle -> Storer
store _ Nothing = byteStorer $ \_k _b _p -> return False
-store chunkconfig (Just dav) = fileStorer $ \k f p -> liftIO $
- withMeteredFile f p $ storeHelper chunkconfig k dav
-
-storeHelper :: ChunkConfig -> Key -> DavHandle -> L.ByteString -> IO Bool
-storeHelper chunkconfig k dav b = do
- case chunkconfig of
- LegacyChunks chunksize -> do
- let storehttp l b' = do
- void $ goDAV dav $ do
- maybe noop (void . mkColRecursive) (locationParent l)
- inLocation l $ putContentM (contentType, b')
- let storer locs = Legacy.storeChunked chunksize locs storehttp b
- let recorder l s = storehttp l (L8.fromString s)
- let finalizer tmp' dest' = goDAV dav $
- finalizeStore (baseURL dav) tmp' (fromJust $ locationParent dest')
- Legacy.storeChunks k tmp dest storer recorder finalizer
- _ -> goDAV dav $ do
- void $ mkColRecursive tmpDir
- inLocation tmp $
- putContentM (contentType, b)
- finalizeStore (baseURL dav) tmp dest
- return True
+store (LegacyChunks chunksize) (Just dav) = fileStorer $ \k f p -> liftIO $
+ withMeteredFile f p $ storeLegacyChunked chunksize k dav
+store _ (Just dav) = httpStorer $ \k reqbody -> liftIO $ goDAV dav $ do
+ let tmp = keyTmpLocation k
+ let dest = keyLocation k ++ keyFile k
+ void $ mkColRecursive tmpDir
+ inLocation tmp $
+ putContentM' (contentType, reqbody)
+ finalizeStore (baseURL dav) tmp dest
+ return True
+
+storeLegacyChunked :: ChunkSize -> Key -> DavHandle -> L.ByteString -> IO Bool
+storeLegacyChunked chunksize k dav b =
+ Legacy.storeChunks k tmp dest storer recorder finalizer
where
+ storehttp l b' = void $ goDAV dav $ do
+ maybe noop (void . mkColRecursive) (locationParent l)
+ inLocation l $ putContentM (contentType, b')
+ storer locs = Legacy.storeChunked chunksize locs storehttp b
+ recorder l s = storehttp l (L8.fromString s)
+ finalizer tmp' dest' = goDAV dav $
+ finalizeStore (baseURL dav) tmp' (fromJust $ locationParent dest')
+
tmp = keyTmpLocation k
dest = keyLocation k ++ keyFile k
diff --git a/debian/changelog b/debian/changelog
index 3b54458c3..1b981c08d 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -18,6 +18,7 @@ git-annex (5.20140718) UNRELEASED; urgency=medium
* Display exception message when a transfer fails due to an exception.
* WebDAV: Sped up by avoiding making multiple http connections
when storing a file.
+ * WebDAV: Avoid buffering whole file in memory when uploading.
* WebDAV: Dropped support for DAV before 0.8.
* testremote: New command to test uploads/downloads to a remote.
* Dropping an object from a bup special remote now deletes the git branch