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 commit809cfbbd8aand5d394023ebS3 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
parent
5d394023eb
commit
9cebfd7002
11 changed files with 143 additions and 148 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
91
Remote/S3.hs
91
Remote/S3.hs
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue