570ceffe8d
One benefit of this is that a typo in annex-cluster-node config won't init a new cluster. Also it gets the cluster description set and is consistent with initremote.
50 lines
1.4 KiB
Haskell
50 lines
1.4 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2024 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Command.InitCluster where
|
|
|
|
import Command
|
|
import qualified Annex
|
|
import Types.Cluster
|
|
import Logs.UUID
|
|
import Config
|
|
import Annex.UUID
|
|
import Git.Types
|
|
import Git.Remote (isLegalName)
|
|
|
|
import qualified Data.Map as M
|
|
|
|
cmd :: Command
|
|
cmd = command "initcluster" SectionSetup "initialize a new cluster"
|
|
(paramPair paramName paramDesc) (withParams seek)
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
seek (clustername:desc:[]) = commandAction $
|
|
start clustername (toUUIDDesc desc)
|
|
seek (clustername:[]) = commandAction $
|
|
start clustername $ toUUIDDesc ("cluster " ++ clustername)
|
|
seek _ = giveup "Expected two parameters, name and description."
|
|
|
|
start :: RemoteName -> UUIDDesc -> CommandStart
|
|
start clustername desc = starting "initcluster" ai si $ do
|
|
unless (isLegalName clustername) $
|
|
giveup "That cluster name is not a valid git remote name."
|
|
|
|
myclusters <- annexClusters <$> Annex.getGitConfig
|
|
unless (M.member clustername myclusters) $ do
|
|
cu <- fromMaybe (giveup "unable to generate a cluster UUID")
|
|
<$> genClusterUUID <$> liftIO genUUID
|
|
setConfig (annexConfig ("cluster." <> encodeBS clustername))
|
|
(fromUUID (fromClusterUUID cu))
|
|
describeUUID (fromClusterUUID cu) desc
|
|
|
|
next $ return True
|
|
where
|
|
ai = ActionItemOther (Just (UnquotedString clustername))
|
|
si = SeekInput [clustername]
|