diff options
Diffstat (limited to 'Remote')
-rw-r--r-- | Remote/BitTorrent.hs | 15 | ||||
-rw-r--r-- | Remote/Bup.hs | 15 | ||||
-rw-r--r-- | Remote/Ddar.hs | 15 | ||||
-rw-r--r-- | Remote/Directory.hs | 108 | ||||
-rw-r--r-- | Remote/External.hs | 15 | ||||
-rw-r--r-- | Remote/GCrypt.hs | 15 | ||||
-rw-r--r-- | Remote/Git.hs | 19 | ||||
-rw-r--r-- | Remote/Glacier.hs | 20 | ||||
-rw-r--r-- | Remote/Helper/Encryptable.hs | 12 | ||||
-rw-r--r-- | Remote/Helper/Export.hs | 126 | ||||
-rw-r--r-- | Remote/Hook.hs | 15 | ||||
-rw-r--r-- | Remote/List.hs | 8 | ||||
-rw-r--r-- | Remote/P2P.hs | 15 | ||||
-rw-r--r-- | Remote/Rsync.hs | 15 | ||||
-rw-r--r-- | Remote/S3.hs | 20 | ||||
-rw-r--r-- | Remote/Tahoe.hs | 15 | ||||
-rw-r--r-- | Remote/Web.hs | 15 | ||||
-rw-r--r-- | Remote/WebDAV.hs | 15 |
18 files changed, 361 insertions, 117 deletions
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 2f29f5baa..37594bd11 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -26,6 +26,7 @@ import Backend.URL import Annex.Perms import Annex.UUID import qualified Annex.Url as Url +import Remote.Helper.Export import Network.URI @@ -35,12 +36,13 @@ import qualified Data.ByteString.Lazy as B #endif remote :: RemoteType -remote = RemoteType { - typename = "bittorrent", - enumerate = list, - generate = gen, - setup = error "not supported" -} +remote = RemoteType + { typename = "bittorrent" + , enumerate = list + , generate = gen + , setup = error "not supported" + , exportSupported = exportUnsupported + } -- There is only one bittorrent remote, and it always exists. list :: Bool -> Annex [Git.Repo] @@ -61,6 +63,7 @@ gen r _ c gc = , lockContent = Nothing , checkPresent = checkKey , checkPresentCheap = False + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 3a2d67bc8..4180cbb7d 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -25,6 +25,7 @@ import Config.Cost import qualified Remote.Helper.Ssh as Ssh import Remote.Helper.Special import Remote.Helper.Messages +import Remote.Helper.Export import Utility.Hash import Utility.UserInfo import Annex.UUID @@ -34,12 +35,13 @@ import Utility.Metered type BupRepo = String remote :: RemoteType -remote = RemoteType { - typename = "bup", - enumerate = const (findSpecialRemotes "buprepo"), - generate = gen, - setup = bupSetup -} +remote = RemoteType + { typename = "bup" + , enumerate = const (findSpecialRemotes "buprepo") + , generate = gen + , setup = bupSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do @@ -61,6 +63,7 @@ gen r u c gc = do , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = bupLocal buprepo + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index 2f8c3b345..3949bf569 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -19,6 +19,7 @@ import qualified Git import Config import Config.Cost import Remote.Helper.Special +import Remote.Helper.Export import Annex.Ssh import Annex.UUID import Utility.SshHost @@ -29,12 +30,13 @@ data DdarRepo = DdarRepo } remote :: RemoteType -remote = RemoteType { - typename = "ddar", - enumerate = const (findSpecialRemotes "ddarrepo"), - generate = gen, - setup = ddarSetup -} +remote = RemoteType + { typename = "ddar" + , enumerate = const (findSpecialRemotes "ddarrepo") + , generate = gen + , setup = ddarSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do @@ -60,6 +62,7 @@ gen r u c gc = do , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = ddarLocal ddarrepo + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 2452c42e2..22413b7e9 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -1,6 +1,6 @@ {- A "remote" that is just a filesystem directory. - - - Copyright 2011-2014 Joey Hess <id@joeyh.name> + - Copyright 2011-2017 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -25,18 +25,21 @@ import Config.Cost import Config import Utility.FileMode import Remote.Helper.Special +import Remote.Helper.Export import qualified Remote.Directory.LegacyChunked as Legacy import Annex.Content import Annex.UUID import Utility.Metered +import Utility.Tmp remote :: RemoteType -remote = RemoteType { - typename = "directory", - enumerate = const (findSpecialRemotes "directory"), - generate = gen, - setup = directorySetup -} +remote = RemoteType + { typename = "directory" + , enumerate = const (findSpecialRemotes "directory") + , generate = gen + , setup = directorySetup + , exportSupported = exportIsSupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do @@ -58,6 +61,13 @@ gen r u c gc = do , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = True + , exportActions = ExportActions + { storeExport = storeExportDirectory dir + , retrieveExport = retrieveExportDirectory dir + , removeExport = removeExportDirectory dir + , checkPresentExport = checkPresentExportDirectory dir + , renameExport = renameExportDirectory dir + } , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing @@ -111,24 +121,21 @@ getLocation d k = do storeDir :: FilePath -> Key -> FilePath storeDir d k = addTrailingPathSeparator $ d </> hashDirLower def k </> keyFile k -{- Where we store temporary data for a key, in the directory, as it's being - - written. -} -tmpDir :: FilePath -> Key -> FilePath -tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k - {- Check if there is enough free disk space in the remote's directory to - store the key. Note that the unencrypted key size is checked. -} prepareStore :: FilePath -> ChunkConfig -> Preparer Storer -prepareStore d chunkconfig = checkPrepare checker +prepareStore d chunkconfig = checkPrepare (checkDiskSpaceDirectory d) (byteStorer $ store d chunkconfig) where - checker k = do - annexdir <- fromRepo gitAnnexObjectDir - samefilesystem <- liftIO $ catchDefaultIO False $ - (\a b -> deviceID a == deviceID b) - <$> getFileStatus d - <*> getFileStatus annexdir - checkDiskSpace (Just d) k 0 samefilesystem + +checkDiskSpaceDirectory :: FilePath -> Key -> Annex Bool +checkDiskSpaceDirectory d k = do + annexdir <- fromRepo gitAnnexObjectDir + samefilesystem <- liftIO $ catchDefaultIO False $ + (\a b -> deviceID a == deviceID b) + <$> getFileStatus d + <*> getFileStatus annexdir + checkDiskSpace (Just d) k 0 samefilesystem store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex Bool store d chunkconfig k b p = liftIO $ do @@ -141,7 +148,7 @@ store d chunkconfig k b p = liftIO $ do finalizeStoreGeneric tmpdir destdir return True where - tmpdir = tmpDir d k + tmpdir = addTrailingPathSeparator $ d </> "tmp" </> keyFile k destdir = storeDir d k {- Passed a temp directory that contains the files that should be placed @@ -211,11 +218,66 @@ removeDirGeneric topdir dir = do checkKey :: FilePath -> ChunkConfig -> CheckPresent checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k -checkKey d _ k = liftIO $ - ifM (anyM doesFileExist (locations d k)) +checkKey d _ k = checkPresentGeneric d (locations d k) + +checkPresentGeneric :: FilePath -> [FilePath] -> Annex Bool +checkPresentGeneric d ps = liftIO $ + ifM (anyM doesFileExist ps) ( return True , ifM (doesDirectoryExist d) ( return False , giveup $ "directory " ++ d ++ " is not accessible" ) ) + +storeExportDirectory :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool +storeExportDirectory d src _k loc p = liftIO $ catchBoolIO $ do + createDirectoryIfMissing True (takeDirectory dest) + -- Write via temp file so that checkPresentGeneric will not + -- see it until it's fully stored. + viaTmp (\tmp () -> withMeteredFile src p (L.writeFile tmp)) dest () + return True + where + dest = exportPath d loc + +retrieveExportDirectory :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +retrieveExportDirectory d _k loc dest p = unVerified $ liftIO $ catchBoolIO $ do + withMeteredFile src p (L.writeFile dest) + return True + where + src = exportPath d loc + +removeExportDirectory :: FilePath -> Key -> ExportLocation -> Annex Bool +removeExportDirectory d _k loc = liftIO $ do + nukeFile src + removeExportLocation d loc + return True + where + src = exportPath d loc + +checkPresentExportDirectory :: FilePath -> Key -> ExportLocation -> Annex Bool +checkPresentExportDirectory d _k loc = + checkPresentGeneric d [exportPath d loc] + +renameExportDirectory :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex Bool +renameExportDirectory d _k oldloc newloc = liftIO $ catchBoolIO $ do + createDirectoryIfMissing True (takeDirectory dest) + renameFile src dest + removeExportLocation d oldloc + return True + where + src = exportPath d oldloc + dest = exportPath d newloc + +exportPath :: FilePath -> ExportLocation -> FilePath +exportPath d (ExportLocation loc) = d </> loc + +{- Removes the ExportLocation directory and its parents, so long as + - they're empty, up to but not including the topdir. -} +removeExportLocation :: FilePath -> ExportLocation -> IO () +removeExportLocation topdir (ExportLocation loc) = go (Just loc) (Right ()) + where + go _ (Left _e) = return () + go Nothing _ = return () + go (Just loc') _ = go (upFrom loc') + =<< tryIO (removeDirectory $ exportPath topdir (ExportLocation loc')) diff --git a/Remote/External.hs b/Remote/External.hs index 32b95e9bb..71a07d3ea 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -18,6 +18,7 @@ import Config import Git.Config (isTrue, boolConfig) import Git.Env import Remote.Helper.Special +import Remote.Helper.Export import Remote.Helper.ReadOnly import Remote.Helper.Messages import Utility.Metered @@ -39,12 +40,13 @@ import System.Log.Logger (debugM) import qualified Data.Map as M remote :: RemoteType -remote = RemoteType { - typename = "external", - enumerate = const (findSpecialRemotes "externaltype"), - generate = gen, - setup = externalSetup -} +remote = RemoteType + { typename = "external" + , enumerate = const (findSpecialRemotes "externaltype") + , generate = gen + , setup = externalSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc @@ -85,6 +87,7 @@ gen r u c gc , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False + , exportActions = exportUnsupported , whereisKey = towhereis , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 2ccc47ad8..3270a1dc7 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -38,6 +38,7 @@ import Remote.Helper.Git import Remote.Helper.Encryptable import Remote.Helper.Special import Remote.Helper.Messages +import Remote.Helper.Export import qualified Remote.Helper.Ssh as Ssh import Utility.Metered import Annex.UUID @@ -51,14 +52,15 @@ import Utility.Gpg import Utility.SshHost remote :: RemoteType -remote = RemoteType { - typename = "gcrypt", +remote = RemoteType + { typename = "gcrypt" -- Remote.Git takes care of enumerating gcrypt remotes too, -- and will call our gen on them. - enumerate = const (return []), - generate = gen, - setup = gCryptSetup -} + , enumerate = const (return []) + , generate = gen + , setup = gCryptSetup + , exportSupported = exportUnsupported + } chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) chainGen gcryptr u c gc = do @@ -114,6 +116,7 @@ gen' r u c gc = do , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = repoCheap r + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Git.hs b/Remote/Git.hs index b48b48b52..02957fda2 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -50,6 +50,7 @@ import Utility.Batch import Utility.SimpleProtocol import Remote.Helper.Git import Remote.Helper.Messages +import Remote.Helper.Export import qualified Remote.Helper.Ssh as Ssh import qualified Remote.GCrypt import qualified Remote.P2P @@ -66,12 +67,13 @@ import qualified Data.Map as M import Network.URI remote :: RemoteType -remote = RemoteType { - typename = "git", - enumerate = list, - generate = gen, - setup = gitSetup -} +remote = RemoteType + { typename = "git" + , enumerate = list + , generate = gen + , setup = gitSetup + , exportSupported = exportUnsupported + } list :: Bool -> Annex [Git.Repo] list autoinit = do @@ -110,7 +112,7 @@ gitSetup Init mu _ c _ = do if isNothing mu || mu == Just u then return (c, u) else error "git remote did not have specified uuid" -gitSetup Enable (Just u) _ c _ = do +gitSetup (Enable _) (Just u) _ c _ = do inRepo $ Git.Command.run [ Param "remote" , Param "add" @@ -118,7 +120,7 @@ gitSetup Enable (Just u) _ c _ = do , Param $ fromMaybe (giveup "no location") (M.lookup "location" c) ] return (c, u) -gitSetup Enable Nothing _ _ _ = error "unable to enable git remote with no specified uuid" +gitSetup (Enable _) Nothing _ _ _ = error "unable to enable git remote with no specified uuid" {- It's assumed to be cheap to read the config of non-URL remotes, so this is - done each time git-annex is run in a way that uses remotes. @@ -157,6 +159,7 @@ gen r u c gc , lockContent = Just (lockKey new) , checkPresent = inAnnex new , checkPresentCheap = repoCheap r + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = if Git.repoIsUrl r then Nothing diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index c2f9bcf12..40a92c700 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -18,6 +18,7 @@ import Config import Config.Cost import Remote.Helper.Special import Remote.Helper.Messages +import Remote.Helper.Export import qualified Remote.Helper.AWS as AWS import Creds import Utility.Metered @@ -29,12 +30,13 @@ type Vault = String type Archive = FilePath remote :: RemoteType -remote = RemoteType { - typename = "glacier", - enumerate = const (findSpecialRemotes "glacier"), - generate = gen, - setup = glacierSetup -} +remote = RemoteType + { typename = "glacier" + , enumerate = const (findSpecialRemotes "glacier") + , generate = gen + , setup = glacierSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost @@ -57,6 +59,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing @@ -87,8 +90,9 @@ glacierSetup' ss u mcreds c gc = do (c', encsetup) <- encryptionSetup c gc c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds let fullconfig = c'' `M.union` defaults - when (ss == Init) $ - genVault fullconfig gc u + case ss of + Init -> genVault fullconfig gc u + _ -> return () gitConfigSpecialRemote u fullconfig "glacier" "true" return (fullconfig, u) where diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 1fe6d75be..97e55a415 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -15,6 +15,7 @@ module Remote.Helper.Encryptable ( embedCreds, cipherKey, extractCipher, + isEncrypted, describeEncryption, ) where @@ -57,7 +58,7 @@ encryptionSetup c gc = do encryption = M.lookup "encryption" c -- Generate a new cipher, depending on the chosen encryption scheme genCipher cmd = case encryption of - _ | M.member "cipher" c || M.member "cipherkeys" c || M.member "pubkeys" c -> cannotchange + _ | hasEncryptionConfig c -> cannotchange Just "none" -> return (c, NoEncryption) Just "shared" -> encsetup $ genSharedCipher cmd -- hybrid encryption is the default when a keyid is @@ -167,6 +168,15 @@ extractCipher c = case (M.lookup "cipher" c, where readkeys = KeyIds . splitc ',' +isEncrypted :: RemoteConfig -> Bool +isEncrypted c = case M.lookup "encryption" c of + Just "none" -> False + Just _ -> True + Nothing -> hasEncryptionConfig c + +hasEncryptionConfig :: RemoteConfig -> Bool +hasEncryptionConfig c = M.member "cipher" c || M.member "cipherkeys" c || M.member "pubkeys" c + describeEncryption :: RemoteConfig -> String describeEncryption c = case extractCipher c of Nothing -> "none" diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs new file mode 100644 index 000000000..58533155b --- /dev/null +++ b/Remote/Helper/Export.hs @@ -0,0 +1,126 @@ +{- exports to remotes + - + - Copyright 2017 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE FlexibleInstances #-} + +module Remote.Helper.Export where + +import Annex.Common +import Types.Remote +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. +class HasExportUnsupported a where + exportUnsupported :: a + +instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where + exportUnsupported = \_ _ -> return False + +instance HasExportUnsupported (ExportActions Annex) where + exportUnsupported = ExportActions + { storeExport = \_ _ _ _ -> return False + , retrieveExport = \_ _ _ _ -> return (False, UnVerified) + , removeExport = \_ _ -> return False + , checkPresentExport = \_ _ -> return False + , renameExport = \_ _ _ -> return False + } + +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 -> 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 + , case M.lookup "exporttree" c of + Just "yes" -> giveup "exporttree=yes is not supported by this special remote" + _ -> 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 + Just "yes" -> ifM (isExportSupported r) + ( isexport + , notexport + ) + _ -> notexport + where + notexport = return $ r { exportActions = exportUnsupported } + isexport = do + db <- openDb (uuid r) + return $ 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")]) + } diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 0ebbf9139..d7c7eb6b8 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -16,6 +16,7 @@ import Config.Cost import Annex.UUID import Remote.Helper.Special import Remote.Helper.Messages +import Remote.Helper.Export import Utility.Env import Messages.Progress @@ -25,12 +26,13 @@ type Action = String type HookName = String remote :: RemoteType -remote = RemoteType { - typename = "hook", - enumerate = const (findSpecialRemotes "hooktype"), - generate = gen, - setup = hookSetup -} +remote = RemoteType + { typename = "hook" + , enumerate = const (findSpecialRemotes "hooktype") + , generate = gen + , setup = hookSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do @@ -51,6 +53,7 @@ gen r u c gc = do , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/List.hs b/Remote/List.hs index a5e305622..2dc5e4823 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -18,6 +18,7 @@ import Types.Remote import Annex.UUID import Remote.Helper.Hooks import Remote.Helper.ReadOnly +import Remote.Helper.Export import qualified Git import qualified Git.Config @@ -42,7 +43,7 @@ import qualified Remote.Hook import qualified Remote.External remoteTypes :: [RemoteType] -remoteTypes = +remoteTypes = map adjustExportableRemoteType [ Remote.Git.remote , Remote.GCrypt.remote , Remote.P2P.remote @@ -100,8 +101,9 @@ remoteGen m t r = do u <- getRepoUUID r gc <- Annex.getRemoteGitConfig r let c = fromMaybe M.empty $ M.lookup u m - mrmt <- generate t r u c gc - return $ adjustReadOnly . addHooks <$> mrmt + generate t r u c gc >>= maybe + (return Nothing) + (Just <$$> adjustExportable . adjustReadOnly . addHooks) {- Updates a local git Remote, re-reading its git config. -} updateRemote :: Remote -> Annex (Maybe Remote) diff --git a/Remote/P2P.hs b/Remote/P2P.hs index 118262b3c..be0d4589f 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -24,6 +24,7 @@ import Annex.UUID import Config import Config.Cost import Remote.Helper.Git +import Remote.Helper.Export import Messages.Progress import Utility.Metered import Utility.AuthToken @@ -33,14 +34,15 @@ import Control.Concurrent import Control.Concurrent.STM remote :: RemoteType -remote = RemoteType { - typename = "p2p", +remote = RemoteType + { typename = "p2p" -- Remote.Git takes care of enumerating P2P remotes, -- and will call chainGen on them. - enumerate = const (return []), - generate = \_ _ _ _ -> return Nothing, - setup = error "P2P remotes are set up using git-annex p2p" -} + , enumerate = const (return []) + , generate = \_ _ _ _ -> return Nothing + , setup = error "P2P remotes are set up using git-annex p2p" + , exportSupported = exportUnsupported + } chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) chainGen addr r u c gc = do @@ -57,6 +59,7 @@ chainGen addr r u c gc = do , lockContent = Just (lock u addr connpool) , checkPresent = checkpresent u addr connpool , checkPresentCheap = False + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 4fc55d725..79aebad6b 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -28,6 +28,7 @@ import Annex.UUID import Annex.Ssh import Remote.Helper.Special import Remote.Helper.Messages +import Remote.Helper.Export import Remote.Rsync.RsyncUrl import Crypto import Utility.Rsync @@ -43,12 +44,13 @@ import Utility.SshHost import qualified Data.Map as M remote :: RemoteType -remote = RemoteType { - typename = "rsync", - enumerate = const (findSpecialRemotes "rsyncurl"), - generate = gen, - setup = rsyncSetup -} +remote = RemoteType + { typename = "rsync" + , enumerate = const (findSpecialRemotes "rsyncurl") + , generate = gen + , setup = rsyncSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do @@ -73,6 +75,7 @@ gen r u c gc = do , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/S3.hs b/Remote/S3.hs index c05831b0b..4b56cce29 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -39,6 +39,7 @@ import Config.Cost import Remote.Helper.Special import Remote.Helper.Http import Remote.Helper.Messages +import Remote.Helper.Export import qualified Remote.Helper.AWS as AWS import Creds import Annex.UUID @@ -53,12 +54,13 @@ import Utility.Url (checkBoth, managerSettings, closeManager) type BucketName = String remote :: RemoteType -remote = RemoteType { - typename = "S3", - enumerate = const (findSpecialRemotes "s3"), - generate = gen, - setup = s3Setup -} +remote = RemoteType + { typename = "S3" + , enumerate = const (findSpecialRemotes "s3") + , generate = gen + , setup = s3Setup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do @@ -84,6 +86,7 @@ gen r u c gc = do , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False + , exportActions = exportUnsupported , whereisKey = Just (getWebUrls info) , remoteFsck = Nothing , repairRepo = Nothing @@ -127,8 +130,9 @@ s3Setup' ss u mcreds c gc (c', encsetup) <- encryptionSetup c gc c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds let fullconfig = c'' `M.union` defaults - when (ss == Init) $ - genBucket fullconfig gc u + case ss of + Init -> genBucket fullconfig gc u + _ -> return () use fullconfig archiveorg = do diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index e4686f2f2..d3d52d7de 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -34,6 +34,7 @@ import qualified Git import Config import Config.Cost import Remote.Helper.Special +import Remote.Helper.Export import Annex.UUID import Annex.Content import Logs.RemoteState @@ -51,12 +52,13 @@ type IntroducerFurl = String type Capability = String remote :: RemoteType -remote = RemoteType { - typename = "tahoe", - enumerate = const (findSpecialRemotes "tahoe"), - generate = gen, - setup = tahoeSetup -} +remote = RemoteType + { typename = "tahoe" + , enumerate = const (findSpecialRemotes "tahoe") + , generate = gen + , setup = tahoeSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do @@ -75,6 +77,7 @@ gen r u c gc = do , lockContent = Nothing , checkPresent = checkKey u hdl , checkPresentCheap = False + , exportActions = exportUnsupported , whereisKey = Just (getWhereisKey u) , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Web.hs b/Remote/Web.hs index be2f265e0..f3580ca99 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -10,6 +10,7 @@ module Remote.Web (remote, getWebUrls) where import Annex.Common import Types.Remote import Remote.Helper.Messages +import Remote.Helper.Export import qualified Git import qualified Git.Construct import Annex.Content @@ -22,12 +23,13 @@ import Annex.Quvi import qualified Utility.Quvi as Quvi remote :: RemoteType -remote = RemoteType { - typename = "web", - enumerate = list, - generate = gen, - setup = error "not supported" -} +remote = RemoteType + { typename = "web" + , enumerate = list + , generate = gen + , setup = error "not supported" + , exportSupported = exportUnsupported + } -- There is only one web remote, and it always exists. -- (If the web should cease to exist, remove this module and redistribute @@ -50,6 +52,7 @@ gen r _ c gc = , lockContent = Nothing , checkPresent = checkKey , checkPresentCheap = False + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 2c4d24c35..4cc3c92e0 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -28,6 +28,7 @@ import Config.Cost import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.Http +import Remote.Helper.Export import qualified Remote.Helper.Chunked.Legacy as Legacy import Creds import Utility.Metered @@ -40,12 +41,13 @@ import Network.HTTP.Client (HttpExceptionContent(..), responseStatus) #endif remote :: RemoteType -remote = RemoteType { - typename = "webdav", - enumerate = const (findSpecialRemotes "webdav"), - generate = gen, - setup = webdavSetup -} +remote = RemoteType + { typename = "webdav" + , enumerate = const (findSpecialRemotes "webdav") + , generate = gen + , setup = webdavSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = new <$> remoteCost gc expensiveRemoteCost @@ -68,6 +70,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False + , exportActions = exportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing |