40ecf58d4b
This does not change the overall license of the git-annex program, which was already AGPL due to a number of sources files being AGPL already. Legally speaking, I'm adding a new license under which these files are now available; I already released their current contents under the GPL license. Now they're dual licensed GPL and AGPL. However, I intend for all my future changes to these files to only be released under the AGPL license, and I won't be tracking the dual licensing status, so I'm simply changing the license statement to say it's AGPL. (In some cases, others wrote parts of the code of a file and released it under the GPL; but in all cases I have contributed a significant portion of the code in each file and it's that code that is getting the AGPL license; the GPL license of other contributors allows combining with AGPL code.)
85 lines
2.7 KiB
Haskell
85 lines
2.7 KiB
Haskell
{- helpers for remotes using http
|
|
-
|
|
- Copyright 2014 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
module Remote.Helper.Http where
|
|
|
|
import Annex.Common
|
|
import Types.StoreRetrieve
|
|
import Remote.Helper.Special
|
|
import Utility.Metered
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified Data.ByteString as S
|
|
import Control.Concurrent
|
|
import Network.HTTP.Client (RequestBody(..), Response, responseStatus, responseBody, BodyReader, NeedsPopper)
|
|
import Network.HTTP.Types
|
|
|
|
-- 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 -> a k =<< liftIO (httpBodyStorer f m)
|
|
|
|
-- Reads the file and generates a streaming request body, that will update
|
|
-- the meter as it's sent.
|
|
httpBodyStorer :: FilePath -> MeterUpdate -> IO RequestBody
|
|
httpBodyStorer src m = do
|
|
size <- getFileSize src
|
|
let streamer sink = withMeteredFile src m $ \b -> byteStringPopper b sink
|
|
return $ RequestBodyStream (fromInteger size) streamer
|
|
|
|
byteStringPopper :: L.ByteString -> NeedsPopper () -> IO ()
|
|
byteStringPopper b sink = do
|
|
mvar <- newMVar $ L.toChunks b
|
|
let getnextchunk = modifyMVar mvar $ \v ->
|
|
case v of
|
|
[] -> return ([], S.empty)
|
|
(c:cs) -> return (cs, c)
|
|
sink getnextchunk
|
|
|
|
{- Makes a Popper that streams a given number of chunks of a given
|
|
- size from the handle, updating the meter as the chunks are read. -}
|
|
handlePopper :: Integer -> Int -> MeterUpdate -> Handle -> NeedsPopper () -> IO ()
|
|
handlePopper numchunks chunksize meterupdate h sink = do
|
|
mvar <- newMVar zeroBytesProcessed
|
|
let getnextchunk = do
|
|
sent <- takeMVar mvar
|
|
if sent >= target
|
|
then do
|
|
putMVar mvar sent
|
|
return S.empty
|
|
else do
|
|
b <- S.hGet h chunksize
|
|
let !sent' = addBytesProcessed sent chunksize
|
|
putMVar mvar sent'
|
|
meterupdate sent'
|
|
return b
|
|
sink getnextchunk
|
|
where
|
|
target = toBytesProcessed (numchunks * fromIntegral chunksize)
|
|
|
|
-- Reads the http body and stores it to the specified file, updating the
|
|
-- meter as it goes.
|
|
httpBodyRetriever :: FilePath -> MeterUpdate -> Response BodyReader -> IO ()
|
|
httpBodyRetriever dest meterupdate resp
|
|
| responseStatus resp /= ok200 = giveup $ show $ responseStatus resp
|
|
| otherwise = bracket (openBinaryFile dest WriteMode) hClose (go zeroBytesProcessed)
|
|
where
|
|
reader = responseBody resp
|
|
go sofar h = do
|
|
b <- reader
|
|
if S.null b
|
|
then return ()
|
|
else do
|
|
let sofar' = addBytesProcessed sofar $ S.length b
|
|
S.hPut h b
|
|
meterupdate sofar'
|
|
go sofar' h
|