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

implement removeExportDirectory

Browse source 
Not yet called by Command.Export.

WebDAV needs this to clean up empty collections. Also, example.sh turned
out to not be cleaning up directories when removing content
from them, so it made sense for it to use this.

Remote.Directory did not need it, and since its cleanup method for empty
directories is more efficient than what Command.Export will need to do
to find empty directories, it uses Nothing so that extra work can be
avoided.

This commit was sponsored by Thom May on Patreon.
This commit is contained in:
Joey Hess 2017-09-15 13:15:47 -04:00
parent 78a67f29f8
commit 9f4ffe65e9
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
9 changed files with 156 additions and 87 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

67
Remote/Directory.hs
View file

@ -47,26 +47,29 @@ gen r u c gc = do
let chunkconfig = getChunkConfig c let chunkconfig = getChunkConfig c
return $ Just $ specialRemote c return $ Just $ specialRemote c
(prepareStore dir chunkconfig) (prepareStore dir chunkconfig)
(retrieve dir chunkconfig) (retrieveKeyFileM dir chunkconfig)
(simplyPrepare $ remove dir) (simplyPrepare $ removeKeyM dir)
(simplyPrepare $ checkKey dir chunkconfig) (simplyPrepare $ checkPresentM dir chunkconfig)
Remote Remote
{ uuid = u { uuid = u
, cost = cst , cost = cst
, name = Git.repoDescribe r , name = Git.repoDescribe r
, storeKey = storeKeyDummy , storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap dir chunkconfig , retrieveKeyFileCheap = retrieveKeyFileCheapM dir chunkconfig
, removeKey = removeKeyDummy , removeKey = removeKeyDummy
, lockContent = Nothing , lockContent = Nothing
, checkPresent = checkPresentDummy , checkPresent = checkPresentDummy
, checkPresentCheap = True , checkPresentCheap = True
, exportActions = return $ ExportActions , exportActions = return $ ExportActions
{ storeExport = storeExportDirectory dir { storeExport = storeExportM dir
, retrieveExport = retrieveExportDirectory dir , retrieveExport = retrieveExportM dir
, removeExport = removeExportDirectory dir , removeExport = removeExportM dir
, checkPresentExport = checkPresentExportDirectory dir , checkPresentExport = checkPresentExportM dir
, renameExport = renameExportDirectory dir -- Not needed because removeExportLocation
-- auto-removes empty directories.
, removeExportDirectory = Nothing
, renameExport = renameExportM dir
} }
, whereisKey = Nothing , whereisKey = Nothing
, remoteFsck = Nothing , remoteFsck = Nothing
@ -166,17 +169,17 @@ finalizeStoreGeneric tmp dest = do
mapM_ preventWrite =<< dirContents dest mapM_ preventWrite =<< dirContents dest
preventWrite dest preventWrite dest
retrieve :: FilePath -> ChunkConfig -> Preparer Retriever retrieveKeyFileM :: FilePath -> ChunkConfig -> Preparer Retriever
retrieve d (LegacyChunks _) = Legacy.retrieve locations d retrieveKeyFileM d (LegacyChunks _) = Legacy.retrieve locations d
retrieve d _ = simplyPrepare $ byteRetriever $ \k sink -> retrieveKeyFileM d _ = simplyPrepare $ byteRetriever $ \k sink ->
sink =<< liftIO (L.readFile =<< getLocation d k) sink =<< liftIO (L.readFile =<< getLocation d k)
retrieveCheap :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool retrieveKeyFileCheapM :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool
-- no cheap retrieval possible for chunks -- no cheap retrieval possible for chunks
retrieveCheap _ (UnpaddedChunks _) _ _ _ = return False retrieveKeyFileCheapM _ (UnpaddedChunks _) _ _ _ = return False
retrieveCheap _ (LegacyChunks _) _ _ _ = return False retrieveKeyFileCheapM _ (LegacyChunks _) _ _ _ = return False
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
retrieveCheap d NoChunks k _af f = liftIO $ catchBoolIO $ do retrieveKeyFileCheapM d NoChunks k _af f = liftIO $ catchBoolIO $ do
file <- absPath =<< getLocation d k file <- absPath =<< getLocation d k
ifM (doesFileExist file) ifM (doesFileExist file)
( do ( do
@ -185,11 +188,11 @@ retrieveCheap d NoChunks k _af f = liftIO $ catchBoolIO $ do
, return False , return False
) )
#else #else
retrieveCheap _ _ _ _ _ = return False retrieveKeyFileCheapM _ _ _ _ _ = return False
#endif #endif
remove :: FilePath -> Remover removeKeyM :: FilePath -> Remover
remove d k = liftIO $ removeDirGeneric d (storeDir d k) removeKeyM d k = liftIO $ removeDirGeneric d (storeDir d k)
{- Removes the directory, which must be located under the topdir. {- Removes the directory, which must be located under the topdir.
- -
@ -216,9 +219,9 @@ removeDirGeneric topdir dir = do
then return ok then return ok
else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir) else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)
checkKey :: FilePath -> ChunkConfig -> CheckPresent checkPresentM :: FilePath -> ChunkConfig -> CheckPresent
checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k
checkKey d _ k = checkPresentGeneric d (locations d k) checkPresentM d _ k = checkPresentGeneric d (locations d k)
checkPresentGeneric :: FilePath -> [FilePath] -> Annex Bool checkPresentGeneric :: FilePath -> [FilePath] -> Annex Bool
checkPresentGeneric d ps = liftIO $ checkPresentGeneric d ps = liftIO $
@ -230,8 +233,8 @@ checkPresentGeneric d ps = liftIO $
) )
) )
storeExportDirectory :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportM :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportDirectory d src _k loc p = liftIO $ catchBoolIO $ do storeExportM d src _k loc p = liftIO $ catchBoolIO $ do
createDirectoryIfMissing True (takeDirectory dest) createDirectoryIfMissing True (takeDirectory dest)
-- Write via temp file so that checkPresentGeneric will not -- Write via temp file so that checkPresentGeneric will not
-- see it until it's fully stored. -- see it until it's fully stored.
@ -240,27 +243,27 @@ storeExportDirectory d src _k loc p = liftIO $ catchBoolIO $ do
where where
dest = exportPath d loc dest = exportPath d loc
retrieveExportDirectory :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportM :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportDirectory d _k loc dest p = liftIO $ catchBoolIO $ do retrieveExportM d _k loc dest p = liftIO $ catchBoolIO $ do
withMeteredFile src p (L.writeFile dest) withMeteredFile src p (L.writeFile dest)
return True return True
where where
src = exportPath d loc src = exportPath d loc
removeExportDirectory :: FilePath -> Key -> ExportLocation -> Annex Bool removeExportM :: FilePath -> Key -> ExportLocation -> Annex Bool
removeExportDirectory d _k loc = liftIO $ do removeExportM d _k loc = liftIO $ do
nukeFile src nukeFile src
removeExportLocation d loc removeExportLocation d loc
return True return True
where where
src = exportPath d loc src = exportPath d loc
checkPresentExportDirectory :: FilePath -> Key -> ExportLocation -> Annex Bool checkPresentExportM :: FilePath -> Key -> ExportLocation -> Annex Bool
checkPresentExportDirectory d _k loc = checkPresentExportM d _k loc =
checkPresentGeneric d [exportPath d loc] checkPresentGeneric d [exportPath d loc]
renameExportDirectory :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex Bool renameExportM :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportDirectory d _k oldloc newloc = liftIO $ catchBoolIO $ do renameExportM d _k oldloc newloc = liftIO $ catchBoolIO $ do
createDirectoryIfMissing True (takeDirectory dest) createDirectoryIfMissing True (takeDirectory dest)
renameFile src dest renameFile src dest
removeExportLocation d oldloc removeExportLocation d oldloc

106
Remote/External.hs
View file

@ -71,11 +71,12 @@ gen r u c gc
exportsupported <- checkExportSupported' external exportsupported <- checkExportSupported' external
let exportactions = if exportsupported let exportactions = if exportsupported
then return $ ExportActions then return $ ExportActions
{ storeExport = storeExportExternal external { storeExport = storeExportM external
, retrieveExport = retrieveExportExternal external , retrieveExport = retrieveExportM external
, removeExport = removeExportExternal external , removeExport = removeExportM external
, checkPresentExport = checkPresentExportExternal external , checkPresentExport = checkPresentExportM external
, renameExport = renameExportExternal external , removeExportDirectory = Just $ removeExportDirectoryM external
, renameExport = renameExportM external
} }
else exportUnsupported else exportUnsupported
-- Cheap exportSupported that replaces the expensive -- Cheap exportSupported that replaces the expensive
@ -84,13 +85,13 @@ gen r u c gc
then exportIsSupported then exportIsSupported
else exportUnsupported else exportUnsupported
mk cst avail mk cst avail
(store external) (storeKeyM external)
(retrieve external) (retrieveKeyFileM external)
(remove external) (removeKeyM external)
(checkKey external) (checkPresentM external)
(Just (whereis external)) (Just (whereisKeyM external))
(Just (claimurl external)) (Just (claimUrlM external))
(Just (checkurl external)) (Just (checkUrlM external))
exportactions exportactions
cheapexportsupported cheapexportsupported
where where
@ -170,8 +171,8 @@ checkExportSupported' external = safely $
UNSUPPORTED_REQUEST -> Just $ return False UNSUPPORTED_REQUEST -> Just $ return False
_ -> Nothing _ -> Nothing
store :: External -> Storer storeKeyM :: External -> Storer
store external = fileStorer $ \k f p -> storeKeyM external = fileStorer $ \k f p ->
handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp -> handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp ->
case resp of case resp of
TRANSFER_SUCCESS Upload k' | k == k' -> TRANSFER_SUCCESS Upload k' | k == k' ->
@ -182,8 +183,8 @@ store external = fileStorer $ \k f p ->
return False return False
_ -> Nothing _ -> Nothing
retrieve :: External -> Retriever retrieveKeyFileM :: External -> Retriever
retrieve external = fileRetriever $ \d k p -> retrieveKeyFileM external = fileRetriever $ \d k p ->
handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp -> handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp ->
case resp of case resp of
TRANSFER_SUCCESS Download k' TRANSFER_SUCCESS Download k'
@ -192,8 +193,8 @@ retrieve external = fileRetriever $ \d k p ->
| k == k' -> Just $ giveup errmsg | k == k' -> Just $ giveup errmsg
_ -> Nothing _ -> Nothing
remove :: External -> Remover removeKeyM :: External -> Remover
remove external k = safely $ removeKeyM external k = safely $
handleRequestKey external REMOVE k Nothing $ \resp -> handleRequestKey external REMOVE k Nothing $ \resp ->
case resp of case resp of
REMOVE_SUCCESS k' REMOVE_SUCCESS k'
@ -204,8 +205,8 @@ remove external k = safely $
return False return False
_ -> Nothing _ -> Nothing
checkKey :: External -> CheckPresent checkPresentM :: External -> CheckPresent
checkKey external k = either giveup id <$> go checkPresentM external k = either giveup id <$> go
where where
go = handleRequestKey external CHECKPRESENT k Nothing $ \resp -> go = handleRequestKey external CHECKPRESENT k Nothing $ \resp ->
case resp of case resp of
@ -217,15 +218,15 @@ checkKey external k = either giveup id <$> go
| k' == k -> Just $ return $ Left errmsg | k' == k -> Just $ return $ Left errmsg
_ -> Nothing _ -> Nothing
whereis :: External -> Key -> Annex [String] whereisKeyM :: External -> Key -> Annex [String]
whereis external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of whereisKeyM external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of
WHEREIS_SUCCESS s -> Just $ return [s] WHEREIS_SUCCESS s -> Just $ return [s]
WHEREIS_FAILURE -> Just $ return [] WHEREIS_FAILURE -> Just $ return []
UNSUPPORTED_REQUEST -> Just $ return [] UNSUPPORTED_REQUEST -> Just $ return []
_ -> Nothing _ -> Nothing
storeExportExternal :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportExternal external f k loc p = safely $ storeExportM external f k loc p = safely $
handleRequestExport external loc req k (Just p) $ \resp -> case resp of handleRequestExport external loc req k (Just p) $ \resp -> case resp of
TRANSFER_SUCCESS Upload k' | k == k' -> TRANSFER_SUCCESS Upload k' | k == k' ->
Just $ return True Just $ return True
@ -240,8 +241,8 @@ storeExportExternal external f k loc p = safely $
where where
req sk = TRANSFEREXPORT Upload sk f req sk = TRANSFEREXPORT Upload sk f
retrieveExportExternal :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportExternal external k loc d p = safely $ retrieveExportM external k loc d p = safely $
handleRequestExport external loc req k (Just p) $ \resp -> case resp of handleRequestExport external loc req k (Just p) $ \resp -> case resp of
TRANSFER_SUCCESS Download k' TRANSFER_SUCCESS Download k'
| k == k' -> Just $ return True | k == k' -> Just $ return True
@ -256,22 +257,8 @@ retrieveExportExternal external k loc d p = safely $
where where
req sk = TRANSFEREXPORT Download sk d req sk = TRANSFEREXPORT Download sk d
removeExportExternal :: External -> Key -> ExportLocation -> Annex Bool checkPresentExportM :: External -> Key -> ExportLocation -> Annex Bool
removeExportExternal external k loc = safely $ checkPresentExportM external k loc = either giveup id <$> go
handleRequestExport external loc REMOVEEXPORT k Nothing $ \resp -> case resp of
REMOVE_SUCCESS k'
| k == k' -> Just $ return True
REMOVE_FAILURE k' errmsg
| k == k' -> Just $ do
warning errmsg
return False
UNSUPPORTED_REQUEST -> Just $ do
warning "REMOVEEXPORT not implemented by external special remote"
return False
_ -> Nothing
checkPresentExportExternal :: External -> Key -> ExportLocation -> Annex Bool
checkPresentExportExternal external k loc = either giveup id <$> go
where where
go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of
CHECKPRESENT_SUCCESS k' CHECKPRESENT_SUCCESS k'
@ -284,8 +271,31 @@ checkPresentExportExternal external k loc = either giveup id <$> go
Left "CHECKPRESENTEXPORT not implemented by external special remote" Left "CHECKPRESENTEXPORT not implemented by external special remote"
_ -> Nothing _ -> Nothing
renameExportExternal :: External -> Key -> ExportLocation -> ExportLocation -> Annex Bool removeExportM :: External -> Key -> ExportLocation -> Annex Bool
renameExportExternal external k src dest = safely $ removeExportM external k loc = safely $
handleRequestExport external loc REMOVEEXPORT k Nothing $ \resp -> case resp of
REMOVE_SUCCESS k'
| k == k' -> Just $ return True
REMOVE_FAILURE k' errmsg
| k == k' -> Just $ do
warning errmsg
return False
UNSUPPORTED_REQUEST -> Just $ do
warning "REMOVEEXPORT not implemented by external special remote"
return False
_ -> Nothing
removeExportDirectoryM :: External -> ExportDirectory -> Annex Bool
removeExportDirectoryM external dir = safely $
handleRequest external req Nothing $ \resp -> case resp of
REMOVEEXPORTDIRECTORY_SUCCESS -> Just $ return True
REMOVEEXPORTDIRECTORY_FAILURE -> Just $ return False
UNSUPPORTED_REQUEST -> Just $ return True
where
req = REMOVEEXPORTDIRECTORY dir
renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportM external k src dest = safely $
handleRequestExport external src req k Nothing $ \resp -> case resp of handleRequestExport external src req k Nothing $ \resp -> case resp of
RENAMEEXPORT_SUCCESS k' RENAMEEXPORT_SUCCESS k'
| k' == k -> Just $ return True | k' == k -> Just $ return True
@ -619,16 +629,16 @@ getAvailability external r gc =
return avail return avail
defavail = return GloballyAvailable defavail = return GloballyAvailable
claimurl :: External -> URLString -> Annex Bool claimUrlM :: External -> URLString -> Annex Bool
claimurl external url = claimUrlM external url =
handleRequest external (CLAIMURL url) Nothing $ \req -> case req of handleRequest external (CLAIMURL url) Nothing $ \req -> case req of
CLAIMURL_SUCCESS -> Just $ return True CLAIMURL_SUCCESS -> Just $ return True
CLAIMURL_FAILURE -> Just $ return False CLAIMURL_FAILURE -> Just $ return False
UNSUPPORTED_REQUEST -> Just $ return False UNSUPPORTED_REQUEST -> Just $ return False
_ -> Nothing _ -> Nothing
checkurl :: External -> URLString -> Annex UrlContents checkUrlM :: External -> URLString -> Annex UrlContents
checkurl external url = checkUrlM external url =
handleRequest external (CHECKURL url) Nothing $ \req -> case req of handleRequest external (CHECKURL url) Nothing $ \req -> case req of
CHECKURL_CONTENTS sz f -> Just $ return $ UrlContents sz CHECKURL_CONTENTS sz f -> Just $ return $ UrlContents sz
(if null f then Nothing else Just $ mkSafeFilePath f) (if null f then Nothing else Just $ mkSafeFilePath f)

13
Remote/External/Types.hs vendored
View file

@ -36,7 +36,7 @@ import Types.StandardGroups (PreferredContentExpression)
import Utility.Metered (BytesProcessed(..)) import Utility.Metered (BytesProcessed(..))
import Types.Transfer (Direction(..)) import Types.Transfer (Direction(..))
import Config.Cost (Cost) import Config.Cost (Cost)
import Types.Remote (RemoteConfig, ExportLocation(..)) import Types.Remote (RemoteConfig, ExportLocation(..), ExportDirectory(..))
import Types.Availability (Availability(..)) import Types.Availability (Availability(..))
import Types.Key import Types.Key
import Utility.Url (URLString) import Utility.Url (URLString)
@ -121,6 +121,7 @@ data Request
| TRANSFEREXPORT Direction SafeKey FilePath | TRANSFEREXPORT Direction SafeKey FilePath
| CHECKPRESENTEXPORT SafeKey | CHECKPRESENTEXPORT SafeKey
| REMOVEEXPORT SafeKey | REMOVEEXPORT SafeKey
| REMOVEEXPORTDIRECTORY ExportDirectory
| RENAMEEXPORT SafeKey ExportLocation | RENAMEEXPORT SafeKey ExportLocation
deriving (Show) deriving (Show)
@ -160,6 +161,8 @@ instance Proto.Sendable Request where
[ "CHECKPRESENTEXPORT", Proto.serialize key ] [ "CHECKPRESENTEXPORT", Proto.serialize key ]
formatMessage (REMOVEEXPORT key) = formatMessage (REMOVEEXPORT key) =
[ "REMOVEEXPORT", Proto.serialize key ] [ "REMOVEEXPORT", Proto.serialize key ]
formatMessage (REMOVEEXPORTDIRECTORY dir) =
[ "REMOVEEXPORTDIRECTORY", Proto.serialize dir ]
formatMessage (RENAMEEXPORT key newloc) = formatMessage (RENAMEEXPORT key newloc) =
[ "RENAMEEXPORT" [ "RENAMEEXPORT"
, Proto.serialize key , Proto.serialize key
@ -190,6 +193,8 @@ data Response
| WHEREIS_FAILURE | WHEREIS_FAILURE
| EXPORTSUPPORTED_SUCCESS | EXPORTSUPPORTED_SUCCESS
| EXPORTSUPPORTED_FAILURE | EXPORTSUPPORTED_FAILURE
| REMOVEEXPORTDIRECTORY_SUCCESS
| REMOVEEXPORTDIRECTORY_FAILURE
| RENAMEEXPORT_SUCCESS Key | RENAMEEXPORT_SUCCESS Key
| RENAMEEXPORT_FAILURE Key | RENAMEEXPORT_FAILURE Key
| UNSUPPORTED_REQUEST | UNSUPPORTED_REQUEST
@ -218,6 +223,8 @@ instance Proto.Receivable Response where
parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE
parseCommand "EXPORTSUPPORTED-SUCCESS" = Proto.parse0 EXPORTSUPPORTED_SUCCESS parseCommand "EXPORTSUPPORTED-SUCCESS" = Proto.parse0 EXPORTSUPPORTED_SUCCESS
parseCommand "EXPORTSUPPORTED-FAILURE" = Proto.parse0 EXPORTSUPPORTED_FAILURE parseCommand "EXPORTSUPPORTED-FAILURE" = Proto.parse0 EXPORTSUPPORTED_FAILURE
parseCommand "REMOVEEXPORTDIRECTORY-SUCCESS" = Proto.parse0 REMOVEEXPORTDIRECTORY_SUCCESS
parseCommand "REMOVEEXPORTDIRECTORY-FAILURE" = Proto.parse0 REMOVEEXPORTDIRECTORY_FAILURE
parseCommand "RENAMEEXPORT-SUCCESS" = Proto.parse1 RENAMEEXPORT_SUCCESS parseCommand "RENAMEEXPORT-SUCCESS" = Proto.parse1 RENAMEEXPORT_SUCCESS
parseCommand "RENAMEEXPORT-FAILURE" = Proto.parse1 RENAMEEXPORT_FAILURE parseCommand "RENAMEEXPORT-FAILURE" = Proto.parse1 RENAMEEXPORT_FAILURE
parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST
@ -352,3 +359,7 @@ instance Proto.Serializable URI where
instance Proto.Serializable ExportLocation where instance Proto.Serializable ExportLocation where
serialize (ExportLocation loc) = loc serialize (ExportLocation loc) = loc
deserialize = Just . ExportLocation deserialize = Just . ExportLocation
instance Proto.Serializable ExportDirectory where
serialize (ExportDirectory loc) = loc
deserialize = Just . ExportDirectory

3
Remote/Helper/Export.hs
View file

@ -32,8 +32,9 @@ instance HasExportUnsupported (Annex (ExportActions Annex)) where
warning "store export is unsupported" warning "store export is unsupported"
return False return False
, retrieveExport = \_ _ _ _ -> return False , retrieveExport = \_ _ _ _ -> return False
, removeExport = \_ _ -> return False
, checkPresentExport = \_ _ -> return False , checkPresentExport = \_ _ -> return False
, removeExport = \_ _ -> return False
, removeExportDirectory = Just $ \_ -> return False
, renameExport = \_ _ _ -> return False , renameExport = \_ _ _ -> return False
} }

2
Remote/S3.hs
View file

@ -92,6 +92,8 @@ gen r u c gc = do
, retrieveExport = retrieveExportS3 info h , retrieveExport = retrieveExportS3 info h
, removeExport = removeExportS3 info h , removeExport = removeExportS3 info h
, checkPresentExport = checkPresentExportS3 info h , checkPresentExport = checkPresentExportS3 info h
-- S3 does not have directories.
, removeExportDirectory = Nothing
, renameExport = renameExportS3 info h , renameExport = renameExportS3 info h
} }
, whereisKey = Just (getWebUrls info c) , whereisKey = Just (getWebUrls info c)

17
Remote/WebDAV.hs
View file

@ -73,8 +73,10 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, exportActions = withDAVHandle this $ \mh -> return $ ExportActions , exportActions = withDAVHandle this $ \mh -> return $ ExportActions
{ storeExport = storeExportDav mh { storeExport = storeExportDav mh
, retrieveExport = retrieveExportDav mh , retrieveExport = retrieveExportDav mh
, removeExport = removeExportDav mh
, checkPresentExport = checkPresentExportDav this mh , checkPresentExport = checkPresentExportDav this mh
, removeExport = removeExportDav mh
, removeExportDirectory = Just $
removeExportDirectoryDav mh
, renameExport = renameExportDav mh , renameExport = renameExportDav mh
} }
, whereisKey = Nothing , whereisKey = Nothing
@ -189,10 +191,6 @@ retrieveExportDav mh _k loc d p = runExport mh $ \_dav -> do
retrieveHelper (exportLocation loc) d p retrieveHelper (exportLocation loc) d p
return True return True
removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
removeExportDav mh _k loc = runExport mh $ \_dav ->
removeHelper (exportLocation loc)
checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
checkPresentExportDav r mh _k loc = case mh of checkPresentExportDav r mh _k loc = case mh of
Nothing -> giveup $ name r ++ " not configured" Nothing -> giveup $ name r ++ " not configured"
@ -200,6 +198,15 @@ checkPresentExportDav r mh _k loc = case mh of
v <- goDAV h $ existsDAV (exportLocation loc) v <- goDAV h $ existsDAV (exportLocation loc)
either giveup return v either giveup return v
removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
removeExportDav mh _k loc = runExport mh $ \_dav ->
removeHelper (exportLocation loc)
removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool
removeExportDirectoryDav mh (ExportDirectory dir) = runExport mh $ \_dav ->
safely (inLocation dir delContentM)
>>= maybe (return False) (const $ return True)
renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
renameExportDav Nothing _ _ _ = return False renameExportDav Nothing _ _ _ = return False
renameExportDav (Just h) _k src dest renameExportDav (Just h) _k src dest

11
Types/Remote.hs
View file

@ -19,6 +19,7 @@ module Types.Remote
, Verification(..) , Verification(..)
, unVerified , unVerified
, ExportLocation(..) , ExportLocation(..)
, ExportDirectory(..)
, isExportSupported , isExportSupported
, ExportActions(..) , ExportActions(..)
) )
@ -164,6 +165,9 @@ unVerified a = do
newtype ExportLocation = ExportLocation FilePath newtype ExportLocation = ExportLocation FilePath
deriving (Show, Eq) deriving (Show, Eq)
newtype ExportDirectory = ExportDirectory FilePath
deriving (Show, Eq)
isExportSupported :: RemoteA a -> a Bool isExportSupported :: RemoteA a -> a Bool
isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r) isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r)
@ -178,6 +182,13 @@ data ExportActions a = ExportActions
, retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a Bool , retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a Bool
-- Removes an exported file (succeeds if the contents are not present) -- Removes an exported file (succeeds if the contents are not present)
, removeExport :: Key -> ExportLocation -> a Bool , removeExport :: Key -> ExportLocation -> a Bool
-- Removes an exported directory. Typically the directory will be
-- empty, but it could possbly contain files or other directories,
-- and it's ok to delete those. If the remote does not use
-- directories, or automatically cleans up empty directories,
-- this can be Nothing. Should not fail if the directory was
-- already removed.
, removeExportDirectory :: Maybe (ExportDirectory -> a Bool)
-- Checks if anything is exported to the remote at the specified -- Checks if anything is exported to the remote at the specified
-- ExportLocation. -- ExportLocation.
-- Throws an exception if the remote cannot be accessed. -- Throws an exception if the remote cannot be accessed.

15
doc/design/external_special_remote_protocol.mdwn
View file

@ -176,6 +176,17 @@ replying with `UNSUPPORTED-REQUEST` is acceptable.
`REMOVE-FAILURE`. `REMOVE-FAILURE`.
If the content was already not present in the remote, it should If the content was already not present in the remote, it should
respond with `REMOVE-SUCCESS`. respond with `REMOVE-SUCCESS`.
* `REMOVEEXPORTDIRECTORY Directory`
Requests the remote remove an exported directory.
If the remote does not use directories, or automatically cleans up
empty directories, this does not need to be implemented.
The directory will be in the form of a relative path, and may contain path
separators, whitespace, and other special characters.
Typically the directory will be empty, but it could possbly contain
files or other directories, and it's ok to remove those.
The remote responds with either `REMOVEEXPORTDIRECTORY-SUCCESS`
or `REMOVEEXPORTDIRECTORY-FAILURE`.
Should not fail if the directory was already removed.
* `RENAMEEXPORT Key NewName` * `RENAMEEXPORT Key NewName`
Requests the remote rename a file stored on it from the previously Requests the remote rename a file stored on it from the previously
provided Name to the NewName. provided Name to the NewName.
@ -261,6 +272,10 @@ while it's handling a request.
Indicates that a `RENAMEEXPORT` was done successfully. Indicates that a `RENAMEEXPORT` was done successfully.
* `RENAMEEXPORT-FAILURE Key` * `RENAMEEXPORT-FAILURE Key`
Indicates that a `RENAMEEXPORT` failed for whatever reason. Indicates that a `RENAMEEXPORT` failed for whatever reason.
* `REMOVEEXPORTDIRECTORY-SUCCESS`
Indicates that a `REMOVEEXPORTDIRECTORY` was done successfully.
* `REMOVEEXPORTDIRECTORY-FAILURE`
Indicates that a `REMOVEEXPORTDIRECTORY` failed for whatever reason.
* `UNSUPPORTED-REQUEST` * `UNSUPPORTED-REQUEST`
Indicates that the special remote does not know how to handle a request. Indicates that the special remote does not know how to handle a request.

9
doc/special_remotes/external/example.sh vendored
View file

@ -264,6 +264,15 @@ while read line; do
key="$2" key="$2"
doremove "$key" "$exportlocation" doremove "$key" "$exportlocation"
;; ;;
REMOVEEXPORTDIRECTORY)
shift 1
dir="$@"
if [ ! -d "$dir" ] || rm -rf "$mydirectory/$dir"; then
echo REMOVEEXPORTDIRECTORY-SUCCESS
else
echo REMOVEEXPORTDIRECTORY-FAILURE
fi
;;
RENAMEEXPORT) RENAMEEXPORT)
key="$2" key="$2"
shift 2 shift 2