purify exportActions

Purifying exportActions will allow introspecting and modifying it,
which is needed to add progress bar display to it.

Only S3 and WebDAV ran an Annex action while constructing ExportActions.
There was a small performance gain from them doing that, since a
resource was able to be prepared and reused for multiple actions by
Command.Export.

As seen in commit 809cfbbd8a and
5d394023eb S3 and WebDAV actually create a
new handle for each access in normal, non-export use. It doesn't seem
worth making export use of them marginally more efficient than normal
use. It would be better to do that work upfront when constructing the
remote. Or perhaps use a MVar to cache a handle.

This commit was sponsored by Nick Piper on Patreon.
This commit is contained in:
Joey Hess 2019-01-30 14:55:28 -04:00
parent 5d394023eb
commit 9cebfd7002
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
11 changed files with 143 additions and 148 deletions

View file

@ -53,7 +53,7 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, exportActions = return $ ExportActions
, exportActions = ExportActions
{ storeExport = storeExportM serial adir
, retrieveExport = retrieveExportM serial adir
, removeExport = removeExportM serial adir

View file

@ -63,7 +63,7 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = True
, exportActions = return $ ExportActions
, exportActions = ExportActions
{ storeExport = storeExportM dir
, retrieveExport = retrieveExportM dir
, removeExport = removeExportM dir

View file

@ -75,7 +75,7 @@ gen r u c gc
then checkExportSupported' external
else return False
let exportactions = if exportsupported
then return $ ExportActions
then ExportActions
{ storeExport = storeExportM external
, retrieveExport = retrieveExportM external
, removeExport = removeExportM external

View file

@ -31,8 +31,8 @@ class HasExportUnsupported a where
instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
exportUnsupported = \_ _ -> return False
instance HasExportUnsupported (Annex (ExportActions Annex)) where
exportUnsupported = return $ ExportActions
instance HasExportUnsupported (ExportActions Annex) where
exportUnsupported = ExportActions
{ storeExport = \_ _ _ _ -> do
warning "store export is unsupported"
return False
@ -182,10 +182,8 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
-- non-export remote)
, checkPresent = if appendonly r
then checkPresent r
else \k -> do
ea <- exportActions r
anyM (checkPresentExport ea k)
=<< getexportlocs k
else \k -> anyM (checkPresentExport (exportActions r) k)
=<< getexportlocs k
-- checkPresent from an export is more expensive
-- than otherwise, so not cheap. Also, this
-- avoids things that look at checkPresentCheap and
@ -211,9 +209,7 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
, warning "unknown export location"
)
return False
(l:_) -> do
ea <- exportActions r
retrieveExport ea k l dest p
(l:_) -> retrieveExport (exportActions r) k l dest p
else do
warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ " backend"
return False

View file

@ -77,7 +77,7 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, exportActions = return $ ExportActions
, exportActions = ExportActions
{ storeExport = storeExportM o
, retrieveExport = retrieveExportM o
, removeExport = removeExportM o

View file

@ -100,16 +100,15 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, exportActions = withS3HandleMaybe' c gc u $ \mh ->
return $ ExportActions
{ storeExport = storeExportS3 u info mh magic
, retrieveExport = retrieveExportS3 u info mh
, removeExport = removeExportS3 u info mh
, checkPresentExport = checkPresentExportS3 u info mh
-- S3 does not have directories.
, removeExportDirectory = Nothing
, renameExport = renameExportS3 u info mh
}
, exportActions = ExportActions
{ storeExport = storeExportS3 this info magic
, retrieveExport = retrieveExportS3 this info
, removeExport = removeExportS3 this info
, checkPresentExport = checkPresentExportS3 this info
-- S3 does not have directories.
, removeExportDirectory = Nothing
, renameExport = renameExportS3 this info
}
, whereisKey = Just (getPublicWebUrls u info c)
, remoteFsck = Nothing
, repairRepo = Nothing
@ -341,63 +340,68 @@ checkKeyHelper info h loc = do
| otherwise = Nothing
#endif
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)
storeExportS3 :: Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportS3 r info magic f k loc p = withS3HandleMaybe r $ \case
Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return False)
Nothing -> do
warning $ needS3Creds (uuid r)
return False
where
go = do
go h = do
let o = T.pack $ bucketExportLocation info loc
storeHelper info h magic f o p
>>= setS3VersionID info u k
>>= setS3VersionID info (uuid r) k
return True
storeExportS3 u _ Nothing _ _ _ _ _ = do
warning $ needS3Creds u
return False
retrieveExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportS3 u info mh _k loc f p =
retrieveExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportS3 r info _k loc f p =
catchNonAsync go (\e -> warning (show e) >> return False)
where
go = case mh of
go = withS3HandleMaybe r $ \case
Just h -> do
retrieveHelper info h (Left (T.pack exporturl)) f p
return True
Nothing -> case getPublicUrlMaker info of
Nothing -> do
warning $ needS3Creds u
warning $ needS3Creds (uuid r)
return False
Just geturl -> Url.withUrlOptions $
liftIO . Url.download p (geturl exporturl) f
exporturl = bucketExportLocation info loc
removeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> Annex Bool
removeExportS3 u info (Just h) k loc = checkVersioning info u k $
catchNonAsync go (\e -> warning (show e) >> return False)
removeExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
removeExportS3 r info k loc = withS3HandleMaybe r $ \case
Just h -> checkVersioning info (uuid r) k $
catchNonAsync (go h) (\e -> warning (show e) >> return False)
Nothing -> do
warning $ needS3Creds (uuid r)
return False
where
go = do
go h = do
res <- tryNonAsync $ sendS3Handle h $
S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info)
return $ either (const False) (const True) res
removeExportS3 u _ Nothing _ _ = do
warning $ needS3Creds u
return False
checkPresentExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> Annex Bool
checkPresentExportS3 _u info (Just h) _k loc =
checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))
checkPresentExportS3 u info Nothing k loc = case getPublicUrlMaker info of
Nothing -> do
warning $ needS3Creds u
giveup "No S3 credentials configured"
Just geturl -> withUrlOptions $ liftIO .
checkBoth (geturl $ bucketExportLocation info loc) (keySize k)
checkPresentExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
checkPresentExportS3 r info k loc = withS3HandleMaybe r $ \case
Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))
Nothing -> case getPublicUrlMaker info of
Just geturl -> withUrlOptions $ liftIO .
checkBoth (geturl $ bucketExportLocation info loc) (keySize k)
Nothing -> do
warning $ needS3Creds (uuid r)
giveup "No S3 credentials configured"
-- S3 has no move primitive; copy and delete.
renameExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportS3 u info (Just h) k src dest = checkVersioning info u k $
catchNonAsync go (\_ -> return False)
renameExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportS3 r info k src dest = withS3HandleMaybe r $ \case
Just h -> checkVersioning info (uuid r) k $
catchNonAsync (go h) (\_ -> return False)
Nothing -> do
warning $ needS3Creds (uuid r)
return False
where
go = do
go h = do
let co = S3.copyObject (bucket info) dstobject
(S3.ObjectId (bucket info) srcobject Nothing)
S3.CopyMetadata
@ -407,9 +411,6 @@ renameExportS3 u info (Just h) k src dest = checkVersioning info u k $
return True
srcobject = T.pack $ bucketExportLocation info src
dstobject = T.pack $ bucketExportLocation info dest
renameExportS3 u _ Nothing _ _ _ = do
warning $ needS3Creds u
return False
{- Generate the bucket if it does not already exist, including creating the
- UUID file within the bucket.

View file

@ -79,14 +79,14 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, exportActions = withDAVHandle this $ \mh -> return $ ExportActions
{ storeExport = storeExportDav mh
, retrieveExport = retrieveExportDav mh
, checkPresentExport = checkPresentExportDav this mh
, removeExport = removeExportDav mh
, exportActions = ExportActions
{ storeExport = storeExportDav this
, retrieveExport = retrieveExportDav this
, checkPresentExport = checkPresentExportDav this
, removeExport = removeExportDav this
, removeExportDirectory = Just $
removeExportDirectoryDav mh
, renameExport = renameExportDav mh
removeExportDirectoryDav this
, renameExport = renameExportDav this
}
, whereisKey = Nothing
, remoteFsck = Nothing
@ -193,45 +193,46 @@ checkKey r chunkconfig (Just dav) k = do
existsDAV (keyLocation k)
either giveup return v
storeExportDav :: Maybe DavHandle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportDav mh f k loc p = runExport mh $ \dav -> do
storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportDav r f k loc p = withDAVHandle r $ \mh -> runExport mh $ \dav -> do
reqbody <- liftIO $ httpBodyStorer f p
storeHelper dav (keyTmpLocation k) (exportLocation loc) reqbody
return True
retrieveExportDav :: Maybe DavHandle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportDav mh _k loc d p = runExport mh $ \_dav -> do
retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportDav r _k loc d p = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do
retrieveHelper (exportLocation loc) d p
return True
checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
checkPresentExportDav r mh _k loc = case mh of
checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
checkPresentExportDav r _k loc = withDAVHandle r $ \case
Nothing -> giveup $ name r ++ " not configured"
Just h -> liftIO $ do
v <- goDAV h $ existsDAV (exportLocation loc)
either giveup return v
removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
removeExportDav mh _k loc = runExport mh $ \_dav ->
removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
removeExportDav r _k loc = withDAVHandle r $ \mh -> runExport mh $ \_dav ->
removeHelper (exportLocation loc)
removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool
removeExportDirectoryDav mh dir = runExport mh $ \_dav -> do
removeExportDirectoryDav :: Remote -> ExportDirectory -> Annex Bool
removeExportDirectoryDav r dir = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do
let d = fromExportDirectory dir
debugDav $ "delContent " ++ d
safely (inLocation d delContentM)
>>= maybe (return False) (const $ return True)
renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportDav Nothing _ _ _ = return False
renameExportDav (Just h) _k src dest
-- box.com's DAV endpoint has buggy handling of renames,
-- so avoid renaming when using it.
| boxComUrl `isPrefixOf` baseURL h = return False
| otherwise = runExport (Just h) $ \dav -> do
maybe noop (void . mkColRecursive) (locationParent (exportLocation dest))
moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)
return True
renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportDav r _k src dest = withDAVHandle r $ \case
Just h
-- box.com's DAV endpoint has buggy handling of renames,
-- so avoid renaming when using it.
| boxComUrl `isPrefixOf` baseURL h -> return False
| otherwise -> runExport (Just h) $ \dav -> do
maybe noop (void . mkColRecursive) (locationParent (exportLocation dest))
moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)
return True
Nothing -> return False
runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool
runExport Nothing _ = return False