+{-# LANGUAGE TemplateHaskell #-}
+
{-| Implementation of the opcodes.
-}
{-
-Copyright (C) 2009, 2010, 2011 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-}
module Ganeti.OpCodes
- ( OpCode(..)
- , ReplaceDisksMode(..)
- , opID
- ) where
-
-import Control.Monad
-import Text.JSON (readJSON, showJSON, makeObj, JSON)
-import qualified Text.JSON as J
-import Text.JSON.Types
-
-import Ganeti.HTools.Utils
-
-data ReplaceDisksMode = ReplaceOnPrimary
- | ReplaceOnSecondary
- | ReplaceNewSecondary
- | ReplaceAuto
- deriving (Show, Read, Eq)
-
-instance JSON ReplaceDisksMode where
- showJSON m = case m of
- ReplaceOnPrimary -> showJSON "replace_on_primary"
- ReplaceOnSecondary -> showJSON "replace_on_secondary"
- ReplaceNewSecondary -> showJSON "replace_new_secondary"
- ReplaceAuto -> showJSON "replace_auto"
- readJSON s = case readJSON s of
- J.Ok "replace_on_primary" -> J.Ok ReplaceOnPrimary
- J.Ok "replace_on_secondary" -> J.Ok ReplaceOnSecondary
- J.Ok "replace_new_secondary" -> J.Ok ReplaceNewSecondary
- J.Ok "replace_auto" -> J.Ok ReplaceAuto
- _ -> J.Error "Can't parse a valid ReplaceDisksMode"
-
-data OpCode = OpTestDelay Double Bool [String]
- | OpInstanceReplaceDisks String (Maybe String) ReplaceDisksMode
- [Int] (Maybe String)
- | OpInstanceFailover String Bool
- | OpInstanceMigrate String Bool Bool Bool
- deriving (Show, Read, Eq)
-
-
-opID :: OpCode -> String
-opID (OpTestDelay _ _ _) = "OP_TEST_DELAY"
-opID (OpInstanceReplaceDisks _ _ _ _ _) = "OP_INSTANCE_REPLACE_DISKS"
-opID (OpInstanceFailover _ _) = "OP_INSTANCE_FAILOVER"
-opID (OpInstanceMigrate _ _ _ _) = "OP_INSTANCE_MIGRATE"
-
-loadOpCode :: JSValue -> J.Result OpCode
-loadOpCode v = do
- o <- liftM J.fromJSObject (readJSON v)
- let extract x = fromObj o x
- op_id <- extract "OP_ID"
- case op_id of
- "OP_TEST_DELAY" -> do
- on_nodes <- extract "on_nodes"
- on_master <- extract "on_master"
- duration <- extract "duration"
- return $ OpTestDelay duration on_master on_nodes
- "OP_INSTANCE_REPLACE_DISKS" -> do
- inst <- extract "instance_name"
- node <- maybeFromObj o "remote_node"
- mode <- extract "mode"
- disks <- extract "disks"
- ialloc <- maybeFromObj o "iallocator"
- return $ OpInstanceReplaceDisks inst node mode disks ialloc
- "OP_INSTANCE_FAILOVER" -> do
- inst <- extract "instance_name"
- consist <- extract "ignore_consistency"
- return $ OpInstanceFailover inst consist
- "OP_INSTANCE_MIGRATE" -> do
- inst <- extract "instance_name"
- live <- extract "live"
- cleanup <- extract "cleanup"
- allow_failover <- fromObjWithDefault o "allow_failover" False
- return $ OpInstanceMigrate inst live cleanup allow_failover
- _ -> J.Error $ "Unknown opcode " ++ op_id
-
-saveOpCode :: OpCode -> JSValue
-saveOpCode op@(OpTestDelay duration on_master on_nodes) =
- let ol = [ ("OP_ID", showJSON $ opID op)
- , ("duration", showJSON duration)
- , ("on_master", showJSON on_master)
- , ("on_nodes", showJSON on_nodes) ]
- in makeObj ol
-
-saveOpCode op@(OpInstanceReplaceDisks inst node mode disks iallocator) =
- let ol = [ ("OP_ID", showJSON $ opID op)
- , ("instance_name", showJSON inst)
- , ("mode", showJSON mode)
- , ("disks", showJSON disks)]
- ol2 = case node of
- Just n -> ("remote_node", showJSON n):ol
- Nothing -> ol
- ol3 = case iallocator of
- Just i -> ("iallocator", showJSON i):ol2
- Nothing -> ol2
- in makeObj ol3
-
-saveOpCode op@(OpInstanceFailover inst consist) =
- let ol = [ ("OP_ID", showJSON $ opID op)
- , ("instance_name", showJSON inst)
- , ("ignore_consistency", showJSON consist) ]
- in makeObj ol
-
-saveOpCode op@(OpInstanceMigrate inst live cleanup allow_failover) =
- let ol = [ ("OP_ID", showJSON $ opID op)
- , ("instance_name", showJSON inst)
- , ("live", showJSON live)
- , ("cleanup", showJSON cleanup)
- , ("allow_failover", showJSON allow_failover) ]
- in makeObj ol
+ ( OpCode(..)
+ , TagObject(..)
+ , tagObjectFrom
+ , encodeTagObject
+ , decodeTagObject
+ , ReplaceDisksMode(..)
+ , DiskIndex
+ , mkDiskIndex
+ , unDiskIndex
+ , opID
+ , allOpIDs
+ ) where
+
+import Text.JSON (readJSON, showJSON, JSON())
+
+import Ganeti.THH
+
+import Ganeti.OpParams
+
+-- | OpCode representation.
+--
+-- We only implement a subset of Ganeti opcodes: those which are actually used
+-- in the htools codebase.
+$(genOpCode "OpCode"
+ [ ("OpTestDelay",
+ [ simpleField "duration" [t| Double |]
+ , simpleField "on_master" [t| Bool |]
+ , simpleField "on_nodes" [t| [String] |]
+ ])
+ , ("OpInstanceReplaceDisks",
+ [ pInstanceName
+ , pRemoteNode
+ , simpleField "mode" [t| ReplaceDisksMode |]
+ , simpleField "disks" [t| [DiskIndex] |]
+ , pIallocator
+ ])
+ , ("OpInstanceFailover",
+ [ pInstanceName
+ , simpleField "ignore_consistency" [t| Bool |]
+ , pMigrationTargetNode
+ ])
+ , ("OpInstanceMigrate",
+ [ pInstanceName
+ , simpleField "live" [t| Bool |]
+ , simpleField "cleanup" [t| Bool |]
+ , defaultField [| False |] $ simpleField "allow_failover" [t| Bool |]
+ , pMigrationTargetNode
+ ])
+ , ("OpTagsSet",
+ [ pTagsObject
+ , pTagsList
+ ])
+ , ("OpTagsDel",
+ [ pTagsObject
+ , pTagsList
+ ])
+ , ("OpClusterPostInit", [])
+ , ("OpClusterDestroy", [])
+ , ("OpClusterQuery", [])
+ , ("OpClusterVerify",
+ [ pDebugSimulateErrors
+ , pErrorCodes
+ , pSkipChecks
+ , pIgnoreErrors
+ , pVerbose
+ , pOptGroupName
+ ])
+ , ("OpClusterVerifyConfig",
+ [ pDebugSimulateErrors
+ , pErrorCodes
+ , pIgnoreErrors
+ , pVerbose
+ ])
+ , ("OpClusterVerifyGroup",
+ [ pGroupName
+ , pDebugSimulateErrors
+ , pErrorCodes
+ , pSkipChecks
+ , pIgnoreErrors
+ , pVerbose
+ ])
+ , ("OpClusterVerifyDisks", [])
+ , ("OpGroupVerifyDisks",
+ [ pGroupName
+ ])
+ , ("OpClusterRepairDiskSizes",
+ [ pInstances
+ ])
+ , ("OpClusterConfigQuery",
+ [ pOutputFields
+ ])
+ , ("OpClusterRename",
+ [ pName
+ ])
+ , ("OpClusterSetParams",
+ [ pHvState
+ , pDiskState
+ , pVgName
+ , pEnabledHypervisors
+ , pClusterHvParams
+ , pClusterBeParams
+ , pOsHvp
+ , pOsParams
+ , pDiskParams
+ , pCandidatePoolSize
+ , pUidPool
+ , pAddUids
+ , pRemoveUids
+ , pMaintainNodeHealth
+ , pPreallocWipeDisks
+ , pNicParams
+ , pNdParams
+ , pIpolicy
+ , pDrbdHelper
+ , pDefaultIAllocator
+ , pMasterNetdev
+ , pReservedLvs
+ , pHiddenOs
+ , pBlacklistedOs
+ , pUseExternalMipScript
+ ])
+ , ("OpClusterRedistConf", [])
+ , ("OpClusterActivateMasterIp", [])
+ , ("OpClusterDeactivateMasterIp", [])
+ , ("OpQuery",
+ [ pQueryWhat
+ , pUseLocking
+ , pQueryFields
+ , pQueryFilter
+ ])
+ , ("OpQueryFields",
+ [ pQueryWhat
+ , pQueryFields
+ ])
+ , ("OpOobCommand",
+ [ pNodeNames
+ , pOobCommand
+ , pOobTimeout
+ , pIgnoreStatus
+ , pPowerDelay
+ ])
+ , ("OpNodeRemove", [ pNodeName ])
+ , ("OpNodeAdd",
+ [ pNodeName
+ , pHvState
+ , pDiskState
+ , pPrimaryIp
+ , pSecondaryIp
+ , pReadd
+ , pNodeGroup
+ , pMasterCapable
+ , pVmCapable
+ , pNdParams
+ ])
+ , ("OpNodeQuery",
+ [ pOutputFields
+ , pUseLocking
+ , pNames
+ ])
+ , ("OpNodeQueryvols",
+ [ pOutputFields
+ , pNodes
+ ])
+ , ("OpNodeQueryStorage",
+ [ pOutputFields
+ , pStorageType
+ , pNodes
+ , pStorageName
+ ])
+ , ("OpNodeModifyStorage",
+ [ pNodeName
+ , pStorageType
+ , pStorageName
+ , pStorageChanges
+ ])
+ , ("OpRepairNodeStorage",
+ [ pNodeName
+ , pStorageType
+ , pStorageName
+ , pIgnoreConsistency
+ ])
+ , ("OpNodeSetParams",
+ [ pNodeName
+ , pForce
+ , pHvState
+ , pDiskState
+ , pMasterCandidate
+ , pOffline
+ , pDrained
+ , pAutoPromote
+ , pMasterCapable
+ , pVmCapable
+ , pSecondaryIp
+ , pNdParams
+ ])
+ , ("OpNodePowercycle",
+ [ pNodeName
+ , pForce
+ ])
+ , ("OpNodeMigrate",
+ [ pNodeName
+ , pMigrationMode
+ , pMigrationLive
+ , pMigrationTargetNode
+ , pAllowRuntimeChgs
+ , pIgnoreIpolicy
+ , pIallocator
+ ])
+ , ("OpNodeEvacuate",
+ [ pEarlyRelease
+ , pNodeName
+ , pRemoteNode
+ , pIallocator
+ , pEvacMode
+ ])
+ ])
+
+-- | Returns the OP_ID for a given opcode value.
+$(genOpID ''OpCode "opID")
+
+-- | A list of all defined/supported opcode IDs.
+$(genAllOpIDs ''OpCode "allOpIDs")
instance JSON OpCode where
- readJSON = loadOpCode
- showJSON = saveOpCode
+ readJSON = loadOpCode
+ showJSON = saveOpCode
projects / ganeti-local / blobdiff