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

run Preparer to get Remover and CheckPresent actions

Browse source 
This will allow special remotes to eg, open a http connection and reuse it,
while checking if chunks are present, or removing chunks.

S3 and WebDAV both need this to support chunks with reasonable speed.

Note that a special remote might want to cache a http connection across
multiple requests. A simple case of this is that CheckPresent is typically
called before Store or Remove. A remote using this interface can certianly
use a Preparer that eg, uses a MVar to cache a http connection.

However, it's up to the remote to then deal with things like stale or
stalled http connections when eg, doing a series of downloads from a remote
and other places. There could be long delays between calls to a remote,
which could lead to eg, http connection stalls; the machine might even
move to a new network, etc.

It might be nice to improve this interface later to allow
the simple case without needing to handle the full complex case.
One way to do it would be to have a `Transaction SpecialRemote cache`,
where SpecialRemote contains methods for Storer, Retriever, Remover, and
CheckPresent, that all expect to be passed a `cache`.
This commit is contained in:
Joey Hess 2014-08-06 14:28:36 -04:00
parent b4cf22a388
commit 8025decc7f
11 changed files with 98 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
Remote/Bup.hs
View file

@ -57,8 +57,8 @@ gen r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap buprepo
, removeKey = remove buprepo
, checkPresent = checkKey r bupr'
, removeKey = removeKeyDummy
, checkPresent = checkPresentDummy
, checkPresentCheap = bupLocal buprepo
, whereisKey = Nothing
, remoteFsck = Nothing
@ -76,6 +76,8 @@ gen r u c gc = do
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this buprepo)
(simplyPrepare $ retrieve buprepo)
(simplyPrepare $ remove buprepo)
(simplyPrepare $ checkKey r bupr')
this
where
buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
@ -146,7 +148,7 @@ retrieveCheap _ _ _ = return False
-
- We can, however, remove the git branch that bup created for the key.
-}
remove :: BupRepo -> Key -> Annex Bool
remove :: BupRepo -> Remover
remove buprepo k = do
go =<< liftIO (bup2GitRemote buprepo)
warning "content cannot be completely removed from bup remote"
@ -163,7 +165,7 @@ remove buprepo k = do
- in a bup repository. One way it to check if the git repository has
- a branch matching the name (as created by bup split -n).
-}
checkKey :: Git.Repo -> Git.Repo -> Key -> Annex Bool
checkKey :: Git.Repo -> Git.Repo -> CheckPresent
checkKey r bupr k
| Git.repoIsUrl bupr = do
showChecking r

10
Remote/Ddar.hs
View file

@ -44,6 +44,8 @@ gen r u c gc = do
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store ddarrepo)
(simplyPrepare $ retrieve ddarrepo)
(simplyPrepare $ remove ddarrepo)
(simplyPrepare $ checkKey ddarrepo)
(this cst)
where
this cst = Remote
@ -53,8 +55,8 @@ gen r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap
, removeKey = remove ddarrepo
, checkPresent = checkKey ddarrepo
, removeKey = removeKeyDummy
, checkPresent = checkPresentDummy
, checkPresentCheap = ddarLocal ddarrepo
, whereisKey = Nothing
, remoteFsck = Nothing
@ -140,7 +142,7 @@ retrieve ddarrepo = byteRetriever $ \k sink -> do
retrieveCheap :: Key -> FilePath -> Annex Bool
retrieveCheap _ _ = return False
remove :: DdarRepo -> Key -> Annex Bool
remove :: DdarRepo -> Remover
remove ddarrepo key = do
(cmd, params) <- ddarRemoteCall ddarrepo 'd' [Param $ key2file key]
liftIO $ boolSystem cmd params
@ -181,7 +183,7 @@ inDdarManifest ddarrepo k = do
where
k' = key2file k
checkKey :: DdarRepo -> Key -> Annex Bool
checkKey :: DdarRepo -> CheckPresent
checkKey ddarrepo key = do
directoryExists <- ddarDirectoryExists ddarrepo
case directoryExists of

10
Remote/Directory.hs
View file

@ -44,6 +44,8 @@ gen r u c gc = do
return $ Just $ specialRemote c
(prepareStore dir chunkconfig)
(retrieve dir chunkconfig)
(simplyPrepare $ remove dir)
(simplyPrepare $ checkKey dir chunkconfig)
Remote {
uuid = u,
cost = cst,
@ -51,8 +53,8 @@ gen r u c gc = do
storeKey = storeKeyDummy,
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap dir chunkconfig,
removeKey = remove dir,
checkPresent = checkKey dir chunkconfig,
removeKey = removeKeyDummy,
checkPresent = checkPresentDummy,
checkPresentCheap = True,
whereisKey = Nothing,
remoteFsck = Nothing,
@ -161,7 +163,7 @@ retrieveCheap d NoChunks k f = liftIO $ catchBoolIO $ do
retrieveCheap _ _ _ _ = return False
#endif
remove :: FilePath -> Key -> Annex Bool
remove :: FilePath -> Remover
remove d k = liftIO $ removeDirGeneric d (storeDir d k)
{- Removes the directory, which must be located under the topdir.
@ -189,7 +191,7 @@ removeDirGeneric topdir dir = do
then return ok
else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)
checkKey :: FilePath -> ChunkConfig -> Key -> Annex Bool
checkKey :: FilePath -> ChunkConfig -> CheckPresent
checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k
checkKey d _ k = liftIO $
ifM (anyM doesFileExist (locations d k))

10
Remote/External.hs
View file

@ -45,6 +45,8 @@ gen r u c gc = do
return $ Just $ specialRemote c
(simplyPrepare $ store external)
(simplyPrepare $ retrieve external)
(simplyPrepare $ remove external)
(simplyPrepare $ checkKey external)
Remote {
uuid = u,
cost = cst,
@ -52,8 +54,8 @@ gen r u c gc = do
storeKey = storeKeyDummy,
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = \_ _ -> return False,
removeKey = remove external,
checkPresent = checkKey external,
removeKey = removeKeyDummy,
checkPresent = checkPresentDummy,
checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
@ -109,7 +111,7 @@ retrieve external = fileRetriever $ \d k p ->
error errmsg
_ -> Nothing
remove :: External -> Key -> Annex Bool
remove :: External -> Remover
remove external k = safely $
handleRequest external (REMOVE k) Nothing $ \resp ->
case resp of
@ -121,7 +123,7 @@ remove external k = safely $
return False
_ -> Nothing
checkKey :: External -> Key -> Annex Bool
checkKey :: External -> CheckPresent
checkKey external k = either error id <$> go
where
go = handleRequest external (CHECKPRESENT k) Nothing $ \resp ->

10
Remote/GCrypt.hs
View file

@ -107,8 +107,8 @@ gen' r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = \_ _ -> return False
, removeKey = remove this rsyncopts
, checkPresent = checkKey this rsyncopts
, removeKey = removeKeyDummy
, checkPresent = checkPresentDummy
, checkPresentCheap = repoCheap r
, whereisKey = Nothing
, remoteFsck = Nothing
@ -124,6 +124,8 @@ gen' r u c gc = do
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this rsyncopts)
(simplyPrepare $ retrieve this rsyncopts)
(simplyPrepare $ remove this rsyncopts)
(simplyPrepare $ checkKey this rsyncopts)
this
where
specialcfg
@ -331,7 +333,7 @@ retrieve r rsyncopts
| otherwise = unsupportedUrl
where
remove :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool
remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover
remove r rsyncopts k
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $
liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (parentDir (gCryptLocation r k))
@ -341,7 +343,7 @@ remove r rsyncopts k
removersync = Remote.Rsync.remove rsyncopts k
removeshell = Ssh.dropKey (repo r) k
checkKey :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool
checkKey :: Remote -> Remote.Rsync.RsyncOpts -> CheckPresent
checkKey r rsyncopts k
| not $ Git.repoIsUrl (repo r) =
guardUsable (repo r) (cantCheck $ repo r) $

10
Remote/Glacier.hs
View file

@ -42,6 +42,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
new cst = Just $ specialRemote' specialcfg c
(prepareStore this)
(prepareRetrieve this)
(simplyPrepare $ remove this)
(simplyPrepare $ checkKey this)
this
where
this = Remote {
@ -51,8 +53,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
storeKey = storeKeyDummy,
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap this,
removeKey = remove this,
checkPresent = checkKey this,
removeKey = removeKeyDummy,
checkPresent = checkPresentDummy,
checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
@ -155,7 +157,7 @@ retrieve r k sink = go =<< glacierEnv c u
retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
remove :: Remote -> Key -> Annex Bool
remove :: Remote -> Remover
remove r k = glacierAction r
[ Param "archive"
@ -164,7 +166,7 @@ remove r k = glacierAction r
, Param $ archive r k
]
checkKey :: Remote -> Key -> Annex Bool
checkKey :: Remote -> CheckPresent
checkKey r k = do
showAction $ "checking " ++ name r
go =<< glacierEnv (config r) (uuid r)

14
Remote/Helper/Messages.hs
View file

@ -9,9 +9,19 @@ module Remote.Helper.Messages where
import Common.Annex
import qualified Git
import qualified Types.Remote as Remote
showChecking :: Git.Repo -> Annex ()
showChecking r = showAction $ "checking " ++ Git.repoDescribe r
cantCheck :: Git.Repo -> a
cantCheck r = error $ "unable to check " ++ Git.repoDescribe r
class Checkable a where
descCheckable :: a -> String
instance Checkable Git.Repo where
descCheckable = Git.repoDescribe
instance Checkable (Remote.RemoteA a) where
descCheckable = Remote.name
cantCheck :: Checkable a => a -> e
cantCheck v = error $ "unable to check " ++ descCheckable v

40
Remote/Helper/Special.hs
View file

@ -11,6 +11,8 @@ module Remote.Helper.Special (
Preparer,
Storer,
Retriever,
Remover,
CheckPresent,
simplyPrepare,
ContentSource,
checkPrepare,
@ -21,6 +23,8 @@ module Remote.Helper.Special (
byteRetriever,
storeKeyDummy,
retreiveKeyFileDummy,
removeKeyDummy,
checkPresentDummy,
SpecialRemoteCfg(..),
specialRemoteCfg,
specialRemote,
@ -36,6 +40,7 @@ import Config.Cost
import Utility.Metered
import Remote.Helper.Chunked as X
import Remote.Helper.Encryptable as X hiding (encryptableRemote)
import Remote.Helper.Messages
import Annex.Content
import Annex.Exception
import qualified Git
@ -114,16 +119,27 @@ byteRetriever :: (Key -> (L.ByteString -> Annex Bool) -> Annex Bool) -> Retrieve
byteRetriever a k _m callback = a k (callback . ByteContent)
{- The base Remote that is provided to specialRemote needs to have
- storeKey and retreiveKeyFile methods, but they are never
- actually used (since specialRemote replaces them).
- storeKey, retreiveKeyFile, removeKey, and checkPresent methods,
- but they are never actually used (since specialRemote replaces them).
- Here are some dummy ones.
-}
storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
storeKeyDummy _ _ _ = return False
retreiveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
retreiveKeyFileDummy _ _ _ _ = return False
removeKeyDummy :: Key -> Annex Bool
removeKeyDummy _ = return False
checkPresentDummy :: Key -> Annex Bool
checkPresentDummy _ = error "missing checkPresent implementation"
type RemoteModifier = RemoteConfig -> Preparer Storer -> Preparer Retriever -> Remote -> Remote
type RemoteModifier
= RemoteConfig
-> Preparer Storer
-> Preparer Retriever
-> Preparer Remover
-> Preparer CheckPresent
-> Remote
-> Remote
data SpecialRemoteCfg = SpecialRemoteCfg
{ chunkConfig :: ChunkConfig
@ -139,13 +155,14 @@ specialRemote :: RemoteModifier
specialRemote c = specialRemote' (specialRemoteCfg c) c
specialRemote' :: SpecialRemoteCfg -> RemoteModifier
specialRemote' cfg c preparestorer prepareretriever baser = encr
specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckpresent baser = encr
where
encr = baser
{ storeKey = \k _f p -> cip >>= storeKeyGen k p
, retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p
, retrieveKeyFileCheap = \k d -> cip >>= maybe
(retrieveKeyFileCheap baser k d)
-- retrieval of encrypted keys is never cheap
(\_ -> return False)
, removeKey = \k -> cip >>= removeKeyGen k
, checkPresent = \k -> cip >>= checkPresentGen k
@ -160,8 +177,7 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr
safely a = catchNonAsyncAnnex a (\e -> warning (show e) >> return False)
-- chunk, then encrypt, then feed to the storer
storeKeyGen k p enc =
safely $ preparestorer k $ safely . go
storeKeyGen k p enc = safely $ preparestorer k $ safely . go
where
go (Just storer) = sendAnnex k rollback $ \src ->
displayprogress p k $ \p' ->
@ -178,7 +194,7 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr
readBytes $ \encb ->
storer (enck k) (ByteContent encb) p
-- call retriever to get chunks; decrypt them; stream to dest file
-- call retrieve-r to get chunks; decrypt them; stream to dest file
retrieveKeyFileGen k dest p enc =
safely $ prepareretriever k $ safely . go
where
@ -188,15 +204,17 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr
go Nothing = return False
enck = maybe id snd enc
removeKeyGen k enc = removeChunks remover (uuid baser) chunkconfig enck k
removeKeyGen k enc = safely $ prepareremover k $ safely . go
where
go (Just remover) = removeChunks remover (uuid baser) chunkconfig enck k
go Nothing = return False
enck = maybe id snd enc
remover = removeKey baser
checkPresentGen k enc = checkPresentChunks checker (uuid baser) chunkconfig enck k
checkPresentGen k enc = preparecheckpresent k go
where
go (Just checker) = checkPresentChunks checker (uuid baser) chunkconfig enck k
go Nothing = cantCheck baser
enck = maybe id snd enc
checker = checkPresent baser
chunkconfig = chunkConfig cfg

10
Remote/Hook.hs
View file

@ -37,6 +37,8 @@ gen r u c gc = do
return $ Just $ specialRemote c
(simplyPrepare $ store hooktype)
(simplyPrepare $ retrieve hooktype)
(simplyPrepare $ remove hooktype)
(simplyPrepare $ checkKey r hooktype)
Remote {
uuid = u,
cost = cst,
@ -44,8 +46,8 @@ gen r u c gc = do
storeKey = storeKeyDummy,
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap hooktype,
removeKey = remove hooktype,
checkPresent = checkKey r hooktype,
removeKey = removeKeyDummy,
checkPresent = checkPresentDummy,
checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
@ -125,10 +127,10 @@ retrieve h = fileRetriever $ \d k _p ->
retrieveCheap :: HookName -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
remove :: HookName -> Key -> Annex Bool
remove :: HookName -> Remover
remove h k = runHook h "remove" k Nothing $ return True
checkKey :: Git.Repo -> HookName -> Key -> Annex Bool
checkKey :: Git.Repo -> HookName -> CheckPresent
checkKey r h k = do
showAction $ "checking " ++ Git.repoDescribe r
v <- lookupHook h action

10
Remote/Rsync.hs
View file

@ -58,6 +58,8 @@ gen r u c gc = do
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ fileStorer $ store o)
(simplyPrepare $ fileRetriever $ retrieve o)
(simplyPrepare $ remove o)
(simplyPrepare $ checkKey r o)
Remote
{ uuid = u
, cost = cst
@ -65,8 +67,8 @@ gen r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap o
, removeKey = remove o
, checkPresent = checkKey r o
, removeKey = removeKeyDummy
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, whereisKey = Nothing
, remoteFsck = Nothing
@ -186,7 +188,7 @@ retrieve o f k p =
retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool
retrieveCheap o k f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False )
remove :: RsyncOpts -> Key -> Annex Bool
remove :: RsyncOpts -> Remover
remove o k = do
ps <- sendParams
withRsyncScratchDir $ \tmp -> liftIO $ do
@ -214,7 +216,7 @@ remove o k = do
, dir </> keyFile k </> "***"
]
checkKey :: Git.Repo -> RsyncOpts -> Key -> Annex Bool
checkKey :: Git.Repo -> RsyncOpts -> CheckPresent
checkKey r o k = do
showAction $ "checking " ++ Git.repoDescribe r
-- note: Does not currently differentiate between rsync failing

16
Remote/S3.hs
View file

@ -47,6 +47,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
new cst = Just $ specialRemote c
(prepareStore this)
(prepareRetrieve this)
(simplyPrepare $ remove this c)
(simplyPrepare $ checkKey this)
this
where
this = Remote {
@ -55,9 +57,9 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
name = Git.repoDescribe r,
storeKey = storeKeyDummy,
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap this,
removeKey = remove this c,
checkPresent = checkKey this,
retrieveKeyFileCheap = retrieveCheap,
removeKey = removeKeyDummy,
checkPresent = checkPresentDummy,
checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
@ -150,13 +152,13 @@ prepareRetrieve r = resourcePrepare (const $ s3Action r False) $ \(conn, bucket)
liftIO (getObject conn $ bucketKey r bucket k)
>>= either s3Error (sink . obj_data)
retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
retrieveCheap :: Key -> FilePath -> Annex Bool
retrieveCheap _ _ = return False
{- Internet Archive doesn't easily allow removing content.
- While it may remove the file, there are generally other files
- derived from it that it does not remove. -}
remove :: Remote -> RemoteConfig -> Key -> Annex Bool
remove :: Remote -> RemoteConfig -> Remover
remove r c k
| isIA c = do
warning "Cannot remove content from the Internet Archive"
@ -167,7 +169,7 @@ remove' :: Remote -> Key -> Annex Bool
remove' r k = s3Action r False $ \(conn, bucket) ->
s3Bool =<< liftIO (deleteObject conn $ bucketKey r bucket k)
checkKey :: Remote -> Key -> Annex Bool
checkKey :: Remote -> CheckPresent
checkKey r k = s3Action r noconn $ \(conn, bucket) -> do
showAction $ "checking " ++ name r
res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k