code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/OpCodes.hs

   1 {-| Implementation of the opcodes.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009, 2010, 2011 Google Inc.
   8
   9 This program is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 2 of the License, or
  12 (at your option) any later version.
  13
  14 This program is distributed in the hope that it will be useful, but
  15 WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program; if not, write to the Free Software
  21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.
  23
  24 -}
  25
  26 module Ganeti.OpCodes
  27     ( OpCode(..)
  28     , ReplaceDisksMode(..)
  29     , opID
  30     ) where
  31
  32 import Control.Monad
  33 import Text.JSON (readJSON, showJSON, makeObj, JSON)
  34 import qualified Text.JSON as J
  35 import Text.JSON.Types
  36
  37 import Ganeti.HTools.Utils
  38
  39 -- | Replace disks type.
  40 data ReplaceDisksMode = ReplaceOnPrimary
  41                   | ReplaceOnSecondary
  42                   | ReplaceNewSecondary
  43                   | ReplaceAuto
  44                   deriving (Show, Read, Eq)
  45
  46 instance JSON ReplaceDisksMode where
  47     showJSON m = case m of
  48                  ReplaceOnPrimary -> showJSON "replace_on_primary"
  49                  ReplaceOnSecondary -> showJSON "replace_on_secondary"
  50                  ReplaceNewSecondary -> showJSON "replace_new_secondary"
  51                  ReplaceAuto -> showJSON "replace_auto"
  52     readJSON s = case readJSON s of
  53                    J.Ok "replace_on_primary" -> J.Ok ReplaceOnPrimary
  54                    J.Ok "replace_on_secondary" -> J.Ok ReplaceOnSecondary
  55                    J.Ok "replace_new_secondary" -> J.Ok ReplaceNewSecondary
  56                    J.Ok "replace_auto" -> J.Ok ReplaceAuto
  57                    _ -> J.Error "Can't parse a valid ReplaceDisksMode"
  58
  59 -- | OpCode representation.
  60 --
  61 -- We only implement a subset of Ganeti opcodes, but only what we
  62 -- actually use in the htools codebase.
  63 data OpCode = OpTestDelay Double Bool [String]
  64             | OpInstanceReplaceDisks String (Maybe String) ReplaceDisksMode
  65               [Int] (Maybe String)
  66             | OpInstanceFailover String Bool
  67             | OpInstanceMigrate String Bool Bool Bool
  68             deriving (Show, Read, Eq)
  69
  70
  71 -- | Computes the OP_ID for an OpCode.
  72 opID :: OpCode -> String
  73 opID (OpTestDelay _ _ _) = "OP_TEST_DELAY"
  74 opID (OpInstanceReplaceDisks _ _ _ _ _) = "OP_INSTANCE_REPLACE_DISKS"
  75 opID (OpInstanceFailover _ _) = "OP_INSTANCE_FAILOVER"
  76 opID (OpInstanceMigrate _ _ _ _) = "OP_INSTANCE_MIGRATE"
  77
  78 -- | Loads an OpCode from the JSON serialised form.
  79 loadOpCode :: JSValue -> J.Result OpCode
  80 loadOpCode v = do
  81   o <- liftM J.fromJSObject (readJSON v)
  82   let extract x = fromObj o x
  83   op_id <- extract "OP_ID"
  84   case op_id of
  85     "OP_TEST_DELAY" -> do
  86                  on_nodes  <- extract "on_nodes"
  87                  on_master <- extract "on_master"
  88                  duration  <- extract "duration"
  89                  return $ OpTestDelay duration on_master on_nodes
  90     "OP_INSTANCE_REPLACE_DISKS" -> do
  91                  inst   <- extract "instance_name"
  92                  node   <- maybeFromObj o "remote_node"
  93                  mode   <- extract "mode"
  94                  disks  <- extract "disks"
  95                  ialloc <- maybeFromObj o "iallocator"
  96                  return $ OpInstanceReplaceDisks inst node mode disks ialloc
  97     "OP_INSTANCE_FAILOVER" -> do
  98                  inst    <- extract "instance_name"
  99                  consist <- extract "ignore_consistency"
 100                  return $ OpInstanceFailover inst consist
 101     "OP_INSTANCE_MIGRATE" -> do
 102                  inst    <- extract "instance_name"
 103                  live    <- extract "live"
 104                  cleanup <- extract "cleanup"
 105                  allow_failover <- fromObjWithDefault o "allow_failover" False
 106                  return $ OpInstanceMigrate inst live cleanup allow_failover
 107     _ -> J.Error $ "Unknown opcode " ++ op_id
 108
 109 -- | Serialises an opcode to JSON.
 110 saveOpCode :: OpCode -> JSValue
 111 saveOpCode op@(OpTestDelay duration on_master on_nodes) =
 112     let ol = [ ("OP_ID", showJSON $ opID op)
 113              , ("duration", showJSON duration)
 114              , ("on_master", showJSON on_master)
 115              , ("on_nodes", showJSON on_nodes) ]
 116     in makeObj ol
 117
 118 saveOpCode op@(OpInstanceReplaceDisks inst node mode disks iallocator) =
 119     let ol = [ ("OP_ID", showJSON $ opID op)
 120              , ("instance_name", showJSON inst)
 121              , ("mode", showJSON mode)
 122              , ("disks", showJSON disks)]
 123         ol2 = case node of
 124                 Just n -> ("remote_node", showJSON n):ol
 125                 Nothing -> ol
 126         ol3 = case iallocator of
 127                 Just i -> ("iallocator", showJSON i):ol2
 128                 Nothing -> ol2
 129     in makeObj ol3
 130
 131 saveOpCode op@(OpInstanceFailover inst consist) =
 132     let ol = [ ("OP_ID", showJSON $ opID op)
 133              , ("instance_name", showJSON inst)
 134              , ("ignore_consistency", showJSON consist) ]
 135     in makeObj ol
 136
 137 saveOpCode op@(OpInstanceMigrate inst live cleanup allow_failover) =
 138     let ol = [ ("OP_ID", showJSON $ opID op)
 139              , ("instance_name", showJSON inst)
 140              , ("live", showJSON live)
 141              , ("cleanup", showJSON cleanup)
 142              , ("allow_failover", showJSON allow_failover) ]
 143     in makeObj ol
 144
 145 instance JSON OpCode where
 146     readJSON = loadOpCode
 147     showJSON = saveOpCode