diff --git a/Makefile.am b/Makefile.am index 2a8fa9a74d12c042e548de29a642175cf46fbbac..9707e7e90a9dd700092a6f70982fde280bd2935f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -464,6 +464,7 @@ HS_LIB_SRCS = \ htools/Ganeti/Luxi.hs \ htools/Ganeti/Objects.hs \ htools/Ganeti/OpCodes.hs \ + htools/Ganeti/OpParams.hs \ htools/Ganeti/Path.hs \ htools/Ganeti/Query/Common.hs \ htools/Ganeti/Query/Filter.hs \ diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs index c4f75f56f9c5645b4dadb5a448bc6c8c2885736c..189a8322fad8a814efebd2ca88ffefe6bb1ed375 100644 --- a/htools/Ganeti/OpCodes.hs +++ b/htools/Ganeti/OpCodes.hs @@ -39,95 +39,11 @@ module Ganeti.OpCodes , allOpIDs ) where -import Text.JSON (readJSON, showJSON, JSON, JSValue(..), fromJSString) -import Text.JSON.Pretty (pp_value) +import Text.JSON (readJSON, showJSON, JSON()) -import qualified Ganeti.Constants as C import Ganeti.THH -import Ganeti.JSON - --- | Data type representing what items do the tag operations apply to. -$(declareSADT "TagType" - [ ("TagTypeInstance", 'C.tagInstance) - , ("TagTypeNode", 'C.tagNode) - , ("TagTypeGroup", 'C.tagNodegroup) - , ("TagTypeCluster", 'C.tagCluster) - ]) -$(makeJSONInstance ''TagType) - --- | Data type holding a tag object (type and object name). -data TagObject = TagInstance String - | TagNode String - | TagGroup String - | TagCluster - deriving (Show, Read, Eq) - --- | Tag type for a given tag object. -tagTypeOf :: TagObject -> TagType -tagTypeOf (TagInstance {}) = TagTypeInstance -tagTypeOf (TagNode {}) = TagTypeNode -tagTypeOf (TagGroup {}) = TagTypeGroup -tagTypeOf (TagCluster {}) = TagTypeCluster - --- | Gets the potential tag object name. -tagNameOf :: TagObject -> Maybe String -tagNameOf (TagInstance s) = Just s -tagNameOf (TagNode s) = Just s -tagNameOf (TagGroup s) = Just s -tagNameOf TagCluster = Nothing - --- | Builds a 'TagObject' from a tag type and name. -tagObjectFrom :: (Monad m) => TagType -> JSValue -> m TagObject -tagObjectFrom TagTypeInstance (JSString s) = - return . TagInstance $ fromJSString s -tagObjectFrom TagTypeNode (JSString s) = return . TagNode $ fromJSString s -tagObjectFrom TagTypeGroup (JSString s) = return . TagGroup $ fromJSString s -tagObjectFrom TagTypeCluster JSNull = return TagCluster -tagObjectFrom t v = - fail $ "Invalid tag type/name combination: " ++ show t ++ "/" ++ - show (pp_value v) - --- | Name of the tag \"name\" field. -tagNameField :: String -tagNameField = "name" - --- | Custom encoder for 'TagObject' as represented in an opcode. -encodeTagObject :: TagObject -> (JSValue, [(String, JSValue)]) -encodeTagObject t = ( showJSON (tagTypeOf t) - , [(tagNameField, maybe JSNull showJSON (tagNameOf t))] ) - --- | Custom decoder for 'TagObject' as represented in an opcode. -decodeTagObject :: (Monad m) => [(String, JSValue)] -> JSValue -> m TagObject -decodeTagObject obj kind = do - ttype <- fromJVal kind - tname <- fromObj obj tagNameField - tagObjectFrom ttype tname - --- | Replace disks type. -$(declareSADT "ReplaceDisksMode" - [ ("ReplaceOnPrimary", 'C.replaceDiskPri) - , ("ReplaceOnSecondary", 'C.replaceDiskSec) - , ("ReplaceNewSecondary", 'C.replaceDiskChg) - , ("ReplaceAuto", 'C.replaceDiskAuto) - ]) -$(makeJSONInstance ''ReplaceDisksMode) - --- | Disk index type (embedding constraints on the index value via a --- smart constructor). -newtype DiskIndex = DiskIndex { unDiskIndex :: Int } - deriving (Show, Read, Eq, Ord) - --- | Smart constructor for 'DiskIndex'. -mkDiskIndex :: (Monad m) => Int -> m DiskIndex -mkDiskIndex i | i >= 0 && i < C.maxDisks = return (DiskIndex i) - | otherwise = fail $ "Invalid value for disk index '" ++ - show i ++ "', required between 0 and " ++ - show C.maxDisks - -instance JSON DiskIndex where - readJSON v = readJSON v >>= mkDiskIndex - showJSON = showJSON . unDiskIndex +import Ganeti.OpParams -- | OpCode representation. -- @@ -140,33 +56,31 @@ $(genOpCode "OpCode" , simpleField "on_nodes" [t| [String] |] ]) , ("OpInstanceReplaceDisks", - [ simpleField "instance_name" [t| String |] + [ pInstanceName , optionalField $ simpleField "remote_node" [t| String |] , simpleField "mode" [t| ReplaceDisksMode |] , simpleField "disks" [t| [DiskIndex] |] , optionalField $ simpleField "iallocator" [t| String |] ]) , ("OpInstanceFailover", - [ simpleField "instance_name" [t| String |] + [ pInstanceName , simpleField "ignore_consistency" [t| Bool |] , optionalField $ simpleField "target_node" [t| String |] ]) , ("OpInstanceMigrate", - [ simpleField "instance_name" [t| String |] + [ pInstanceName , simpleField "live" [t| Bool |] , simpleField "cleanup" [t| Bool |] , defaultField [| False |] $ simpleField "allow_failover" [t| Bool |] , optionalField $ simpleField "target_node" [t| String |] ]) , ("OpTagsSet", - [ customField 'decodeTagObject 'encodeTagObject $ - simpleField "kind" [t| TagObject |] - , simpleField "tags" [t| [String] |] + [ pTagsObject + , pTagsList ]) , ("OpTagsDel", - [ customField 'decodeTagObject 'encodeTagObject $ - simpleField "kind" [t| TagObject |] - , simpleField "tags" [t| [String] |] + [ pTagsObject + , pTagsList ]) ]) diff --git a/htools/Ganeti/OpParams.hs b/htools/Ganeti/OpParams.hs new file mode 100644 index 0000000000000000000000000000000000000000..1612ee15d2648395f17ac98078ea378d364a054f --- /dev/null +++ b/htools/Ganeti/OpParams.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-| Implementation of opcodes parameters. + +These are defined in a separate module only due to TemplateHaskell +stage restrictions - expressions defined in the current module can't +be passed to splices. So we have to either parameters/repeat each +parameter definition multiple times, or separate them into this +module. + +-} + +{- + +Copyright (C) 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 +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.OpParams + ( TagType(..) + , TagObject(..) + , tagObjectFrom + , decodeTagObject + , encodeTagObject + , ReplaceDisksMode(..) + , DiskIndex + , mkDiskIndex + , unDiskIndex + , pInstanceName + , pTagsList + , pTagsObject + ) where + +import Text.JSON (readJSON, showJSON, JSON, JSValue(..), fromJSString) +import Text.JSON.Pretty (pp_value) + +import qualified Ganeti.Constants as C +import Ganeti.THH +import Ganeti.JSON + +-- * Helper functions and types + +-- ** Tags + +-- | Data type representing what items do the tag operations apply to. +$(declareSADT "TagType" + [ ("TagTypeInstance", 'C.tagInstance) + , ("TagTypeNode", 'C.tagNode) + , ("TagTypeGroup", 'C.tagNodegroup) + , ("TagTypeCluster", 'C.tagCluster) + ]) +$(makeJSONInstance ''TagType) + +-- | Data type holding a tag object (type and object name). +data TagObject = TagInstance String + | TagNode String + | TagGroup String + | TagCluster + deriving (Show, Read, Eq) + +-- | Tag type for a given tag object. +tagTypeOf :: TagObject -> TagType +tagTypeOf (TagInstance {}) = TagTypeInstance +tagTypeOf (TagNode {}) = TagTypeNode +tagTypeOf (TagGroup {}) = TagTypeGroup +tagTypeOf (TagCluster {}) = TagTypeCluster + +-- | Gets the potential tag object name. +tagNameOf :: TagObject -> Maybe String +tagNameOf (TagInstance s) = Just s +tagNameOf (TagNode s) = Just s +tagNameOf (TagGroup s) = Just s +tagNameOf TagCluster = Nothing + +-- | Builds a 'TagObject' from a tag type and name. +tagObjectFrom :: (Monad m) => TagType -> JSValue -> m TagObject +tagObjectFrom TagTypeInstance (JSString s) = + return . TagInstance $ fromJSString s +tagObjectFrom TagTypeNode (JSString s) = return . TagNode $ fromJSString s +tagObjectFrom TagTypeGroup (JSString s) = return . TagGroup $ fromJSString s +tagObjectFrom TagTypeCluster JSNull = return TagCluster +tagObjectFrom t v = + fail $ "Invalid tag type/name combination: " ++ show t ++ "/" ++ + show (pp_value v) + +-- | Name of the tag \"name\" field. +tagNameField :: String +tagNameField = "name" + +-- | Custom encoder for 'TagObject' as represented in an opcode. +encodeTagObject :: TagObject -> (JSValue, [(String, JSValue)]) +encodeTagObject t = ( showJSON (tagTypeOf t) + , [(tagNameField, maybe JSNull showJSON (tagNameOf t))] ) + +-- | Custom decoder for 'TagObject' as represented in an opcode. +decodeTagObject :: (Monad m) => [(String, JSValue)] -> JSValue -> m TagObject +decodeTagObject obj kind = do + ttype <- fromJVal kind + tname <- fromObj obj tagNameField + tagObjectFrom ttype tname + +-- ** Disks + +-- | Replace disks type. +$(declareSADT "ReplaceDisksMode" + [ ("ReplaceOnPrimary", 'C.replaceDiskPri) + , ("ReplaceOnSecondary", 'C.replaceDiskSec) + , ("ReplaceNewSecondary", 'C.replaceDiskChg) + , ("ReplaceAuto", 'C.replaceDiskAuto) + ]) +$(makeJSONInstance ''ReplaceDisksMode) + +-- | Disk index type (embedding constraints on the index value via a +-- smart constructor). +newtype DiskIndex = DiskIndex { unDiskIndex :: Int } + deriving (Show, Read, Eq, Ord) + +-- | Smart constructor for 'DiskIndex'. +mkDiskIndex :: (Monad m) => Int -> m DiskIndex +mkDiskIndex i | i >= 0 && i < C.maxDisks = return (DiskIndex i) + | otherwise = fail $ "Invalid value for disk index '" ++ + show i ++ "', required between 0 and " ++ + show C.maxDisks + +instance JSON DiskIndex where + readJSON v = readJSON v >>= mkDiskIndex + showJSON = showJSON . unDiskIndex + +-- * Parameters + +-- | Instance name. +pInstanceName :: Field +pInstanceName = simpleField "instance_name" [t| String |] + +-- | Tags list. +pTagsList :: Field +pTagsList = simpleField "tags" [t| [String] |] + +-- | Tags object. +pTagsObject :: Field +pTagsObject = customField 'decodeTagObject 'encodeTagObject $ + simpleField "kind" [t| TagObject |]