From b1e8152024ccdf8049f34508a41e6f90fd16a6f3 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Fri, 18 Nov 2011 10:59:12 +0100
Subject: [PATCH] htools: add partial implementation of lib/objects.py
This is partial since not all object types can be easily converted for
now (will need some changes on the Python side for this).
Most importantly, the *Params types do not have a good solution now:
the Python code, due to its dynamic typing, hides the fact that we
actually have two different types at play: a full type which needs to
have all keys, and the 'partial' type which has slightly different
behaviour. I've implemented these in Haskell as two different types,
Full* and Partial*, which are derived automatically from a single
Parameter type, together with the associated Fill* functions.
Furthermore, HVParams is even more special, as its contents is not
fixed but varies per hypervisor type, plus it has the HV_GLOBALS part
which should not be customisable at instance type (yay for
exceptions). As such, this should be written in Haskell as a
multi-constructor type, but it's the only one so far and thus we don't
have support for it yet.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>
---
Makefile.am | 1 +
htools/Ganeti/Objects.hs | 266 +++++++++++++++++++++++++++++++++++++++
htools/Ganeti/THH.hs | 6 +-
3 files changed, 270 insertions(+), 3 deletions(-)
create mode 100644 htools/Ganeti/Objects.hs
diff --git a/Makefile.am b/Makefile.am
index 8949cd93f..eff92145b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -397,6 +397,7 @@ HS_LIB_SRCS = \
htools/Ganeti/BasicTypes.hs \
htools/Ganeti/Jobs.hs \
htools/Ganeti/Luxi.hs \
+ htools/Ganeti/Objects.hs \
htools/Ganeti/OpCodes.hs \
htools/Ganeti/THH.hs
diff --git a/htools/Ganeti/Objects.hs b/htools/Ganeti/Objects.hs
new file mode 100644
index 000000000..a366546cb
--- /dev/null
+++ b/htools/Ganeti/Objects.hs
@@ -0,0 +1,266 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+{-| Implementation of the Ganeti config objects.
+
+Some object fields are not implemented yet, and as such they are
+commented out below.
+
+-}
+
+{-
+
+Copyright (C) 2011, 2012 Google Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Ganeti.Objects
+ ( NICMode(..)
+ , PartialNICParams(..)
+ , FilledNICParams(..)
+ , fillNICParams
+ , PartialNIC(..)
+ , DiskMode(..)
+ , DiskType(..)
+ , Disk(..)
+ , DiskTemplate(..)
+ , PartialBEParams(..)
+ , FilledBEParams(..)
+ , fillBEParams
+ , Instance(..)
+ , toDictInstance
+ , PartialNDParams(..)
+ , FilledNDParams(..)
+ , fillNDParams
+ , Node(..)
+ , AllocPolicy(..)
+ , NodeGroup(..)
+ , Cluster(..)
+ , ConfigData(..)
+ ) where
+
+import Data.Maybe
+import Text.JSON (makeObj, showJSON, readJSON)
+
+import qualified Ganeti.Constants as C
+import Ganeti.HTools.JSON
+
+import Ganeti.THH
+
+-- * NIC definitions
+
+$(declareSADT "NICMode"
+ [ ("NMBridged", 'C.nicModeBridged)
+ , ("NMRouted", 'C.nicModeRouted)
+ ])
+$(makeJSONInstance ''NICMode)
+
+$(buildParam "NIC" "nicp"
+ [ simpleField "mode" [t| NICMode |]
+ , simpleField "link" [t| String |]
+ ])
+
+$(buildObject "PartialNIC" "nic"
+ [ simpleField "mac" [t| String |]
+ , optionalField $ simpleField "ip" [t| String |]
+ , simpleField "nicparams" [t| PartialNICParams |]
+ ])
+
+-- * Disk definitions
+
+$(declareSADT "DiskMode"
+ [ ("DiskRdOnly", 'C.diskRdonly)
+ , ("DiskRdWr", 'C.diskRdwr)
+ ])
+$(makeJSONInstance ''DiskMode)
+
+$(declareSADT "DiskType"
+ [ ("LD_LV", 'C.ldLv)
+ , ("LD_DRBD8", 'C.ldDrbd8)
+ , ("LD_FILE", 'C.ldFile)
+ , ("LD_BLOCKDEV", 'C.ldBlockdev)
+ ])
+$(makeJSONInstance ''DiskType)
+
+-- | Disk data structure.
+--
+-- This is declared manually as it's a recursive structure, and our TH
+-- code currently can't build it.
+data Disk = Disk
+ { diskDevType :: DiskType
+-- , diskLogicalId :: String
+-- , diskPhysicalId :: String
+ , diskChildren :: [Disk]
+ , diskIvName :: String
+ , diskSize :: Int
+ , diskMode :: DiskMode
+ } deriving (Read, Show, Eq)
+
+$(buildObjectSerialisation "Disk"
+ [ simpleField "dev_type" [t| DiskMode |]
+-- , simpleField "logical_id" [t| String |]
+-- , simpleField "physical_id" [t| String |]
+ , defaultField [| [] |] $ simpleField "children" [t| [Disk] |]
+ , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
+ , simpleField "size" [t| Int |]
+ , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
+ ])
+
+-- * 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)
+ ])
+$(makeJSONInstance ''DiskTemplate)
+
+$(declareSADT "AdminState"
+ [ ("AdminOffline", 'C.adminstOffline)
+ , ("AdminDown", 'C.adminstDown)
+ , ("AdminUp", 'C.adminstUp)
+ ])
+$(makeJSONInstance ''AdminState)
+
+$(buildParam "BE" "bep" $
+ [ simpleField "minmem" [t| Int |]
+ , simpleField "maxmem" [t| Int |]
+ , simpleField "vcpus" [t| Int |]
+ , simpleField "auto_balance" [t| Bool |]
+ ])
+
+$(buildObject "Instance" "inst" $
+ [ simpleField "name" [t| String |]
+ , simpleField "primary_node" [t| String |]
+ , simpleField "os" [t| String |]
+ , simpleField "hypervisor" [t| String |]
+-- , simpleField "hvparams" [t| [(String, String)] |]
+ , simpleField "beparams" [t| PartialBEParams |]
+-- , simpleField "osparams" [t| [(String, String)] |]
+ , simpleField "admin_state" [t| AdminState |]
+ , simpleField "nics" [t| [PartialNIC] |]
+ , simpleField "disks" [t| [Disk] |]
+ , simpleField "disk_template" [t| DiskTemplate |]
+ , optionalField $ simpleField "network_port" [t| Int |]
+ ]
+ ++ timeStampFields
+ ++ uuidFields
+ ++ serialFields)
+
+-- * Node definitions
+
+$(buildParam "ND" "ndp" $
+ [ simpleField "oob_program" [t| String |]
+ ])
+
+$(buildObject "Node" "node" $
+ [ simpleField "name" [t| String |]
+ , simpleField "primary_ip" [t| String |]
+ , simpleField "secondary_ip" [t| String |]
+ , simpleField "master_candidate" [t| Bool |]
+ , simpleField "offline" [t| Bool |]
+ , simpleField "drained" [t| Bool |]
+ , simpleField "group" [t| String |]
+ , simpleField "master_capable" [t| Bool |]
+ , simpleField "vm_capable" [t| Bool |]
+-- , simpleField "ndparams" [t| PartialNDParams |]
+ , simpleField "powered" [t| Bool |]
+ ]
+ ++ timeStampFields
+ ++ uuidFields
+ ++ serialFields)
+
+-- * 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)
+
+$(buildObject "NodeGroup" "group" $
+ [ simpleField "name" [t| String |]
+ , defaultField [| [] |] $ simpleField "members" [t| [String] |]
+-- , simpleField "ndparams" [t| PartialNDParams |]
+ , simpleField "alloc_policy" [t| AllocPolicy |]
+ ]
+ ++ timeStampFields
+ ++ uuidFields
+ ++ serialFields)
+
+-- * Cluster definitions
+$(buildObject "Cluster" "cluster" $
+ [ simpleField "rsahostkeypub" [t| String |]
+ , simpleField "highest_used_port" [t| Int |]
+ , simpleField "tcpudp_port_pool" [t| [Int] |]
+ , simpleField "mac_prefix" [t| String |]
+ , simpleField "volume_group_name" [t| String |]
+ , simpleField "reserved_lvs" [t| [String] |]
+-- , simpleField "drbd_usermode_helper" [t| String |]
+-- , simpleField "default_bridge" [t| String |]
+-- , simpleField "default_hypervisor" [t| String |]
+ , simpleField "master_node" [t| String |]
+ , simpleField "master_ip" [t| String |]
+ , simpleField "master_netdev" [t| String |]
+-- , simpleField "master_netmask" [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 "hvparams" [t| [(String, [(String, String)])] |]
+-- , simpleField "os_hvp" [t| [(String, String)] |]
+ , containerField $ simpleField "beparams" [t| FilledBEParams |]
+-- , simpleField "osparams" [t| [(String, String)] |]
+ , containerField $ simpleField "nicparams" [t| FilledNICParams |]
+-- , simpleField "ndparams" [t| FilledNDParams |]
+ , simpleField "candidate_pool_size" [t| Int |]
+ , simpleField "modify_etc_hosts" [t| Bool |]
+ , simpleField "modify_ssh_setup" [t| Bool |]
+ , simpleField "maintain_node_health" [t| Bool |]
+ , simpleField "uid_pool" [t| [Int] |]
+ , simpleField "default_iallocator" [t| String |]
+ , simpleField "hidden_os" [t| [String] |]
+ , simpleField "blacklisted_os" [t| [String] |]
+ , simpleField "primary_ip_family" [t| Int |]
+ , simpleField "prealloc_wipe_disks" [t| Bool |]
+ ]
+ ++ serialFields)
+
+-- * ConfigData definitions
+
+$(buildObject "ConfigData" "config" $
+-- timeStampFields ++
+ [ simpleField "version" [t| Int |]
+ , simpleField "cluster" [t| Cluster |]
+ , containerField $ simpleField "nodes" [t| Node |]
+ , containerField $ simpleField "nodegroups" [t| NodeGroup |]
+ , containerField $ simpleField "instances" [t| Instance |]
+ ]
+ ++ serialFields)
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 87e6b0aa9..2c036550b 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -10,7 +10,7 @@ needs in this module (except the one for unittests).
{-
-Copyright (C) 2011 Google Inc.
+Copyright (C) 2011, 2012 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -717,8 +717,8 @@ buildParam sname field_pfx fields = do
fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
let decl_f = RecC name_f fields_f
decl_p = RecC name_p fields_p
- let declF = DataD [] name_f [] [decl_f] [''Show, ''Read]
- declP = DataD [] name_p [] [decl_p] [''Show, ''Read]
+ let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
+ declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
ser_decls_f <- buildObjectSerialisation sname_f fields
ser_decls_p <- buildPParamSerialisation sname_p fields
fill_decls <- fillParam sname field_pfx fields
--
GitLab