Commit 92f51573 authored by Iustin Pop's avatar Iustin Pop

Split OpCode.hs and add module for opcode parameters

Due to TemplateHaskell stage restrictions, we can't define parameters
in the same module as we're using them for TH, so we have to define
all module parameters in a separate module.

This patch therefore splits OpCodes.hs in two, adding that module and
moves most code there (types, parameters, etc.). The remaining parts
in OpCodes.hs, the actual opcode definitions, now use more parameters
instead of direct field definitions (more will come later)
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarAdeodato Simo <dato@google.com>
parent 5e9deac0
......@@ -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 \
......
......@@ -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
])
])
......
{-# 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 |]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment