Revision de36f091

b/src/Ganeti/OpCodes.hs
29 29
module Ganeti.OpCodes
30 30
  ( pyClasses
31 31
  , OpCode(..)
32
  , TagObject(..)
33
  , tagObjectFrom
34
  , encodeTagObject
35
  , decodeTagObject
36 32
  , ReplaceDisksMode(..)
37 33
  , DiskIndex
38 34
  , mkDiskIndex
b/src/Ganeti/OpParams.hs
33 33

  
34 34
module Ganeti.OpParams
35 35
  ( TagType(..)
36
  , TagObject(..)
37
  , tagObjectFrom
38
  , tagNameOf
39
  , decodeTagObject
40
  , encodeTagObject
41 36
  , ReplaceDisksMode(..)
42 37
  , DiskIndex
43 38
  , mkDiskIndex
......
317 312
  ])
318 313
$(makeJSONInstance ''TagType)
319 314

  
320
-- | Data type holding a tag object (type and object name).
321
data TagObject = TagInstance String
322
               | TagNode     String
323
               | TagGroup    String
324
               | TagCluster
325
               deriving (Show, Eq)
326

  
327
-- | Tag type for a given tag object.
328
tagTypeOf :: TagObject -> TagType
329
tagTypeOf (TagInstance {}) = TagTypeInstance
330
tagTypeOf (TagNode     {}) = TagTypeNode
331
tagTypeOf (TagGroup    {}) = TagTypeGroup
332
tagTypeOf (TagCluster  {}) = TagTypeCluster
333

  
334
-- | Gets the potential tag object name.
335
tagNameOf :: TagObject -> Maybe String
336
tagNameOf (TagInstance s) = Just s
337
tagNameOf (TagNode     s) = Just s
338
tagNameOf (TagGroup    s) = Just s
339
tagNameOf  TagCluster     = Nothing
340

  
341
-- | Builds a 'TagObject' from a tag type and name.
342
tagObjectFrom :: (Monad m) => TagType -> JSValue -> m TagObject
343
tagObjectFrom TagTypeInstance (JSString s) =
344
  return . TagInstance $ fromJSString s
345
tagObjectFrom TagTypeNode     (JSString s) = return . TagNode $ fromJSString s
346
tagObjectFrom TagTypeGroup    (JSString s) = return . TagGroup $ fromJSString s
347
tagObjectFrom TagTypeCluster   JSNull      = return TagCluster
348
tagObjectFrom t v =
349
  fail $ "Invalid tag type/name combination: " ++ show t ++ "/" ++
350
         show (pp_value v)
351

  
352
-- | Name of the tag \"name\" field.
353
tagNameField :: String
354
tagNameField = "name"
355

  
356
-- | Custom encoder for 'TagObject' as represented in an opcode.
357
encodeTagObject :: TagObject -> (JSValue, [(String, JSValue)])
358
encodeTagObject t = ( showJSON (tagTypeOf t)
359
                    , [(tagNameField, maybe JSNull showJSON (tagNameOf t))] )
360

  
361
-- | Custom decoder for 'TagObject' as represented in an opcode.
362
decodeTagObject :: (Monad m) => [(String, JSValue)] -> JSValue -> m TagObject
363
decodeTagObject obj kind = do
364
  ttype <- fromJVal kind
365
  tname <- fromObj obj tagNameField
366
  tagObjectFrom ttype tname
367

  
368 315
-- ** Disks
369 316

  
370 317
-- | Replace disks type.
b/test/hs/Test/Ganeti/OpCodes.hs
58 58

  
59 59
-- * Arbitrary instances
60 60

  
61
instance Arbitrary OpCodes.TagObject where
62
  arbitrary = oneof [ OpCodes.TagInstance <$> genFQDN
63
                    , OpCodes.TagNode     <$> genFQDN
64
                    , OpCodes.TagGroup    <$> genFQDN
65
                    , pure OpCodes.TagCluster
66
                    ]
61
instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (Map.Map k a) where
62
  arbitrary = Map.fromList <$> arbitrary
67 63

  
68 64
arbitraryOpTagsGet :: Gen OpCodes.OpCode
69 65
arbitraryOpTagsGet = do

Also available in: Unified diff