From 669b305de2e5eb338075d7f06819aedacae50aff Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 23 Jan 2019 13:08:47 -0400 Subject: [PATCH] S3: Send a Content-Type header when storing objects in S3 So exports to public buckets can be linked to from web pages. (When git-annex is built with MagicMime support.) Thanks to Jared Cosulich for the idea. --- CHANGELOG | 8 ++++++++ Remote/S3.hs | 39 ++++++++++++++++++++++++--------------- 2 files changed, 32 insertions(+), 15 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index b6db7ce5a0..bed8582a2f 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,11 @@ +git-annex (7.20190123) UNRELEASED; urgency=medium + + * S3: Send a Content-Type header when storing objects in S3, + so exports to public buckets can be linked to from web pages. + (When git-annex is built with MagicMime support.) + + -- Joey Hess Wed, 23 Jan 2019 12:54:56 -0400 + git-annex (7.20190122) upstream; urgency=medium * sync --content: Fix dropping unwanted content from the local repository. diff --git a/Remote/S3.hs b/Remote/S3.hs index 2333afe22e..b3248ba7ee 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -1,6 +1,6 @@ {- S3 remotes - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -24,6 +24,7 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified System.FilePath.Posix as Posix import Data.Char +import Data.String import Network.Socket (HostName) import Network.HTTP.Conduit (Manager) import Network.HTTP.Client (responseStatus, responseBody, RequestBody(..)) @@ -47,6 +48,7 @@ import Remote.Helper.Export import qualified Remote.Helper.AWS as AWS import Creds import Annex.UUID +import Annex.Magic import Logs.Web import Logs.MetaData import Types.MetaData @@ -74,10 +76,11 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remot gen r u c gc = do cst <- remoteCost gc expensiveRemoteCost info <- extractS3Info c - return $ new cst info + magic <- liftIO initMagicMimeType + return $ new cst info magic where - new cst info = Just $ specialRemote c - (prepareS3Handle this $ store this info) + new cst info magic = Just $ specialRemote c + (prepareS3Handle this $ store this info magic) (prepareS3HandleMaybe this $ retrieve this c info) (prepareS3Handle this $ remove info) (prepareS3HandleMaybe this $ checkKey this c info) @@ -99,7 +102,7 @@ gen r u c gc = do , checkPresentCheap = False , exportActions = withS3HandleMaybe c gc u $ \mh -> return $ ExportActions - { storeExport = storeExportS3 u info mh + { storeExport = storeExportS3 u info mh magic , retrieveExport = retrieveExportS3 u info mh , removeExport = removeExportS3 u info mh , checkPresentExport = checkPresentExportS3 u info mh @@ -190,16 +193,16 @@ prepareS3HandleMaybe :: Remote -> (Maybe S3Handle -> helper) -> Preparer helper prepareS3HandleMaybe r = resourcePrepare $ const $ withS3HandleMaybe (config r) (gitconfig r) (uuid r) -store :: Remote -> S3Info -> S3Handle -> Storer -store _r info h = fileStorer $ \k f p -> do - void $ storeHelper info h f (T.pack $ bucketObject info k) p +store :: Remote -> S3Info -> Maybe Magic -> S3Handle -> Storer +store _r info magic h = fileStorer $ \k f p -> do + void $ storeHelper info h magic f (T.pack $ bucketObject info k) p -- Store public URL to item in Internet Archive. when (isIA info && not (isChunkKey k)) $ setUrlPresent k (iaPublicUrl info (bucketObject info k)) return True -storeHelper :: S3Info -> S3Handle -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3VersionID) -storeHelper info h f object p = case partSize info of +storeHelper :: S3Info -> S3Handle -> Maybe Magic -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3VersionID) +storeHelper info h magic f object p = case partSize info of Just partsz | partsz > 0 -> do fsz <- liftIO $ getFileSize f if fsz > partsz @@ -208,16 +211,20 @@ storeHelper info h f object p = case partSize info of _ -> singlepartupload where singlepartupload = do + contenttype <- getcontenttype rbody <- liftIO $ httpBodyStorer f p - r <- sendS3Handle h $ putObject info object rbody + r <- sendS3Handle h $ (putObject info object rbody) + { S3.poContentType = encodeBS <$> contenttype } return (mkS3VersionID object (S3.porVersionId r)) multipartupload fsz partsz = do #if MIN_VERSION_aws(0,16,0) + contenttype <- getcontenttype let startreq = (S3.postInitiateMultipartUpload (bucket info) object) { S3.imuStorageClass = Just (storageClass info) , S3.imuMetadata = metaHeaders info , S3.imuAutoMakeBucket = isIA info , S3.imuExpires = Nothing -- TODO set some reasonable expiry + , S3.imuContentType = fromString <$> contenttype } uploadid <- S3.imurUploadId <$> sendS3Handle h startreq @@ -254,6 +261,8 @@ storeHelper info h f object p = case partSize info of warning $ "Cannot do multipart upload (partsize " ++ show partsz ++ ") of large file (" ++ show fsz ++ "); built with too old a version of the aws library." singlepartupload #endif + getcontenttype = liftIO $ + maybe (pure Nothing) (flip getMagicMimeType f) magic {- Implemented as a fileRetriever, that uses conduit to stream the chunks - out to the file. Would be better to implement a byteRetriever, but @@ -343,16 +352,16 @@ checkKeyHelper info h loc = do | otherwise = Nothing #endif -storeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool -storeExportS3 u info (Just h) f k loc p = +storeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool +storeExportS3 u info (Just h) magic f k loc p = catchNonAsync go (\e -> warning (show e) >> return False) where go = do let o = T.pack $ bucketExportLocation info loc - storeHelper info h f o p + storeHelper info h magic f o p >>= setS3VersionID info u k return True -storeExportS3 u _ Nothing _ _ _ _ = do +storeExportS3 u _ Nothing _ _ _ _ _ = do warning $ needS3Creds u return False