diff --git a/Command/UpdateCluster.hs b/Command/UpdateCluster.hs new file mode 100644 index 0000000000..5e1474d293 --- /dev/null +++ b/Command/UpdateCluster.hs @@ -0,0 +1,86 @@ +{- git-annex command + - + - Copyright 2024 Joey Hess + - + - 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 Config +import Annex.UUID +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 with cluster configuration" + 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 = do + clusternames <- remoteAnnexClusterNode (R.gitconfig r) + return $ M.fromList $ zip clusternames (repeat (S.singleton r)) + let myclusternodes = M.unionsWith S.union (mapMaybe getnode rs) + + -- Generate cluster UUIDs and store in git config for each new cluster. + myclusters <- annexClusters <$> Annex.getGitConfig + forM_ (M.keys myclusternodes) $ \clustername -> + unless (M.member clustername myclusters) $ do + liftIO $ putStrLn $ safeOutput $ + "Configuring new cluster: " ++ clustername + cu <- fromMaybe (giveup "unable to generate a cluster UUID") + <$> genClusterUUID <$> liftIO genUUID + setConfig (annexConfig ("cluster." <> encodeBS clustername)) + (fromUUID (fromClusterUUID cu)) + reloadConfig + + -- Update the cluster log to list the currently configured nodes + -- of each configured cluster. + myclusters' <- annexClusters <$> Annex.getGitConfig + recordedclusters <- getClusters + descs <- R.uuidDescriptions + 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 + if recordednodes == mynodes + then liftIO $ putStrLn $ safeOutput $ + "No cluster node changes for cluster: " ++ clustername + else do + describechanges descs clustername recordednodes mynodes mynodesremotes + recordCluster cu mynodes + + next $ return True + where + describechanges descs clustername oldnodes mynodes 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 mynodes) $ do + let desc = maybe (fromUUID (fromClusterNodeUUID n)) fromUUIDDesc $ + M.lookup (fromClusterNodeUUID n) descs + liftIO $ putStrLn $ safeOutput $ + "Removed node " ++ desc ++ " from cluster: " ++ clustername