From d8e7c45e2e7d3a64f8d9d7e0d7ae621ba21af6be Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Thu, 8 Nov 2012 13:51:11 +0100
Subject: [PATCH] Convert tag objects to a safer type
Currently, we keep information about the "target" of a tag operation
in a data type similar to (TagKind, Maybe String). This is unsafe, as
nothing (at the type level) prevents us from accidentally having
(TagCluster, Just "instance1.example.com"), or (TagInstance, Nothing).
To fix this problem, we rename the current TagObject type to TagType
(an internal utility type), and create TagObject as a better/safer
data type (see the definition), which doesn't allow such possibilities
in the future.
The downside is that, since at encoding level (both opcode and luxi)
this is done in an ugly way (type elements spread at the same level as
level as other value), we have to add custom encoders/decoders. The
encoder is shared between the OpCode and Luxi usage, the decoder is
different however as Luxi uses custom decoding.
This also fixes the recent breakage in confd w.r.t. QueryTags.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Michael Hanselmann <hansmi@google.com>
---
htest/Test/Ganeti/Luxi.hs | 2 +-
htest/Test/Ganeti/OpCodes.hs | 11 ++++--
htools/Ganeti/Luxi.hs | 7 ++--
htools/Ganeti/OpCodes.hs | 74 +++++++++++++++++++++++++++++------
htools/Ganeti/Query/Server.hs | 10 ++---
5 files changed, 81 insertions(+), 23 deletions(-)
diff --git a/htest/Test/Ganeti/Luxi.hs b/htest/Test/Ganeti/Luxi.hs
index 8e01bcc9f..a788e59cf 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 e2bc8a468..728fa76dc 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 622eceb6c..8ad7f32b7 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 789d84a04..e2c91810f 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 91aa745ca..6b33a9ea9 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
--
GitLab