-}
module Ganeti.OpCodes
- ( OpCode(..)
- , ReplaceDisksMode(..)
- , opID
- ) where
+ ( 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 qualified Ganeti.Constants as C
-import qualified Ganeti.THH as THH
+import Ganeti.THH
-import Ganeti.HTools.Utils
+import Ganeti.HTools.JSON
-- | Replace disks type.
-$(THH.declareSADT "ReplaceDisksMode"
- [ ("ReplaceOnPrimary", 'C.replaceDiskPri)
- , ("ReplaceOnSecondary", 'C.replaceDiskSec)
- , ("ReplaceNewSecondary", 'C.replaceDiskChg)
- , ("ReplaceAuto", 'C.replaceDiskAuto)
- ])
-$(THH.makeJSONInstance ''ReplaceDisksMode)
+$(declareSADT "ReplaceDisksMode"
+ [ ("ReplaceOnPrimary", 'C.replaceDiskPri)
+ , ("ReplaceOnSecondary", 'C.replaceDiskSec)
+ , ("ReplaceNewSecondary", 'C.replaceDiskChg)
+ , ("ReplaceAuto", 'C.replaceDiskAuto)
+ ])
+$(makeJSONInstance ''ReplaceDisksMode)
-- | OpCode representation.
--
-- We only implement a subset of Ganeti opcodes, but only what we
-- actually use in the htools codebase.
-data OpCode = OpTestDelay Double Bool [String]
- | OpInstanceReplaceDisks String (Maybe String) ReplaceDisksMode
- [Int] (Maybe String)
- | OpInstanceFailover String Bool (Maybe String)
- | OpInstanceMigrate String Bool Bool Bool (Maybe String)
- deriving (Show, Read, Eq)
-
-
--- | Computes the OP_ID for an OpCode.
-opID :: OpCode -> String
-opID (OpTestDelay _ _ _) = "OP_TEST_DELAY"
-opID (OpInstanceReplaceDisks _ _ _ _ _) = "OP_INSTANCE_REPLACE_DISKS"
-opID (OpInstanceFailover {}) = "OP_INSTANCE_FAILOVER"
-opID (OpInstanceMigrate {}) = "OP_INSTANCE_MIGRATE"
-
--- | Loads an OpCode from the JSON serialised form.
-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"
- tnode <- maybeFromObj o "target_node"
- return $ OpInstanceFailover inst consist tnode
- "OP_INSTANCE_MIGRATE" -> do
- inst <- extract "instance_name"
- live <- extract "live"
- cleanup <- extract "cleanup"
- allow_failover <- fromObjWithDefault o "allow_failover" False
- tnode <- maybeFromObj o "target_node"
- return $ OpInstanceMigrate inst live cleanup
- allow_failover tnode
- _ -> J.Error $ "Unknown opcode " ++ op_id
-
--- | Serialises an opcode to JSON.
-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 tnode) =
- let ol = [ ("OP_ID", showJSON $ opID op)
- , ("instance_name", showJSON inst)
- , ("ignore_consistency", showJSON consist) ]
- ol' = case tnode of
- Nothing -> ol
- Just node -> ("target_node", showJSON node):ol
- in makeObj ol'
-
-saveOpCode op@(OpInstanceMigrate inst live cleanup allow_failover tnode) =
- let ol = [ ("OP_ID", showJSON $ opID op)
- , ("instance_name", showJSON inst)
- , ("live", showJSON live)
- , ("cleanup", showJSON cleanup)
- , ("allow_failover", showJSON allow_failover) ]
- ol' = case tnode of
- Nothing -> ol
- Just node -> ("target_node", showJSON node):ol
- in makeObj ol'
+$(genOpCode "OpCode"
+ [ ("OpTestDelay",
+ [ simpleField "duration" [t| Double |]
+ , simpleField "on_master" [t| Bool |]
+ , simpleField "on_nodes" [t| [String] |]
+ ])
+ , ("OpInstanceReplaceDisks",
+ [ simpleField "instance_name" [t| String |]
+ , optionalField $ simpleField "remote_node" [t| String |]
+ , simpleField "mode" [t| ReplaceDisksMode |]
+ , simpleField "disks" [t| [Int] |]
+ , optionalField $ simpleField "iallocator" [t| String |]
+ ])
+ , ("OpInstanceFailover",
+ [ simpleField "instance_name" [t| String |]
+ , simpleField "ignore_consistency" [t| Bool |]
+ , optionalField $ simpleField "target_node" [t| String |]
+ ])
+ , ("OpInstanceMigrate",
+ [ simpleField "instance_name" [t| String |]
+ , simpleField "live" [t| Bool |]
+ , simpleField "cleanup" [t| Bool |]
+ , defaultField [| False |] $ simpleField "allow_failover" [t| Bool |]
+ , optionalField $ simpleField "target_node" [t| String |]
+ ])
+ ])
+
+$(genOpID ''OpCode "opID")
instance JSON OpCode where
- readJSON = loadOpCode
- showJSON = saveOpCode
+ readJSON = loadOpCode
+ showJSON = saveOpCode