diff options
-rw-r--r-- | Remote/S3.hs | 19 |
1 files changed, 14 insertions, 5 deletions
diff --git a/Remote/S3.hs b/Remote/S3.hs index 3e87407c5..9184e0698 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -157,7 +157,7 @@ store r h = fileStorer $ \k f p -> do Just partsz | partsz > 0 -> do fsz <- fromIntegral . fileSize <$> liftIO (getFileStatus f) if fsz > partsz - then multipartupload partsz k f p + then multipartupload fsz partsz k f p else singlepartupload k f p _ -> singlepartupload k f p -- Store public URL to item in Internet Archive. @@ -168,7 +168,7 @@ store r h = fileStorer $ \k f p -> do singlepartupload k f p = do rbody <- liftIO $ httpBodyStorer f p void $ sendS3Handle h $ putObject h (bucketObject (hinfo h) k) rbody - multipartupload partsz k f p = do + multipartupload fsz partsz k f p = do #if MIN_VERSION_aws(0,10,6) let info = hinfo h let object = bucketObject info k @@ -181,14 +181,23 @@ store r h = fileStorer $ \k f p -> do } uploadid <- S3.imurUploadId <$> sendS3Handle h req + -- The actual part size will be a even multiple of the + -- 32k chunk size that hGetUntilMetered uses. + let partsz' = (partsz `div` defaultChunkSize) * defaultChunkSize + -- Send parts of the file, taking care to stream each part -- w/o buffering in memory, since the parts can be large. etags <- bracketIO (openBinaryFile f ReadMode) hClose $ \fh -> do let sendparts meter etags partnum = ifM (liftIO $ hIsClosed fh) ( return (reverse etags) , do - b <- liftIO $ hGetUntilMetered fh (< partsz) meter - let sz = L.length b + pos <- liftIO $ hTell fh + -- Calculate size of part that will + -- be read. + let sz = if fsz - pos < partsz' + then fsz - pos + else partsz' + b <- liftIO $ hGetUntilMetered fh (< partsz') meter let body = RequestBodyStream sz (mkPopper b) S3.UploadPartResponse _ etag <- sendS3Handle h $ S3.uploadPart (bucket info) object partnum uploadid body @@ -199,7 +208,7 @@ store r h = fileStorer $ \k f p -> do void $ sendS3Handle h $ S3.postCompleteMultipartUpload (bucket info) object uploadid (zip [1..] etags) #else - warning $ "Cannot do multipart upload (partsize " ++ show partsz ++ "); built with too old a version of the aws library." + warning $ "Cannot do multipart upload (partsize " ++ show partsz ++ ") of large file (" ++ show fsz ++ "); built with too old a version of the aws library." singlepartupload k f p #endif |