mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

prepareS3Handle didn't give any benefits, so remove

Browse source 
I seem to have thought that a Preparer was only run once when a remote
is accessed multiple times, but that is not in fact the case. prepareS3Handle
is run once per access. So, there is no point to it.

That there is some duplicate work done on each access is now apparent.
Luckily, the http manager is reused, so only one http connection is
made. But the S3 creds are loaded repeatedly. Room for improvement here.

This commit was sponsored by Jack Hill on Patreon.
This commit is contained in:
Joey Hess 2019-01-30 14:23:39 -04:00
parent 720e5fda5c
commit 809cfbbd8a
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
1 changed files with 57 additions and 62 deletions
Download patch file Download diff file Expand all files Collapse all files

119
Remote/S3.hs
View file

@ -80,10 +80,10 @@ gen r u c gc = do
return $ new cst info magic return $ new cst info magic
where where
new cst info magic = Just $ specialRemote c new cst info magic = Just $ specialRemote c
(prepareS3Handle this $ store this info magic) (simplyPrepare $ store this info magic)
(prepareS3HandleMaybe this $ retrieve this c info) (simplyPrepare $ retrieve this c info)
(prepareS3Handle this $ remove info) (simplyPrepare $ remove this info)
(prepareS3HandleMaybe this $ checkKey this c info) (simplyPrepare $ checkKey this c info)
this this
where where
this = Remote this = Remote
@ -100,7 +100,7 @@ gen r u c gc = do
, lockContent = Nothing , lockContent = Nothing
, checkPresent = checkPresentDummy , checkPresent = checkPresentDummy
, checkPresentCheap = False , checkPresentCheap = False
, exportActions = withS3HandleMaybe c gc u $ \mh -> , exportActions = withS3HandleMaybe' c gc u $ \mh ->
return $ ExportActions return $ ExportActions
{ storeExport = storeExportS3 u info mh magic { storeExport = storeExportS3 u info mh magic
, retrieveExport = retrieveExportS3 u info mh , retrieveExport = retrieveExportS3 u info mh
@ -179,23 +179,12 @@ s3Setup' ss u mcreds c gc
-- special constraints on key names -- special constraints on key names
M.insert "mungekeys" "ia" defaults M.insert "mungekeys" "ia" defaults
info <- extractS3Info archiveconfig info <- extractS3Info archiveconfig
withS3Handle archiveconfig gc u $ withS3Handle' archiveconfig gc u $
writeUUIDFile archiveconfig u info writeUUIDFile archiveconfig u info
use archiveconfig use archiveconfig
-- Sets up a http connection manager for S3 endpoint, which allows store :: Remote -> S3Info -> Maybe Magic -> Storer
-- http connections to be reused across calls to the helper. store r info magic = fileStorer $ \k f p -> withS3Handle r $ \h -> do
prepareS3Handle :: Remote -> (S3Handle -> helper) -> Preparer helper
prepareS3Handle r = resourcePrepare $ const $
withS3Handle (config r) (gitconfig r) (uuid r)
-- Allows for read-only actions, which can be run without a S3Handle.
prepareS3HandleMaybe :: Remote -> (Maybe S3Handle -> helper) -> Preparer helper
prepareS3HandleMaybe r = resourcePrepare $ const $
withS3HandleMaybe (config r) (gitconfig r) (uuid r)
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 void $ storeHelper info h magic f (T.pack $ bucketObject info k) p
-- Store public URL to item in Internet Archive. -- Store public URL to item in Internet Archive.
when (isIA info && not (isChunkKey k)) $ when (isIA info && not (isChunkKey k)) $
@ -268,20 +257,21 @@ storeHelper info h magic f object p = case partSize info of
{- Implemented as a fileRetriever, that uses conduit to stream the chunks {- Implemented as a fileRetriever, that uses conduit to stream the chunks
- out to the file. Would be better to implement a byteRetriever, but - out to the file. Would be better to implement a byteRetriever, but
- that is difficult. -} - that is difficult. -}
retrieve :: Remote -> RemoteConfig -> S3Info -> Maybe S3Handle -> Retriever retrieve :: Remote -> RemoteConfig -> S3Info -> Retriever
retrieve r c info (Just h) = fileRetriever $ \f k p -> retrieve r c info = fileRetriever $ \f k p -> withS3HandleMaybe r $ \case
eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case (Just h) ->
Left failreason -> do eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case
warning failreason Left failreason -> do
giveup "cannot download content" warning failreason
Right loc -> retrieveHelper info h loc f p giveup "cannot download content"
retrieve r c info Nothing = fileRetriever $ \f k p -> Right loc -> retrieveHelper info h loc f p
getPublicWebUrls' (uuid r) info c k >>= \case Nothing ->
Left failreason -> do getPublicWebUrls' (uuid r) info c k >>= \case
warning failreason Left failreason -> do
giveup "cannot download content" warning failreason
Right us -> unlessM (downloadUrl k p us f) $ giveup "cannot download content"
giveup "failed to download content" Right us -> unlessM (downloadUrl k p us f) $
giveup "failed to download content"
retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Annex () retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Annex ()
retrieveHelper info h loc f p = liftIO $ runResourceT $ do retrieveHelper info h loc f p = liftIO $ runResourceT $ do
@ -295,33 +285,31 @@ retrieveHelper info h loc f p = liftIO $ runResourceT $ do
retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False retrieveCheap _ _ _ = return False
{- Internet Archive doesn't easily allow removing content. remove :: Remote -> S3Info -> Remover
- While it may remove the file, there are generally other files remove r info k = withS3Handle r $ \h -> do
- derived from it that it does not remove. -}
remove :: S3Info -> S3Handle -> Remover
remove info h k = do
res <- tryNonAsync $ sendS3Handle h $ res <- tryNonAsync $ sendS3Handle h $
S3.DeleteObject (T.pack $ bucketObject info k) (bucket info) S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
return $ either (const False) (const True) res return $ either (const False) (const True) res
checkKey :: Remote -> RemoteConfig -> S3Info -> Maybe S3Handle -> CheckPresent checkKey :: Remote -> RemoteConfig -> S3Info -> CheckPresent
checkKey r c info (Just h) k = do checkKey r c info k = withS3HandleMaybe r $ \case
showChecking r Just h -> do
eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case showChecking r
Left failreason -> do eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case
warning failreason Left failreason -> do
giveup "cannot check content" warning failreason
Right loc -> checkKeyHelper info h loc giveup "cannot check content"
checkKey r c info Nothing k = Right loc -> checkKeyHelper info h loc
getPublicWebUrls' (uuid r) info c k >>= \case Nothing ->
Left failreason -> do getPublicWebUrls' (uuid r) info c k >>= \case
warning failreason Left failreason -> do
giveup "cannot check content" warning failreason
Right us -> do giveup "cannot check content"
showChecking r Right us -> do
let check u = withUrlOptions $ showChecking r
liftIO . checkBoth u (keySize k) let check u = withUrlOptions $
anyM check us liftIO . checkBoth u (keySize k)
anyM check us
checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool
checkKeyHelper info h loc = do checkKeyHelper info h loc = do
@ -434,7 +422,7 @@ genBucket :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
genBucket c gc u = do genBucket c gc u = do
showAction "checking bucket" showAction "checking bucket"
info <- extractS3Info c info <- extractS3Info c
withS3Handle c gc u $ \h -> withS3Handle' c gc u $ \h ->
go info h =<< checkUUIDFile c u info h go info h =<< checkUUIDFile c u info h
where where
go _ _ (Right True) = noop go _ _ (Right True) = noop
@ -537,15 +525,21 @@ sendS3Handle'
-> ResourceT IO a -> ResourceT IO a
sendS3Handle' h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r sendS3Handle' h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r
withS3Handle :: RemoteConfig -> RemoteGitConfig -> UUID -> (S3Handle -> Annex a) -> Annex a withS3Handle :: Remote -> (S3Handle -> Annex a) -> Annex a
withS3Handle c gc u a = withS3HandleMaybe c gc u $ \mh -> case mh of withS3Handle r = withS3Handle' (config r) (gitconfig r) (uuid r)
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 Just h -> a h
Nothing -> do Nothing -> do
warning $ needS3Creds u warning $ needS3Creds u
giveup "No S3 credentials configured" giveup "No S3 credentials configured"
withS3HandleMaybe :: RemoteConfig -> RemoteGitConfig -> UUID -> (Maybe S3Handle -> Annex a) -> Annex a withS3HandleMaybe :: Remote -> (Maybe S3Handle -> Annex a) -> Annex a
withS3HandleMaybe c gc u a = do 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
mcreds <- getRemoteCredPair c gc (AWS.creds u) mcreds <- getRemoteCredPair c gc (AWS.creds u)
case mcreds of case mcreds of
Just creds -> do Just creds -> do
@ -881,7 +875,7 @@ enableBucketVersioning ss c _ _ = do
enableversioning b = do enableversioning b = do
#if MIN_VERSION_aws(0,22,0) #if MIN_VERSION_aws(0,22,0)
showAction "enabling bucket versioning" showAction "enabling bucket versioning"
withS3Handle c gc u $ \h -> withS3Handle' c gc u $ \h ->
void $ sendS3Handle h $ S3.putBucketVersioning b S3.VersioningEnabled void $ sendS3Handle h $ S3.putBucketVersioning b S3.VersioningEnabled
#else #else
showLongNote $ unlines showLongNote $ unlines
@ -911,3 +905,4 @@ checkVersioning info u k a
return False return False
_ -> a _ -> a
| otherwise = a | otherwise = a