fogot to add

diff --git a/Command/UpdateCluster.hs b/Command/UpdateCluster.hs
new file mode 100644 (file)
index 0000000..5e1474d
--- /dev/null
+++ b/Command/UpdateCluster.hs
@@ -0,0 +1,86 @@
+{- 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 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