import P2P.IO
import Annex.Proxy
import Logs.Location
+import Logs.PreferredContent
import Types.Command
import Remote.List
import qualified Remote
clusterProxySelector :: ClusterUUID -> ProtocolVersion -> Annex ProxySelector
clusterProxySelector clusteruuid protocolversion = do
- nodes <- (fromMaybe S.empty . M.lookup clusteruuid . clusterUUIDs)
+ nodeuuids <- (fromMaybe S.empty . M.lookup clusteruuid . clusterUUIDs)
<$> getClusters
clusternames <- annexClusters <$> Annex.getGitConfig
- remotes <- filter (isnode nodes clusternames) <$> remoteList
- remotesides <- mapM (proxySshRemoteSide protocolversion) remotes
+ remotes <- filter (isnode nodeuuids clusternames) <$> remoteList
+ nodes <- mapM (proxySshRemoteSide protocolversion) remotes
return $ ProxySelector
- { proxyCHECKPRESENT = nodecontaining remotesides
- , proxyGET = nodecontaining remotesides
+ { proxyCHECKPRESENT = nodecontaining nodes
+ , proxyGET = nodecontaining nodes
-- The key is sent to multiple nodes at the same time,
-- skipping nodes where it's known/expected to already be
- -- present to avoid needing to connect to those.
- , proxyPUT = \k -> do
+ -- present to avoid needing to connect to those, and
+ -- skipping nodes where it's not preferred content.
+ , proxyPUT = \af k -> do
locs <- S.fromList <$> loggedLocations k
- let l = filter (flip S.notMember locs . remoteUUID) remotesides
- return $ if null l
- then remotesides
- else l
+ let l = filter (flip S.notMember locs . remoteUUID) nodes
+ l' <- filterM (\n -> isPreferredContent (Just (remoteUUID n)) mempty (Just k) af True) l
+ -- PUT to no nodes doesn't work, so fall
+ -- back to all nodes.
+ return $ nonempty [l', l] nodes
-- Remove the key from every node that contains it.
-- But, since it's possible the location log for some nodes
-- could be out of date, actually try to remove from every
-- node.
- , proxyREMOVE = const (pure remotesides)
+ , proxyREMOVE = const (pure nodes)
-- Content is not locked on the cluster as a whole,
-- instead it can be locked on individual nodes that are
-- proxied to the client.
where
-- Nodes of the cluster have remote.name.annex-cluster-node
-- containing its name.
- isnode nodes clusternames r =
+ isnode nodeuuids clusternames r =
case remoteAnnexClusterNode (Remote.gitconfig r) of
Nothing -> False
Just names
| any (isclustername clusternames) names ->
- flip S.member nodes $
+ flip S.member nodeuuids $
ClusterNodeUUID $ Remote.uuid r
| otherwise -> False
isclustername clusternames name =
M.lookup name clusternames == Just clusteruuid
- nodecontaining remotesides k = do
+ nodecontaining nodes k = do
locs <- S.fromList <$> loggedLocations k
- case filter (flip S.member locs . remoteUUID) remotesides of
+ case filter (flip S.member locs . remoteUUID) nodes of
-- TODO: Avoid always using same remote
(r:_) -> return (Just r)
[] -> return Nothing
+ nonempty (l:ls) fallback
+ | null l = nonempty ls fallback
+ | otherwise = l
+ nonempty [] fallback = fallback
-- its serialization cannot contain any whitespace. This is handled
-- by replacing whitespace with '%' (and '%' with '%%')
--
--- When deserializing an AssociatedFile from a peer, it's sanitized,
--- to avoid any unusual characters that might cause problems when it's
--- displayed to the user.
+-- When deserializing an AssociatedFile from a peer, that escaping is
+-- reversed. Unfortunately, an input tab will be deescaped to a space
+-- though. And it's sanitized, to avoid any control characters that might
+-- cause problems when it's displayed to the user.
--
--- These mungings are ok, because a ProtoAssociatedFile is only ever displayed
--- to the user and does not need to match a file on disk.
+-- These mungings are ok, because a ProtoAssociatedFile is normally
+-- only displayed to the user and so does not need to match a file on disk.
+-- It may also be used in checking preferred content, which is very
+-- unlikely to care about spaces vs tabs or control characters.
instance Proto.Serializable ProtoAssociatedFile where
serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = ""
serialize (ProtoAssociatedFile (AssociatedFile (Just af))) =
import P2P.Protocol
import P2P.IO
import Utility.Metered
+import Git.FilePath
import Data.Either
import Control.Concurrent.STM
, proxyREMOVE :: Key -> Annex [RemoteSide]
-- ^ remove from all of these remotes
, proxyGET :: Key -> Annex (Maybe RemoteSide)
- , proxyPUT :: Key -> Annex [RemoteSide]
+ , proxyPUT :: AssociatedFile -> Key -> Annex [RemoteSide]
-- ^ put to some/all of these remotes
}
, proxyUNLOCKCONTENT = pure (Just r)
, proxyREMOVE = const (pure [r])
, proxyGET = const (pure (Just r))
- , proxyPUT = const (pure [r])
+ , proxyPUT = const (const (pure [r]))
}
{- To keep this module limited to P2P protocol actions,
protoerrhandler proxynextclientmessage $
client $ net $ sendMessage $
ERROR "content not present"
- PUT _ k -> do
- remotesides <- proxyPUT proxyselector k
+ PUT paf k -> do
+ af <- getassociatedfile paf
+ remotesides <- proxyPUT proxyselector af k
servermodechecker checkPUTServerMode $
handlePUT remotesides k message
-- These messages involve the git repository, not the
| protocolversion < 2 -> SUCCESS
| otherwise -> SUCCESS_PLUS us
+ -- The associated file received from the P2P protocol
+ -- is relative to the top of the git repository. But this process
+ -- may be running with a different cwd.
+ getassociatedfile (ProtoAssociatedFile (AssociatedFile (Just f))) =
+ AssociatedFile . Just
+ <$> fromRepo (fromTopFilePath (asTopFilePath f))
+ getassociatedfile (ProtoAssociatedFile (AssociatedFile Nothing)) =
+ return $ AssociatedFile Nothing
For June's work on [[design/passthrough_proxy]], remaining todos:
-* On upload to cluster, send to nodes where its preferred content, and not
- to other nodes. Unless no nodes prefer it, then what?
-
* Getting a key from a cluster currently always selects the lowest cost
remote, and always the same remote if cost is the same. Should
round-robin amoung remotes, and prefer to avoid using remotes that
* Avoid `git-annex sync --content` etc from operating on cluster nodes by
default since syncing with a cluster implicitly syncs with its nodes. (done)
+
+* On upload to cluster, send to nodes where its preferred content, and not
+ to other nodes. (done)
projects / git-annex.git / commitdiff