Simplify a bit queryFields

[ganeti-local] / htools / Ganeti / Objects.hs

diff --git a/htools/Ganeti/Objects.hs b/htools/Ganeti/Objects.hs
index d20edb4..dfc6480 100644 (file)
--- a/htools/Ganeti/Objects.hs
+++ b/htools/Ganeti/Objects.hs
@@ -29,13 +29,18 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 -}
 
 module Ganeti.Objects
 -}
 
 module Ganeti.Objects

-  ( HvParams
+  ( VType(..)
+  , vTypeFromRaw
+  , HvParams

   , OsParams
   , NICMode(..)
   , PartialNicParams(..)
   , FilledNicParams(..)
   , fillNicParams
   , OsParams
   , NICMode(..)
   , PartialNicParams(..)
   , FilledNicParams(..)
   , fillNicParams

+  , allNicParamFields

   , PartialNic(..)
   , PartialNic(..)

+  , FileDriver(..)
+  , BlockDriver(..)

   , DiskMode(..)
   , DiskType(..)
   , DiskLogicalId(..)
   , DiskMode(..)
   , DiskType(..)
   , DiskLogicalId(..)

@@ -44,6 +49,7 @@ module Ganeti.Objects
   , PartialBeParams(..)
   , FilledBeParams(..)
   , fillBeParams
   , PartialBeParams(..)
   , FilledBeParams(..)
   , fillBeParams

+  , allBeParamFields

   , Hypervisor(..)
   , AdminState(..)
   , adminStateFromRaw
   , Hypervisor(..)
   , AdminState(..)
   , adminStateFromRaw

@@ -52,11 +58,16 @@ module Ganeti.Objects
   , PartialNDParams(..)
   , FilledNDParams(..)
   , fillNDParams
   , PartialNDParams(..)
   , FilledNDParams(..)
   , fillNDParams

+  , allNDParamFields

   , Node(..)
   , Node(..)

+  , NodeRole(..)
+  , nodeRoleToRaw
+  , roleDescription

   , AllocPolicy(..)
   , FilledISpecParams(..)
   , PartialISpecParams(..)
   , fillISpecParams
   , AllocPolicy(..)
   , FilledISpecParams(..)
   , PartialISpecParams(..)
   , fillISpecParams

+  , allISpecParamFields

   , FilledIPolicy(..)
   , PartialIPolicy(..)
   , fillIPolicy
   , FilledIPolicy(..)
   , PartialIPolicy(..)
   , fillIPolicy

@@ -72,16 +83,23 @@ module Ganeti.Objects
   , ClusterNicParams
   , Cluster(..)
   , ConfigData(..)
   , ClusterNicParams
   , Cluster(..)
   , ConfigData(..)

+  , TimeStampObject(..)
+  , UuidObject(..)
+  , SerialNoObject(..)
+  , TagsObject(..)
+  , DictObject(..) -- re-exported from THH
+  , TagSet -- re-exported from THH

   ) where
 
 import Data.List (foldl')
 import Data.Maybe
 import qualified Data.Map as Map
   ) where
 
 import Data.List (foldl')
 import Data.Maybe
 import qualified Data.Map as Map

+import qualified Data.Set as Set

 import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..))
 import qualified Text.JSON as J
 
 import qualified Ganeti.Constants as C
 import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..))
 import qualified Text.JSON as J
 
 import qualified Ganeti.Constants as C

-import Ganeti.HTools.JSON
+import Ganeti.JSON

 
 import Ganeti.THH
 
 
 import Ganeti.THH
 

@@ -94,6 +112,16 @@ fillDict defaults custom skip_keys =
   let updated = Map.union custom defaults
   in foldl' (flip Map.delete) updated skip_keys
 
   let updated = Map.union custom defaults
   in foldl' (flip Map.delete) updated skip_keys
 

+-- | The VTYPES, a mini-type system in Python.
+$(declareSADT "VType"
+  [ ("VTypeString",      'C.vtypeString)
+  , ("VTypeMaybeString", 'C.vtypeMaybeString)
+  , ("VTypeBool",        'C.vtypeBool)
+  , ("VTypeSize",        'C.vtypeSize)
+  , ("VTypeInt",         'C.vtypeInt)
+  ])
+$(makeJSONInstance ''VType)
+

 -- | The hypervisor parameter type. This is currently a simple map,
 -- without type checking on key/value pairs.
 type HvParams = Container JSValue
 -- | The hypervisor parameter type. This is currently a simple map,
 -- without type checking on key/value pairs.
 type HvParams = Container JSValue

@@ -103,6 +131,42 @@ type HvParams = Container JSValue
 -- the values are always strings.
 type OsParams = Container String
 
 -- the values are always strings.
 type OsParams = Container String
 

+-- | Class of objects that have timestamps.
+class TimeStampObject a where
+  cTimeOf :: a -> Double
+  mTimeOf :: a -> Double
+
+-- | Class of objects that have an UUID.
+class UuidObject a where
+  uuidOf :: a -> String
+
+-- | Class of object that have a serial number.
+class SerialNoObject a where
+  serialOf :: a -> Int
+
+-- | Class of objects that have tags.
+class TagsObject a where
+  tagsOf :: a -> Set.Set String
+
+-- * Node role object
+
+$(declareSADT "NodeRole"
+  [ ("NROffline",   'C.nrOffline)
+  , ("NRDrained",   'C.nrDrained)
+  , ("NRRegular",   'C.nrRegular)
+  , ("NRCandidate", 'C.nrMcandidate)
+  , ("NRMaster",    'C.nrMaster)
+  ])
+$(makeJSONInstance ''NodeRole)
+
+-- | The description of the node role.
+roleDescription :: NodeRole -> String
+roleDescription NROffline   = "offline"
+roleDescription NRDrained   = "drained"
+roleDescription NRRegular   = "regular"
+roleDescription NRCandidate = "master candidate"
+roleDescription NRMaster    = "master"
+

 -- * NIC definitions
 
 $(declareSADT "NICMode"
 -- * NIC definitions
 
 $(declareSADT "NICMode"

@@ -212,35 +276,35 @@ decodeDLId obj lid = do
           mB' <- readJSON mB
           k'  <- readJSON k
           return $ LIDDrbd8 nA' nB' p' mA' mB' k'
           mB' <- readJSON mB
           k'  <- readJSON k
           return $ LIDDrbd8 nA' nB' p' mA' mB' k'

-        _ -> fail $ "Can't read logical_id for DRBD8 type"
+        _ -> fail "Can't read logical_id for DRBD8 type"

     LD_LV ->
       case lid of
         JSArray [vg, lv] -> do
           vg' <- readJSON vg
           lv' <- readJSON lv
           return $ LIDPlain vg' lv'
     LD_LV ->
       case lid of
         JSArray [vg, lv] -> do
           vg' <- readJSON vg
           lv' <- readJSON lv
           return $ LIDPlain vg' lv'

-        _ -> fail $ "Can't read logical_id for plain type"
+        _ -> fail "Can't read logical_id for plain type"

     LD_FILE ->
       case lid of
         JSArray [driver, path] -> do
           driver' <- readJSON driver
           path'   <- readJSON path
           return $ LIDFile driver' path'
     LD_FILE ->
       case lid of
         JSArray [driver, path] -> do
           driver' <- readJSON driver
           path'   <- readJSON path
           return $ LIDFile driver' path'

-        _ -> fail $ "Can't read logical_id for file type"
+        _ -> fail "Can't read logical_id for file type"

     LD_BLOCKDEV ->
       case lid of
         JSArray [driver, path] -> do
           driver' <- readJSON driver
           path'   <- readJSON path
           return $ LIDBlockDev driver' path'
     LD_BLOCKDEV ->
       case lid of
         JSArray [driver, path] -> do
           driver' <- readJSON driver
           path'   <- readJSON path
           return $ LIDBlockDev driver' path'

-        _ -> fail $ "Can't read logical_id for blockdev type"
+        _ -> fail "Can't read logical_id for blockdev type"

     LD_RADOS ->
       case lid of
         JSArray [driver, path] -> do
           driver' <- readJSON driver
           path'   <- readJSON path
           return $ LIDRados driver' path'
     LD_RADOS ->
       case lid of
         JSArray [driver, path] -> do
           driver' <- readJSON driver
           path'   <- readJSON path
           return $ LIDRados driver' path'

-        _ -> fail $ "Can't read logical_id for rdb type"
+        _ -> fail "Can't read logical_id for rdb type"

 
 -- | Disk data structure.
 --
 
 -- | Disk data structure.
 --

@@ -299,7 +363,7 @@ $(declareSADT "AdminState"
   ])
 $(makeJSONInstance ''AdminState)
 
   ])
 $(makeJSONInstance ''AdminState)
 

-$(buildParam "Be" "bep" $
+$(buildParam "Be" "bep"

   [ simpleField "minmem"       [t| Int  |]
   , simpleField "maxmem"       [t| Int  |]
   , simpleField "vcpus"        [t| Int  |]
   [ simpleField "minmem"       [t| Int  |]
   , simpleField "maxmem"       [t| Int  |]
   , simpleField "vcpus"        [t| Int  |]

@@ -325,19 +389,33 @@ $(buildObject "Instance" "inst" $
   ++ serialFields
   ++ tagsFields)
 
   ++ serialFields
   ++ tagsFields)
 

+instance TimeStampObject Instance where
+  cTimeOf = instCtime
+  mTimeOf = instMtime
+
+instance UuidObject Instance where
+  uuidOf = instUuid
+
+instance SerialNoObject Instance where
+  serialOf = instSerial
+
+instance TagsObject Instance where
+  tagsOf = instTags
+

 -- * IPolicy definitions
 
 -- * IPolicy definitions
 

-$(buildParam "ISpec" "ispec" $
+$(buildParam "ISpec" "ispec"

   [ simpleField C.ispecMemSize     [t| Int |]
   , simpleField C.ispecDiskSize    [t| Int |]
   , simpleField C.ispecDiskCount   [t| Int |]
   , simpleField C.ispecCpuCount    [t| Int |]
   [ simpleField C.ispecMemSize     [t| Int |]
   , simpleField C.ispecDiskSize    [t| Int |]
   , simpleField C.ispecDiskCount   [t| Int |]
   , simpleField C.ispecCpuCount    [t| Int |]

+  , simpleField C.ispecNicCount    [t| Int |]

   , simpleField C.ispecSpindleUse  [t| Int |]
   ])
 
 -- | Custom partial ipolicy. This is not built via buildParam since it
 -- has a special 2-level inheritance mode.
   , simpleField C.ispecSpindleUse  [t| Int |]
   ])
 
 -- | Custom partial ipolicy. This is not built via buildParam since it
 -- has a special 2-level inheritance mode.

-$(buildObject "PartialIPolicy" "ipolicy" $
+$(buildObject "PartialIPolicy" "ipolicy"

   [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
   , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
   , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
   [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
   , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
   , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]

@@ -351,7 +429,7 @@ $(buildObject "PartialIPolicy" "ipolicy" $
 
 -- | Custom filled ipolicy. This is not built via buildParam since it
 -- has a special 2-level inheritance mode.
 
 -- | Custom filled ipolicy. This is not built via buildParam since it
 -- has a special 2-level inheritance mode.

-$(buildObject "FilledIPolicy" "ipolicy" $
+$(buildObject "FilledIPolicy" "ipolicy"

   [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
   , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
   , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
   [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
   , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
   , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]

@@ -384,7 +462,7 @@ fillIPolicy (FilledIPolicy { ipolicyMinSpec       = fmin
                 }
 -- * Node definitions
 
                 }
 -- * Node definitions
 

-$(buildParam "ND" "ndp" $
+$(buildParam "ND" "ndp"

   [ simpleField "oob_program"   [t| String |]
   , simpleField "spindle_count" [t| Int    |]
   ])
   [ simpleField "oob_program"   [t| String |]
   , simpleField "spindle_count" [t| Int    |]
   ])

@@ -407,6 +485,19 @@ $(buildObject "Node" "node" $
   ++ serialFields
   ++ tagsFields)
 
   ++ serialFields
   ++ tagsFields)
 

+instance TimeStampObject Node where
+  cTimeOf = nodeCtime
+  mTimeOf = nodeMtime
+
+instance UuidObject Node where
+  uuidOf = nodeUuid
+
+instance SerialNoObject Node where
+  serialOf = nodeSerial
+
+instance TagsObject Node where
+  tagsOf = nodeTags
+

 -- * NodeGroup definitions
 
 -- | The Group allocation policy type.
 -- * NodeGroup definitions
 
 -- | The Group allocation policy type.

@@ -440,6 +531,19 @@ $(buildObject "NodeGroup" "group" $
   ++ serialFields
   ++ tagsFields)
 
   ++ serialFields
   ++ tagsFields)
 

+instance TimeStampObject NodeGroup where
+  cTimeOf = groupCtime
+  mTimeOf = groupMtime
+
+instance UuidObject NodeGroup where
+  uuidOf = groupUuid
+
+instance SerialNoObject NodeGroup where
+  serialOf = groupSerial
+
+instance TagsObject NodeGroup where
+  tagsOf = groupTags
+

 -- | IP family type
 $(declareIADT "IpFamily"
   [ ("IpFamilyV4", 'C.ip4Family)
 -- | IP family type
 $(declareIADT "IpFamily"
   [ ("IpFamilyV4", 'C.ip4Family)

@@ -489,7 +593,7 @@ $(buildObject "Cluster" "cluster" $
   , simpleField "cluster_name"            [t| String           |]
   , simpleField "file_storage_dir"        [t| String           |]
   , simpleField "shared_file_storage_dir" [t| String           |]
   , simpleField "cluster_name"            [t| String           |]
   , simpleField "file_storage_dir"        [t| String           |]
   , simpleField "shared_file_storage_dir" [t| String           |]

-  , simpleField "enabled_hypervisors"     [t| [String]         |]
+  , simpleField "enabled_hypervisors"     [t| [Hypervisor]     |]

   , simpleField "hvparams"                [t| ClusterHvParams  |]
   , simpleField "os_hvp"                  [t| OsHvParams       |]
   , simpleField "beparams"                [t| ClusterBeParams  |]
   , simpleField "hvparams"                [t| ClusterHvParams  |]
   , simpleField "os_hvp"                  [t| OsHvParams       |]
   , simpleField "beparams"                [t| ClusterBeParams  |]

@@ -509,11 +613,24 @@ $(buildObject "Cluster" "cluster" $
   , simpleField "prealloc_wipe_disks"     [t| Bool             |]
   , simpleField "ipolicy"                 [t| FilledIPolicy    |]
  ]
   , simpleField "prealloc_wipe_disks"     [t| Bool             |]
   , simpleField "ipolicy"                 [t| FilledIPolicy    |]
  ]

- ++ serialFields

  ++ timeStampFields
  ++ uuidFields
  ++ timeStampFields
  ++ uuidFields

+ ++ serialFields

  ++ tagsFields)
 
  ++ tagsFields)
 

+instance TimeStampObject Cluster where
+  cTimeOf = clusterCtime
+  mTimeOf = clusterMtime
+
+instance UuidObject Cluster where
+  uuidOf = clusterUuid
+
+instance SerialNoObject Cluster where
+  serialOf = clusterSerial
+
+instance TagsObject Cluster where
+  tagsOf = clusterTags
+

 -- * ConfigData definitions
 
 $(buildObject "ConfigData" "config" $
 -- * ConfigData definitions
 
 $(buildObject "ConfigData" "config" $

@@ -525,3 +642,6 @@ $(buildObject "ConfigData" "config" $
   , simpleField "instances"  [t| Container Instance  |]
   ]
   ++ serialFields)
   , simpleField "instances"  [t| Container Instance  |]
   ]
   ++ serialFields)

+
+instance SerialNoObject ConfigData where
+  serialOf = configSerial