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

Merge branch 'sameas'

Browse source
This commit is contained in:
Joey Hess 2019-10-14 16:07:19 -04:00
commit 123d0d9add
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
61 changed files with 818 additions and 461 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
Annex/Branch.hs
View file

@ -1,6 +1,6 @@
{- management of the git-annex branch {- management of the git-annex branch
- -
- Copyright 2011-2018 Joey Hess <id@joeyh.name> - Copyright 2011-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -63,6 +63,7 @@ import Logs
import Logs.Transitions import Logs.Transitions
import Logs.File import Logs.File
import Logs.Trust.Pure import Logs.Trust.Pure
import Logs.Remote.Pure
import Logs.Difference.Pure import Logs.Difference.Pure
import qualified Annex.Queue import qualified Annex.Queue
import Annex.Branch.Transitions import Annex.Branch.Transitions
@ -574,27 +575,30 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
run [] = noop run [] = noop
run changers = do run changers = do
trustmap <- calcTrustMap <$> getStaged trustLog trustmap <- calcTrustMap <$> getStaged trustLog
remoteconfigmap <- calcRemoteConfigMap <$> getStaged remoteLog
-- partially apply, improves performance
let changers' = map (\c -> c trustmap remoteconfigmap) changers
fs <- branchFiles fs <- branchFiles
forM_ fs $ \f -> do forM_ fs $ \f -> do
content <- getStaged f content <- getStaged f
apply changers f content trustmap apply changers' f content
apply [] _ _ _ = return () apply [] _ _ = return ()
apply (changer:rest) file content trustmap = apply (changer:rest) file content = case changer file content of
case changer file content trustmap of PreserveFile -> apply rest file content
RemoveFile -> do ChangeFile builder -> do
let content' = toLazyByteString builder
if L.null content'
then do
Annex.Queue.addUpdateIndex Annex.Queue.addUpdateIndex
=<< inRepo (Git.UpdateIndex.unstageFile file) =<< inRepo (Git.UpdateIndex.unstageFile file)
-- File is deleted; can't run any other -- File is deleted; can't run any other
-- transitions on it. -- transitions on it.
return () return ()
ChangeFile builder -> do else do
let content' = toLazyByteString builder
sha <- hashBlob content' sha <- hashBlob content'
Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $ Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $
Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file) Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file)
apply rest file content' trustmap apply rest file content'
PreserveFile ->
apply rest file content trustmap
checkBranchDifferences :: Git.Ref -> Annex () checkBranchDifferences :: Git.Ref -> Annex ()
checkBranchDifferences ref = do checkBranchDifferences ref = do
@ -662,3 +666,4 @@ rememberTreeish treeish graftpoint = lockJournal $ \jl -> do
-- and the index was updated to that above, so it's safe to -- and the index was updated to that above, so it's safe to
-- say that the index contains c'. -- say that the index contains c'.
setIndexSha c' setIndexSha c'

63
Annex/Branch/Transitions.hs
View file

@ -20,54 +20,71 @@ import qualified Logs.MetaData.Pure as MetaData
import Types.TrustLevel import Types.TrustLevel
import Types.UUID import Types.UUID
import Types.MetaData import Types.MetaData
import Types.Remote
import Annex.SpecialRemote.Config
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Lazy as A
import Data.ByteString.Builder import Data.ByteString.Builder
data FileTransition data FileTransition
= ChangeFile Builder = ChangeFile Builder
| RemoveFile
| PreserveFile | PreserveFile
type TransitionCalculator = FilePath -> L.ByteString -> TrustMap -> FileTransition type TransitionCalculator = TrustMap -> M.Map UUID RemoteConfig -> FilePath -> L.ByteString -> FileTransition
getTransitionCalculator :: Transition -> Maybe TransitionCalculator getTransitionCalculator :: Transition -> Maybe TransitionCalculator
getTransitionCalculator ForgetGitHistory = Nothing getTransitionCalculator ForgetGitHistory = Nothing
getTransitionCalculator ForgetDeadRemotes = Just dropDead getTransitionCalculator ForgetDeadRemotes = Just dropDead
dropDead :: FilePath -> L.ByteString -> TrustMap -> FileTransition -- Removes data about all dead repos.
dropDead f content trustmap = case getLogVariety f of --
-- The trust log is not changed, because other, unmerged clones
-- may contain other data about the dead repos. So we need to rememebr
-- which are dead to later remove that.
--
-- When the remote log contains a sameas-uuid pointing to a dead uuid,
-- the uuid of that remote configuration is also effectively dead,
-- though not in the trust log. There may be per-remote state stored using
-- the latter uuid, that also needs to be removed. That configuration
-- is not removed from the remote log, for the same reason the trust log
-- is not changed.
dropDead :: TransitionCalculator
dropDead trustmap remoteconfigmap f content = case getLogVariety f of
Just OldUUIDBasedLog Just OldUUIDBasedLog
-- Don't remove the dead repo from the trust log,
-- because git remotes may still exist, and they need
-- to still know it's dead.
| f == trustLog -> PreserveFile | f == trustLog -> PreserveFile
| otherwise -> ChangeFile $ | otherwise ->
let go tm = ChangeFile $
UUIDBased.buildLogOld byteString $ UUIDBased.buildLogOld byteString $
dropDeadFromMapLog trustmap id $ dropDeadFromMapLog tm id $
UUIDBased.parseLogOld A.takeByteString content UUIDBased.parseLogOld A.takeByteString content
in if f == remoteLog
then go trustmap
else go trustmap'
Just NewUUIDBasedLog -> ChangeFile $ Just NewUUIDBasedLog -> ChangeFile $
UUIDBased.buildLogNew byteString $ UUIDBased.buildLogNew byteString $
dropDeadFromMapLog trustmap id $ dropDeadFromMapLog trustmap' id $
UUIDBased.parseLogNew A.takeByteString content UUIDBased.parseLogNew A.takeByteString content
Just (ChunkLog _) -> ChangeFile $ Just (ChunkLog _) -> ChangeFile $
Chunk.buildLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content Chunk.buildLog $ dropDeadFromMapLog trustmap' fst $
Just (PresenceLog _) -> Chunk.parseLog content
let newlog = Presence.compactLog $ Just (PresenceLog _) -> ChangeFile $ Presence.buildLog $
dropDeadFromPresenceLog trustmap $ Presence.parseLog content Presence.compactLog $
in if null newlog dropDeadFromPresenceLog trustmap' $
then RemoveFile Presence.parseLog content
else ChangeFile $ Presence.buildLog newlog Just RemoteMetaDataLog -> ChangeFile $ MetaData.buildLog $
Just RemoteMetaDataLog -> dropDeadFromRemoteMetaDataLog trustmap' $
let newlog = dropDeadFromRemoteMetaDataLog trustmap $ MetaData.simplifyLog $ MetaData.parseLog content MetaData.simplifyLog $ MetaData.parseLog content
in if S.null newlog
then RemoveFile
else ChangeFile $ MetaData.buildLog newlog
Just OtherLog -> PreserveFile Just OtherLog -> PreserveFile
Nothing -> PreserveFile Nothing -> PreserveFile
where
trustmap' = trustmap `M.union`
M.map (const DeadTrusted) (M.filter sameasdead remoteconfigmap)
sameasdead cm =
case toUUID <$> M.lookup sameasUUIDField cm of
Nothing -> False
Just u' -> M.lookup u' trustmap == Just DeadTrusted
dropDeadFromMapLog :: TrustMap -> (k -> UUID) -> M.Map k v -> M.Map k v dropDeadFromMapLog :: TrustMap -> (k -> UUID) -> M.Map k v -> M.Map k v
dropDeadFromMapLog trustmap getuuid = dropDeadFromMapLog trustmap getuuid =

8
Annex/Import.hs
View file

@ -382,7 +382,7 @@ downloadImport remote importtreeconfig importablecontents = do
getTopFilePath subdir </> fromImportLocation loc getTopFilePath subdir </> fromImportLocation loc
getcidkey cidmap db cid = liftIO $ getcidkey cidmap db cid = liftIO $
CIDDb.getContentIdentifierKeys db (Remote.uuid remote) cid >>= \case CIDDb.getContentIdentifierKeys db rs cid >>= \case
[] -> atomically $ [] -> atomically $
maybeToList . M.lookup cid <$> readTVar cidmap maybeToList . M.lookup cid <$> readTVar cidmap
l -> return l l -> return l
@ -390,8 +390,10 @@ downloadImport remote importtreeconfig importablecontents = do
recordcidkey cidmap db cid k = do recordcidkey cidmap db cid k = do
liftIO $ atomically $ modifyTVar' cidmap $ liftIO $ atomically $ modifyTVar' cidmap $
M.insert cid k M.insert cid k
liftIO $ CIDDb.recordContentIdentifier db (Remote.uuid remote) cid k liftIO $ CIDDb.recordContentIdentifier db rs cid k
CIDLog.recordContentIdentifier (Remote.uuid remote) cid k CIDLog.recordContentIdentifier rs cid k
rs = Remote.remoteStateHandle remote
{- Temporary key used for import of a ContentIdentifier while downloading {- Temporary key used for import of a ContentIdentifier while downloading
- content, before generating its real key. -} - content, before generating its real key. -}

85
Annex/SpecialRemote.hs
View file

@ -1,19 +1,26 @@
{- git-annex special remote configuration {- git-annex special remote configuration
- -
- Copyright 2011-2015 Joey Hess <id@joeyh.name> - Copyright 2011-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
module Annex.SpecialRemote where module Annex.SpecialRemote (
module Annex.SpecialRemote,
module Annex.SpecialRemote.Config
) where
import Annex.Common import Annex.Common
import Remote (remoteTypes, remoteMap) import Annex.SpecialRemote.Config
import Types.Remote (RemoteConfig, RemoteConfigKey, SetupStage(..), typename, setup) import Remote (remoteTypes)
import Types.Remote (RemoteConfig, SetupStage(..), typename, setup)
import Types.GitConfig import Types.GitConfig
import Config
import Remote.List
import Logs.Remote import Logs.Remote
import Logs.Trust import Logs.Trust
import qualified Git.Config import qualified Git.Config
import qualified Types.Remote as Remote
import Git.Types (RemoteName) import Git.Types (RemoteName)
import qualified Data.Map as M import qualified Data.Map as M
@ -22,38 +29,54 @@ import Data.Ord
{- See if there's an existing special remote with this name. {- See if there's an existing special remote with this name.
- -
- Prefer remotes that are not dead when a name appears multiple times. -} - Prefer remotes that are not dead when a name appears multiple times. -}
findExisting :: RemoteName -> Annex (Maybe (UUID, RemoteConfig)) findExisting :: RemoteName -> Annex (Maybe (UUID, RemoteConfig, Maybe (ConfigFrom UUID)))
findExisting name = do findExisting name = do
t <- trustMap t <- trustMap
headMaybe headMaybe
. sortBy (comparing $ \(u, _c) -> Down $ M.lookup u t) . sortBy (comparing $ \(u, _, _) -> Down $ M.lookup u t)
. findByName name . findByName name
<$> Logs.Remote.readRemoteLog <$> Logs.Remote.readRemoteLog
newConfig :: RemoteName -> RemoteConfig findByName :: RemoteName -> M.Map UUID RemoteConfig -> [(UUID, RemoteConfig, Maybe (ConfigFrom UUID))]
newConfig = M.singleton nameKey findByName n = map sameasuuid . filter (matching . snd) . M.toList
findByName :: RemoteName -> M.Map UUID RemoteConfig -> [(UUID, RemoteConfig)]
findByName n = filter (matching . snd) . M.toList
where where
matching c = case M.lookup nameKey c of matching c = case lookupName c of
Nothing -> False Nothing -> False
Just n' Just n'
| n' == n -> True | n' == n -> True
| otherwise -> False | otherwise -> False
sameasuuid (u, c) = case M.lookup sameasUUIDField c of
Nothing -> (u, c, Nothing)
Just u' -> (toUUID u', c, Just (ConfigFrom u))
newConfig
:: RemoteName
-> Maybe (Sameas UUID)
-> RemoteConfig
-- ^ configuration provided by the user
-> M.Map UUID RemoteConfig
-- ^ configuration of other special remotes, to inherit from
-- when sameas is used
-> RemoteConfig
newConfig name sameas fromuser m = case sameas of
Nothing -> M.insert nameField name fromuser
Just (Sameas u) -> addSameasInherited m $ M.fromList
[ (sameasNameField, name)
, (sameasUUIDField, fromUUID u)
] `M.union` fromuser
specialRemoteMap :: Annex (M.Map UUID RemoteName) specialRemoteMap :: Annex (M.Map UUID RemoteName)
specialRemoteMap = do specialRemoteMap = do
m <- Logs.Remote.readRemoteLog m <- Logs.Remote.readRemoteLog
return $ M.fromList $ mapMaybe go (M.toList m) return $ M.fromList $ mapMaybe go (M.toList m)
where where
go (u, c) = case M.lookup nameKey c of go (u, c) = case lookupName c of
Nothing -> Nothing Nothing -> Nothing
Just n -> Just (u, n) Just n -> Just (u, n)
{- find the specified remote type -} {- find the remote type -}
findType :: RemoteConfig -> Either String RemoteType findType :: RemoteConfig -> Either String RemoteType
findType config = maybe unspecified specified $ M.lookup typeKey config findType config = maybe unspecified specified $ M.lookup typeField config
where where
unspecified = Left "Specify the type of remote with type=" unspecified = Left "Specify the type of remote with type="
specified s = case filter (findtype s) remoteTypes of specified s = case filter (findtype s) remoteTypes of
@ -61,31 +84,31 @@ findType config = maybe unspecified specified $ M.lookup typeKey config
(t:_) -> Right t (t:_) -> Right t
findtype s i = typename i == s findtype s i = typename i == s
{- The name of a configured remote is stored in its config using this key. -}
nameKey :: RemoteConfigKey
nameKey = "name"
{- The type of a remote is stored in its config using this key. -}
typeKey :: RemoteConfigKey
typeKey = "type"
autoEnableKey :: RemoteConfigKey
autoEnableKey = "autoenable"
autoEnable :: Annex () autoEnable :: Annex ()
autoEnable = do autoEnable = do
remotemap <- M.filter configured <$> readRemoteLog remotemap <- M.filter configured <$> readRemoteLog
enabled <- remoteMap id enabled <- getenabledremotes
forM_ (M.toList remotemap) $ \(u, c) -> unless (u `M.member` enabled) $ do forM_ (M.toList remotemap) $ \(cu, c) -> unless (cu `M.member` enabled) $ do
case (M.lookup nameKey c, findType c) of let u = case findSameasUUID c of
Just (Sameas u') -> u'
Nothing -> cu
case (lookupName c, findType c) of
(Just name, Right t) -> whenM (canenable u) $ do (Just name, Right t) -> whenM (canenable u) $ do
showSideAction $ "Auto enabling special remote " ++ name showSideAction $ "Auto enabling special remote " ++ name
dummycfg <- liftIO dummyRemoteGitConfig dummycfg <- liftIO dummyRemoteGitConfig
tryNonAsync (setup t (Enable c) (Just u) Nothing c dummycfg) >>= \case tryNonAsync (setup t (Enable c) (Just u) Nothing c dummycfg) >>= \case
Left e -> warning (show e) Left e -> warning (show e)
Right _ -> return () Right (_c, _u) ->
when (cu /= u) $
setConfig (remoteConfig c "config-uuid") (fromUUID cu)
_ -> return () _ -> return ()
where where
configured rc = fromMaybe False $ configured rc = fromMaybe False $
Git.Config.isTrue =<< M.lookup autoEnableKey rc Git.Config.isTrue =<< M.lookup autoEnableField rc
canenable u = (/= DeadTrusted) <$> lookupTrust u canenable u = (/= DeadTrusted) <$> lookupTrust u
getenabledremotes = M.fromList
. map (\r -> (getcu r, r))
<$> remoteList
getcu r = fromMaybe
(Remote.uuid r)
(remoteAnnexConfigUUID (Remote.gitconfig r))

103
Annex/SpecialRemote/Config.hs Normal file
View file

@ -0,0 +1,103 @@
{- git-annex special remote configuration
-
- Copyright 2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Annex.SpecialRemote.Config where
import Common
import Types.Remote (RemoteConfigField, RemoteConfig)
import Types.UUID
import qualified Data.Map as M
import qualified Data.Set as S
newtype Sameas t = Sameas t
deriving (Show)
newtype ConfigFrom t = ConfigFrom t
deriving (Show)
{- The name of a configured remote is stored in its config using this key. -}
nameField :: RemoteConfigField
nameField = "name"
{- The name of a sameas remote is stored using this key instead.
- This prevents old versions of git-annex getting confused. -}
sameasNameField :: RemoteConfigField
sameasNameField = "sameas-name"
lookupName :: RemoteConfig -> Maybe String
lookupName c = M.lookup nameField c <|> M.lookup sameasNameField c
{- The uuid that a sameas remote is the same as is stored in this key. -}
sameasUUIDField :: RemoteConfigField
sameasUUIDField = "sameas-uuid"
{- The type of a remote is stored in its config using this key. -}
typeField :: RemoteConfigField
typeField = "type"
autoEnableField :: RemoteConfigField
autoEnableField = "autoenable"
encryptionField :: RemoteConfigField
encryptionField = "encryption"
macField :: RemoteConfigField
macField = "mac"
cipherField :: RemoteConfigField
cipherField = "cipher"
cipherkeysField :: RemoteConfigField
cipherkeysField = "cipherkeys"
pubkeysField :: RemoteConfigField
pubkeysField = "pubkeys"
chunksizeField :: RemoteConfigField
chunksizeField = "chunksize"
{- A remote with sameas-uuid set will inherit these values from the config
- of that uuid. These values cannot be overridden in the remote's config. -}
sameasInherits :: S.Set RemoteConfigField
sameasInherits = S.fromList
-- encryption configuration is necessarily the same for two
-- remotes that access the same data store
[ encryptionField
, macField
, cipherField
, cipherkeysField
, pubkeysField
-- legacy chunking was either enabled or not, so has to be the same
-- across configs for remotes that access the same data
-- (new-style chunking does not have that limitation)
, chunksizeField
]
{- Each RemoteConfig that has a sameas-uuid inherits some fields
- from it. Such fields can only be set by inheritance; the RemoteConfig
- cannot provide values from them. -}
addSameasInherited :: M.Map UUID RemoteConfig -> RemoteConfig -> RemoteConfig
addSameasInherited m c = case findSameasUUID c of
Nothing -> c
Just (Sameas sameasuuid) -> case M.lookup sameasuuid m of
Nothing -> c
Just parentc ->
M.withoutKeys c sameasInherits
`M.union`
M.restrictKeys parentc sameasInherits
findSameasUUID :: RemoteConfig -> Maybe (Sameas UUID)
findSameasUUID c = Sameas . toUUID <$> M.lookup sameasUUIDField c
{- Remove any fields inherited from a sameas-uuid. When storing a
- RemoteConfig, those fields don't get stored, since they were already
- inherited. -}
removeSameasInherited :: RemoteConfig -> RemoteConfig
removeSameasInherited c = case M.lookup sameasUUIDField c of
Nothing -> c
Just _ -> M.withoutKeys c sameasInherits

11
Assistant/Gpg.hs
View file

@ -9,7 +9,8 @@ module Assistant.Gpg where
import Utility.Gpg import Utility.Gpg
import Utility.UserInfo import Utility.UserInfo
import Types.Remote (RemoteConfigKey) import Types.Remote (RemoteConfigField)
import Annex.SpecialRemote.Config
import qualified Data.Map as M import qualified Data.Map as M
import Control.Applicative import Control.Applicative
@ -30,7 +31,7 @@ data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption
deriving (Eq) deriving (Eq)
{- Generates Remote configuration for encryption. -} {- Generates Remote configuration for encryption. -}
configureEncryption :: EnableEncryption -> (RemoteConfigKey, String) configureEncryption :: EnableEncryption -> (RemoteConfigField, String)
configureEncryption SharedEncryption = ("encryption", "shared") configureEncryption SharedEncryption = (encryptionField, "shared")
configureEncryption NoEncryption = ("encryption", "none") configureEncryption NoEncryption = (encryptionField, "none")
configureEncryption HybridEncryption = ("encryption", "hybrid") configureEncryption HybridEncryption = (encryptionField, "hybrid")

25
Assistant/MakeRemote.hs
View file

@ -18,6 +18,7 @@ import qualified Git
import qualified Git.Command import qualified Git.Command
import qualified Annex import qualified Annex
import qualified Annex.SpecialRemote import qualified Annex.SpecialRemote
import Annex.SpecialRemote.Config
import Logs.UUID import Logs.UUID
import Logs.Remote import Logs.Remote
import Git.Remote import Git.Remote
@ -26,6 +27,7 @@ import Creds
import Assistant.Gpg import Assistant.Gpg
import Utility.Gpg (KeyId) import Utility.Gpg (KeyId)
import Types.GitConfig import Types.GitConfig
import Config
import qualified Data.Map as M import qualified Data.Map as M
@ -51,11 +53,11 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $
go =<< Annex.SpecialRemote.findExisting name go =<< Annex.SpecialRemote.findExisting name
where where
go Nothing = setupSpecialRemote name Rsync.remote config Nothing go Nothing = setupSpecialRemote name Rsync.remote config Nothing
(Nothing, R.Init, Annex.SpecialRemote.newConfig name) (Nothing, R.Init, Annex.SpecialRemote.newConfig name Nothing mempty mempty) Nothing
go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing go (Just (u, c, mcu)) = setupSpecialRemote name Rsync.remote config Nothing
(Just u, R.Enable c, c) (Just u, R.Enable c, c) mcu
config = M.fromList config = M.fromList
[ ("encryption", "shared") [ (encryptionField, "shared")
, ("rsyncurl", location) , ("rsyncurl", location)
, ("type", "rsync") , ("type", "rsync")
] ]
@ -82,7 +84,7 @@ initSpecialRemote name remotetype mcreds config = go 0
let fullname = if n == 0 then name else name ++ show n let fullname = if n == 0 then name else name ++ show n
Annex.SpecialRemote.findExisting fullname >>= \case Annex.SpecialRemote.findExisting fullname >>= \case
Nothing -> setupSpecialRemote fullname remotetype config mcreds Nothing -> setupSpecialRemote fullname remotetype config mcreds
(Nothing, R.Init, Annex.SpecialRemote.newConfig fullname) (Nothing, R.Init, Annex.SpecialRemote.newConfig fullname Nothing mempty mempty) Nothing
Just _ -> go (n + 1) Just _ -> go (n + 1)
{- Enables an existing special remote. -} {- Enables an existing special remote. -}
@ -90,13 +92,13 @@ enableSpecialRemote :: SpecialRemoteMaker
enableSpecialRemote name remotetype mcreds config = enableSpecialRemote name remotetype mcreds config =
Annex.SpecialRemote.findExisting name >>= \case Annex.SpecialRemote.findExisting name >>= \case
Nothing -> error $ "Cannot find a special remote named " ++ name Nothing -> error $ "Cannot find a special remote named " ++ name
Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c) Just (u, c, mcu) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c) mcu
setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Annex RemoteName setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> Annex RemoteName
setupSpecialRemote = setupSpecialRemote' True setupSpecialRemote = setupSpecialRemote' True
setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Annex RemoteName setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> Annex RemoteName
setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) = do setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) mcu = do
{- Currently, only 'weak' ciphers can be generated from the {- Currently, only 'weak' ciphers can be generated from the
- assistant, because otherwise GnuPG may block once the entropy - assistant, because otherwise GnuPG may block once the entropy
- pool is drained, and as of now there's no way to tell the user - pool is drained, and as of now there's no way to tell the user
@ -104,7 +106,12 @@ setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) = do
let weakc = M.insert "highRandomQuality" "false" $ M.union config c let weakc = M.insert "highRandomQuality" "false" $ M.union config c
dummycfg <- liftIO dummyRemoteGitConfig dummycfg <- liftIO dummyRemoteGitConfig
(c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg (c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg
case mcu of
Nothing ->
configSet u c' configSet u c'
Just (Annex.SpecialRemote.ConfigFrom cu) -> do
setConfig (remoteConfig c' "config-uuid") (fromUUID cu)
configSet cu c'
when setdesc $ when setdesc $
whenM (isNothing . M.lookup u <$> uuidDescMap) $ whenM (isNothing . M.lookup u <$> uuidDescMap) $
describeUUID u (toUUIDDesc name) describeUUID u (toUUIDDesc name)

3
Assistant/WebApp/Configurators/AWS.hs
View file

@ -24,6 +24,7 @@ import Types.StandardGroups
import Creds import Creds
import Assistant.Gpg import Assistant.Gpg
import Git.Types (RemoteName) import Git.Types (RemoteName)
import Annex.SpecialRemote.Config
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
@ -195,7 +196,7 @@ enableAWSRemote remotetype uuid = do
case result of case result of
FormSuccess creds -> liftH $ do FormSuccess creds -> liftH $ do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog
let name = fromJust $ M.lookup "name" $ let name = fromJust $ lookupName $
fromJust $ M.lookup uuid m fromJust $ M.lookup uuid m
makeAWSRemote enableSpecialRemote remotetype SmallArchiveGroup creds name M.empty makeAWSRemote enableSpecialRemote remotetype SmallArchiveGroup creds name M.empty
_ -> do _ -> do

3
Assistant/WebApp/Configurators/IA.hs
View file

@ -24,6 +24,7 @@ import Assistant.Gpg
import Types.Remote (RemoteConfig) import Types.Remote (RemoteConfig)
import qualified Annex.Url as Url import qualified Annex.Url as Url
import Creds import Creds
import Annex.SpecialRemote.Config
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
@ -169,7 +170,7 @@ enableIARemote uuid = do
case result of case result of
FormSuccess creds -> liftH $ do FormSuccess creds -> liftH $ do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog
let name = fromJust $ M.lookup "name" $ let name = fromJust $ lookupName $
fromJust $ M.lookup uuid m fromJust $ M.lookup uuid m
AWS.makeAWSRemote enableSpecialRemote S3.remote PublicGroup creds name M.empty AWS.makeAWSRemote enableSpecialRemote S3.remote PublicGroup creds name M.empty
_ -> do _ -> do

7
Assistant/WebApp/Configurators/Ssh.hs
View file

@ -27,6 +27,7 @@ import qualified Git.Command
import qualified Annex.Branch import qualified Annex.Branch
import Annex.UUID import Annex.UUID
import Logs.UUID import Logs.UUID
import Annex.SpecialRemote.Config
import Assistant.RemoteControl import Assistant.RemoteControl
import Types.Creds import Types.Creds
import Assistant.CredPairCache import Assistant.CredPairCache
@ -208,7 +209,7 @@ postEnableSshGitRemoteR = enableSshRemote getsshinput enableRsyncNet enablesshgi
enableSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> UUID -> Handler Html) -> UUID -> Handler Html enableSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> UUID -> Handler Html) -> UUID -> Handler Html
enableSshRemote getsshdata rsyncnetsetup genericsetup u = do enableSshRemote getsshdata rsyncnetsetup genericsetup u = do
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
case (unmangle <$> getsshdata m, M.lookup "name" m) of case (unmangle <$> getsshdata m, lookupName m) of
(Just sshdata, Just reponame) -> sshConfigurator $ do (Just sshdata, Just reponame) -> sshConfigurator $ do
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
@ -546,7 +547,9 @@ makeSshRepo rs sshdata
let c = fromMaybe M.empty (M.lookup (Remote.uuid r) m) let c = fromMaybe M.empty (M.lookup (Remote.uuid r) m)
let c' = M.insert "location" (genSshUrl sshdata) $ let c' = M.insert "location" (genSshUrl sshdata) $
M.insert "type" "git" $ M.insert "type" "git" $
M.insert "name" (fromMaybe (Remote.name r) (M.lookup "name" c)) c case M.lookup nameField c of
Just _ -> c
Nothing -> M.insert nameField (Remote.name r) c
configSet (Remote.uuid r) c' configSet (Remote.uuid r) c'
makeSshRepoConnection :: RepoStatus -> Annex RemoteName -> (Remote -> Annex ()) -> Handler Html makeSshRepoConnection :: RepoStatus -> Annex RemoteName -> (Remote -> Annex ()) -> Handler Html

3
Assistant/WebApp/Configurators/WebDAV.hs
View file

@ -21,6 +21,7 @@ import Logs.Remote
import Git.Types (RemoteName) import Git.Types (RemoteName)
import Assistant.Gpg import Assistant.Gpg
import Types.GitConfig import Types.GitConfig
import Annex.SpecialRemote.Config
import qualified Data.Map as M import qualified Data.Map as M
#endif #endif
@ -56,7 +57,7 @@ postEnableWebDAVR :: UUID -> Handler Html
postEnableWebDAVR uuid = do postEnableWebDAVR uuid = do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog
let c = fromJust $ M.lookup uuid m let c = fromJust $ M.lookup uuid m
let name = fromJust $ M.lookup "name" c let name = fromJust $ lookupName c
let url = fromJust $ M.lookup "url" c let url = fromJust $ M.lookup "url" c
mcreds <- liftAnnex $ do mcreds <- liftAnnex $ do
dummycfg <- liftIO dummyRemoteGitConfig dummycfg <- liftIO dummyRemoteGitConfig

3
Assistant/WebApp/Gpg.hs
View file

@ -21,6 +21,7 @@ import qualified Git.GCrypt
import qualified Remote.GCrypt as GCrypt import qualified Remote.GCrypt as GCrypt
import Git.Types (RemoteName) import Git.Types (RemoteName)
import Assistant.WebApp.MakeRemote import Assistant.WebApp.MakeRemote
import Annex.SpecialRemote.Config
import Logs.Remote import Logs.Remote
import qualified Data.Map as M import qualified Data.Map as M
@ -79,7 +80,7 @@ getGCryptRemoteName u repoloc = do
mname <- ifM (inRepo $ Git.Command.runBool [Param "fetch", Param tmpremote]) mname <- ifM (inRepo $ Git.Command.runBool [Param "fetch", Param tmpremote])
( do ( do
void Annex.Branch.forceUpdate void Annex.Branch.forceUpdate
(M.lookup "name" <=< M.lookup u) <$> readRemoteLog (lookupName <=< M.lookup u) <$> readRemoteLog
, return Nothing , return Nothing
) )
void $ inRepo $ Git.Remote.Remove.remove tmpremote void $ inRepo $ Git.Remote.Remove.remove tmpremote

14
CHANGELOG
View file

@ -1,3 +1,17 @@
git-annex (7.20191011) UNRELEASED; urgency=medium
* initremote: Added --sameas option, allows for two special remotes that
access the same data store.
* Note that due to complications of the sameas feature, any external
special remotes that try to send SETSTATE or GETSTATE during INITREMOTE
or EXPORTSUPPORTED will now get back an ERROR. That would be a very
hackish thing for an external special remote to do, needing some kind
of hard-coded key value to be used, so probably nothing will be affected.
* forget --drop-dead: Remove several classes of git-annex log files
when they become empty, further reducing the size of the git-annex branch.
-- Joey Hess <id@joeyh.name> Thu, 19 Sep 2019 11:11:19 -0400
git-annex (7.20191009) upstream; urgency=medium git-annex (7.20191009) upstream; urgency=medium
* Fix bug in handling of annex.largefiles that use largerthan/smallerthan. * Fix bug in handling of annex.largefiles that use largerthan/smallerthan.

6
CmdLine/GitAnnex/Options.hs
View file

@ -1,6 +1,6 @@
{- git-annex command-line option parsing {- git-annex command-line option parsing
- -
- Copyright 2010-2018 Joey Hess <id@joeyh.name> - Copyright 2010-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -114,6 +114,10 @@ parseRemoteOption = DeferredParse
. (fromJust <$$> Remote.byNameWithUUID) . (fromJust <$$> Remote.byNameWithUUID)
. Just . Just
parseUUIDOption :: String -> DeferredParse UUID
parseUUIDOption = DeferredParse
. (Remote.nameToUUID)
-- | From or To a remote. -- | From or To a remote.
data FromToOptions data FromToOptions
= FromRemote (DeferredParse Remote) = FromRemote (DeferredParse Remote)

35
Command/EnableRemote.hs
View file

@ -1,6 +1,6 @@
{- git-annex command {- git-annex command
- -
- Copyright 2013-2016 Joey Hess <id@joeyh.name> - Copyright 2013-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -13,7 +13,7 @@ import qualified Logs.Remote
import qualified Types.Remote as R import qualified Types.Remote as R
import qualified Git import qualified Git
import qualified Git.Types as Git import qualified Git.Types as Git
import qualified Annex.SpecialRemote import qualified Annex.SpecialRemote as SpecialRemote
import qualified Remote import qualified Remote
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
import qualified Remote.Git import qualified Remote.Git
@ -40,7 +40,7 @@ start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes
where where
matchingname r = Git.remoteName r == Just name matchingname r = Git.remoteName r == Just name
go [] = startSpecialRemote name (Logs.Remote.keyValToConfig rest) go [] = startSpecialRemote name (Logs.Remote.keyValToConfig rest)
=<< Annex.SpecialRemote.findExisting name =<< SpecialRemote.findExisting name
go (r:_) = do go (r:_) = do
-- This could be either a normal git remote or a special -- This could be either a normal git remote or a special
-- remote that has an url (eg gcrypt). -- remote that has an url (eg gcrypt).
@ -62,32 +62,37 @@ startNormalRemote name restparams r
| otherwise = giveup $ | otherwise = giveup $
"That is a normal git remote; passing these parameters does not make sense: " ++ unwords restparams "That is a normal git remote; passing these parameters does not make sense: " ++ unwords restparams
startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig) -> CommandStart startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID)) -> CommandStart
startSpecialRemote name config Nothing = do startSpecialRemote name config Nothing = do
m <- Annex.SpecialRemote.specialRemoteMap m <- SpecialRemote.specialRemoteMap
confm <- Logs.Remote.readRemoteLog confm <- Logs.Remote.readRemoteLog
Remote.nameToUUID' name >>= \case Remote.nameToUUID' name >>= \case
Right u | u `M.member` m -> Right u | u `M.member` m ->
startSpecialRemote name config $ startSpecialRemote name config $
Just (u, fromMaybe M.empty (M.lookup u confm)) Just (u, fromMaybe M.empty (M.lookup u confm), Nothing)
_ -> unknownNameError "Unknown remote name." _ -> unknownNameError "Unknown remote name."
startSpecialRemote name config (Just (u, c)) = startSpecialRemote name config (Just (u, c, mcu)) =
starting "enableremote" (ActionItemOther (Just name)) $ do starting "enableremote" (ActionItemOther (Just name)) $ do
let fullconfig = config `M.union` c let fullconfig = config `M.union` c
t <- either giveup return (Annex.SpecialRemote.findType fullconfig) t <- either giveup return (SpecialRemote.findType fullconfig)
gc <- maybe (liftIO dummyRemoteGitConfig) gc <- maybe (liftIO dummyRemoteGitConfig)
(return . Remote.gitconfig) (return . Remote.gitconfig)
=<< Remote.byUUID u =<< Remote.byUUID u
performSpecialRemote t u c fullconfig gc performSpecialRemote t u c fullconfig gc mcu
performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform
performSpecialRemote t u oldc c gc = do performSpecialRemote t u oldc c gc mcu = do
(c', u') <- R.setup t (R.Enable oldc) (Just u) Nothing c gc (c', u') <- R.setup t (R.Enable oldc) (Just u) Nothing c gc
next $ cleanupSpecialRemote u' c' next $ cleanupSpecialRemote u' c' mcu
cleanupSpecialRemote :: UUID -> R.RemoteConfig -> CommandCleanup cleanupSpecialRemote :: UUID -> R.RemoteConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandCleanup
cleanupSpecialRemote u c = do cleanupSpecialRemote u c mcu = do
case mcu of
Nothing ->
Logs.Remote.configSet u c Logs.Remote.configSet u c
Just (SpecialRemote.ConfigFrom cu) -> do
setConfig (remoteConfig c "config-uuid") (fromUUID cu)
Logs.Remote.configSet cu c
Remote.byUUID u >>= \case Remote.byUUID u >>= \case
Nothing -> noop Nothing -> noop
Just r -> do Just r -> do
@ -97,7 +102,7 @@ cleanupSpecialRemote u c = do
unknownNameError :: String -> Annex a unknownNameError :: String -> Annex a
unknownNameError prefix = do unknownNameError prefix = do
m <- Annex.SpecialRemote.specialRemoteMap m <- SpecialRemote.specialRemoteMap
descm <- M.unionWith Remote.addName descm <- M.unionWith Remote.addName
<$> uuidDescMap <$> uuidDescMap
<*> pure (M.map toUUIDDesc m) <*> pure (M.map toUUIDDesc m)

70
Command/InitRemote.hs
View file

@ -1,6 +1,6 @@
{- git-annex command {- git-annex command
- -
- Copyright 2011,2013 Joey Hess <id@joeyh.name> - Copyright 2011-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -14,50 +14,82 @@ import Annex.SpecialRemote
import qualified Remote import qualified Remote
import qualified Logs.Remote import qualified Logs.Remote
import qualified Types.Remote as R import qualified Types.Remote as R
import Annex.UUID
import Logs.UUID import Logs.UUID
import Logs.Remote
import Types.GitConfig import Types.GitConfig
import Config
cmd :: Command cmd :: Command
cmd = command "initremote" SectionSetup cmd = command "initremote" SectionSetup
"creates a special (non-git) remote" "creates a special (non-git) remote"
(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
(withParams seek) (seek <$$> optParser)
seek :: CmdParams -> CommandSeek data InitRemoteOptions = InitRemoteOptions
seek = withWords (commandAction . start) { cmdparams :: CmdParams
, sameas :: Maybe (DeferredParse UUID)
}
start :: [String] -> CommandStart optParser :: CmdParamsDesc -> Parser InitRemoteOptions
start [] = giveup "Specify a name for the remote." optParser desc = InitRemoteOptions
start (name:ws) = ifM (isJust <$> findExisting name) <$> cmdParams desc
<*> optional parseSameasOption
parseSameasOption :: Parser (DeferredParse UUID)
parseSameasOption = parseUUIDOption <$> strOption
( long "sameas"
<> metavar (paramRemote `paramOr` paramDesc `paramOr` paramUUID)
<> help "new remote that accesses the same data"
<> completeRemotes
)
seek :: InitRemoteOptions -> CommandSeek
seek o = withWords (commandAction . (start o)) (cmdparams o)
start :: InitRemoteOptions -> [String] -> CommandStart
start _ [] = giveup "Specify a name for the remote."
start o (name:ws) = ifM (isJust <$> findExisting name)
( giveup $ "There is already a special remote named \"" ++ name ++ ( giveup $ "There is already a special remote named \"" ++ name ++
"\". (Use enableremote to enable an existing special remote.)" "\". (Use enableremote to enable an existing special remote.)"
, do , do
ifM (isJust <$> Remote.byNameOnly name) ifM (isJust <$> Remote.byNameOnly name)
( giveup $ "There is already a remote named \"" ++ name ++ "\"" ( giveup $ "There is already a remote named \"" ++ name ++ "\""
, do , do
let c = newConfig name sameasuuid <- maybe
t <- either giveup return (findType config) (pure Nothing)
(Just . Sameas <$$> getParsed)
(sameas o)
c <- newConfig name sameasuuid
(Logs.Remote.keyValToConfig ws)
<$> readRemoteLog
t <- either giveup return (findType c)
starting "initremote" (ActionItemOther (Just name)) $ starting "initremote" (ActionItemOther (Just name)) $
perform t name $ M.union config c perform t name c o
) )
) )
where
config = Logs.Remote.keyValToConfig ws
perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform perform :: RemoteType -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform
perform t name c = do perform t name c o = do
dummycfg <- liftIO dummyRemoteGitConfig dummycfg <- liftIO dummyRemoteGitConfig
(c', u) <- R.setup t R.Init cu Nothing c dummycfg (c', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) Nothing c dummycfg
next $ cleanup u name c' next $ cleanup u name c' o
where where
cu = case M.lookup "uuid" c of uuidfromuser = case M.lookup "uuid" c of
Just s Just s
| isUUID s -> Just (toUUID s) | isUUID s -> Just (toUUID s)
| otherwise -> giveup "invalid uuid" | otherwise -> giveup "invalid uuid"
Nothing -> Nothing Nothing -> Nothing
sameasu = toUUID <$> M.lookup sameasUUIDField c
cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup cleanup :: UUID -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandCleanup
cleanup u name c = do cleanup u name c o = do
case sameas o of
Nothing -> do
describeUUID u (toUUIDDesc name) describeUUID u (toUUIDDesc name)
Logs.Remote.configSet u c Logs.Remote.configSet u c
Just _ -> do
cu <- liftIO genUUID
setConfig (remoteConfig c "config-uuid") (fromUUID cu)
Logs.Remote.configSet cu c
return True return True

21
Command/RenameRemote.hs
View file

@ -9,6 +9,7 @@ module Command.RenameRemote where
import Command import Command
import qualified Annex.SpecialRemote import qualified Annex.SpecialRemote
import Annex.SpecialRemote.Config (nameField, sameasNameField)
import qualified Logs.Remote import qualified Logs.Remote
import qualified Types.Remote as R import qualified Types.Remote as R
import qualified Remote import qualified Remote
@ -26,9 +27,9 @@ seek = withWords (commandAction . start)
start :: [String] -> CommandStart start :: [String] -> CommandStart
start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case
Just (u, cfg) -> Annex.SpecialRemote.findExisting newname >>= \case Just (u, cfg, mcu) -> Annex.SpecialRemote.findExisting newname >>= \case
Just _ -> giveup $ "The name " ++ newname ++ " is already used by a special remote." Just _ -> giveup $ "The name " ++ newname ++ " is already used by a special remote."
Nothing -> go u cfg Nothing -> go u cfg mcu
-- Support lookup by uuid or description as well as remote name, -- Support lookup by uuid or description as well as remote name,
-- as a fallback when there is nothing with the name in the -- as a fallback when there is nothing with the name in the
-- special remote log. -- special remote log.
@ -38,13 +39,17 @@ start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case
m <- Logs.Remote.readRemoteLog m <- Logs.Remote.readRemoteLog
case M.lookup u m of case M.lookup u m of
Nothing -> giveup "That is not a special remote." Nothing -> giveup "That is not a special remote."
Just cfg -> go u cfg Just cfg -> go u cfg Nothing
where where
go u cfg = starting "rename" (ActionItemOther Nothing) $ go u cfg mcu = starting "rename" (ActionItemOther Nothing) $
perform u cfg newname perform u cfg mcu newname
start _ = giveup "Specify an old name (or uuid or description) and a new name." start _ = giveup "Specify an old name (or uuid or description) and a new name."
perform :: UUID -> R.RemoteConfig -> String -> CommandPerform perform :: UUID -> R.RemoteConfig -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> String -> CommandPerform
perform u cfg newname = do perform u cfg mcu newname = do
Logs.Remote.configSet u (M.insert "name" newname cfg) let (namefield, cu) = case mcu of
Nothing -> (nameField, u)
Just (Annex.SpecialRemote.ConfigFrom u') -> (sameasNameField, u')
Logs.Remote.configSet cu (M.insert namefield newname cfg)
next $ return True next $ return True

1
Command/TestRemote.hs
View file

@ -153,6 +153,7 @@ adjustRemoteConfig r adjustconfig = do
(Remote.uuid r) (Remote.uuid r)
(adjustconfig (Remote.config r)) (adjustconfig (Remote.config r))
(Remote.gitconfig r) (Remote.gitconfig r)
(Remote.remoteStateHandle r)
test :: Annex.AnnexState -> Remote -> Key -> [TestTree] test :: Annex.AnnexState -> Remote -> Key -> [TestTree]
test st r k = catMaybes test st r k = catMaybes

3
Config.hs
View file

@ -19,6 +19,7 @@ import Config.DynamicConfig
import Types.Availability import Types.Availability
import Git.Types import Git.Types
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
import qualified Annex.SpecialRemote.Config as SpecialRemote
import qualified Data.Map as M import qualified Data.Map as M
@ -62,7 +63,7 @@ instance RemoteNameable Remote where
getRemoteName = Remote.name getRemoteName = Remote.name
instance RemoteNameable Remote.RemoteConfig where instance RemoteNameable Remote.RemoteConfig where
getRemoteName c = fromMaybe "" (M.lookup "name" c) getRemoteName c = fromMaybe "" (SpecialRemote.lookupName c)
{- A per-remote config setting in git config. -} {- A per-remote config setting in git config. -}
remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey

10
Creds.hs
View file

@ -26,7 +26,7 @@ import Types.Creds
import Annex.Perms import Annex.Perms
import Utility.FileMode import Utility.FileMode
import Crypto import Crypto
import Types.Remote (RemoteConfig, RemoteConfigKey) import Types.Remote (RemoteConfig, RemoteConfigField)
import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher) import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher)
import Utility.Env (getEnv) import Utility.Env (getEnv)
@ -39,7 +39,7 @@ import Utility.Base64
data CredPairStorage = CredPairStorage data CredPairStorage = CredPairStorage
{ credPairFile :: FilePath { credPairFile :: FilePath
, credPairEnvironment :: (String, String) , credPairEnvironment :: (String, String)
, credPairRemoteKey :: RemoteConfigKey , credPairRemoteField :: RemoteConfigField
} }
{- Stores creds in a remote's configuration, if the remote allows {- Stores creds in a remote's configuration, if the remote allows
@ -58,7 +58,7 @@ setRemoteCredPair encsetup c gc storage mcreds = case mcreds of
=<< getRemoteCredPair c gc storage =<< getRemoteCredPair c gc storage
Just creds Just creds
| embedCreds c -> | embedCreds c ->
let key = credPairRemoteKey storage let key = credPairRemoteField storage
in storeconfig creds key =<< flip remoteCipher gc =<< localcache creds in storeconfig creds key =<< flip remoteCipher gc =<< localcache creds
| otherwise -> localcache creds | otherwise -> localcache creds
where where
@ -84,7 +84,7 @@ getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
fromenv = liftIO $ getEnvCredPair storage fromenv = liftIO $ getEnvCredPair storage
fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage
fromconfig = do fromconfig = do
let key = credPairRemoteKey storage let key = credPairRemoteField storage
mcipher <- remoteCipher' c gc mcipher <- remoteCipher' c gc
case (M.lookup key c, mcipher) of case (M.lookup key c, mcipher) of
(Nothing, _) -> return Nothing (Nothing, _) -> return Nothing
@ -190,7 +190,7 @@ includeCredsInfo c storage info = do
Just _ -> do Just _ -> do
let (uenv, penv) = credPairEnvironment storage let (uenv, penv) = credPairEnvironment storage
ret $ "from environment variables (" ++ unwords [uenv, penv] ++ ")" ret $ "from environment variables (" ++ unwords [uenv, penv] ++ ")"
Nothing -> case (`M.lookup` c) (credPairRemoteKey storage) of Nothing -> case (`M.lookup` c) (credPairRemoteField storage) of
Nothing -> ifM (existsCacheCredPair storage) Nothing -> ifM (existsCacheCredPair storage)
( ret "stored locally" ( ret "stored locally"
, ret "not available" , ret "not available"

7
Crypto.hs
View file

@ -45,6 +45,7 @@ import qualified Utility.Gpg as Gpg
import Types.Crypto import Types.Crypto
import Types.Remote import Types.Remote
import Types.Key import Types.Key
import Annex.SpecialRemote.Config
{- The beginning of a Cipher is used for MAC'ing; the remainder is used {- The beginning of a Cipher is used for MAC'ing; the remainder is used
- as the GPG symmetric encryption passphrase when using the hybrid - as the GPG symmetric encryption passphrase when using the hybrid
@ -236,9 +237,9 @@ instance LensGpgEncParams (RemoteConfig, RemoteGitConfig) where
getGpgEncParams (c,gc) = getGpgEncParamsBase (c,gc) ++ getGpgEncParams (c,gc) = getGpgEncParamsBase (c,gc) ++
{- When the remote is configured to use public-key encryption, {- When the remote is configured to use public-key encryption,
- look up the recipient keys and add them to the option list. -} - look up the recipient keys and add them to the option list. -}
case M.lookup "encryption" c of case M.lookup encryptionField c of
Just "pubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup "cipherkeys" c Just "pubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup cipherkeysField c
Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup "pubkeys" c Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup pubkeysField c
_ -> [] _ -> []
getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc) getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc)

18
Database/ContentIdentifier.hs
View file

@ -34,6 +34,7 @@ import Annex.Locations
import Annex.Common hiding (delete) import Annex.Common hiding (delete)
import qualified Annex.Branch import qualified Annex.Branch
import Types.Import import Types.Import
import Types.RemoteState
import Git.Types import Git.Types
import Git.Sha import Git.Sha
import Git.FilePath import Git.FilePath
@ -89,20 +90,21 @@ flushDbQueue :: ContentIdentifierHandle -> IO ()
flushDbQueue (ContentIdentifierHandle h) = H.flushDbQueue h flushDbQueue (ContentIdentifierHandle h) = H.flushDbQueue h
-- Be sure to also update the git-annex branch when using this. -- Be sure to also update the git-annex branch when using this.
recordContentIdentifier :: ContentIdentifierHandle -> UUID -> ContentIdentifier -> Key -> IO () recordContentIdentifier :: ContentIdentifierHandle -> RemoteStateHandle -> ContentIdentifier -> Key -> IO ()
recordContentIdentifier h u cid k = queueDb h $ do recordContentIdentifier h (RemoteStateHandle u) cid k = queueDb h $ do
void $ insert_ $ ContentIdentifiers u cid (toIKey k) void $ insert_ $ ContentIdentifiers u cid (toIKey k)
getContentIdentifiers :: ContentIdentifierHandle -> UUID -> Key -> IO [ContentIdentifier] getContentIdentifiers :: ContentIdentifierHandle -> RemoteStateHandle -> Key -> IO [ContentIdentifier]
getContentIdentifiers (ContentIdentifierHandle h) u k = H.queryDbQueue h $ do getContentIdentifiers (ContentIdentifierHandle h) (RemoteStateHandle u) k =
H.queryDbQueue h $ do
l <- selectList l <- selectList
[ ContentIdentifiersKey ==. toIKey k [ ContentIdentifiersKey ==. toIKey k
, ContentIdentifiersRemote ==. u , ContentIdentifiersRemote ==. u
] [] ] []
return $ map (contentIdentifiersCid . entityVal) l return $ map (contentIdentifiersCid . entityVal) l
getContentIdentifierKeys :: ContentIdentifierHandle -> UUID -> ContentIdentifier -> IO [Key] getContentIdentifierKeys :: ContentIdentifierHandle -> RemoteStateHandle -> ContentIdentifier -> IO [Key]
getContentIdentifierKeys (ContentIdentifierHandle h) u cid = getContentIdentifierKeys (ContentIdentifierHandle h) (RemoteStateHandle u) cid =
H.queryDbQueue h $ do H.queryDbQueue h $ do
l <- selectList l <- selectList
[ ContentIdentifiersCid ==. cid [ ContentIdentifiersCid ==. cid
@ -147,6 +149,6 @@ updateFromLog db (oldtree, currtree) = do
Nothing -> return () Nothing -> return ()
Just k -> do Just k -> do
l <- Log.getContentIdentifiers k l <- Log.getContentIdentifiers k
liftIO $ forM_ l $ \(u, cids) -> liftIO $ forM_ l $ \(rs, cids) ->
forM_ cids $ \cid -> forM_ cids $ \cid ->
recordContentIdentifier db u cid k recordContentIdentifier db rs cid k

9
Logs/ContentIdentifier.hs
View file

@ -15,6 +15,7 @@ import Annex.Common
import Logs import Logs
import Logs.MapLog import Logs.MapLog
import Types.Import import Types.Import
import Types.RemoteState
import qualified Annex.Branch import qualified Annex.Branch
import Logs.ContentIdentifier.Pure as X import Logs.ContentIdentifier.Pure as X
import qualified Annex import qualified Annex
@ -27,8 +28,8 @@ import qualified Data.List.NonEmpty as NonEmpty
-- --
-- A remote may use multiple content identifiers for the same key over time, -- A remote may use multiple content identifiers for the same key over time,
-- so ones that were recorded before are preserved. -- so ones that were recorded before are preserved.
recordContentIdentifier :: UUID -> ContentIdentifier -> Key -> Annex () recordContentIdentifier :: RemoteStateHandle -> ContentIdentifier -> Key -> Annex ()
recordContentIdentifier u cid k = do recordContentIdentifier (RemoteStateHandle u) cid k = do
c <- liftIO currentVectorClock c <- liftIO currentVectorClock
config <- Annex.getGitConfig config <- Annex.getGitConfig
Annex.Branch.change (remoteContentIdentifierLogFile config k) $ Annex.Branch.change (remoteContentIdentifierLogFile config k) $
@ -39,9 +40,9 @@ recordContentIdentifier u cid k = do
m = simpleMap l m = simpleMap l
-- | Get all known content identifiers for a key. -- | Get all known content identifiers for a key.
getContentIdentifiers :: Key -> Annex [(UUID, [ContentIdentifier])] getContentIdentifiers :: Key -> Annex [(RemoteStateHandle, [ContentIdentifier])]
getContentIdentifiers k = do getContentIdentifiers k = do
config <- Annex.getGitConfig config <- Annex.getGitConfig
map (\(u, l) -> (u, NonEmpty.toList l) ) map (\(u, l) -> (RemoteStateHandle u, NonEmpty.toList l) )
. M.toList . simpleMap . parseLog . M.toList . simpleMap . parseLog
<$> Annex.Branch.get (remoteContentIdentifierLogFile config k) <$> Annex.Branch.get (remoteContentIdentifierLogFile config k)

13
Logs/MetaData.hs
View file

@ -19,6 +19,7 @@
- after the other remote redundantly set foo +x, it was unset, - after the other remote redundantly set foo +x, it was unset,
- and so foo currently has no value. - and so foo currently has no value.
- -
- Copyright 2014-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -35,6 +36,7 @@ module Logs.MetaData (
import Annex.Common import Annex.Common
import Types.MetaData import Types.MetaData
import Types.RemoteState
import Annex.MetaData.StandardFields import Annex.MetaData.StandardFields
import Annex.VectorClock import Annex.VectorClock
import qualified Annex.Branch import qualified Annex.Branch
@ -84,8 +86,8 @@ getCurrentMetaData' getlogfile k = do
Unknown -> 0 Unknown -> 0
showts = formatPOSIXTime "%F@%H-%M-%S" showts = formatPOSIXTime "%F@%H-%M-%S"
getCurrentRemoteMetaData :: UUID -> Key -> Annex RemoteMetaData getCurrentRemoteMetaData :: RemoteStateHandle -> Key -> Annex RemoteMetaData
getCurrentRemoteMetaData u k = extractRemoteMetaData u <$> getCurrentRemoteMetaData (RemoteStateHandle u) k = extractRemoteMetaData u <$>
getCurrentMetaData' remoteMetaDataLogFile k getCurrentMetaData' remoteMetaDataLogFile k
{- Adds in some metadata, which can override existing values, or unset {- Adds in some metadata, which can override existing values, or unset
@ -116,9 +118,10 @@ addMetaDataClocked' getlogfile k d@(MetaData m) c
where where
metadata = MetaData $ M.filterWithKey (\f _ -> not (isLastChangedField f)) m metadata = MetaData $ M.filterWithKey (\f _ -> not (isLastChangedField f)) m
addRemoteMetaData :: Key -> RemoteMetaData -> Annex () addRemoteMetaData :: Key -> RemoteStateHandle -> MetaData -> Annex ()
addRemoteMetaData k m = do addRemoteMetaData k (RemoteStateHandle u) m =
addMetaData' remoteMetaDataLogFile k (fromRemoteMetaData m) addMetaData' remoteMetaDataLogFile k $ fromRemoteMetaData $
RemoteMetaData u m
getMetaDataLog :: Key -> Annex (Log MetaData) getMetaDataLog :: Key -> Annex (Log MetaData)
getMetaDataLog key = do getMetaDataLog key = do

74
Logs/Remote.hs
View file

@ -1,6 +1,6 @@
{- git-annex remote log {- git-annex remote log
- -
- Copyright 2011 Joey Hess <id@joeyh.name> - Copyright 2011-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -22,10 +22,10 @@ import qualified Annex.Branch
import Types.Remote import Types.Remote
import Logs import Logs
import Logs.UUIDBased import Logs.UUIDBased
import Logs.Remote.Pure
import Annex.SpecialRemote.Config
import qualified Data.Map as M import qualified Data.Map as M
import Data.Char
import qualified Data.Attoparsec.ByteString.Lazy as A
import Data.ByteString.Builder import Data.ByteString.Builder
{- Adds or updates a remote's config in the log. -} {- Adds or updates a remote's config in the log. -}
@ -34,74 +34,10 @@ configSet u cfg = do
c <- liftIO currentVectorClock c <- liftIO currentVectorClock
Annex.Branch.change remoteLog $ Annex.Branch.change remoteLog $
buildLogOld (byteString . encodeBS . showConfig) buildLogOld (byteString . encodeBS . showConfig)
. changeLog c u cfg . changeLog c u (removeSameasInherited cfg)
. parseLogOld remoteConfigParser . parseLogOld remoteConfigParser
{- Map of remotes by uuid containing key/value config maps. -} {- Map of remotes by uuid containing key/value config maps. -}
readRemoteLog :: Annex (M.Map UUID RemoteConfig) readRemoteLog :: Annex (M.Map UUID RemoteConfig)
readRemoteLog = simpleMap . parseLogOld remoteConfigParser readRemoteLog = calcRemoteConfigMap
<$> Annex.Branch.get remoteLog <$> Annex.Branch.get remoteLog
remoteConfigParser :: A.Parser RemoteConfig
remoteConfigParser = keyValToConfig . words . decodeBS <$> A.takeByteString
showConfig :: RemoteConfig -> String
showConfig = unwords . configToKeyVal
{- Given Strings like "key=value", generates a RemoteConfig. -}
keyValToConfig :: [String] -> RemoteConfig
keyValToConfig ws = M.fromList $ map (/=/) ws
where
(/=/) s = (k, v)
where
k = takeWhile (/= '=') s
v = configUnEscape $ drop (1 + length k) s
configToKeyVal :: M.Map String String -> [String]
configToKeyVal m = map toword $ sort $ M.toList m
where
toword (k, v) = k ++ "=" ++ configEscape v
configEscape :: String -> String
configEscape = concatMap escape
where
escape c
| isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";"
| otherwise = [c]
configUnEscape :: String -> String
configUnEscape = unescape
where
unescape [] = []
unescape (c:rest)
| c == '&' = entity rest
| otherwise = c : unescape rest
entity s
| not (null num) && ";" `isPrefixOf` r =
chr (Prelude.read num) : unescape rest
| otherwise =
'&' : unescape s
where
num = takeWhile isNumber s
r = drop (length num) s
rest = drop 1 r
{- for quickcheck -}
prop_isomorphic_configEscape :: String -> Bool
prop_isomorphic_configEscape s = s == (configUnEscape . configEscape) s
prop_parse_show_Config :: RemoteConfig -> Bool
prop_parse_show_Config c
-- whitespace and '=' are not supported in config keys
| any (\k -> any isSpace k || elem '=' k) (M.keys c) = True
| any (any excluded) (M.keys c) = True
| any (any excluded) (M.elems c) = True
| otherwise = A.parseOnly remoteConfigParser (encodeBS $ showConfig c) ~~ Right c
where
normalize v = sort . M.toList <$> v
a ~~ b = normalize a == normalize b
-- limit to ascii alphanumerics for simplicity; characters not
-- allowed by the current character set in the config may not
-- round-trip in an identical representation due to the use of the
-- filesystem encoding.
excluded ch = not (isAlphaNum ch) || not (isAscii ch)

9
Logs/RemoteState.hs
View file

@ -11,6 +11,7 @@ module Logs.RemoteState (
) where ) where
import Annex.Common import Annex.Common
import Types.RemoteState
import Logs import Logs
import Logs.UUIDBased import Logs.UUIDBased
import qualified Annex.Branch import qualified Annex.Branch
@ -23,8 +24,8 @@ import Data.ByteString.Builder
type RemoteState = String type RemoteState = String
setRemoteState :: UUID -> Key -> RemoteState -> Annex () setRemoteState :: RemoteStateHandle -> Key -> RemoteState -> Annex ()
setRemoteState u k s = do setRemoteState (RemoteStateHandle u) k s = do
c <- liftIO currentVectorClock c <- liftIO currentVectorClock
config <- Annex.getGitConfig config <- Annex.getGitConfig
Annex.Branch.change (remoteStateLogFile config k) $ Annex.Branch.change (remoteStateLogFile config k) $
@ -33,8 +34,8 @@ setRemoteState u k s = do
buildRemoteState :: Log RemoteState -> Builder buildRemoteState :: Log RemoteState -> Builder
buildRemoteState = buildLogNew (byteString . encodeBS) buildRemoteState = buildLogNew (byteString . encodeBS)
getRemoteState :: UUID -> Key -> Annex (Maybe RemoteState) getRemoteState :: RemoteStateHandle -> Key -> Annex (Maybe RemoteState)
getRemoteState u k = do getRemoteState (RemoteStateHandle u) k = do
config <- Annex.getGitConfig config <- Annex.getGitConfig
extract . parseRemoteState extract . parseRemoteState
<$> Annex.Branch.get (remoteStateLogFile config k) <$> Annex.Branch.get (remoteStateLogFile config k)

5
Remote/Adb.hs
View file

@ -40,8 +40,8 @@ remote = RemoteType
, importSupported = importIsSupported , importSupported = importIsSupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = do gen r u c gc rs = do
let this = Remote let this = Remote
{ uuid = u { uuid = u
-- adb operates over USB or wifi, so is not as cheap -- adb operates over USB or wifi, so is not as cheap
@ -90,6 +90,7 @@ gen r u c gc = do
] ]
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
return $ Just $ specialRemote c return $ Just $ specialRemote c
(simplyPrepare $ store serial adir) (simplyPrepare $ store serial adir)

5
Remote/BitTorrent.hs
View file

@ -52,8 +52,8 @@ list _autoinit = do
r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown) r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown)
return [r] return [r]
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r _ c gc = do gen r _ c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
return $ Just Remote return $ Just Remote
{ uuid = bitTorrentUUID { uuid = bitTorrentUUID
@ -85,6 +85,7 @@ gen r _ c gc = do
, getInfo = return [] , getInfo = return []
, claimUrl = Just (pure . isSupportedUrl) , claimUrl = Just (pure . isSupportedUrl)
, checkUrl = Just checkTorrentUrl , checkUrl = Just checkTorrentUrl
, remoteStateHandle = rs
} }
downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)

5
Remote/Bup.hs
View file

@ -44,8 +44,8 @@ remote = RemoteType
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = do gen r u c gc rs = do
bupr <- liftIO $ bup2GitRemote buprepo bupr <- liftIO $ bup2GitRemote buprepo
cst <- remoteCost gc $ cst <- remoteCost gc $
if bupLocal buprepo if bupLocal buprepo
@ -86,6 +86,7 @@ gen r u c gc = do
, getInfo = return [("repo", buprepo)] , getInfo = return [("repo", buprepo)]
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
return $ Just $ specialRemote' specialcfg c return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this buprepo) (simplyPrepare $ store this buprepo)

5
Remote/Ddar.hs
View file

@ -39,8 +39,8 @@ remote = RemoteType
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = do gen r u c gc rs = do
cst <- remoteCost gc $ cst <- remoteCost gc $
if ddarLocal ddarrepo if ddarLocal ddarrepo
then nearlyCheapRemoteCost then nearlyCheapRemoteCost
@ -85,6 +85,7 @@ gen r u c gc = do
, getInfo = return [("repo", ddarRepoLocation ddarrepo)] , getInfo = return [("repo", ddarRepoLocation ddarrepo)]
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
ddarrepo = maybe (giveup "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc) ddarrepo = maybe (giveup "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc)
specialcfg = (specialRemoteCfg c) specialcfg = (specialRemoteCfg c)

9
Remote/Directory.hs
View file

@ -45,8 +45,8 @@ remote = RemoteType
, importSupported = importIsSupported , importSupported = importIsSupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = do gen r u c gc rs = do
cst <- remoteCost gc cheapRemoteCost cst <- remoteCost gc cheapRemoteCost
let chunkconfig = getChunkConfig c let chunkconfig = getChunkConfig c
return $ Just $ specialRemote c return $ Just $ specialRemote c
@ -97,11 +97,12 @@ gen r u c gc = do
, appendonly = False , appendonly = False
, availability = LocallyAvailable , availability = LocallyAvailable
, remotetype = remote , remotetype = remote
, mkUnavailable = gen r u c $ , mkUnavailable = gen r u c
gc { remoteAnnexDirectory = Just "/dev/null" } (gc { remoteAnnexDirectory = Just "/dev/null" }) rs
, getInfo = return [("directory", dir)] , getInfo = return [("directory", dir)]
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
where where
dir = fromMaybe (giveup "missing directory") $ remoteAnnexDirectory gc dir = fromMaybe (giveup "missing directory") $ remoteAnnexDirectory gc

34
Remote/External.hs
View file

@ -50,8 +50,8 @@ remote = RemoteType
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc gen r u c gc rs
-- readonly mode only downloads urls; does not use external program -- readonly mode only downloads urls; does not use external program
| remoteAnnexReadOnly gc = do | remoteAnnexReadOnly gc = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
@ -67,7 +67,7 @@ gen r u c gc
exportUnsupported exportUnsupported
exportUnsupported exportUnsupported
| otherwise = do | otherwise = do
external <- newExternal externaltype u c gc external <- newExternal externaltype u c gc (Just rs)
Annex.addCleanup (RemoteCleanup u) $ stopExternal external Annex.addCleanup (RemoteCleanup u) $ stopExternal external
cst <- getCost external r gc cst <- getCost external r gc
avail <- getAvailability external r gc avail <- getAvailability external r gc
@ -132,11 +132,12 @@ gen r u c gc
, availability = avail , availability = avail
, remotetype = remote , remotetype = remote
{ exportSupported = cheapexportsupported } { exportSupported = cheapexportsupported }
, mkUnavailable = gen r u c $ , mkUnavailable = gen r u c
gc { remoteAnnexExternalType = Just "!dne!" } (gc { remoteAnnexExternalType = Just "!dne!" }) rs
, getInfo = togetinfo , getInfo = togetinfo
, claimUrl = toclaimurl , claimUrl = toclaimurl
, checkUrl = tocheckurl , checkUrl = tocheckurl
, remoteStateHandle = rs
} }
return $ Just $ specialRemote c return $ Just $ specialRemote c
(simplyPrepare tostore) (simplyPrepare tostore)
@ -155,10 +156,10 @@ externalSetup _ mu _ c gc = do
c'' <- case M.lookup "readonly" c of c'' <- case M.lookup "readonly" c of
Just v | isTrue v == Just True -> do Just v | isTrue v == Just True -> do
setConfig (remoteConfig (fromJust (M.lookup "name" c)) "readonly") (boolConfig True) setConfig (remoteConfig (fromJust (lookupName c)) "readonly") (boolConfig True)
return c' return c'
_ -> do _ -> do
external <- newExternal externaltype u c' gc external <- newExternal externaltype u c' gc Nothing
handleRequest external INITREMOTE Nothing $ \resp -> case resp of handleRequest external INITREMOTE Nothing $ \resp -> case resp of
INITREMOTE_SUCCESS -> result () INITREMOTE_SUCCESS -> result ()
INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg
@ -174,7 +175,7 @@ checkExportSupported c gc = do
let externaltype = fromMaybe (giveup "Specify externaltype=") $ let externaltype = fromMaybe (giveup "Specify externaltype=") $
remoteAnnexExternalType gc <|> M.lookup "externaltype" c remoteAnnexExternalType gc <|> M.lookup "externaltype" c
checkExportSupported' checkExportSupported'
=<< newExternal externaltype NoUUID c gc =<< newExternal externaltype NoUUID c gc Nothing
checkExportSupported' :: External -> Annex Bool checkExportSupported' :: External -> Annex Bool
checkExportSupported' external = go `catchNonAsync` (const (return False)) checkExportSupported' external = go `catchNonAsync` (const (return False))
@ -414,11 +415,16 @@ handleRequest' st external req mp responsehandler
<$> preferredContentMapRaw <$> preferredContentMapRaw
send $ VALUE expr send $ VALUE expr
handleRemoteRequest (SETSTATE key state) = handleRemoteRequest (SETSTATE key state) =
setRemoteState (externalUUID external) key state case externalRemoteStateHandle external of
handleRemoteRequest (GETSTATE key) = do Just h -> setRemoteState h key state
Nothing -> senderror "cannot send SETSTATE here"
handleRemoteRequest (GETSTATE key) =
case externalRemoteStateHandle external of
Just h -> do
state <- fromMaybe "" state <- fromMaybe ""
<$> getRemoteState (externalUUID external) key <$> getRemoteState h key
send $ VALUE state send $ VALUE state
Nothing -> senderror "cannot send GETSTATE here"
handleRemoteRequest (SETURLPRESENT key url) = handleRemoteRequest (SETURLPRESENT key url) =
setUrlPresent key url setUrlPresent key url
handleRemoteRequest (SETURLMISSING key url) = handleRemoteRequest (SETURLMISSING key url) =
@ -432,17 +438,17 @@ handleRequest' st external req mp responsehandler
send (VALUE "") -- end of list send (VALUE "") -- end of list
handleRemoteRequest (DEBUG msg) = liftIO $ debugM "external" msg handleRemoteRequest (DEBUG msg) = liftIO $ debugM "external" msg
handleRemoteRequest (INFO msg) = showInfo msg handleRemoteRequest (INFO msg) = showInfo msg
handleRemoteRequest (VERSION _) = handleRemoteRequest (VERSION _) = senderror "too late to send VERSION"
sendMessage st external (ERROR "too late to send VERSION")
handleAsyncMessage (ERROR err) = giveup $ "external special remote error: " ++ err handleAsyncMessage (ERROR err) = giveup $ "external special remote error: " ++ err
send = sendMessage st external send = sendMessage st external
senderror = sendMessage st external . ERROR
credstorage setting = CredPairStorage credstorage setting = CredPairStorage
{ credPairFile = base { credPairFile = base
, credPairEnvironment = (base ++ "login", base ++ "password") , credPairEnvironment = (base ++ "login", base ++ "password")
, credPairRemoteKey = setting , credPairRemoteField = setting
} }
where where
base = replace "/" "_" $ fromUUID (externalUUID external) ++ "-" ++ setting base = replace "/" "_" $ fromUUID (externalUUID external) ++ "-" ++ setting

8
Remote/External/Types.hs vendored
View file

@ -37,7 +37,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) import Types.Remote (RemoteConfig, RemoteStateHandle)
import Types.Export import Types.Export
import Types.Availability (Availability(..)) import Types.Availability (Availability(..))
import Types.Key import Types.Key
@ -57,16 +57,18 @@ data External = External
, externalLastPid :: TVar PID , externalLastPid :: TVar PID
, externalDefaultConfig :: RemoteConfig , externalDefaultConfig :: RemoteConfig
, externalGitConfig :: RemoteGitConfig , externalGitConfig :: RemoteGitConfig
, externalRemoteStateHandle :: Maybe RemoteStateHandle
} }
newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex External newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Maybe RemoteStateHandle -> Annex External
newExternal externaltype u c gc = liftIO $ External newExternal externaltype u c gc rs = liftIO $ External
<$> pure externaltype <$> pure externaltype
<*> pure u <*> pure u
<*> atomically (newTVar []) <*> atomically (newTVar [])
<*> atomically (newTVar 0) <*> atomically (newTVar 0)
<*> pure c <*> pure c
<*> pure gc <*> pure gc
<*> pure rs
type ExternalType = String type ExternalType = String

23
Remote/GCrypt.hs
View file

@ -65,16 +65,16 @@ remote = RemoteType
, importSupported = importUnsupported , importSupported = importUnsupported
} }
chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
chainGen gcryptr u c gc = do chainGen gcryptr u c gc rs = do
g <- gitRepo g <- gitRepo
-- get underlying git repo with real path, not gcrypt path -- get underlying git repo with real path, not gcrypt path
r <- liftIO $ Git.GCrypt.encryptedRemote g gcryptr r <- liftIO $ Git.GCrypt.encryptedRemote g gcryptr
let r' = r { Git.remoteName = Git.remoteName gcryptr } let r' = r { Git.remoteName = Git.remoteName gcryptr }
gen r' u c gc gen r' u c gc rs
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen baser u c gc = do gen baser u c gc rs = do
-- doublecheck that cache matches underlying repo's gcrypt-id -- doublecheck that cache matches underlying repo's gcrypt-id
-- (which might not be set), only for local repos -- (which might not be set), only for local repos
(mgcryptid, r) <- getGCryptId True baser gc (mgcryptid, r) <- getGCryptId True baser gc
@ -82,7 +82,7 @@ gen baser u c gc = do
case (mgcryptid, Git.GCrypt.remoteRepoId g (Git.remoteName baser)) of case (mgcryptid, Git.GCrypt.remoteRepoId g (Git.remoteName baser)) of
(Just gcryptid, Just cachedgcryptid) (Just gcryptid, Just cachedgcryptid)
| gcryptid /= cachedgcryptid -> resetup gcryptid r | gcryptid /= cachedgcryptid -> resetup gcryptid r
_ -> gen' r u c gc _ -> gen' r u c gc rs
where where
-- A different drive may have been mounted, making a different -- A different drive may have been mounted, making a different
-- gcrypt remote available. So need to set the cached -- gcrypt remote available. So need to set the cached
@ -95,15 +95,15 @@ gen baser u c gc = do
case (Git.remoteName baser, v) of case (Git.remoteName baser, v) of
(Just remotename, Just c') -> do (Just remotename, Just c') -> do
setGcryptEncryption c' remotename setGcryptEncryption c' remotename
setConfig (remoteConfig baser "uuid") (fromUUID u') storeUUIDIn (remoteConfig baser "uuid") u'
setConfig (ConfigKey $ Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid setConfig (ConfigKey $ Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid
gen' r u' c' gc gen' r u' c' gc rs
_ -> do _ -> do
warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r
return Nothing return Nothing
gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen' r u c gc = do gen' r u c gc rs = do
cst <- remoteCost gc $ cst <- remoteCost gc $
if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost
(rsynctransport, rsyncurl) <- rsyncTransportToObjects r gc (rsynctransport, rsyncurl) <- rsyncTransportToObjects r gc
@ -137,6 +137,7 @@ gen' r u c gc = do
, getInfo = gitRepoInfo this , getInfo = gitRepoInfo this
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
return $ Just $ specialRemote' specialcfg c return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this rsyncopts) (simplyPrepare $ store this rsyncopts)
@ -183,7 +184,7 @@ unsupportedUrl = giveup "using non-ssh remote repo url with gcrypt is not suppor
gCryptSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) gCryptSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
gCryptSetup _ mu _ c gc = go $ M.lookup "gitrepo" c gCryptSetup _ mu _ c gc = go $ M.lookup "gitrepo" c
where where
remotename = fromJust (M.lookup "name" c) remotename = fromJust (lookupName c)
go Nothing = giveup "Specify gitrepo=" go Nothing = giveup "Specify gitrepo="
go (Just gitrepo) = do go (Just gitrepo) = do
(c', _encsetup) <- encryptionSetup c gc (c', _encsetup) <- encryptionSetup c gc

20
Remote/Git.hs
View file

@ -32,6 +32,7 @@ import qualified Annex.Content
import qualified Annex.BranchState import qualified Annex.BranchState
import qualified Annex.Branch import qualified Annex.Branch
import qualified Annex.Url as Url import qualified Annex.Url as Url
import qualified Annex.SpecialRemote.Config as SpecialRemote
import Utility.Tmp import Utility.Tmp
import Config import Config
import Config.Cost import Config.Cost
@ -120,7 +121,7 @@ gitSetup (Enable _) (Just u) _ c _ = do
inRepo $ Git.Command.run inRepo $ Git.Command.run
[ Param "remote" [ Param "remote"
, Param "add" , Param "add"
, Param $ fromMaybe (giveup "no name") (M.lookup "name" c) , Param $ fromMaybe (giveup "no name") (SpecialRemote.lookupName c)
, Param $ fromMaybe (giveup "no location") (M.lookup "location" c) , Param $ fromMaybe (giveup "no location") (M.lookup "location" c)
] ]
return (c, u) return (c, u)
@ -145,17 +146,17 @@ configRead autoinit r = do
(False, _, NoUUID) -> tryGitConfigRead autoinit r (False, _, NoUUID) -> tryGitConfigRead autoinit r
_ -> return r _ -> return r
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc gen r u c gc rs
-- Remote.GitLFS may be used with a repo that is also encrypted -- Remote.GitLFS may be used with a repo that is also encrypted
-- with gcrypt so is checked first. -- with gcrypt so is checked first.
| remoteAnnexGitLFS gc = Remote.GitLFS.gen r u c gc | remoteAnnexGitLFS gc = Remote.GitLFS.gen r u c gc rs
| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc | Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc rs
| otherwise = case repoP2PAddress r of | otherwise = case repoP2PAddress r of
Nothing -> do Nothing -> do
st <- mkState r u gc st <- mkState r u gc
go st <$> remoteCost gc defcst go st <$> remoteCost gc defcst
Just addr -> Remote.P2P.chainGen addr r u c gc Just addr -> Remote.P2P.chainGen addr r u c gc rs
where where
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
go st cst = Just new go st cst = Just new
@ -189,14 +190,15 @@ gen r u c gc
, appendonly = False , appendonly = False
, availability = availabilityCalc r , availability = availabilityCalc r
, remotetype = remote , remotetype = remote
, mkUnavailable = unavailable r u c gc , mkUnavailable = unavailable r u c gc rs
, getInfo = gitRepoInfo new , getInfo = gitRepoInfo new
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
unavailable r u c gc = gen r' u c gc unavailable r = gen r'
where where
r' = case Git.location r of r' = case Git.location r of
Git.Local { Git.gitdir = d } -> Git.Local { Git.gitdir = d } ->

47
Remote/GitLFS.hs
View file

@ -57,8 +57,8 @@ remote = RemoteType
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = do gen r u c gc rs = do
-- If the repo uses gcrypt, get the underlaying repo without the -- If the repo uses gcrypt, get the underlaying repo without the
-- gcrypt url, to do LFS endpoint discovery on. -- gcrypt url, to do LFS endpoint discovery on.
r' <- if Git.GCrypt.isEncrypted r r' <- if Git.GCrypt.isEncrypted r
@ -70,10 +70,10 @@ gen r u c gc = do
h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
return $ Just $ specialRemote' specialcfg c return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store u h) (simplyPrepare $ store rs h)
(simplyPrepare $ retrieve u h) (simplyPrepare $ retrieve rs h)
(simplyPrepare $ remove h) (simplyPrepare $ remove h)
(simplyPrepare $ checkKey u h) (simplyPrepare $ checkKey rs h)
(this cst) (this cst)
where where
this cst = Remote this cst = Remote
@ -109,6 +109,7 @@ gen r u c gc = do
, getInfo = gitRepoInfo (this cst) , getInfo = gitRepoInfo (this cst)
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
specialcfg = (specialRemoteCfg c) specialcfg = (specialRemoteCfg c)
-- chunking would not improve git-lfs -- chunking would not improve git-lfs
@ -157,7 +158,7 @@ mySetup _ mu _ c gc = do
return (c'', u) return (c'', u)
where where
url = fromMaybe (giveup "Specify url=") (M.lookup "url" c) url = fromMaybe (giveup "Specify url=") (M.lookup "url" c)
remotename = fromJust (M.lookup "name" c) remotename = fromJust (lookupName c)
data LFSHandle = LFSHandle data LFSHandle = LFSHandle
{ downloadEndpoint :: Maybe LFS.Endpoint { downloadEndpoint :: Maybe LFS.Endpoint
@ -327,8 +328,8 @@ extractKeySize k
| isEncKey k = Nothing | isEncKey k = Nothing
| otherwise = keySize k | otherwise = keySize k
mkUploadRequest :: UUID -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer) mkUploadRequest :: RemoteStateHandle -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer)
mkUploadRequest u k content = case (extractKeySha256 k, extractKeySize k) of mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of
(Just sha256, Just size) -> (Just sha256, Just size) ->
ret sha256 size ret sha256 size
(_, Just size) -> do (_, Just size) -> do
@ -355,12 +356,12 @@ mkUploadRequest u k content = case (extractKeySha256 k, extractKeySize k) of
} }
return (req, sha256, size) return (req, sha256, size)
remembersha256 sha256 = setRemoteState u k (T.unpack sha256) remembersha256 sha256 = setRemoteState rs k (T.unpack sha256)
rememberboth sha256 size = setRemoteState u k $ rememberboth sha256 size = setRemoteState rs k $
show size ++ " " ++ T.unpack sha256 show size ++ " " ++ T.unpack sha256
mkDownloadRequest :: UUID -> Key -> Annex (Maybe (LFS.TransferRequest, LFS.SHA256, Integer)) mkDownloadRequest :: RemoteStateHandle -> Key -> Annex (Maybe (LFS.TransferRequest, LFS.SHA256, Integer))
mkDownloadRequest u k = case (extractKeySha256 k, extractKeySize k) of mkDownloadRequest rs k = case (extractKeySha256 k, extractKeySize k) of
(Just sha256, Just size) -> ret sha256 size (Just sha256, Just size) -> ret sha256 size
(_, Just size) -> (_, Just size) ->
remembersha256 >>= \case remembersha256 >>= \case
@ -383,8 +384,8 @@ mkDownloadRequest u k = case (extractKeySha256 k, extractKeySize k) of
, LFS.req_objects = [obj] , LFS.req_objects = [obj]
} }
return $ Just (req, sha256, size) return $ Just (req, sha256, size)
remembersha256 = fmap T.pack <$> getRemoteState u k remembersha256 = fmap T.pack <$> getRemoteState rs k
rememberboth = maybe Nothing parse <$> getRemoteState u k rememberboth = maybe Nothing parse <$> getRemoteState rs k
where where
parse s = case words s of parse s = case words s of
[ssize, ssha256] -> do [ssize, ssha256] -> do
@ -392,11 +393,11 @@ mkDownloadRequest u k = case (extractKeySha256 k, extractKeySize k) of
return (T.pack ssha256, size) return (T.pack ssha256, size)
_ -> Nothing _ -> Nothing
store :: UUID -> TVar LFSHandle -> Storer store :: RemoteStateHandle -> TVar LFSHandle -> Storer
store u h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \case store rs h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \case
Nothing -> return False Nothing -> return False
Just endpoint -> flip catchNonAsync failederr $ do Just endpoint -> flip catchNonAsync failederr $ do
(req, sha256, size) <- mkUploadRequest u k src (req, sha256, size) <- mkUploadRequest rs k src
sendTransferRequest req endpoint >>= \case sendTransferRequest req endpoint >>= \case
Left err -> do Left err -> do
warning err warning err
@ -424,10 +425,10 @@ store u h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \cas
warning (show e) warning (show e)
return False return False
retrieve :: UUID -> TVar LFSHandle -> Retriever retrieve :: RemoteStateHandle -> TVar LFSHandle -> Retriever
retrieve u h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h >>= \case retrieve rs h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h >>= \case
Nothing -> giveup "unable to connect to git-lfs endpoint" Nothing -> giveup "unable to connect to git-lfs endpoint"
Just endpoint -> mkDownloadRequest u k >>= \case Just endpoint -> mkDownloadRequest rs k >>= \case
Nothing -> giveup "unable to download this object from git-lfs" Nothing -> giveup "unable to download this object from git-lfs"
Just (req, sha256, size) -> sendTransferRequest req endpoint >>= \case Just (req, sha256, size) -> sendTransferRequest req endpoint >>= \case
Left err -> giveup (show err) Left err -> giveup (show err)
@ -448,10 +449,10 @@ retrieve u h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h
uo <- getUrlOptions uo <- getUrlOptions
liftIO $ downloadConduit p req dest uo liftIO $ downloadConduit p req dest uo
checkKey :: UUID -> TVar LFSHandle -> CheckPresent checkKey :: RemoteStateHandle -> TVar LFSHandle -> CheckPresent
checkKey u h key = getLFSEndpoint LFS.RequestDownload h >>= \case checkKey rs h key = getLFSEndpoint LFS.RequestDownload h >>= \case
Nothing -> giveup "unable to connect to git-lfs endpoint" Nothing -> giveup "unable to connect to git-lfs endpoint"
Just endpoint -> mkDownloadRequest u key >>= \case Just endpoint -> mkDownloadRequest rs key >>= \case
-- Unable to find enough information to request the key -- Unable to find enough information to request the key
-- from git-lfs, so it's not present there. -- from git-lfs, so it's not present there.
Nothing -> return False Nothing -> return False

7
Remote/Glacier.hs
View file

@ -39,8 +39,8 @@ remote = RemoteType
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost gen r u c gc rs = new <$> remoteCost gc veryExpensiveRemoteCost
where where
new cst = Just $ specialRemote' specialcfg c new cst = Just $ specialRemote' specialcfg c
(prepareStore this) (prepareStore this)
@ -83,6 +83,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
[ ("glacier vault", getVault c) ] [ ("glacier vault", getVault c) ]
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
specialcfg = (specialRemoteCfg c) specialcfg = (specialRemoteCfg c)
-- Disabled until jobList gets support for chunks. -- Disabled until jobList gets support for chunks.
@ -104,7 +105,7 @@ glacierSetup' ss u mcreds c gc = do
gitConfigSpecialRemote u fullconfig [("glacier", "true")] gitConfigSpecialRemote u fullconfig [("glacier", "true")]
return (fullconfig, u) return (fullconfig, u)
where where
remotename = fromJust (M.lookup "name" c) remotename = fromJust (lookupName c)
defvault = remotename ++ "-" ++ fromUUID u defvault = remotename ++ "-" ++ fromUUID u
defaults = M.fromList defaults = M.fromList
[ ("datacenter", T.unpack $ AWS.defaultRegion AWS.Glacier) [ ("datacenter", T.unpack $ AWS.defaultRegion AWS.Glacier)

2
Remote/Helper/AWS.hs
View file

@ -23,7 +23,7 @@ creds :: UUID -> CredPairStorage
creds u = CredPairStorage creds u = CredPairStorage
{ credPairFile = fromUUID u { credPairFile = fromUUID u
, credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY") , credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY")
, credPairRemoteKey = "s3creds" , credPairRemoteField = "s3creds"
} }
data Service = S3 | Glacier data Service = S3 | Glacier

5
Remote/Helper/Chunked.hs
View file

@ -25,6 +25,7 @@ import Logs.Chunk
import Utility.Metered import Utility.Metered
import Crypto (EncKey) import Crypto (EncKey)
import Backend (isStableKey) import Backend (isStableKey)
import Annex.SpecialRemote.Config
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M import qualified Data.Map as M
@ -49,11 +50,11 @@ noChunks _ = False
getChunkConfig :: RemoteConfig -> ChunkConfig getChunkConfig :: RemoteConfig -> ChunkConfig
getChunkConfig m = getChunkConfig m =
case M.lookup "chunksize" m of case M.lookup chunksizeField m of
Nothing -> case M.lookup "chunk" m of Nothing -> case M.lookup "chunk" m of
Nothing -> NoChunks Nothing -> NoChunks
Just v -> readsz UnpaddedChunks v "chunk" Just v -> readsz UnpaddedChunks v "chunk"
Just v -> readsz LegacyChunks v "chunksize" Just v -> readsz LegacyChunks v chunksizeField
where where
readsz c v f = case readSize dataUnits v of readsz c v f = case readSize dataUnits v of
Just size Just size

27
Remote/Helper/Encryptable.hs
View file

@ -29,6 +29,7 @@ import Config
import Crypto import Crypto
import Types.Crypto import Types.Crypto
import qualified Annex import qualified Annex
import Annex.SpecialRemote.Config
-- Used to ensure that encryption has been set up before trying to -- Used to ensure that encryption has been set up before trying to
-- eg, store creds in the remote config that would need to use the -- eg, store creds in the remote config that would need to use the
@ -55,7 +56,7 @@ encryptionSetup c gc = do
maybe (genCipher cmd) (updateCipher cmd) (extractCipher c) maybe (genCipher cmd) (updateCipher cmd) (extractCipher c)
where where
-- The type of encryption -- The type of encryption
encryption = M.lookup "encryption" c encryption = M.lookup encryptionField c
-- Generate a new cipher, depending on the chosen encryption scheme -- Generate a new cipher, depending on the chosen encryption scheme
genCipher cmd = case encryption of genCipher cmd = case encryption of
_ | hasEncryptionConfig c -> cannotchange _ | hasEncryptionConfig c -> cannotchange
@ -68,7 +69,7 @@ encryptionSetup c gc = do
Just "pubkey" -> encsetup $ genEncryptedCipher cmd (c, gc) key PubKey Just "pubkey" -> encsetup $ genEncryptedCipher cmd (c, gc) key PubKey
Just "sharedpubkey" -> encsetup $ genSharedPubKeyCipher cmd key Just "sharedpubkey" -> encsetup $ genSharedPubKeyCipher cmd key
_ -> giveup $ "Specify " ++ intercalate " or " _ -> giveup $ "Specify " ++ intercalate " or "
(map ("encryption=" ++) (map ((encryptionField ++ "=") ++)
["none","shared","hybrid","pubkey", "sharedpubkey"]) ["none","shared","hybrid","pubkey", "sharedpubkey"])
++ "." ++ "."
key = fromMaybe (giveup "Specify keyid=...") $ M.lookup "keyid" c key = fromMaybe (giveup "Specify keyid=...") $ M.lookup "keyid" c
@ -130,30 +131,30 @@ remoteCipher' c gc = go $ extractCipher c
embedCreds :: RemoteConfig -> Bool embedCreds :: RemoteConfig -> Bool
embedCreds c = case yesNo =<< M.lookup "embedcreds" c of embedCreds c = case yesNo =<< M.lookup "embedcreds" c of
Just v -> v Just v -> v
Nothing -> isJust (M.lookup "cipherkeys" c) && isJust (M.lookup "cipher" c) Nothing -> isJust (M.lookup cipherkeysField c) && isJust (M.lookup cipherField c)
{- Gets encryption Cipher, and key encryptor. -} {- Gets encryption Cipher, and key encryptor. -}
cipherKey :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey)) cipherKey :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey))
cipherKey c gc = fmap make <$> remoteCipher c gc cipherKey c gc = fmap make <$> remoteCipher c gc
where where
make ciphertext = (ciphertext, encryptKey mac ciphertext) make ciphertext = (ciphertext, encryptKey mac ciphertext)
mac = fromMaybe defaultMac $ M.lookup "mac" c >>= readMac mac = fromMaybe defaultMac $ M.lookup macField c >>= readMac
{- Stores an StorableCipher in a remote's configuration. -} {- Stores an StorableCipher in a remote's configuration. -}
storeCipher :: StorableCipher -> RemoteConfig -> RemoteConfig storeCipher :: StorableCipher -> RemoteConfig -> RemoteConfig
storeCipher cip = case cip of storeCipher cip = case cip of
(SharedCipher t) -> addcipher t (SharedCipher t) -> addcipher t
(EncryptedCipher t _ ks) -> addcipher t . storekeys ks "cipherkeys" (EncryptedCipher t _ ks) -> addcipher t . storekeys ks cipherkeysField
(SharedPubKeyCipher t ks) -> addcipher t . storekeys ks "pubkeys" (SharedPubKeyCipher t ks) -> addcipher t . storekeys ks pubkeysField
where where
addcipher t = M.insert "cipher" (toB64bs t) addcipher t = M.insert cipherField (toB64bs t)
storekeys (KeyIds l) n = M.insert n (intercalate "," l) storekeys (KeyIds l) n = M.insert n (intercalate "," l)
{- Extracts an StorableCipher from a remote's configuration. -} {- Extracts an StorableCipher from a remote's configuration. -}
extractCipher :: RemoteConfig -> Maybe StorableCipher extractCipher :: RemoteConfig -> Maybe StorableCipher
extractCipher c = case (M.lookup "cipher" c, extractCipher c = case (M.lookup cipherField c,
M.lookup "cipherkeys" c <|> M.lookup "pubkeys" c, M.lookup cipherkeysField c <|> M.lookup pubkeysField c,
M.lookup "encryption" c) of M.lookup encryptionField c) of
(Just t, Just ks, encryption) | maybe True (== "hybrid") encryption -> (Just t, Just ks, encryption) | maybe True (== "hybrid") encryption ->
Just $ EncryptedCipher (fromB64bs t) Hybrid (readkeys ks) Just $ EncryptedCipher (fromB64bs t) Hybrid (readkeys ks)
(Just t, Just ks, Just "pubkey") -> (Just t, Just ks, Just "pubkey") ->
@ -167,13 +168,15 @@ extractCipher c = case (M.lookup "cipher" c,
readkeys = KeyIds . splitc ',' readkeys = KeyIds . splitc ','
isEncrypted :: RemoteConfig -> Bool isEncrypted :: RemoteConfig -> Bool
isEncrypted c = case M.lookup "encryption" c of isEncrypted c = case M.lookup encryptionField c of
Just "none" -> False Just "none" -> False
Just _ -> True Just _ -> True
Nothing -> hasEncryptionConfig c Nothing -> hasEncryptionConfig c
hasEncryptionConfig :: RemoteConfig -> Bool hasEncryptionConfig :: RemoteConfig -> Bool
hasEncryptionConfig c = M.member "cipher" c || M.member "cipherkeys" c || M.member "pubkeys" c hasEncryptionConfig c = M.member cipherField c
|| M.member cipherkeysField c
|| M.member pubkeysField c
describeEncryption :: RemoteConfig -> String describeEncryption :: RemoteConfig -> String
describeEncryption c = case extractCipher c of describeEncryption c = case extractCipher c of

12
Remote/Helper/ExportImport.hs
View file

@ -99,8 +99,8 @@ adjustExportImportRemoteType rt = rt { setup = setup' }
-- | Adjust a remote to support exporttree=yes and importree=yes. -- | Adjust a remote to support exporttree=yes and importree=yes.
-- --
-- Note that all remotes with importree=yes also have exporttree=yes. -- Note that all remotes with importree=yes also have exporttree=yes.
adjustExportImport :: Remote -> Annex Remote adjustExportImport :: Remote -> RemoteStateHandle -> Annex Remote
adjustExportImport r = case M.lookup "exporttree" (config r) of adjustExportImport r rs = case M.lookup "exporttree" (config r) of
Nothing -> return $ notexport r Nothing -> return $ notexport r
Just c -> case yesNo c of Just c -> case yesNo c of
Just True -> ifM (isExportSupported r) Just True -> ifM (isExportSupported r)
@ -136,7 +136,7 @@ adjustExportImport r = case M.lookup "exporttree" (config r) of
let keycids k = do let keycids k = do
db <- getciddb ciddbv db <- getciddb ciddbv
liftIO $ ContentIdentifier.getContentIdentifiers db (uuid r') k liftIO $ ContentIdentifier.getContentIdentifiers db rs k
let checkpresent k loc = let checkpresent k loc =
checkPresentExportWithContentIdentifier checkPresentExportWithContentIdentifier
@ -152,16 +152,16 @@ adjustExportImport r = case M.lookup "exporttree" (config r) of
updateexportdb exportdb exportdbv updateexportdb exportdb exportdbv
oldks <- liftIO $ Export.getExportTreeKey exportdb loc oldks <- liftIO $ Export.getExportTreeKey exportdb loc
oldcids <- liftIO $ concat oldcids <- liftIO $ concat
<$> mapM (ContentIdentifier.getContentIdentifiers db (uuid r')) oldks <$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks
storeExportWithContentIdentifier (importActions r') f k loc oldcids p >>= \case storeExportWithContentIdentifier (importActions r') f k loc oldcids p >>= \case
Left err -> do Left err -> do
warning err warning err
return False return False
Right newcid -> do Right newcid -> do
withExclusiveLock gitAnnexContentIdentifierLock $ do withExclusiveLock gitAnnexContentIdentifierLock $ do
liftIO $ ContentIdentifier.recordContentIdentifier db (uuid r') newcid k liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k
liftIO $ ContentIdentifier.flushDbQueue db liftIO $ ContentIdentifier.flushDbQueue db
recordContentIdentifier (uuid r') newcid k recordContentIdentifier rs newcid k
return True return True
, removeExport = \k loc -> , removeExport = \k loc ->
removeExportWithContentIdentifier (importActions r') k loc removeExportWithContentIdentifier (importActions r') k loc

5
Remote/Helper/Special.hs
View file

@ -30,14 +30,17 @@ module Remote.Helper.Special (
specialRemoteCfg, specialRemoteCfg,
specialRemote, specialRemote,
specialRemote', specialRemote',
lookupName,
module X module X
) where ) where
import Annex.Common import Annex.Common
import qualified Annex import qualified Annex
import Annex.SpecialRemote.Config
import Types.StoreRetrieve import Types.StoreRetrieve
import Types.Remote import Types.Remote
import Crypto import Crypto
import Annex.UUID
import Config import Config
import Config.Cost import Config.Cost
import Utility.Metered import Utility.Metered
@ -70,7 +73,7 @@ gitConfigSpecialRemote :: UUID -> RemoteConfig -> [(String, String)] -> Annex ()
gitConfigSpecialRemote u c cfgs = do gitConfigSpecialRemote u c cfgs = do
forM_ cfgs $ \(k, v) -> forM_ cfgs $ \(k, v) ->
setConfig (remoteConfig c k) v setConfig (remoteConfig c k) v
setConfig (remoteConfig c "uuid") (fromUUID u) storeUUIDIn (remoteConfig c "uuid") u
-- RetrievalVerifiableKeysSecure unless overridden by git config. -- RetrievalVerifiableKeysSecure unless overridden by git config.
-- --

10
Remote/Hook.hs
View file

@ -35,8 +35,8 @@ remote = RemoteType
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = do gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
return $ Just $ specialRemote c return $ Just $ specialRemote c
(simplyPrepare $ store hooktype) (simplyPrepare $ store hooktype)
@ -70,11 +70,13 @@ gen r u c gc = do
, appendonly = False , appendonly = False
, availability = GloballyAvailable , availability = GloballyAvailable
, remotetype = remote , remotetype = remote
, mkUnavailable = gen r u c $ , mkUnavailable = gen r u c
gc { remoteAnnexHookType = Just "!dne!" } (gc { remoteAnnexHookType = Just "!dne!" })
rs
, getInfo = return [("hooktype", hooktype)] , getInfo = return [("hooktype", hooktype)]
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
where where
hooktype = fromMaybe (giveup "missing hooktype") $ remoteAnnexHookType gc hooktype = fromMaybe (giveup "missing hooktype") $ remoteAnnexHookType gc

15
Remote/List.hs
View file

@ -1,12 +1,12 @@
{-# LANGUAGE CPP #-}
{- git-annex remote list {- git-annex remote list
- -
- Copyright 2011,2012 Joey Hess <id@joeyh.name> - Copyright 2011-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE CPP #-}
module Remote.List where module Remote.List where
import qualified Data.Map as M import qualified Data.Map as M
@ -15,6 +15,7 @@ import Annex.Common
import qualified Annex import qualified Annex
import Logs.Remote import Logs.Remote
import Types.Remote import Types.Remote
import Types.RemoteState
import Annex.UUID import Annex.UUID
import Remote.Helper.Hooks import Remote.Helper.Hooks
import Remote.Helper.ReadOnly import Remote.Helper.ReadOnly
@ -105,10 +106,12 @@ remoteGen :: M.Map UUID RemoteConfig -> RemoteType -> Git.Repo -> Annex (Maybe R
remoteGen m t g = do remoteGen m t g = do
u <- getRepoUUID g u <- getRepoUUID g
gc <- Annex.getRemoteGitConfig g gc <- Annex.getRemoteGitConfig g
let c = fromMaybe M.empty $ M.lookup u m let cu = fromMaybe u $ remoteAnnexConfigUUID gc
generate t g u c gc >>= \case let rs = RemoteStateHandle cu
let c = fromMaybe M.empty $ M.lookup cu m
generate t g u c gc rs >>= \case
Nothing -> return Nothing Nothing -> return Nothing
Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs
{- Updates a local git Remote, re-reading its git config. -} {- Updates a local git Remote, re-reading its git config. -}
updateRemote :: Remote -> Annex (Maybe Remote) updateRemote :: Remote -> Annex (Maybe Remote)

7
Remote/P2P.hs
View file

@ -35,14 +35,14 @@ remote = RemoteType
-- Remote.Git takes care of enumerating P2P remotes, -- Remote.Git takes care of enumerating P2P remotes,
-- and will call chainGen on them. -- and will call chainGen on them.
, enumerate = const (return []) , enumerate = const (return [])
, generate = \_ _ _ _ -> return Nothing , generate = \_ _ _ _ _ -> return Nothing
, setup = error "P2P remotes are set up using git-annex p2p" , setup = error "P2P remotes are set up using git-annex p2p"
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , importSupported = importUnsupported
} }
chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
chainGen addr r u c gc = do chainGen addr r u c gc rs = do
connpool <- mkConnectionPool connpool <- mkConnectionPool
cst <- remoteCost gc veryExpensiveRemoteCost cst <- remoteCost gc veryExpensiveRemoteCost
let protorunner = runProto u addr connpool let protorunner = runProto u addr connpool
@ -76,6 +76,7 @@ chainGen addr r u c gc = do
, getInfo = gitRepoInfo this , getInfo = gitRepoInfo this
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
return (Just this) return (Just this)

5
Remote/Rsync.hs
View file

@ -54,8 +54,8 @@ remote = RemoteType
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = do gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
(transport, url) <- rsyncTransport gc $ (transport, url) <- rsyncTransport gc $
fromMaybe (giveup "missing rsyncurl") $ remoteAnnexRsyncUrl gc fromMaybe (giveup "missing rsyncurl") $ remoteAnnexRsyncUrl gc
@ -104,6 +104,7 @@ gen r u c gc = do
, getInfo = return [("url", url)] , getInfo = return [("url", url)]
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
where where
specialcfg = (specialRemoteCfg c) specialcfg = (specialRemoteCfg c)

134
Remote/S3.hs
View file

@ -44,6 +44,7 @@ import qualified Git
import qualified Annex import qualified Annex
import Config import Config
import Config.Cost import Config.Cost
import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Http import Remote.Helper.Http
import Remote.Helper.Messages import Remote.Helper.Messages
@ -77,8 +78,8 @@ remote = RemoteType
, importSupported = importIsSupported , importSupported = importIsSupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = do gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
info <- extractS3Info c info <- extractS3Info c
hdl <- mkS3HandleVar c gc u hdl <- mkS3HandleVar c gc u
@ -87,9 +88,9 @@ gen r u c gc = do
where where
new cst info hdl magic = Just $ specialRemote c new cst info hdl magic = Just $ specialRemote c
(simplyPrepare $ store hdl this info magic) (simplyPrepare $ store hdl this info magic)
(simplyPrepare $ retrieve hdl this c info) (simplyPrepare $ retrieve hdl this rs c info)
(simplyPrepare $ remove hdl this info) (simplyPrepare $ remove hdl this info)
(simplyPrepare $ checkKey hdl this c info) (simplyPrepare $ checkKey hdl this rs c info)
this this
where where
this = Remote this = Remote
@ -107,23 +108,23 @@ gen r u c gc = do
, checkPresent = checkPresentDummy , checkPresent = checkPresentDummy
, checkPresentCheap = False , checkPresentCheap = False
, exportActions = ExportActions , exportActions = ExportActions
{ storeExport = storeExportS3 hdl this info magic { storeExport = storeExportS3 hdl this rs info magic
, retrieveExport = retrieveExportS3 hdl this info , retrieveExport = retrieveExportS3 hdl this info
, removeExport = removeExportS3 hdl this info , removeExport = removeExportS3 hdl this rs info
, checkPresentExport = checkPresentExportS3 hdl this info , checkPresentExport = checkPresentExportS3 hdl this info
-- S3 does not have directories. -- S3 does not have directories.
, removeExportDirectory = Nothing , removeExportDirectory = Nothing
, renameExport = renameExportS3 hdl this info , renameExport = renameExportS3 hdl this rs info
} }
, importActions = ImportActions , importActions = ImportActions
{ listImportableContents = listImportableContentsS3 hdl this info { listImportableContents = listImportableContentsS3 hdl this info
, retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierS3 hdl this info , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierS3 hdl this rs info
, storeExportWithContentIdentifier = storeExportWithContentIdentifierS3 hdl this info magic , storeExportWithContentIdentifier = storeExportWithContentIdentifierS3 hdl this rs info magic
, removeExportWithContentIdentifier = removeExportWithContentIdentifierS3 hdl this info , removeExportWithContentIdentifier = removeExportWithContentIdentifierS3 hdl this rs info
, removeExportDirectoryWhenEmpty = Nothing , removeExportDirectoryWhenEmpty = Nothing
, checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierS3 hdl this info , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierS3 hdl this info
} }
, whereisKey = Just (getPublicWebUrls u info c) , whereisKey = Just (getPublicWebUrls u rs info c)
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
@ -134,10 +135,11 @@ gen r u c gc = do
, appendonly = versioning info , appendonly = versioning info
, availability = GloballyAvailable , availability = GloballyAvailable
, remotetype = remote , remotetype = remote
, mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc , mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc rs
, getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info) , getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info)
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
s3Setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) s3Setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
@ -150,7 +152,7 @@ s3Setup' ss u mcreds c gc
| configIA c = archiveorg | configIA c = archiveorg
| otherwise = defaulthost | otherwise = defaulthost
where where
remotename = fromJust (M.lookup "name" c) remotename = fromJust (lookupName c)
defbucket = remotename ++ "-" ++ fromUUID u defbucket = remotename ++ "-" ++ fromUUID u
defaults = M.fromList defaults = M.fromList
[ ("datacenter", T.unpack $ AWS.defaultRegion AWS.S3) [ ("datacenter", T.unpack $ AWS.defaultRegion AWS.S3)
@ -188,7 +190,7 @@ s3Setup' ss u mcreds c gc
-- IA acdepts x-amz-* as an alias for x-archive-* -- IA acdepts x-amz-* as an alias for x-archive-*
M.mapKeys (replace "x-archive-" "x-amz-") $ M.mapKeys (replace "x-archive-" "x-amz-") $
-- encryption does not make sense here -- encryption does not make sense here
M.insert "encryption" "none" $ M.insert encryptionField "none" $
M.insert "bucket" validbucket $ M.insert "bucket" validbucket $
M.union c' $ M.union c' $
-- special constraints on key names -- special constraints on key names
@ -292,16 +294,16 @@ storeHelper info h magic f object p = liftIO $ case partSize info of
{- Implemented as a fileRetriever, that uses conduit to stream the chunks {- Implemented as a fileRetriever, that uses conduit to stream the chunks
- out to the file. Would be better to implement a byteRetriever, but - out to the file. Would be better to implement a byteRetriever, but
- that is difficult. -} - that is difficult. -}
retrieve :: S3HandleVar -> Remote -> RemoteConfig -> S3Info -> Retriever retrieve :: S3HandleVar -> Remote -> RemoteStateHandle -> RemoteConfig -> S3Info -> Retriever
retrieve hv r c info = fileRetriever $ \f k p -> withS3Handle hv $ \case retrieve hv r rs c info = fileRetriever $ \f k p -> withS3Handle hv $ \case
(Just h) -> (Just h) ->
eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case
Left failreason -> do Left failreason -> do
warning failreason warning failreason
giveup "cannot download content" giveup "cannot download content"
Right loc -> retrieveHelper info h loc f p Right loc -> retrieveHelper info h loc f p
Nothing -> Nothing ->
getPublicWebUrls' (uuid r) info c k >>= \case getPublicWebUrls' (uuid r) rs info c k >>= \case
Left failreason -> do Left failreason -> do
warning failreason warning failreason
giveup "cannot download content" giveup "cannot download content"
@ -329,17 +331,17 @@ remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> liftIO $ runResource
S3.DeleteObject (T.pack $ bucketObject info k) (bucket info) S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
return $ either (const False) (const True) res return $ either (const False) (const True) res
checkKey :: S3HandleVar -> Remote -> RemoteConfig -> S3Info -> CheckPresent checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> RemoteConfig -> S3Info -> CheckPresent
checkKey hv r c info k = withS3Handle hv $ \case checkKey hv r rs c info k = withS3Handle hv $ \case
Just h -> do Just h -> do
showChecking r showChecking r
eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case
Left failreason -> do Left failreason -> do
warning failreason warning failreason
giveup "cannot check content" giveup "cannot check content"
Right loc -> checkKeyHelper info h loc Right loc -> checkKeyHelper info h loc
Nothing -> Nothing ->
getPublicWebUrls' (uuid r) info c k >>= \case getPublicWebUrls' (uuid r) rs info c k >>= \case
Left failreason -> do Left failreason -> do
warning failreason warning failreason
giveup "cannot check content" giveup "cannot check content"
@ -365,12 +367,12 @@ checkKeyHelper' info h o limit = liftIO $ runResourceT $ do
where where
req = limit $ S3.headObject (bucket info) o req = limit $ S3.headObject (bucket info) o
storeExportS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportS3 hv r info magic f k loc p = fst storeExportS3 hv r rs info magic f k loc p = fst
<$> storeExportS3' hv r info magic f k loc p <$> storeExportS3' hv r rs info magic f k loc p
storeExportS3' :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Bool, (Maybe S3Etag, Maybe S3VersionID)) storeExportS3' :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Bool, (Maybe S3Etag, Maybe S3VersionID))
storeExportS3' hv r info magic f k loc p = withS3Handle hv $ \case storeExportS3' hv r rs info magic f k loc p = withS3Handle hv $ \case
Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return (False, (Nothing, Nothing))) Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return (False, (Nothing, Nothing)))
Nothing -> do Nothing -> do
warning $ needS3Creds (uuid r) warning $ needS3Creds (uuid r)
@ -379,7 +381,7 @@ storeExportS3' hv r info magic f k loc p = withS3Handle hv $ \case
go h = do go h = do
let o = T.pack $ bucketExportLocation info loc let o = T.pack $ bucketExportLocation info loc
(metag, mvid) <- storeHelper info h magic f o p (metag, mvid) <- storeHelper info h magic f o p
setS3VersionID info (uuid r) k mvid setS3VersionID info rs k mvid
return (True, (metag, mvid)) return (True, (metag, mvid))
retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
@ -398,9 +400,9 @@ retrieveExportS3 hv r info _k loc f p =
liftIO . Url.download p (geturl exportloc) f liftIO . Url.download p (geturl exportloc) f
exportloc = bucketExportLocation info loc exportloc = bucketExportLocation info loc
removeExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> Annex Bool removeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> Annex Bool
removeExportS3 hv r info k loc = withS3Handle hv $ \case removeExportS3 hv r rs info k loc = withS3Handle hv $ \case
Just h -> checkVersioning info (uuid r) k $ Just h -> checkVersioning info rs k $
catchNonAsync (go h) (\e -> warning (show e) >> return False) catchNonAsync (go h) (\e -> warning (show e) >> return False)
Nothing -> do Nothing -> do
warning $ needS3Creds (uuid r) warning $ needS3Creds (uuid r)
@ -422,11 +424,11 @@ checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case
giveup "No S3 credentials configured" giveup "No S3 credentials configured"
-- S3 has no move primitive; copy and delete. -- S3 has no move primitive; copy and delete.
renameExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) renameExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)
renameExportS3 hv r info k src dest = Just <$> go renameExportS3 hv r rs info k src dest = Just <$> go
where where
go = withS3Handle hv $ \case go = withS3Handle hv $ \case
Just h -> checkVersioning info (uuid r) k $ Just h -> checkVersioning info rs k $
catchNonAsync (go' h) (\_ -> return False) catchNonAsync (go' h) (\_ -> return False)
Nothing -> do Nothing -> do
warning $ needS3Creds (uuid r) warning $ needS3Creds (uuid r)
@ -542,8 +544,8 @@ mkImportableContentsVersioned info = build . groupfiles
| otherwise = | otherwise =
i : removemostrecent mtime rest i : removemostrecent mtime rest
retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Annex (Maybe Key) -> MeterUpdate -> Annex (Maybe Key) retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Annex (Maybe Key) -> MeterUpdate -> Annex (Maybe Key)
retrieveExportWithContentIdentifierS3 hv r info loc cid dest mkkey p = withS3Handle hv $ \case retrieveExportWithContentIdentifierS3 hv r rs info loc cid dest mkkey p = withS3Handle hv $ \case
Nothing -> do Nothing -> do
warning $ needS3Creds (uuid r) warning $ needS3Creds (uuid r)
return Nothing return Nothing
@ -554,7 +556,7 @@ retrieveExportWithContentIdentifierS3 hv r info loc cid dest mkkey p = withS3Han
mk <- mkkey mk <- mkkey
case (mk, extractContentIdentifier cid o) of case (mk, extractContentIdentifier cid o) of
(Just k, Right vid) -> (Just k, Right vid) ->
setS3VersionID info (uuid r) k vid setS3VersionID info rs k vid
_ -> noop _ -> noop
return mk return mk
where where
@ -576,8 +578,8 @@ rewritePreconditionException a = catchJust (Url.matchStatusCodeException want) a
-- --
-- When the bucket is not versioned, data loss can result. -- When the bucket is not versioned, data loss can result.
-- This is why that configuration requires --force to enable. -- This is why that configuration requires --force to enable.
storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier) storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier)
storeExportWithContentIdentifierS3 hv r info magic src k loc _overwritablecids p storeExportWithContentIdentifierS3 hv r rs info magic src k loc _overwritablecids p
| versioning info = go | versioning info = go
-- FIXME Actual aws version that supports getting Etag for a store -- FIXME Actual aws version that supports getting Etag for a store
-- is not known; patch not merged yet. -- is not known; patch not merged yet.
@ -589,7 +591,7 @@ storeExportWithContentIdentifierS3 hv r info magic src k loc _overwritablecids p
Left "git-annex is built with too old a version of the aws library to support this operation" Left "git-annex is built with too old a version of the aws library to support this operation"
#endif #endif
where where
go = storeExportS3' hv r info magic src k loc p >>= \case go = storeExportS3' hv r rs info magic src k loc p >>= \case
(False, _) -> return $ Left "failed to store content in S3 bucket" (False, _) -> return $ Left "failed to store content in S3 bucket"
(True, (_, Just vid)) -> return $ Right $ (True, (_, Just vid)) -> return $ Right $
mkS3VersionedContentIdentifier vid mkS3VersionedContentIdentifier vid
@ -604,9 +606,9 @@ storeExportWithContentIdentifierS3 hv r info magic src k loc _overwritablecids p
-- --
-- When the bucket is not versioned, data loss can result. -- When the bucket is not versioned, data loss can result.
-- This is why that configuration requires --force to enable. -- This is why that configuration requires --force to enable.
removeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool removeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
removeExportWithContentIdentifierS3 hv r info k loc _removeablecids = removeExportWithContentIdentifierS3 hv r rs info k loc _removeablecids =
removeExportS3 hv r info k loc removeExportS3 hv r rs info k loc
checkPresentExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
checkPresentExportWithContentIdentifierS3 hv r info _k loc knowncids = checkPresentExportWithContentIdentifierS3 hv r info _k loc knowncids =
@ -979,11 +981,11 @@ s3Info c info = catMaybes
showstorageclass (S3.OtherStorageClass t) = T.unpack t showstorageclass (S3.OtherStorageClass t) = T.unpack t
showstorageclass sc = show sc showstorageclass sc = show sc
getPublicWebUrls :: UUID -> S3Info -> RemoteConfig -> Key -> Annex [URLString] getPublicWebUrls :: UUID -> RemoteStateHandle -> S3Info -> RemoteConfig -> Key -> Annex [URLString]
getPublicWebUrls u info c k = either (const []) id <$> getPublicWebUrls' u info c k getPublicWebUrls u rs info c k = either (const []) id <$> getPublicWebUrls' u rs info c k
getPublicWebUrls' :: UUID -> S3Info -> RemoteConfig -> Key -> Annex (Either String [URLString]) getPublicWebUrls' :: UUID -> RemoteStateHandle -> S3Info -> RemoteConfig -> Key -> Annex (Either String [URLString])
getPublicWebUrls' u info c k getPublicWebUrls' u rs info c k
| not (public info) = return $ Left $ | not (public info) = return $ Left $
"S3 bucket does not allow public access; " ++ needS3Creds u "S3 bucket does not allow public access; " ++ needS3Creds u
| exportTree c = if versioning info | exportTree c = if versioning info
@ -999,7 +1001,7 @@ getPublicWebUrls' u info c k
Nothing -> return nopublicurl Nothing -> return nopublicurl
where where
nopublicurl = Left "No publicurl is configured for this remote" nopublicurl = Left "No publicurl is configured for this remote"
getversionid url = getS3VersionIDPublicUrls url info u k >>= \case getversionid url = getS3VersionIDPublicUrls url info rs k >>= \case
[] -> return (Left "Remote is configured to use versioning, but no S3 version ID is recorded for this key") [] -> return (Left "Remote is configured to use versioning, but no S3 version ID is recorded for this key")
l -> return (Right l) l -> return (Right l)
@ -1100,20 +1102,20 @@ extractContentIdentifier (ContentIdentifier v) o =
"#" -> Left (T.drop 1 t) "#" -> Left (T.drop 1 t)
_ -> Right (mkS3VersionID o (Just t)) _ -> Right (mkS3VersionID o (Just t))
setS3VersionID :: S3Info -> UUID -> Key -> Maybe S3VersionID -> Annex () setS3VersionID :: S3Info -> RemoteStateHandle -> Key -> Maybe S3VersionID -> Annex ()
setS3VersionID info u k vid setS3VersionID info rs k vid
| versioning info = maybe noop (setS3VersionID' u k) vid | versioning info = maybe noop (setS3VersionID' rs k) vid
| otherwise = noop | otherwise = noop
setS3VersionID' :: UUID -> Key -> S3VersionID -> Annex () setS3VersionID' :: RemoteStateHandle -> Key -> S3VersionID -> Annex ()
setS3VersionID' u k vid = addRemoteMetaData k $ setS3VersionID' rs k vid = addRemoteMetaData k rs $
RemoteMetaData u (updateMetaData s3VersionField v emptyMetaData) updateMetaData s3VersionField v emptyMetaData
where where
v = mkMetaValue (CurrentlySet True) (formatS3VersionID vid) v = mkMetaValue (CurrentlySet True) (formatS3VersionID vid)
getS3VersionID :: UUID -> Key -> Annex [S3VersionID] getS3VersionID :: RemoteStateHandle -> Key -> Annex [S3VersionID]
getS3VersionID u k = do getS3VersionID rs k = do
(RemoteMetaData _ m) <- getCurrentRemoteMetaData u k (RemoteMetaData _ m) <- getCurrentRemoteMetaData rs k
return $ mapMaybe parseS3VersionID $ map unwrap $ S.toList $ return $ mapMaybe parseS3VersionID $ map unwrap $ S.toList $
metaDataValues s3VersionField m metaDataValues s3VersionField m
where where
@ -1122,9 +1124,9 @@ getS3VersionID u k = do
s3VersionField :: MetaField s3VersionField :: MetaField
s3VersionField = mkMetaFieldUnchecked "V" s3VersionField = mkMetaFieldUnchecked "V"
eitherS3VersionID :: S3Info -> UUID -> RemoteConfig -> Key -> S3.Object -> Annex (Either String (Either S3.Object S3VersionID)) eitherS3VersionID :: S3Info -> RemoteStateHandle -> RemoteConfig -> Key -> S3.Object -> Annex (Either String (Either S3.Object S3VersionID))
eitherS3VersionID info u c k fallback eitherS3VersionID info rs c k fallback
| versioning info = getS3VersionID u k >>= return . \case | versioning info = getS3VersionID rs k >>= return . \case
[] -> if exportTree c [] -> if exportTree c
then Left "Remote is configured to use versioning, but no S3 version ID is recorded for this key" then Left "Remote is configured to use versioning, but no S3 version ID is recorded for this key"
else Right (Left fallback) else Right (Left fallback)
@ -1140,9 +1142,9 @@ s3VersionIDPublicUrl mk info (S3VersionID obj vid) = concat
, T.unpack vid -- version ID is "url ready" so no escaping needed , T.unpack vid -- version ID is "url ready" so no escaping needed
] ]
getS3VersionIDPublicUrls :: (S3Info -> BucketObject -> URLString) -> S3Info -> UUID -> Key -> Annex [URLString] getS3VersionIDPublicUrls :: (S3Info -> BucketObject -> URLString) -> S3Info -> RemoteStateHandle -> Key -> Annex [URLString]
getS3VersionIDPublicUrls mk info u k = getS3VersionIDPublicUrls mk info rs k =
map (s3VersionIDPublicUrl mk info) <$> getS3VersionID u k map (s3VersionIDPublicUrl mk info) <$> getS3VersionID rs k
-- Enable versioning on the bucket can only be done at init time; -- Enable versioning on the bucket can only be done at init time;
-- setting versioning in a bucket that git-annex has already exported -- setting versioning in a bucket that git-annex has already exported
@ -1188,9 +1190,9 @@ enableBucketVersioning ss info _ _ _ = do
-- were created without versioning, some unversioned files exported to -- were created without versioning, some unversioned files exported to
-- them, and then versioning enabled, and this is to avoid data loss in -- them, and then versioning enabled, and this is to avoid data loss in
-- those cases. -- those cases.
checkVersioning :: S3Info -> UUID -> Key -> Annex Bool -> Annex Bool checkVersioning :: S3Info -> RemoteStateHandle -> Key -> Annex Bool -> Annex Bool
checkVersioning info u k a checkVersioning info rs k a
| versioning info = getS3VersionID u k >>= \case | versioning info = getS3VersionID rs k >>= \case
[] -> do [] -> do
warning $ "Remote is configured to use versioning, but no S3 version ID is recorded for this key, so it cannot safely be modified." warning $ "Remote is configured to use versioning, but no S3 version ID is recorded for this key, so it cannot safely be modified."
return False return False

39
Remote/Tahoe.hs
View file

@ -61,8 +61,8 @@ remote = RemoteType
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = do gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
hdl <- liftIO $ TahoeHandle hdl <- liftIO $ TahoeHandle
<$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc) <$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc)
@ -71,18 +71,18 @@ gen r u c gc = do
{ uuid = u { uuid = u
, cost = cst , cost = cst
, name = Git.repoDescribe r , name = Git.repoDescribe r
, storeKey = store u hdl , storeKey = store rs hdl
, retrieveKeyFile = retrieve u hdl , retrieveKeyFile = retrieve rs hdl
, retrieveKeyFileCheap = \_ _ _ -> return False , retrieveKeyFileCheap = \_ _ _ -> return False
-- Tahoe cryptographically verifies content. -- Tahoe cryptographically verifies content.
, retrievalSecurityPolicy = RetrievalAllKeysSecure , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = remove , removeKey = remove
, lockContent = Nothing , lockContent = Nothing
, checkPresent = checkKey u hdl , checkPresent = checkKey rs hdl
, checkPresentCheap = False , checkPresentCheap = False
, exportActions = exportUnsupported , exportActions = exportUnsupported
, importActions = importUnsupported , importActions = importUnsupported
, whereisKey = Just (getWhereisKey u) , whereisKey = Just (getWhereisKey rs)
, remoteFsck = Nothing , remoteFsck = Nothing
, repairRepo = Nothing , repairRepo = Nothing
, config = c , config = c
@ -97,6 +97,7 @@ gen r u c gc = do
, getInfo = return [] , getInfo = return []
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
tahoeSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) tahoeSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
@ -119,14 +120,14 @@ tahoeSetup _ mu _ c _ = do
furlk = "introducer-furl" furlk = "introducer-furl"
missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use."
store :: UUID -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store u hdl k _f _p = sendAnnex k noop $ \src -> store rs hdl k _f _p = sendAnnex k noop $ \src ->
parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe
(return False) (return False)
(\cap -> storeCapability u k cap >> return True) (\cap -> storeCapability rs k cap >> return True)
retrieve :: UUID -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
retrieve u hdl k _f d _p = unVerified $ go =<< getCapability u k retrieve rs hdl k _f d _p = unVerified $ go =<< getCapability rs k
where where
go Nothing = return False go Nothing = return False
go (Just cap) = liftIO $ requestTahoe hdl "get" [Param cap, File d] go (Just cap) = liftIO $ requestTahoe hdl "get" [Param cap, File d]
@ -136,8 +137,8 @@ remove _k = do
warning "content cannot be removed from tahoe remote" warning "content cannot be removed from tahoe remote"
return False return False
checkKey :: UUID -> TahoeHandle -> Key -> Annex Bool checkKey :: RemoteStateHandle -> TahoeHandle -> Key -> Annex Bool
checkKey u hdl k = go =<< getCapability u k checkKey rs hdl k = go =<< getCapability rs k
where where
go Nothing = return False go Nothing = return False
go (Just cap) = liftIO $ do go (Just cap) = liftIO $ do
@ -233,14 +234,14 @@ tahoeParams :: TahoeConfigDir -> String -> [CommandParam] -> [CommandParam]
tahoeParams configdir command params = tahoeParams configdir command params =
Param "-d" : File configdir : Param command : params Param "-d" : File configdir : Param command : params
storeCapability :: UUID -> Key -> Capability -> Annex () storeCapability :: RemoteStateHandle -> Key -> Capability -> Annex ()
storeCapability u k cap = setRemoteState u k cap storeCapability rs k cap = setRemoteState rs k cap
getCapability :: UUID -> Key -> Annex (Maybe Capability) getCapability :: RemoteStateHandle -> Key -> Annex (Maybe Capability)
getCapability u k = getRemoteState u k getCapability rs k = getRemoteState rs k
getWhereisKey :: UUID -> Key -> Annex [String] getWhereisKey :: RemoteStateHandle -> Key -> Annex [String]
getWhereisKey u k = disp <$> getCapability u k getWhereisKey rs k = disp <$> getCapability rs k
where where
disp Nothing = [] disp Nothing = []
disp (Just c) = [c] disp (Just c) = [c]

5
Remote/Web.hs
View file

@ -40,8 +40,8 @@ list _autoinit = do
r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown) r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown)
return [r] return [r]
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r _ c gc = do gen r _ c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
return $ Just Remote return $ Just Remote
{ uuid = webUUID { uuid = webUUID
@ -74,6 +74,7 @@ gen r _ c gc = do
, getInfo = return [] , getInfo = return []
, claimUrl = Nothing -- implicitly claims all urls , claimUrl = Nothing -- implicitly claims all urls
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)

9
Remote/WebDAV.hs
View file

@ -50,8 +50,8 @@ remote = RemoteType
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost
where where
new cst = Just $ specialRemote c new cst = Just $ specialRemote c
(prepareDAV this $ store chunkconfig) (prepareDAV this $ store chunkconfig)
@ -95,11 +95,12 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, appendonly = False , appendonly = False
, availability = GloballyAvailable , availability = GloballyAvailable
, remotetype = remote , remotetype = remote
, mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc , mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc rs
, getInfo = includeCredsInfo c (davCreds u) $ , getInfo = includeCredsInfo c (davCreds u) $
[("url", fromMaybe "unknown" (M.lookup "url" c))] [("url", fromMaybe "unknown" (M.lookup "url" c))]
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs
} }
chunkconfig = getChunkConfig c chunkconfig = getChunkConfig c
@ -341,7 +342,7 @@ davCreds :: UUID -> CredPairStorage
davCreds u = CredPairStorage davCreds u = CredPairStorage
{ credPairFile = fromUUID u { credPairFile = fromUUID u
, credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD") , credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")
, credPairRemoteKey = "davcreds" , credPairRemoteField = "davcreds"
} }
{- Content-Type to use for files uploaded to WebDAV. -} {- Content-Type to use for files uploaded to WebDAV. -}

2
Types/GitConfig.hs
View file

@ -246,6 +246,7 @@ data RemoteGitConfig = RemoteGitConfig
, remoteAnnexRetry :: Maybe Integer , remoteAnnexRetry :: Maybe Integer
, remoteAnnexRetryDelay :: Maybe Seconds , remoteAnnexRetryDelay :: Maybe Seconds
, remoteAnnexAllowUnverifiedDownloads :: Bool , remoteAnnexAllowUnverifiedDownloads :: Bool
, remoteAnnexConfigUUID :: Maybe UUID
{- These settings are specific to particular types of remotes {- These settings are specific to particular types of remotes
- including special remotes. -} - including special remotes. -}
@ -308,6 +309,7 @@ extractRemoteGitConfig r remotename = do
<$> getmayberead "retrydelay" <$> getmayberead "retrydelay"
, remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ , remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $
getmaybe ("security-allow-unverified-downloads") getmaybe ("security-allow-unverified-downloads")
, remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid"
, remoteAnnexShell = getmaybe "shell" , remoteAnnexShell = getmaybe "shell"
, remoteAnnexSshOptions = getoptions "ssh-options" , remoteAnnexSshOptions = getoptions "ssh-options"
, remoteAnnexRsyncOptions = getoptions "rsync-options" , remoteAnnexRsyncOptions = getoptions "rsync-options"

11
Types/Remote.hs
View file

@ -10,10 +10,11 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
module Types.Remote module Types.Remote
( RemoteConfigKey ( RemoteConfigField
, RemoteConfig , RemoteConfig
, RemoteTypeA(..) , RemoteTypeA(..)
, RemoteA(..) , RemoteA(..)
, RemoteStateHandle
, SetupStage(..) , SetupStage(..)
, Availability(..) , Availability(..)
, Verification(..) , Verification(..)
@ -36,6 +37,7 @@ import Types.UUID
import Types.GitConfig import Types.GitConfig
import Types.Availability import Types.Availability
import Types.Creds import Types.Creds
import Types.RemoteState
import Types.UrlContents import Types.UrlContents
import Types.NumCopies import Types.NumCopies
import Types.Export import Types.Export
@ -47,9 +49,9 @@ import Utility.SafeCommand
import Utility.Url import Utility.Url
import Utility.DataUnits import Utility.DataUnits
type RemoteConfigKey = String type RemoteConfigField = String
type RemoteConfig = M.Map RemoteConfigKey String type RemoteConfig = M.Map RemoteConfigField String
data SetupStage = Init | Enable RemoteConfig data SetupStage = Init | Enable RemoteConfig
@ -61,7 +63,7 @@ data RemoteTypeA a = RemoteType
-- The Bool is True if automatic initialization of remotes is desired -- The Bool is True if automatic initialization of remotes is desired
, enumerate :: Bool -> a [Git.Repo] , enumerate :: Bool -> a [Git.Repo]
-- generates a remote of this type -- generates a remote of this type
, generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)) , generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))
-- initializes or enables a remote -- initializes or enables a remote
, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID) , setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
-- check if a remote of this type is able to support export -- check if a remote of this type is able to support export
@ -151,6 +153,7 @@ data RemoteA a = Remote
-- its contents, without downloading the full content. -- its contents, without downloading the full content.
-- Throws an exception if the url is inaccessible. -- Throws an exception if the url is inaccessible.
, checkUrl :: Maybe (URLString -> a UrlContents) , checkUrl :: Maybe (URLString -> a UrlContents)
, remoteStateHandle :: RemoteStateHandle
} }
instance Show (RemoteA a) where instance Show (RemoteA a) where

19
Types/RemoteState.hs Normal file
View file

@ -0,0 +1,19 @@
{- git-annex remote state handle type
-
- Copyright 2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Types.RemoteState where
import Types.UUID
{- When per-remote state, its UUID is used to identify it.
-
- However, sameas remotes mean that two different Remote implementations
- can be used for the same underlying data store. To avoid them using
- state in conflicting ways, a different UUID needs to be used for each
- additional sameas remote.
-}
newtype RemoteStateHandle = RemoteStateHandle UUID

19
doc/git-annex-initremote.mdwn
View file

@ -43,6 +43,25 @@ want to use `git annex renameremote`.
and re-run with `--fast`, which causes it to use a lower-quality source of and re-run with `--fast`, which causes it to use a lower-quality source of
randomness. (Ie, /dev/urandom instead of /dev/random) randomness. (Ie, /dev/urandom instead of /dev/random)
* `--sameas=remote`
Use this when the new special remote uses the same underlying storage
as some other remote. This will result in the new special remote having
the same uuid as the specified remote, and either can be used to access
the same content.
The `remote` can be the name of a git remote, or the description
or uuid of any git-annex repository.
When using this option, the new remote inherits the encryption settings
of the existing remote, so you should not specify any encryption
parameters. No other configuration is inherited from the existing remote.
This will only work if both remotes use the underlying storage in
compatible ways. See this page for information about known
compatabilities.
<http://git-annex.branchable.com/tips/multiple_remotes_accessing_the_same_data_store/>
# COMMON CONFIGURATION PARAMETERS # COMMON CONFIGURATION PARAMETERS
* `encryption` * `encryption`

2
doc/git-annex-renameremote.mdwn
View file

@ -10,7 +10,7 @@ git annex renameremote `name|uuid|desc newname`
Changes the name that is used to enable a special remote. Changes the name that is used to enable a special remote.
Normally the current name is used to identify the special remote, Normally the current name is used to identify the special remote to rename,
but its uuid or description can also be used. but its uuid or description can also be used.
This is especially useful when an old special remote used a name, and now you This is especially useful when an old special remote used a name, and now you

5
doc/git-annex.mdwn
View file

@ -1268,6 +1268,11 @@ Remotes are configured using these settings in `.git/config`.
git-annex caches UUIDs of remote repositories here. git-annex caches UUIDs of remote repositories here.
* `remote.<name>.annex-config-uuid`
Used for some special remotes, points to a different special remote
configuration to use.
* `remote.<name>.annex-retry`, `annex.retry` * `remote.<name>.annex-retry`, `annex.retry`
Configure retries of failed transfers on a per-remote and general Configure retries of failed transfers on a per-remote and general

2
doc/internals.mdwn
View file

@ -277,7 +277,7 @@ For example:
These log files store per-remote content identifiers for keys. These log files store per-remote content identifiers for keys.
A given key may have any number of content identifiers. A given key may have any number of content identifiers.
The format is a timestamp, followed by the uuid or the remote, The format is a timestamp, followed by the uuid of the remote,
followed by the content identifiers which are separated by colons. followed by the content identifiers which are separated by colons.
If a content identifier contains a colon or \r or \n, it will be base64 If a content identifier contains a colon or \r or \n, it will be base64
encoded. Base64 encoded values are indicated by prefixing them with "!". encoded. Base64 encoded values are indicated by prefixing them with "!".

58
doc/tips/multiple_remotes_accessing_the_same_data_store.mdwn Normal file
View file

@ -0,0 +1,58 @@
A remote configures git-annex with a way to access a particular data
store. Sometimes, there's more than one way for git-annex to access the
same underlying data store. It then makes sense to have multiple remotes.
The most common and easy case of this is when the data store is itself a
git-annex repository. For example, using git-annex on your laptop, you
might add a ssh remote which works from anywhere. But, when you're located
on the same LAN as the server, it might be faster or simpler to use a
different ssh url.
git remote add server someserver.example.com:/data
git remote add lanserver someserver.lan:/data
git-annex is able to realize automatically that these two remotes both
access the same repository (by contacting the repository and looking up its
git-annex uuid). You can use git-annex to access which ever remote you
want to at a given time.
[[Special_remotes]] don't store data in a git-annex repository. It's
possible to configure two special remotes that access the same underlying
data store, at least in theory. Whether it will work depends on how the
two special remotes store their data. If they don't use the same filename
(or whatever), it might not work.
The case almost guaranteed to work is two special remotes of the same type,
and other configuration, but with different urls that point to the same
data store. For example, a [[special_remotes/git-lfs]] repository can be
accessed using http or ssh. So two git-lfs special remotes can be set up,
and both access the same data.
git annex initremote lfs-ssh type=git-lfs encryption=shared url=git@example.com:repo
git annex initremote --sameas=lfs-ssh lfs-http type=git-lfs url=https://example.com/repo
The `--sameas` parameter tells git-annex that the new special remote
uses the same data store as an existing special remote. Note that
the encryption= parameter, which is usually mandatory, is omitted.
The two necessarily encrypt data in the same way, so it will
inherit the encryption configuration. Other configuration is not inherited,
so if you need some parameter to initremote to make a special remote behave
a certian way, be sure to pass it to both.
Finally, it's sometimes possible to access the same data stored in two
special remotes with different types. One combination that works is
a [[special_remotes/directory]] special remote
and a [[special_remotes/rsync]] special remote.
git annex initremote dir type=directory encryption=none directory=/foo
git annex initremote --sameas=dir rsync type=rsync rsyncurl=localhost:/foo
If a combination does not work, git-annex will be unable to access files
in one remote or the other, it could get into a scrambled mess. So it's
best to test a a combination carefully before you start using it for real.
If you find combinations that work, please edit this page to list them.
## known working combinations
* directory and rsync

5
doc/todo/git-lfs_special_remote_simpler_setup.mdwn
View file

@ -17,6 +17,11 @@ make enableremote with a new url= add that as urlN=.
[[support_multiple_special_remotes_with_same_uuid]] would solve it, perhaps [[support_multiple_special_remotes_with_same_uuid]] would solve it, perhaps
in a cleaner way. in a cleaner way.
> If each url is treated as a separate special remote (which makes a lot of sense
> by analogy with how regular git remotes work), then
> [[support_multiple_special_remotes_with_same_uuid]] could be used to
> solve this.
Problem: The user might go in and change the remote's url to point to some Problem: The user might go in and change the remote's url to point to some
other server with a different git-lfs backend. In fact, they could already other server with a different git-lfs backend. In fact, they could already
do so! Remembering the urls actually would let the special remote detect do so! Remembering the urls actually would let the special remote detect

35
doc/todo/support_multiple_special_remotes_with_same_uuid/comment_12_704637f56a74a0f561798ae398e1470b._comment Normal file
View file

@ -0,0 +1,35 @@
[[!comment format=mdwn
username="joey"
subject="""comment 12"""
date="2019-10-11T19:56:12Z"
content="""
Looking over all my comments now that I have an implementatation..
`git annex dead` on a sameas remote name marks the parent remote dead.
I think this is ok; dead means the content is gone, so which remote is used
to access it is immaterial; they're all dead.
sameas loops are not a problem, it only looks up the sameas-uuid value
once, will not loop.
old git-annex are prevented from enabling a sameas remote, since it has no
name=
old git-annex with an enabled sameas remote will see the annex-uuid of the
parent, and treat it as the parent. Some git config values needed to use
the parent may not be set, or may potentially be set differently than for
the parent. Unlikely to cause any bad behavior, other than the remote not
working.
encrypted data and legacy chunking is inherited, and cannot be overridden
RemoteConfig always contains any inherited parameters of a sameas remote.
Logs.Remote.configSet filters those out.
Logs.Remote.configSet is a little bit less safe; if its caller passed the
RemoteConfig from a sameas remote, it needs to make sure to not pass the
uuid of the parent remote, or it will overwrite the wrong config. All calls
to it handle that now.
per-remote state still to be done.
"""]]

5
git-annex.cabal
View file

@ -304,7 +304,7 @@ Executable git-annex
base (>= 4.11.1.0 && < 5.0), base (>= 4.11.1.0 && < 5.0),
network-uri (>= 2.6), network-uri (>= 2.6),
optparse-applicative (>= 0.14.1), optparse-applicative (>= 0.14.1),
containers (>= 0.5.7.1), containers (>= 0.5.8),
exceptions (>= 0.6), exceptions (>= 0.6),
stm (>= 2.3), stm (>= 2.3),
mtl (>= 2), mtl (>= 2),
@ -653,6 +653,7 @@ Executable git-annex
Annex.ReplaceFile Annex.ReplaceFile
Annex.RemoteTrackingBranch Annex.RemoteTrackingBranch
Annex.SpecialRemote Annex.SpecialRemote
Annex.SpecialRemote.Config
Annex.Ssh Annex.Ssh
Annex.TaggedPush Annex.TaggedPush
Annex.Tmp Annex.Tmp
@ -896,6 +897,7 @@ Executable git-annex
Logs.Presence Logs.Presence
Logs.Presence.Pure Logs.Presence.Pure
Logs.Remote Logs.Remote
Logs.Remote.Pure
Logs.RemoteState Logs.RemoteState
Logs.Schedule Logs.Schedule
Logs.SingleValue Logs.SingleValue
@ -993,6 +995,7 @@ Executable git-annex
Types.NumCopies Types.NumCopies
Types.RefSpec Types.RefSpec
Types.Remote Types.Remote
Types.RemoteState
Types.RepoVersion Types.RepoVersion
Types.ScheduledActivity Types.ScheduledActivity
Types.StandardGroups Types.StandardGroups