202ea3ff2a
Avoid `git-annex sync --content` etc from operating on cluster nodes by default since syncing with a cluster implicitly syncs with its nodes. This avoids a lot of unncessary work when a cluster has a lot of nodes just in checking if each node's preferred content is satisfied. And it avoids content being sent to nodes individually, so instead syncing with clusters always fanout uploads to nodes. The downside is that there are situations where a cluster's preferred content settings can be met, but those of its nodes are not. Or where a node does not contain a key, but the cluster does, and there are not enough copies of the key yet, so it would be desirable the send it there. I think that's an acceptable tradeoff. These kind of situations are ones where the cluster itself should probably be responsible for copying content to the node. Which it can do much less expensively than a client can. Part of the balanced preferred content design that I will be working on in a couple of months involves rebalancing clusters, so I expect to revisit this. The use of annex-sync config does allow running git-annex sync with a specific node, or nodes, and it will sync with it. And it's also possible to set annex-sync git configs to make it sync with a node by default. (Although that will require setting up an explicit git remote for the node rather than relying on the proxied remote.) Logs.Cluster.Basic is needed because Remote.Git cannot import Logs.Cluster due to a cycle. And the Annex.Startup load of clusters happens too late for Remote.Git to use that. This does mean one redundant load of the cluster log, though only when there is a proxy.
91 lines
2.7 KiB
Haskell
91 lines
2.7 KiB
Haskell
{- git-annex cluster log, basics
|
|
-
|
|
- Copyright 2024 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings, TupleSections #-}
|
|
|
|
module Logs.Cluster.Basic (
|
|
module Types.Cluster,
|
|
getClustersWith,
|
|
recordCluster,
|
|
) where
|
|
|
|
import qualified Annex
|
|
import Annex.Common
|
|
import qualified Annex.Branch
|
|
import Types.Cluster
|
|
import Logs
|
|
import Logs.UUIDBased
|
|
import Logs.MapLog
|
|
|
|
import qualified Data.Set as S
|
|
import qualified Data.Map as M
|
|
import Data.ByteString.Builder
|
|
import qualified Data.Attoparsec.ByteString as A
|
|
import qualified Data.Attoparsec.ByteString.Char8 as A8
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
{- Gets the clusters. Note that this includes any dead nodes,
|
|
- unless a function is provided to remove them.
|
|
-}
|
|
getClustersWith
|
|
:: (M.Map ClusterUUID (S.Set ClusterNodeUUID)
|
|
-> M.Map ClusterUUID (S.Set ClusterNodeUUID))
|
|
-> Annex Clusters
|
|
getClustersWith removedeadnodes = do
|
|
m <- removedeadnodes
|
|
. convclusteruuids
|
|
. M.map value
|
|
. fromMapLog
|
|
. parseClusterLog
|
|
<$> Annex.Branch.get clusterLog
|
|
return $ Clusters
|
|
{ clusterUUIDs = m
|
|
, clusterNodeUUIDs = M.foldlWithKey inverter mempty m
|
|
}
|
|
where
|
|
convclusteruuids :: M.Map UUID (S.Set ClusterNodeUUID) -> M.Map ClusterUUID (S.Set ClusterNodeUUID)
|
|
convclusteruuids = M.fromList
|
|
. mapMaybe (\(mk, v) -> (, v) <$> mk)
|
|
. M.toList . M.mapKeys mkClusterUUID
|
|
inverter m k v = M.unionWith (<>) m
|
|
(M.fromList (map (, S.singleton k) (S.toList v)))
|
|
|
|
recordCluster :: ClusterUUID -> S.Set ClusterNodeUUID -> Annex ()
|
|
recordCluster clusteruuid nodeuuids = do
|
|
-- If a private UUID has been configured as a cluster node,
|
|
-- avoid leaking it into the git-annex log.
|
|
privateuuids <- annexPrivateRepos <$> Annex.getGitConfig
|
|
let nodeuuids' = S.filter
|
|
(\(ClusterNodeUUID n) -> S.notMember n privateuuids)
|
|
nodeuuids
|
|
|
|
c <- currentVectorClock
|
|
Annex.Branch.change (Annex.Branch.RegardingUUID [fromClusterUUID clusteruuid]) clusterLog $
|
|
(buildLogNew buildClusterNodeList)
|
|
. changeLog c (fromClusterUUID clusteruuid) nodeuuids'
|
|
. parseClusterLog
|
|
|
|
buildClusterNodeList :: S.Set ClusterNodeUUID -> Builder
|
|
buildClusterNodeList = assemble
|
|
. map (buildUUID . fromClusterNodeUUID)
|
|
. S.toList
|
|
where
|
|
assemble [] = mempty
|
|
assemble (x:[]) = x
|
|
assemble (x:y:l) = x <> " " <> assemble (y:l)
|
|
|
|
parseClusterLog :: L.ByteString -> Log (S.Set ClusterNodeUUID)
|
|
parseClusterLog = parseLogNew parseClusterNodeList
|
|
|
|
parseClusterNodeList :: A.Parser (S.Set ClusterNodeUUID)
|
|
parseClusterNodeList = S.fromList <$> many parseword
|
|
where
|
|
parseword = parsenode
|
|
<* ((const () <$> A8.char ' ') <|> A.endOfInput)
|
|
parsenode = ClusterNodeUUID
|
|
<$> (toUUID <$> A8.takeWhile1 (/= ' '))
|
|
|