no remotes support import yet

Remote/Helper/ExportImport.hs

@@ -0,0 +1,229 @@
+{- Helper to make remotes support export and import (or not).
+ -
+ - Copyright 2017-2019 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE FlexibleInstances #-}
+
+module Remote.Helper.ExportImport where
+
+import Annex.Common
+import Types.Remote
+import Types.Backend
+import Types.Key
+import Backend
+import Remote.Helper.Encryptable (isEncrypted)
+import Database.Export
+import Annex.Export
+import Config
+import Git.Types (fromRef)
+import Logs.Export
+
+import qualified Data.Map as M
+import Control.Concurrent.STM
+
+-- | Use for remotes that do not support exports.
+class HasExportUnsupported a where
+	exportUnsupported :: a
+
+instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
+	exportUnsupported = \_ _ -> return False
+
+instance HasExportUnsupported (ExportActions Annex) where
+	exportUnsupported = ExportActions
+		{ storeExport = \_ _ _ _ -> do
+			warning "store export is unsupported"
+			return False
+		, retrieveExport = \_ _ _ _ -> return False
+		, checkPresentExport = \_ _ -> return False
+		, removeExport = \_ _ -> return False
+		, removeExportDirectory = Just $ \_ -> return False
+		, renameExport = \_ _ _ -> return False
+		}
+
+-- | Use for remotes that do not support imports.
+class HasImportUnsupported a where
+	importUnsupported :: a
+
+instance HasImportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
+	importUnsupported = \_ _ -> return False
+
+instance HasImportUnsupported (ImportActions Annex) where
+	importUnsupported = ImportActions
+		{ listContents = return Nothing
+		, retrieveExportWithContentIdentifier = \_ _ _ _ -> return Nothing
+		, storeExportWithContentIdentifier = \_ _ _ _ _ -> return Nothing
+		}
+
+exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool
+exportIsSupported = \_ _ -> return True
+
+-- | Prevent or allow exporttree=yes when setting up a new remote,
+-- depending on exportSupported and other configuration.
+adjustExportableRemoteType :: RemoteType -> RemoteType
+adjustExportableRemoteType rt = rt { setup = setup' }
+  where
+	setup' st mu cp c gc = do
+		let cont = setup rt st mu cp c gc
+		ifM (exportSupported rt c gc)
+			( case st of
+				Init
+					| exportTree c && isEncrypted c ->
+						giveup "cannot enable both encryption and exporttree"
+					| otherwise -> cont
+				Enable oldc
+					| exportTree c /= exportTree oldc ->
+						giveup "cannot change exporttree of existing special remote"
+					| otherwise -> cont
+			, if exportTree c
+				then giveup "exporttree=yes is not supported by this special remote"
+				else cont
+			)
+
+-- | If the remote is exportSupported, and exporttree=yes, adjust the
+-- remote to be an export.
+adjustExportable :: Remote -> Annex Remote
+adjustExportable r = case M.lookup "exporttree" (config r) of
+	Nothing -> notexport
+	Just c -> case yesNo c of
+		Just True -> ifM (isExportSupported r)
+			( isexport
+			, notexport
+			)
+		Just False -> notexport
+		Nothing -> do
+			warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export"
+			notexport
+  where
+	notexport = return $ r 
+		{ exportActions = exportUnsupported
+		, remotetype = (remotetype r)
+			{ exportSupported = exportUnsupported
+			}
+		}
+	isexport = do
+		db <- openDb (uuid r)
+		updateflag <- liftIO $ newTVarIO Nothing
+
+		-- When multiple threads run this, all except the first
+		-- will block until the first runs doneupdateonce.
+		-- Returns True when an update should be done and False
+		-- when the update has already been done.
+		let startupdateonce = liftIO $ atomically $
+			readTVar updateflag >>= \case
+				Nothing -> do
+					writeTVar updateflag (Just True)
+					return True
+				Just True -> retry
+				Just False -> return False
+		let doneupdateonce = \updated ->
+			when updated $
+				liftIO $ atomically $
+					writeTVar updateflag (Just False)
+		
+		exportinconflict <- liftIO $ newTVarIO False
+
+		-- Get export locations for a key. Checks once
+		-- if the export log is different than the database and
+		-- updates the database, to notice when an export has been
+		-- updated from another repository.
+		let getexportlocs = \k -> do
+			bracket startupdateonce doneupdateonce $ \updatenow ->
+				when updatenow $
+					updateExportTreeFromLog db >>= \case
+						ExportUpdateSuccess -> return ()
+						ExportUpdateConflict -> do
+							warnExportConflict r
+							liftIO $ atomically $
+								writeTVar exportinconflict True
+			liftIO $ getExportTree db k
+
+		return $ r
+			-- Storing a key on an export could be implemented,
+			-- but it would perform unncessary work
+			-- when another repository has already stored the
+			-- key, and the local repository does not know
+			-- about it. To avoid unnecessary costs, don't do it.
+			{ storeKey = \_ _ _ -> do
+				warning "remote is configured with exporttree=yes; use `git-annex export` to store content on it"
+				return False
+			-- Keys can be retrieved using retrieveExport, 
+			-- but since that retrieves from a path in the
+			-- remote that another writer could have replaced
+			-- with content not of the requested key,
+			-- the content has to be strongly verified.
+			--
+			-- appendonly remotes have a key/value store,
+			-- so don't need to use retrieveExport. However,
+			-- fall back to it if retrieveKeyFile fails.
+			, retrieveKeyFile = \k af dest p ->
+				let retrieveexport = retrieveKeyFileFromExport getexportlocs exportinconflict k af dest p
+				in if appendonly r
+					then do
+						ret@(ok, _v) <- retrieveKeyFile r k af dest p
+						if ok
+							then return ret
+							else retrieveexport
+					else retrieveexport
+			, retrieveKeyFileCheap = if appendonly r
+				then retrieveKeyFileCheap r
+				else \_ _ _ -> return False
+			-- Removing a key from an export would need to
+			-- change the tree in the export log to not include
+			-- the file. Otherwise, conflicts when removing
+			-- files would not be dealt with correctly.
+			-- There does not seem to be a good use case for
+			-- removing a key from an export in any case.
+			, removeKey = \_k -> do
+				warning "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove"
+				return False
+			-- 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.
+			--
+			-- (except for appendonly remotes)
+			, lockContent = if appendonly r
+				then lockContent r
+				else Nothing
+			-- Check if any of the files a key was exported to
+			-- are present. This doesn't guarantee the export
+			-- contains the right content, which is why export
+			-- remotes are untrusted.
+			--
+			-- (but appendonly remotes work the same as any
+			-- non-export remote)
+			, checkPresent = if appendonly r
+				then checkPresent r
+				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
+			-- silently skip non-present files from behaving
+			-- in confusing ways when there's an export
+			-- conflict.
+			, checkPresentCheap = False
+			, mkUnavailable = return Nothing
+			, getInfo = do
+				ts <- map fromRef . exportedTreeishes
+					<$> getExport (uuid r)
+				is <- getInfo r
+				return (is++[("export", "yes"), ("exportedtree", unwords ts)])
+			}
+	retrieveKeyFileFromExport getexportlocs exportinconflict k _af dest p = unVerified $
+		if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))
+			then do
+				locs <- getexportlocs k
+				case locs of
+					[] -> do
+						ifM (liftIO $ atomically $ readTVar exportinconflict)
+							( warning "unknown export location, likely due to the export conflict"
+							, warning "unknown export location"
+							)
+						return False
+					(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