git-annex/Command/UpdateCluster.hs

{- git-annex command
 -
 - Copyright 2024 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE OverloadedStrings #-}

module Command.UpdateCluster where

import Command
import qualified Annex
import Types.Cluster
import Logs.Cluster
import qualified Remote as R
import qualified Types.Remote as R
import qualified Command.UpdateProxy
import Utility.SafeOutput

import qualified Data.Map as M
import qualified Data.Set as S

cmd :: Command
cmd = noMessages $ command "updatecluster" SectionSetup 
	"update records of cluster nodes"
	paramNothing (withParams seek)

seek :: CmdParams -> CommandSeek
seek = withNothing $ do
	commandAction start
	commandAction Command.UpdateProxy.start

start :: CommandStart
start = startingCustomOutput (ActionItemOther Nothing) $ do
	rs <- R.remoteList
	let getnode r = case remoteAnnexClusterNode (R.gitconfig r) of
		Nothing -> return Nothing
		Just [] -> return Nothing
		Just clusternames -> 
			ifM (Command.UpdateProxy.checkCanProxy r "Cannot use this special remote as a cluster node.")
				( return $ Just $ M.fromList $
					zip clusternames (repeat (S.singleton r))
				, return Nothing
				)
	myclusternodes <- M.unionsWith S.union . catMaybes
		<$> mapM getnode rs
	myclusters <- annexClusters <$> Annex.getGitConfig
	recordedclusters <- getClusters
	descs <- R.uuidDescriptions
	
	-- Update the cluster log to list the currently configured nodes
	-- of each configured cluster.
	forM_ (M.toList myclusters) $ \(clustername, cu) -> do
		let mynodesremotes = fromMaybe mempty $
			M.lookup clustername myclusternodes
		let mynodes = S.map (ClusterNodeUUID . R.uuid) mynodesremotes
		let recordednodes = fromMaybe mempty $ M.lookup cu $
			clusterUUIDs recordedclusters
		proxiednodes <- findProxiedClusterNodes recordednodes 
		let allnodes = S.union mynodes proxiednodes
		if recordednodes == allnodes
			then liftIO $ putStrLn $ safeOutput $
				"No cluster node changes for cluster: " ++ clustername
			else do
				describechanges descs clustername recordednodes allnodes mynodesremotes
				recordCluster cu allnodes

	next $ return True
  where
	describechanges descs clustername oldnodes allnodes mynodesremotes = do
		forM_ (S.toList mynodesremotes) $ \r ->
			unless (S.member (ClusterNodeUUID (R.uuid r)) oldnodes) $
				liftIO $ putStrLn $ safeOutput $
					"Added node " ++ R.name r ++ " to cluster: " ++ clustername
		forM_ (S.toList oldnodes) $ \n ->
			unless (S.member n allnodes) $ do
				let desc = maybe (fromUUID (fromClusterNodeUUID n)) fromUUIDDesc $
					M.lookup (fromClusterNodeUUID n) descs
				liftIO $ putStrLn $ safeOutput $
					"Removed node " ++ desc ++ " from cluster: " ++ clustername

-- Finds nodes that are proxied by other cluster gateways.
findProxiedClusterNodes :: S.Set ClusterNodeUUID -> Annex (S.Set ClusterNodeUUID)
findProxiedClusterNodes recordednodes =
	(S.fromList . map asclusternode . filter isproxynode) <$> R.remoteList
  where
	isproxynode r = 
		asclusternode r `S.member` recordednodes
			&& isJust (remoteAnnexProxiedBy (R.gitconfig r))
	asclusternode = ClusterNodeUUID . R.uuid