diff --git a/htest/Test/Ganeti/Luxi.hs b/htest/Test/Ganeti/Luxi.hs
index 8e01bcc9ff7c14871f64d10909114099991d90d2..a788e59cfe40bca91ebe7c3de0e52c1dac44243c 100644
--- a/htest/Test/Ganeti/Luxi.hs
+++ b/htest/Test/Ganeti/Luxi.hs
@@ -69,7 +69,7 @@ instance Arbitrary Luxi.LuxiOp where
listOf getFQDN <*> arbitrary
Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields
Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo
- Luxi.ReqQueryTags -> Luxi.QueryTags <$> arbitrary <*> getFQDN
+ Luxi.ReqQueryTags -> Luxi.QueryTags <$> arbitrary
Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> resize maxOpCodes arbitrary
Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$>
resize maxOpCodes arbitrary
diff --git a/htest/Test/Ganeti/OpCodes.hs b/htest/Test/Ganeti/OpCodes.hs
index e2bc8a468ce1a869fc4299f728404978482f83d4..728fa76dcfa97321cfa8ae098e5c9c3b6858aaba 100644
--- a/htest/Test/Ganeti/OpCodes.hs
+++ b/htest/Test/Ganeti/OpCodes.hs
@@ -48,7 +48,12 @@ import qualified Ganeti.OpCodes as OpCodes
-- * Arbitrary instances
-$(genArbitrary ''OpCodes.TagObject)
+instance Arbitrary OpCodes.TagObject where
+ arbitrary = oneof [ OpCodes.TagInstance <$> getFQDN
+ , OpCodes.TagNode <$> getFQDN
+ , OpCodes.TagGroup <$> getFQDN
+ , pure OpCodes.TagCluster
+ ]
$(genArbitrary ''OpCodes.ReplaceDisksMode)
@@ -72,9 +77,9 @@ instance Arbitrary OpCodes.OpCode where
OpCodes.OpInstanceMigrate <$> getFQDN <*> arbitrary <*>
arbitrary <*> arbitrary <*> getMaybe getFQDN
"OP_TAGS_SET" ->
- OpCodes.OpTagsSet <$> arbitrary <*> genTags <*> getMaybe getFQDN
+ OpCodes.OpTagsSet <$> arbitrary <*> genTags
"OP_TAGS_DEL" ->
- OpCodes.OpTagsSet <$> arbitrary <*> genTags <*> getMaybe getFQDN
+ OpCodes.OpTagsSet <$> arbitrary <*> genTags
_ -> fail "Wrong opcode"
-- * Test cases
diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index 622eceb6c0fefeaaafc193b65ed8c6d31ffc02ac..8ad7f32b74bdf39d918567095a0ea5cf7c74d150 100644
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -137,8 +137,8 @@ $(genLuxiOp "LuxiOp"
)
, (luxiReqQueryClusterInfo, [])
, (luxiReqQueryTags,
- [ simpleField "kind" [t| TagObject |]
- , simpleField "name" [t| String |]
+ [ customField 'decodeTagObject 'encodeTagObject $
+ simpleField "kind" [t| TagObject |]
])
, (luxiReqSubmitJob,
[ simpleField "job" [t| [OpCode] |] ]
@@ -386,7 +386,8 @@ decodeCall (LuxiCall call args) =
return $ QueryConfigValues fields
ReqQueryTags -> do
(kind, name) <- fromJVal args
- return $ QueryTags kind name
+ item <- tagObjectFrom kind name
+ return $ QueryTags item
ReqCancelJob -> do
[job] <- fromJVal args
rid <- parseJobId job
diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs
index 789d84a04f411e0b1e57a2e350c4edf78a49ea45..e2c91810fe49eb1da648a18fe2741d2777869a24 100644
--- a/htools/Ganeti/OpCodes.hs
+++ b/htools/Ganeti/OpCodes.hs
@@ -28,6 +28,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Ganeti.OpCodes
( OpCode(..)
, TagObject(..)
+ , tagObjectFrom
+ , encodeTagObject
+ , decodeTagObject
, ReplaceDisksMode(..)
, DiskIndex
, mkDiskIndex
@@ -36,7 +39,8 @@ module Ganeti.OpCodes
, allOpIDs
) where
-import Text.JSON (readJSON, showJSON, makeObj, JSON)
+import Text.JSON (readJSON, showJSON, makeObj, JSON, JSValue(..), fromJSString)
+import Text.JSON.Pretty (pp_value)
import qualified Ganeti.Constants as C
import Ganeti.THH
@@ -44,13 +48,61 @@ import Ganeti.THH
import Ganeti.JSON
-- | Data type representing what items do the tag operations apply to.
-$(declareSADT "TagObject"
- [ ("TagInstance", 'C.tagInstance)
- , ("TagNode", 'C.tagNode)
- , ("TagGroup", 'C.tagNodegroup)
- , ("TagCluster", 'C.tagCluster)
+$(declareSADT "TagType"
+ [ ("TagTypeInstance", 'C.tagInstance)
+ , ("TagTypeNode", 'C.tagNode)
+ , ("TagTypeGroup", 'C.tagNodegroup)
+ , ("TagTypeCluster", 'C.tagCluster)
])
-$(makeJSONInstance ''TagObject)
+$(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"
@@ -107,14 +159,14 @@ $(genOpCode "OpCode"
, optionalField $ simpleField "target_node" [t| String |]
])
, ("OpTagsSet",
- [ simpleField "kind" [t| TagObject |]
+ [ customField 'decodeTagObject 'encodeTagObject $
+ simpleField "kind" [t| TagObject |]
, simpleField "tags" [t| [String] |]
- , optionalNullSerField $ simpleField "name" [t| String |]
])
, ("OpTagsDel",
- [ simpleField "kind" [t| TagObject |]
+ [ customField 'decodeTagObject 'encodeTagObject $
+ simpleField "kind" [t| TagObject |]
, simpleField "tags" [t| [String] |]
- , optionalNullSerField $ simpleField "name" [t| String |]
])
])
diff --git a/htools/Ganeti/Query/Server.hs b/htools/Ganeti/Query/Server.hs
index 91aa745ca93cb272542743dbfc87938e56aad4a3..6b33a9ea92bc347ed215f2e6416bd01a050085e5 100644
--- a/htools/Ganeti/Query/Server.hs
+++ b/htools/Ganeti/Query/Server.hs
@@ -138,12 +138,12 @@ handleCall cdata QueryClusterInfo =
in return . Ok . J.makeObj $ obj
-handleCall cfg (QueryTags kind name) =
+handleCall cfg (QueryTags kind) =
let tags = case kind of
- TagCluster -> Ok . clusterTags $ configCluster cfg
- TagGroup -> groupTags <$> Config.getGroup cfg name
- TagNode -> nodeTags <$> Config.getNode cfg name
- TagInstance -> instTags <$> Config.getInstance cfg name
+ TagCluster -> Ok . clusterTags $ configCluster cfg
+ TagGroup name -> groupTags <$> Config.getGroup cfg name
+ TagNode name -> nodeTags <$> Config.getNode cfg name
+ TagInstance name -> instTags <$> Config.getInstance cfg name
in return (J.showJSON <$> tags)
handleCall cfg (Query qkind qfields qfilter) = do