Move FileDriver from Objects to Types
[ganeti-local] / htools / Ganeti / Objects.hs
index 423547e..f591bb9 100644 (file)
@@ -29,13 +29,18 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 -}
 
 module Ganeti.Objects
-  ( HvParams
+  ( VType(..)
+  , vTypeFromRaw
+  , HvParams
   , OsParams
   , NICMode(..)
   , PartialNicParams(..)
   , FilledNicParams(..)
   , fillNicParams
+  , allNicParamFields
   , PartialNic(..)
+  , FileDriver(..)
+  , BlockDriver(..)
   , DiskMode(..)
   , DiskType(..)
   , DiskLogicalId(..)
@@ -44,7 +49,7 @@ module Ganeti.Objects
   , PartialBeParams(..)
   , FilledBeParams(..)
   , fillBeParams
-  , Hypervisor(..)
+  , allBeParamFields
   , AdminState(..)
   , adminStateFromRaw
   , Instance(..)
@@ -52,6 +57,7 @@ module Ganeti.Objects
   , PartialNDParams(..)
   , FilledNDParams(..)
   , fillNDParams
+  , allNDParamFields
   , Node(..)
   , NodeRole(..)
   , nodeRoleToRaw
@@ -60,6 +66,7 @@ module Ganeti.Objects
   , FilledISpecParams(..)
   , PartialISpecParams(..)
   , fillISpecParams
+  , allISpecParamFields
   , FilledIPolicy(..)
   , PartialIPolicy(..)
   , fillIPolicy
@@ -79,18 +86,20 @@ module Ganeti.Objects
   , 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
 import qualified Data.Set as Set
-import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..))
+import Text.JSON (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.Types
 import Ganeti.THH
 
 -- * Generic definitions
@@ -102,6 +111,16 @@ fillDict defaults custom 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
@@ -183,13 +202,6 @@ $(declareSADT "DiskType"
   ])
 $(makeJSONInstance ''DiskType)
 
--- | The file driver type.
-$(declareSADT "FileDriver"
-  [ ("FileLoop",   'C.fdLoop)
-  , ("FileBlktap", 'C.fdBlktap)
-  ])
-$(makeJSONInstance ''FileDriver)
-
 -- | The persistent block driver type. Currently only one type is allowed.
 $(declareSADT "BlockDriver"
   [ ("BlockDrvManual", 'C.blockdevDriverManual)
@@ -256,35 +268,35 @@ decodeDLId obj lid = do
           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'
-        _ -> 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'
-        _ -> 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'
-        _ -> 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'
-        _ -> fail $ "Can't read logical_id for rdb type"
+        _ -> fail "Can't read logical_id for rdb type"
 
 -- | Disk data structure.
 --
@@ -309,33 +321,8 @@ $(buildObjectSerialisation "Disk"
   , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
   ])
 
--- * Hypervisor definitions
-
--- | This may be due to change when we add hypervisor parameters.
-$(declareSADT "Hypervisor"
-  [ ( "Kvm",    'C.htKvm )
-  , ( "XenPvm", 'C.htXenPvm )
-  , ( "Chroot", 'C.htChroot )
-  , ( "XenHvm", 'C.htXenHvm )
-  , ( "Lxc",    'C.htLxc )
-  , ( "Fake",   'C.htFake )
-  ])
-$(makeJSONInstance ''Hypervisor)
-
 -- * Instance definitions
 
--- | Instance disk template type. **Copied from HTools/Types.hs**
-$(declareSADT "DiskTemplate"
-  [ ("DTDiskless",   'C.dtDiskless)
-  , ("DTFile",       'C.dtFile)
-  , ("DTSharedFile", 'C.dtSharedFile)
-  , ("DTPlain",      'C.dtPlain)
-  , ("DTBlock",      'C.dtBlock)
-  , ("DTDrbd8",      'C.dtDrbd8)
-  , ("DTRados",      'C.dtRbd)
-  ])
-$(makeJSONInstance ''DiskTemplate)
-
 $(declareSADT "AdminState"
   [ ("AdminOffline", 'C.adminstOffline)
   , ("AdminDown",    'C.adminstDown)
@@ -343,7 +330,7 @@ $(declareSADT "AdminState"
   ])
 $(makeJSONInstance ''AdminState)
 
-$(buildParam "Be" "bep" $
+$(buildParam "Be" "bep"
   [ simpleField "minmem"       [t| Int  |]
   , simpleField "maxmem"       [t| Int  |]
   , simpleField "vcpus"        [t| Int  |]
@@ -384,17 +371,18 @@ instance TagsObject Instance where
 
 -- * 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.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.
-$(buildObject "PartialIPolicy" "ipolicy" $
+$(buildObject "PartialIPolicy" "ipolicy"
   [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
   , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
   , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
@@ -408,7 +396,7 @@ $(buildObject "PartialIPolicy" "ipolicy" $
 
 -- | 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 |]
@@ -441,7 +429,7 @@ fillIPolicy (FilledIPolicy { ipolicyMinSpec       = fmin
                 }
 -- * Node definitions
 
-$(buildParam "ND" "ndp" $
+$(buildParam "ND" "ndp"
   [ simpleField "oob_program"   [t| String |]
   , simpleField "spindle_count" [t| Int    |]
   ])
@@ -479,21 +467,6 @@ instance TagsObject Node where
 
 -- * NodeGroup definitions
 
--- | The Group allocation policy type.
---
--- Note that the order of constructors is important as the automatic
--- Ord instance will order them in the order they are defined, so when
--- changing this data type be careful about the interaction with the
--- desired sorting order.
---
--- FIXME: COPIED from Types.hs; we need to eliminate this duplication later
-$(declareSADT "AllocPolicy"
-  [ ("AllocPreferred",   'C.allocPolicyPreferred)
-  , ("AllocLastResort",  'C.allocPolicyLastResort)
-  , ("AllocUnallocable", 'C.allocPolicyUnallocable)
-  ])
-$(makeJSONInstance ''AllocPolicy)
-
 -- | The disk parameters type.
 type DiskParams = Container (Container JSValue)
 
@@ -572,7 +545,7 @@ $(buildObject "Cluster" "cluster" $
   , 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  |]