103 lines
3.7 KiB
Haskell
103 lines
3.7 KiB
Haskell
{- exports to remotes
|
|
-
|
|
- Copyright 2017 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Remote.Helper.Export where
|
|
|
|
import Annex.Common
|
|
import Types.Remote
|
|
import Types.Creds
|
|
import Types.Backend
|
|
import Types.Key
|
|
import Backend
|
|
import Remote.Helper.Encryptable (isEncrypted)
|
|
import Database.Export
|
|
|
|
import qualified Data.Map as M
|
|
|
|
-- | Use for remotes that do not support exports.
|
|
exportUnsupported :: ExportActions Annex
|
|
exportUnsupported = ExportActions
|
|
{ exportSupported = return False
|
|
, storeExport = \_ _ _ _ -> return False
|
|
, retrieveExport = \_ _ _ _ -> return (False, UnVerified)
|
|
, removeExport = \_ _ -> return False
|
|
, checkPresentExport = \_ _ -> return False
|
|
, renameExport = \_ _ _ -> return False
|
|
}
|
|
|
|
-- | A remote that supports exports when configured with exporttree=yes,
|
|
-- and otherwise does not.
|
|
exportableRemote :: Remote -> Annex (Maybe Remote)
|
|
exportableRemote r = case M.lookup "exporttree" (config r) of
|
|
Just "yes" -> do
|
|
db <- openDb (uuid r)
|
|
|
|
return $ Just $ r
|
|
-- Storing a key on an export would need a way to
|
|
-- look up the file(s) that the currently exported
|
|
-- tree uses for a key; there's not currently an
|
|
-- inexpensive way to do that (getExportLocation
|
|
-- only finds files that have been stored on the
|
|
-- export already).
|
|
{ storeKey = \_ _ _ -> do
|
|
warning "remote is configured with exporttree=yes; use `git-annex export` to store content on it"
|
|
return False
|
|
-- Keys can be retrieved, but since an export
|
|
-- is not a true key/value store, the content of
|
|
-- the key has to be able to be strongly verified.
|
|
, retrieveKeyFile = \k _af dest p ->
|
|
if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))
|
|
then do
|
|
locs <- liftIO $ getExportLocation db k
|
|
case locs of
|
|
[] -> do
|
|
warning "unknown export location"
|
|
return (False, UnVerified)
|
|
(l:_) -> retrieveExport (exportActions r) k l dest p
|
|
else do
|
|
warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"
|
|
return (False, UnVerified)
|
|
, retrieveKeyFileCheap = \_ _ _ -> return False
|
|
-- Remove all files a key was exported to.
|
|
, removeKey = \k -> do
|
|
locs <- liftIO $ getExportLocation db k
|
|
oks <- forM locs $ \loc -> do
|
|
ok <- removeExport (exportActions r) k loc
|
|
when ok $
|
|
liftIO $ removeExportLocation db k loc
|
|
return ok
|
|
liftIO $ flushDbQueue db
|
|
return (and oks)
|
|
-- Can't lock content on exports, since they're
|
|
-- not key/value stores, and someone else could
|
|
-- change what's exported to a file at any time.
|
|
, lockContent = Nothing
|
|
-- Check if any of the files a key was exported
|
|
-- to are present. This doesn't guarantee the
|
|
-- export contains the right content.
|
|
, checkPresent = \k ->
|
|
anyM (checkPresentExport (exportActions r) k)
|
|
=<< liftIO (getExportLocation db k)
|
|
, mkUnavailable = return Nothing
|
|
, getInfo = do
|
|
is <- getInfo r
|
|
return (is++[("export", "yes")])
|
|
}
|
|
_ -> return $ Just $ r { exportActions = exportUnsupported }
|
|
|
|
exportableRemoteSetup :: (SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)) -> SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
|
exportableRemoteSetup setupaction st mu cp c gc = case st of
|
|
Init -> case M.lookup "exporttree" c of
|
|
Just "yes" | isEncrypted c ->
|
|
giveup "cannot enable both encryption and exporttree"
|
|
_ -> cont
|
|
Enable oldc
|
|
| M.lookup "exporttree" c /= M.lookup "exporttree" oldc ->
|
|
giveup "cannot change exporttree of existing special remote"
|
|
| otherwise -> cont
|
|
where
|
|
cont = setupaction st mu cp c gc
|