Synnefo » snf-ganeti » ganeti-local

{-# LANGUAGE TemplateHaskell #-}

{-| Implementation of the opcodes.

-}

{-

Copyright (C) 2009, 2010, 2011 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

the Free Software Foundation; either version 2 of the License, or

(at your option) any later version.

This program is distributed in the hope that it will be useful, but

WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

General Public License for more details.

You should have received a copy of the GNU General Public License

along with this program; if not, write to the Free Software

Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA

02110-1301, USA.

-}

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 qualified Ganeti.Constants as C

import qualified Ganeti.THH as THH

import Ganeti.HTools.Utils

-- | Replace disks type.

$(THH.declareSADT "ReplaceDisksMode"

     [ ("ReplaceOnPrimary",    'C.replaceDiskPri)

     , ("ReplaceOnSecondary",  'C.replaceDiskSec)

     , ("ReplaceNewSecondary", 'C.replaceDiskChg)

     , ("ReplaceAuto",         'C.replaceDiskAuto)

     ])

$(THH.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)

$(THH.genOpID ''OpCode "opID")

-- | 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'

instance JSON OpCode where

    readJSON = loadOpCode

    showJSON = saveOpCode