diff options
| -rw-r--r-- | Remote/Helper/Http.hs | 39 | ||||
| -rw-r--r-- | Remote/WebDAV.hs | 45 | ||||
| -rw-r--r-- | debian/changelog | 1 |
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 |