diff options
Diffstat (limited to 'Remote/Helper')
| -rw-r--r-- | Remote/Helper/AWS.hs | 34 | ||||
| -rw-r--r-- | Remote/Helper/Http.hs | 14 |
2 files changed, 38 insertions, 10 deletions
diff --git a/Remote/Helper/AWS.hs b/Remote/Helper/AWS.hs index 9b3643bc2..1675e8a50 100644 --- a/Remote/Helper/AWS.hs +++ b/Remote/Helper/AWS.hs @@ -1,6 +1,6 @@ {- Amazon Web Services common infrastructure. - - - Copyright 2011,2012 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -12,8 +12,14 @@ module Remote.Helper.AWS where import Common.Annex import Creds +import qualified Aws +import qualified Aws.S3 as S3 import qualified Data.Map as M +import qualified Data.ByteString as B +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Data.Text (Text) +import Data.IORef creds :: UUID -> CredPairStorage creds u = CredPairStorage @@ -22,6 +28,13 @@ creds u = CredPairStorage , credPairRemoteKey = Just "s3creds" } +genCredentials :: CredPair -> IO Aws.Credentials +genCredentials (keyid, secret) = Aws.Credentials + <$> pure (encodeUtf8 (T.pack keyid)) + <*> pure (encodeUtf8 (T.pack secret)) + <*> newIORef [] + <*> pure Nothing + data Service = S3 | Glacier deriving (Eq) @@ -33,9 +46,10 @@ regionMap = M.fromList . regionInfo defaultRegion :: Service -> Region defaultRegion = snd . Prelude.head . regionInfo -{- S3 and Glacier use different names for some regions. Ie, "us-east-1" - - cannot be used with S3, while "US" cannot be used with Glacier. Dunno why. - - Also, Glacier is not yet available in all regions. -} +data ServiceRegion = BothRegion Region | S3Region Region | GlacierRegion Region + +{- The "US" and "EU" names are used as location constraints when creating a + - S3 bucket. -} regionInfo :: Service -> [(Text, Region)] regionInfo service = map (\(t, r) -> (t, fromServiceRegion r)) $ filter (matchingService . snd) $ @@ -63,4 +77,14 @@ regionInfo service = map (\(t, r) -> (t, fromServiceRegion r)) $ matchingService (S3Region _) = service == S3 matchingService (GlacierRegion _) = service == Glacier -data ServiceRegion = BothRegion Region | S3Region Region | GlacierRegion Region +s3HostName :: Region -> B.ByteString +s3HostName "US" = "s3.amazonaws.com" +s3HostName "EU" = "s3-eu-west-1.amazonaws.com" +s3HostName r = encodeUtf8 $ T.concat ["s3-", r, ".amazonaws.com"] + +s3DefaultHost :: String +s3DefaultHost = "s3.amazonaws.com" + +mkLocationConstraint :: Region -> S3.LocationConstraint +mkLocationConstraint "US" = S3.locationUsClassic +mkLocationConstraint r = r diff --git a/Remote/Helper/Http.hs b/Remote/Helper/Http.hs index f1d576d1c..4088854ff 100644 --- a/Remote/Helper/Http.hs +++ b/Remote/Helper/Http.hs @@ -24,14 +24,18 @@ import Control.Concurrent -- 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 +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 <- fromIntegral . fileSize <$> getFileStatus src :: IO Integer + let streamer sink = withMeteredFile src 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 + return $ RequestBodyStream (fromInteger size) streamer where pop [] = ([], S.empty) pop (c:cs) = (cs, c) |