Improved speed of S3 remote by only loading S3 creds once
This gets back any speed lost in commit
9cebfd7002, and speeds up all uses of S3
remotes that operate on them more than once.
This commit was sponsored by Brett Eisenberg on Patreon.
This commit is contained in:
Joey Hess
parent
8eb66a5c40
commit
ab689cf0cd
2 changed files with 65 additions and 52 deletions
|
|
@ -7,6 +7,7 @@ git-annex (7.20190130) UNRELEASED; urgency=medium
|
|||
fails, fall back to trying to retrieve from the exported tree.
|
||||
This allows downloads of files that were exported to such a remote
|
||||
before versioning was enabled on it.
|
||||
* Improved speed of S3 remote by only loading S3 creds once.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Wed, 30 Jan 2019 12:30:22 -0400
|
||||
|
||||
|
|
|
|||
116
Remote/S3.hs
116
Remote/S3.hs
|
|
@ -33,6 +33,8 @@ import Control.Monad.Trans.Resource
|
|||
import Control.Monad.Catch
|
||||
import Data.IORef
|
||||
import System.Log.Logger
|
||||
import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TVar
|
||||
|
||||
import Annex.Common
|
||||
import Types.Remote
|
||||
|
|
@ -56,7 +58,7 @@ import Utility.Metered
|
|||
import qualified Annex.Url as Url
|
||||
import Utility.DataUnits
|
||||
import Annex.Content
|
||||
import Annex.Url (withUrlOptions)
|
||||
import Annex.Url (getUrlOptions, withUrlOptions)
|
||||
import Utility.Url (checkBoth, UrlOptions(..))
|
||||
import Utility.Env
|
||||
|
||||
|
|
@ -76,14 +78,15 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remot
|
|||
gen r u c gc = do
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
info <- extractS3Info c
|
||||
hdl <- mkS3HandleVar c gc u
|
||||
magic <- liftIO initMagicMimeType
|
||||
return $ new cst info magic
|
||||
return $ new cst info hdl magic
|
||||
where
|
||||
new cst info magic = Just $ specialRemote c
|
||||
(simplyPrepare $ store this info magic)
|
||||
(simplyPrepare $ retrieve this c info)
|
||||
(simplyPrepare $ remove this info)
|
||||
(simplyPrepare $ checkKey this c info)
|
||||
new cst info hdl magic = Just $ specialRemote c
|
||||
(simplyPrepare $ store hdl this info magic)
|
||||
(simplyPrepare $ retrieve hdl this c info)
|
||||
(simplyPrepare $ remove hdl this info)
|
||||
(simplyPrepare $ checkKey hdl this c info)
|
||||
this
|
||||
where
|
||||
this = Remote
|
||||
|
|
@ -101,13 +104,13 @@ gen r u c gc = do
|
|||
, checkPresent = checkPresentDummy
|
||||
, checkPresentCheap = False
|
||||
, exportActions = ExportActions
|
||||
{ storeExport = storeExportS3 this info magic
|
||||
, retrieveExport = retrieveExportS3 this info
|
||||
, removeExport = removeExportS3 this info
|
||||
, checkPresentExport = checkPresentExportS3 this info
|
||||
{ storeExport = storeExportS3 hdl this info magic
|
||||
, retrieveExport = retrieveExportS3 hdl this info
|
||||
, removeExport = removeExportS3 hdl this info
|
||||
, checkPresentExport = checkPresentExportS3 hdl this info
|
||||
-- S3 does not have directories.
|
||||
, removeExportDirectory = Nothing
|
||||
, renameExport = renameExportS3 this info
|
||||
, renameExport = renameExportS3 hdl this info
|
||||
}
|
||||
, whereisKey = Just (getPublicWebUrls u info c)
|
||||
, remoteFsck = Nothing
|
||||
|
|
@ -178,12 +181,13 @@ s3Setup' ss u mcreds c gc
|
|||
-- special constraints on key names
|
||||
M.insert "mungekeys" "ia" defaults
|
||||
info <- extractS3Info archiveconfig
|
||||
withS3Handle' archiveconfig gc u $
|
||||
hdl <- mkS3HandleVar archiveconfig gc u
|
||||
withS3HandleOrFail u hdl $
|
||||
writeUUIDFile archiveconfig u info
|
||||
use archiveconfig
|
||||
|
||||
store :: Remote -> S3Info -> Maybe Magic -> Storer
|
||||
store r info magic = fileStorer $ \k f p -> withS3Handle r $ \h -> do
|
||||
store :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> Storer
|
||||
store mh r info magic = fileStorer $ \k f p -> withS3HandleOrFail (uuid r) mh $ \h -> 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)) $
|
||||
|
|
@ -256,8 +260,8 @@ storeHelper info h magic f object p = liftIO $ case partSize info of
|
|||
{- Implemented as a fileRetriever, that uses conduit to stream the chunks
|
||||
- out to the file. Would be better to implement a byteRetriever, but
|
||||
- that is difficult. -}
|
||||
retrieve :: Remote -> RemoteConfig -> S3Info -> Retriever
|
||||
retrieve r c info = fileRetriever $ \f k p -> withS3HandleMaybe r $ \case
|
||||
retrieve :: S3HandleVar -> Remote -> RemoteConfig -> S3Info -> Retriever
|
||||
retrieve hv r c info = fileRetriever $ \f k p -> withS3Handle hv $ \case
|
||||
(Just h) ->
|
||||
eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case
|
||||
Left failreason -> do
|
||||
|
|
@ -284,14 +288,14 @@ retrieveHelper info h loc f p = liftIO $ runResourceT $ do
|
|||
retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
retrieveCheap _ _ _ = return False
|
||||
|
||||
remove :: Remote -> S3Info -> Remover
|
||||
remove r info k = withS3Handle r $ \h -> liftIO $ runResourceT $ do
|
||||
remove :: S3HandleVar -> Remote -> S3Info -> Remover
|
||||
remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> liftIO $ runResourceT $ do
|
||||
res <- tryNonAsync $ sendS3Handle h $
|
||||
S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
|
||||
return $ either (const False) (const True) res
|
||||
|
||||
checkKey :: Remote -> RemoteConfig -> S3Info -> CheckPresent
|
||||
checkKey r c info k = withS3HandleMaybe r $ \case
|
||||
checkKey :: S3HandleVar -> Remote -> RemoteConfig -> S3Info -> CheckPresent
|
||||
checkKey hv r c info k = withS3Handle hv $ \case
|
||||
Just h -> do
|
||||
showChecking r
|
||||
eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case
|
||||
|
|
@ -340,8 +344,8 @@ checkKeyHelper info h loc = liftIO $ runResourceT $ do
|
|||
| otherwise = Nothing
|
||||
#endif
|
||||
|
||||
storeExportS3 :: Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
|
||||
storeExportS3 r info magic f k loc p = withS3HandleMaybe r $ \case
|
||||
storeExportS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
|
||||
storeExportS3 hv r info magic f k loc p = withS3Handle hv $ \case
|
||||
Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return False)
|
||||
Nothing -> do
|
||||
warning $ needS3Creds (uuid r)
|
||||
|
|
@ -353,11 +357,11 @@ storeExportS3 r info magic f k loc p = withS3HandleMaybe r $ \case
|
|||
>>= setS3VersionID info (uuid r) k
|
||||
return True
|
||||
|
||||
retrieveExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportS3 r info _k loc f p =
|
||||
retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportS3 hv r info _k loc f p =
|
||||
catchNonAsync go (\e -> warning (show e) >> return False)
|
||||
where
|
||||
go = withS3HandleMaybe r $ \case
|
||||
go = withS3Handle hv $ \case
|
||||
Just h -> do
|
||||
retrieveHelper info h (Left (T.pack exporturl)) f p
|
||||
return True
|
||||
|
|
@ -369,8 +373,8 @@ retrieveExportS3 r info _k loc f p =
|
|||
liftIO . Url.download p (geturl exporturl) f
|
||||
exporturl = bucketExportLocation info loc
|
||||
|
||||
removeExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportS3 r info k loc = withS3HandleMaybe r $ \case
|
||||
removeExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportS3 hv r info k loc = withS3Handle hv $ \case
|
||||
Just h -> checkVersioning info (uuid r) k $
|
||||
catchNonAsync (go h) (\e -> warning (show e) >> return False)
|
||||
Nothing -> do
|
||||
|
|
@ -382,8 +386,8 @@ removeExportS3 r info k loc = withS3HandleMaybe r $ \case
|
|||
S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info)
|
||||
return $ either (const False) (const True) res
|
||||
|
||||
checkPresentExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportS3 r info k loc = withS3HandleMaybe r $ \case
|
||||
checkPresentExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case
|
||||
Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))
|
||||
Nothing -> case getPublicUrlMaker info of
|
||||
Just geturl -> withUrlOptions $ liftIO .
|
||||
|
|
@ -393,8 +397,8 @@ checkPresentExportS3 r info k loc = withS3HandleMaybe r $ \case
|
|||
giveup "No S3 credentials configured"
|
||||
|
||||
-- S3 has no move primitive; copy and delete.
|
||||
renameExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool
|
||||
renameExportS3 r info k src dest = withS3HandleMaybe r $ \case
|
||||
renameExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool
|
||||
renameExportS3 hv r info k src dest = withS3Handle hv $ \case
|
||||
Just h -> checkVersioning info (uuid r) k $
|
||||
catchNonAsync (go h) (\_ -> return False)
|
||||
Nothing -> do
|
||||
|
|
@ -423,7 +427,8 @@ genBucket :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
|
|||
genBucket c gc u = do
|
||||
showAction "checking bucket"
|
||||
info <- extractS3Info c
|
||||
withS3Handle' c gc u $ \h ->
|
||||
hdl <- mkS3HandleVar c gc u
|
||||
withS3HandleOrFail u hdl $ \h ->
|
||||
go info h =<< checkUUIDFile c u info h
|
||||
where
|
||||
go _ _ (Right True) = noop
|
||||
|
|
@ -501,7 +506,7 @@ uuidFile c = getFilePrefix c ++ "annex-uuid"
|
|||
tryS3 :: ResourceT IO a -> ResourceT IO (Either S3.S3Error a)
|
||||
tryS3 a = (Right <$> a) `catch` (pure . Left)
|
||||
|
||||
data S3Handle = S3Handle
|
||||
data S3Handle = S3Handle
|
||||
{ hmanager :: Manager
|
||||
, hawscfg :: AWS.Configuration
|
||||
, hs3cfg :: S3.S3Configuration AWS.NormalQuery
|
||||
|
|
@ -515,21 +520,12 @@ sendS3Handle
|
|||
-> ResourceT IO a
|
||||
sendS3Handle h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r
|
||||
|
||||
withS3Handle :: Remote -> (S3Handle -> Annex a) -> Annex a
|
||||
withS3Handle r = withS3Handle' (config r) (gitconfig r) (uuid r)
|
||||
type S3HandleVar = TVar (Either (Annex (Maybe S3Handle)) (Maybe S3Handle))
|
||||
|
||||
withS3Handle' :: RemoteConfig -> RemoteGitConfig -> UUID -> (S3Handle -> Annex a) -> Annex a
|
||||
withS3Handle' c gc u a = withS3HandleMaybe' c gc u $ \mh -> case mh of
|
||||
Just h -> a h
|
||||
Nothing -> do
|
||||
warning $ needS3Creds u
|
||||
giveup "No S3 credentials configured"
|
||||
|
||||
withS3HandleMaybe :: Remote -> (Maybe S3Handle -> Annex a) -> Annex a
|
||||
withS3HandleMaybe r = withS3HandleMaybe' (config r) (gitconfig r) (uuid r)
|
||||
|
||||
withS3HandleMaybe' :: RemoteConfig -> RemoteGitConfig -> UUID -> (Maybe S3Handle -> Annex a) -> Annex a
|
||||
withS3HandleMaybe' c gc u a = do
|
||||
{- Prepares a S3Handle for later use. Does not connect to S3 or do anything
|
||||
- else expensive. -}
|
||||
mkS3HandleVar :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar
|
||||
mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $ do
|
||||
mcreds <- getRemoteCredPair c gc (AWS.creds u)
|
||||
case mcreds of
|
||||
Just creds -> do
|
||||
|
|
@ -538,12 +534,27 @@ withS3HandleMaybe' c gc u a = do
|
|||
#if MIN_VERSION_aws(0,17,0)
|
||||
Nothing
|
||||
#endif
|
||||
withUrlOptions $ \ou ->
|
||||
a $ Just $ S3Handle (httpManager ou) awscfg s3cfg
|
||||
Nothing -> a Nothing
|
||||
ou <- getUrlOptions
|
||||
return $ Just $ S3Handle (httpManager ou) awscfg s3cfg
|
||||
Nothing -> return Nothing
|
||||
where
|
||||
s3cfg = s3Configuration c
|
||||
|
||||
withS3Handle :: S3HandleVar -> (Maybe S3Handle -> Annex a) -> Annex a
|
||||
withS3Handle hv a = liftIO (readTVarIO hv) >>= \case
|
||||
Right hdl -> a hdl
|
||||
Left mkhdl -> do
|
||||
hdl <- mkhdl
|
||||
liftIO $ atomically $ writeTVar hv (Right hdl)
|
||||
a hdl
|
||||
|
||||
withS3HandleOrFail :: UUID -> S3HandleVar -> (S3Handle -> Annex a) -> Annex a
|
||||
withS3HandleOrFail u hv a = withS3Handle hv $ \case
|
||||
Just hdl -> a hdl
|
||||
Nothing -> do
|
||||
warning $ needS3Creds u
|
||||
giveup "No S3 credentials configured"
|
||||
|
||||
needS3Creds :: UUID -> String
|
||||
needS3Creds u = missingCredPairFor "S3" (AWS.creds u)
|
||||
|
||||
|
|
@ -865,7 +876,8 @@ enableBucketVersioning ss c _ _ = do
|
|||
enableversioning b = do
|
||||
#if MIN_VERSION_aws(0,22,0)
|
||||
showAction "enabling bucket versioning"
|
||||
withS3Handle' c gc u $ \h ->
|
||||
hdl <- mkS3HandleVar c gc u
|
||||
withS3HandleOrFail u hdl $ \h ->
|
||||
void $ liftIO $ runResourceT $ sendS3Handle h $
|
||||
S3.putBucketVersioning b S3.VersioningEnabled
|
||||
#else
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue