diff --git a/htest/Test/Ganeti/OpCodes.hs b/htest/Test/Ganeti/OpCodes.hs index 51dd653ec1e8c9e4334edc37a0f0917a45fba3b4..c1f6c91559b71a6247cd10eaf153f8baebe3943b 100644 --- a/htest/Test/Ganeti/OpCodes.hs +++ b/htest/Test/Ganeti/OpCodes.hs @@ -63,6 +63,8 @@ instance Arbitrary OpCodes.TagObject where $(genArbitrary ''OpCodes.ReplaceDisksMode) +$(genArbitrary ''DiskAccess) + instance Arbitrary OpCodes.DiskIndex where arbitrary = choose (0, C.maxDisks - 1) >>= OpCodes.mkDiskIndex @@ -70,6 +72,11 @@ instance Arbitrary INicParams where arbitrary = INicParams <$> getMaybe genNameNE <*> getMaybe getName <*> getMaybe genNameNE <*> getMaybe genNameNE +instance Arbitrary IDiskParams where + arbitrary = IDiskParams <$> arbitrary <*> arbitrary <*> + getMaybe genNameNE <*> getMaybe genNameNE <*> + getMaybe genNameNE + instance Arbitrary OpCodes.OpCode where arbitrary = do op_id <- elements OpCodes.allOpIDs @@ -169,6 +176,19 @@ instance Arbitrary OpCodes.OpCode where "OP_NODE_EVACUATE" -> OpCodes.OpNodeEvacuate <$> arbitrary <*> genNodeNameNE <*> getMaybe genNodeNameNE <*> getMaybe genNameNE <*> arbitrary + "OP_INSTANCE_CREATE" -> + OpCodes.OpInstanceCreate <$> getFQDN <*> arbitrary <*> + arbitrary <*> arbitrary <*> arbitrary <*> pure emptyJSObject <*> + arbitrary <*> arbitrary <*> arbitrary <*> getMaybe genNameNE <*> + pure emptyJSObject <*> arbitrary <*> getMaybe genNameNE <*> + arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> + arbitrary <*> arbitrary <*> pure emptyJSObject <*> + getMaybe genNameNE <*> + getMaybe genNodeNameNE <*> getMaybe genNodeNameNE <*> + getMaybe (pure []) <*> getMaybe genNodeNameNE <*> + arbitrary <*> getMaybe genNodeNameNE <*> + getMaybe genNodeNameNE <*> getMaybe genNameNE <*> + arbitrary <*> (genTags >>= mapM mkNonEmpty) _ -> fail $ "Undefined arbitrary for opcode " ++ op_id -- * Helper functions diff --git a/htest/Test/Ganeti/Types.hs b/htest/Test/Ganeti/Types.hs index f345437a45d8d90766ec7c014e0746d308f87ace..aa64d7a889bf757591dd916b6bebe318202dec21 100644 --- a/htest/Test/Ganeti/Types.hs +++ b/htest/Test/Ganeti/Types.hs @@ -56,6 +56,12 @@ instance (Arbitrary a, Ord a, Num a, Show a) => (QuickCheck.Positive i) <- arbitrary Types.mkPositive i +instance (Arbitrary a, Ord a, Num a, Show a) => + Arbitrary (Types.NonNegative a) where + arbitrary = do + (QuickCheck.NonNegative i) <- arbitrary + Types.mkNonNegative i + instance (Arbitrary a) => Arbitrary (Types.NonEmpty a) where arbitrary = do QuickCheck.NonEmpty lst <- arbitrary @@ -85,6 +91,8 @@ $(genArbitrary ''NodeEvacMode) $(genArbitrary ''FileDriver) +$(genArbitrary ''InstCreateMode) + -- * Properties prop_AllocPolicy_serialisation :: AllocPolicy -> Property @@ -182,6 +190,10 @@ prop_NodeEvacMode_serialisation = testSerialisation prop_FileDriver_serialisation :: FileDriver -> Property prop_FileDriver_serialisation = testSerialisation +-- | Test 'InstCreate' serialisation. +prop_InstCreateMode_serialisation :: InstCreateMode -> Property +prop_InstCreateMode_serialisation = testSerialisation + testSuite "Types" [ 'prop_AllocPolicy_serialisation , 'prop_DiskTemplate_serialisation @@ -202,4 +214,5 @@ testSuite "Types" , 'prop_StorageType_serialisation , 'prop_NodeEvacMode_serialisation , 'prop_FileDriver_serialisation + , 'prop_InstCreateMode_serialisation ] diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs index 033a68bc92bb46f0efa6623157dc03bd8be33cbc..7e67b88599c31b2ed4a68d7c95168a1b4862b771 100644 --- a/htools/Ganeti/OpCodes.hs +++ b/htools/Ganeti/OpCodes.hs @@ -128,7 +128,7 @@ $(genOpCode "OpCode" , pClusterHvParams , pClusterBeParams , pOsHvp - , pOsParams + , pClusterOsParams , pDiskParams , pCandidatePoolSize , pUidPool @@ -241,6 +241,39 @@ $(genOpCode "OpCode" , pIallocator , pEvacMode ]) + , ("OpInstanceCreate", + [ pInstanceName + , pForceVariant + , pWaitForSync + , pNameCheck + , pIgnoreIpolicy + , pInstBeParams + , pInstDisks + , pDiskTemplate + , pFileDriver + , pFileStorageDir + , pInstHvParams + , pHypervisor + , pIallocator + , pResetDefaults + , pIpCheck + , pIpConflictsCheck + , pInstCreateMode + , pInstNics + , pNoInstall + , pInstOsParams + , pInstOs + , pPrimaryNode + , pSecondaryNode + , pSourceHandshake + , pSourceInstance + , pSourceShutdownTimeout + , pSourceX509Ca + , pSrcNode + , pSrcPath + , pStartInstance + , pInstTags + ]) ]) -- | Returns the OP_ID for a given opcode value. diff --git a/htools/Ganeti/OpParams.hs b/htools/Ganeti/OpParams.hs index 40a7b834d473083ab30bb1ddd313bb590950357b..b23a1a8665943f3d0c7b53026e6b67800295191e 100644 --- a/htools/Ganeti/OpParams.hs +++ b/htools/Ganeti/OpParams.hs @@ -41,6 +41,7 @@ module Ganeti.OpParams , DiskIndex , mkDiskIndex , unDiskIndex + , DiskAccess(..) , INicParams(..) , IDiskParams(..) , pInstanceName @@ -68,6 +69,8 @@ module Ganeti.OpParams , pGroupNodeParams , pQueryWhat , pEarlyRelease + , pIpCheck + , pIpConflictsCheck , pNoRemember , pMigrationTargetNode , pStartupPaused @@ -82,12 +85,21 @@ module Ganeti.OpParams , pDiskState , pIgnoreIpolicy , pAllowRuntimeChgs + , pInstDisks + , pDiskTemplate + , pFileDriver + , pFileStorageDir , pVgName , pEnabledHypervisors + , pHypervisor , pClusterHvParams + , pInstHvParams , pClusterBeParams + , pInstBeParams + , pResetDefaults , pOsHvp - , pOsParams + , pClusterOsParams + , pInstOsParams , pCandidatePoolSize , pUidPool , pAddUids @@ -95,6 +107,7 @@ module Ganeti.OpParams , pMaintainNodeHealth , pPreallocWipeDisks , pNicParams + , pInstNics , pNdParams , pIpolicy , pDrbdHelper @@ -129,13 +142,27 @@ module Ganeti.OpParams , pIallocator , pRemoteNode , pEvacMode + , pInstCreateMode + , pNoInstall + , pInstOs + , pPrimaryNode + , pSecondaryNode + , pSourceHandshake + , pSourceInstance + , pSourceShutdownTimeout + , pSourceX509Ca + , pSrcNode + , pSrcPath + , pStartInstance + , pInstTags ) where import qualified Data.Set as Set import Text.JSON (readJSON, showJSON, JSON, JSValue(..), fromJSString, - JSObject) + JSObject, toJSObject) import Text.JSON.Pretty (pp_value) +import Ganeti.BasicTypes import qualified Ganeti.Constants as C import Ganeti.THH import Ganeti.JSON @@ -176,6 +203,18 @@ optionalNEStringField = optionalField . flip simpleField [t| NonEmptyString |] -- | Unchecked dict, should be replaced by a better definition. type UncheckedDict = JSObject JSValue +-- | Unchecked list, shoild be replaced by a better definition. +type UncheckedList = [JSValue] + +-- | Function to force a non-negative value, without returning via a +-- monad. This is needed for, and should be used /only/ in the case of +-- forcing constants. In case the constant is wrong (< 0), this will +-- become a runtime error. +forceNonNeg :: (Num a, Ord a, Show a) => a -> NonNegative a +forceNonNeg i = case mkNonNegative i of + Ok n -> n + Bad msg -> error msg + -- ** Tags -- | Data type representing what items do the tag operations apply to. @@ -279,13 +318,13 @@ $(buildObject "INicParams" "inic" , optionalField $ simpleField C.inicLink [t| NonEmptyString |] ]) --- | Disk modification definition. +-- | Disk modification definition. FIXME: disksize should be VTYPE_UNIT. $(buildObject "IDiskParams" "idisk" - [ simpleField C.idiskSize [t| Int |] -- FIXME: VTYPE_UNIT - , simpleField C.idiskMode [t| DiskAccess |] - , simpleField C.idiskAdopt [t| NonEmptyString |] - , simpleField C.idiskVg [t| NonEmptyString |] - , simpleField C.idiskMetavg [t| NonEmptyString |] + [ optionalField $ simpleField C.idiskSize [t| Int |] + , optionalField $ simpleField C.idiskMode [t| DiskAccess |] + , optionalField $ simpleField C.idiskAdopt [t| NonEmptyString |] + , optionalField $ simpleField C.idiskVg [t| NonEmptyString |] + , optionalField $ simpleField C.idiskMetavg [t| NonEmptyString |] ]) -- * Parameters @@ -400,7 +439,13 @@ pQueryWhat = simpleField "what" [t| Qlang.QueryTypeOp |] pEarlyRelease :: Field pEarlyRelease = defaultFalse "early_release" --- _PIpCheckDoc = "Whether to ensure instance's IP address is inactive" +-- | Whether to ensure instance's IP address is inactive. +pIpCheck :: Field +pIpCheck = defaultTrue "ip_check" + +-- | Check for conflicting IPs. +pIpConflictsCheck :: Field +pIpConflictsCheck = defaultTrue "conflicts_check" -- | Do not remember instance state changes. pNoRemember :: Field @@ -475,7 +520,22 @@ type TestClusterOsList = [TestClusterOsListItem] -- Utility type for NIC definitions. --type TestNicDef = INicParams ---type TDiskParams = IDiskParams + +-- | List of instance disks. +pInstDisks :: Field +pInstDisks = renameField "instDisks" $ simpleField "disks" [t| [IDiskParams] |] + +-- | Instance disk template. +pDiskTemplate :: Field +pDiskTemplate = simpleField "disk_template" [t| DiskTemplate |] + +-- | File driver. +pFileDriver :: Field +pFileDriver = optionalField $ simpleField "file_driver" [t| FileDriver |] + +-- | Directory for storing file-backed disks. +pFileStorageDir :: Field +pFileStorageDir = optionalNEStringField "file_storage_dir" -- | Volume group name. pVgName :: Field @@ -487,25 +547,59 @@ pEnabledHypervisors = optionalField $ simpleField "enabled_hypervisors" [t| NonEmpty Hypervisor |] +-- | Selected hypervisor for an instance. +pHypervisor :: Field +pHypervisor = + optionalField $ + simpleField "hypervisor" [t| Hypervisor |] + -- | Cluster-wide hypervisor parameters, hypervisor-dependent. pClusterHvParams :: Field pClusterHvParams = + renameField "ClusterHvParams" . optionalField $ simpleField "hvparams" [t| Container UncheckedDict |] +-- | Instance hypervisor parameters. +pInstHvParams :: Field +pInstHvParams = + renameField "InstHvParams" . + defaultField [| toJSObject [] |] $ + simpleField "hvparams" [t| UncheckedDict |] + -- | Cluster-wide beparams. pClusterBeParams :: Field -pClusterBeParams = optionalField $ simpleField "beparams" [t| UncheckedDict |] +pClusterBeParams = + renameField "ClusterBeParams" . + optionalField $ simpleField "beparams" [t| UncheckedDict |] + +-- | Instance beparams. +pInstBeParams :: Field +pInstBeParams = + renameField "InstBeParams" . + defaultField [| toJSObject [] |] $ + simpleField "beparams" [t| UncheckedDict |] + +-- | Reset instance parameters to default if equal. +pResetDefaults :: Field +pResetDefaults = defaultFalse "identify_defaults" -- | Cluster-wide per-OS hypervisor parameter defaults. pOsHvp :: Field pOsHvp = optionalField $ simpleField "os_hvp" [t| Container UncheckedDict |] -- | Cluster-wide OS parameter defaults. -pOsParams :: Field -pOsParams = +pClusterOsParams :: Field +pClusterOsParams = + renameField "clusterOsParams" . optionalField $ simpleField "osparams" [t| Container UncheckedDict |] +-- | Instance OS parameters. +pInstOsParams :: Field +pInstOsParams = + renameField "instOsParams" . defaultField [| toJSObject [] |] $ + simpleField "osparams" [t| UncheckedDict |] + -- | Candidate pool size. pCandidatePoolSize :: Field pCandidatePoolSize = @@ -538,6 +632,10 @@ pPreallocWipeDisks = optionalField $ booleanField "prealloc_wipe_disks" pNicParams :: Field pNicParams = optionalField $ simpleField "nicparams" [t| INicParams |] +-- | Instance NIC definitions. +pInstNics :: Field +pInstNics = simpleField "nics" [t| [INicParams] |] + -- | Cluster-wide node parameter defaults. pNdParams :: Field pNdParams = optionalField $ simpleField "ndparams" [t| UncheckedDict |] @@ -685,3 +783,64 @@ pRemoteNode = optionalNEStringField "remote_node" -- | Node evacuation mode. pEvacMode :: Field pEvacMode = renameField "EvacMode" $ simpleField "mode" [t| NodeEvacMode |] + +-- | Instance creation mode. +pInstCreateMode :: Field +pInstCreateMode = + renameField "InstCreateMode" $ simpleField "mode" [t| InstCreateMode |] + +-- | Do not install the OS (will disable automatic start). +pNoInstall :: Field +pNoInstall = optionalField $ booleanField "no_install" + +-- | OS type for instance installation. +pInstOs :: Field +pInstOs = optionalNEStringField "os_type" + +-- | Primary node for an instance. +pPrimaryNode :: Field +pPrimaryNode = optionalNEStringField "pnode" + +-- | Secondary node for an instance. +pSecondaryNode :: Field +pSecondaryNode = optionalNEStringField "snode" + +-- | Signed handshake from source (remote import only). +pSourceHandshake :: Field +pSourceHandshake = + optionalField $ simpleField "source_handshake" [t| UncheckedList |] + +-- | Source instance name (remote import only). +pSourceInstance :: Field +pSourceInstance = optionalNEStringField "source_instance_name" + +-- | How long source instance was given to shut down (remote import only). +-- FIXME: non-negative int, whereas the constant is a plain int. +pSourceShutdownTimeout :: Field +pSourceShutdownTimeout = + defaultField [| forceNonNeg C.defaultShutdownTimeout |] $ + simpleField "source_shutdown_timeout" [t| NonNegative Int |] + +-- | Source X509 CA in PEM format (remote import only). +pSourceX509Ca :: Field +pSourceX509Ca = optionalNEStringField "source_x509_ca" + +-- | Source node for import. +pSrcNode :: Field +pSrcNode = optionalNEStringField "src_node" + +-- | Source directory for import. +pSrcPath :: Field +pSrcPath = optionalNEStringField "src_path" + +-- | Whether to start instance after creation. +pStartInstance :: Field +pStartInstance = defaultTrue "start" + +-- | Instance tags. FIXME: unify/simplify with pTags, once that +-- migrates to NonEmpty String. +pInstTags :: Field +pInstTags = + renameField "InstTags" . + defaultField [| [] |] $ + simpleField "tags" [t| [NonEmptyString] |] diff --git a/htools/Ganeti/Types.hs b/htools/Ganeti/Types.hs index 166b41ce0e4716c13765228861f80311df860623..f332e18d44f789ad5c779ffe11febf0cef2747b9 100644 --- a/htools/Ganeti/Types.hs +++ b/htools/Ganeti/Types.hs @@ -60,6 +60,7 @@ module Ganeti.Types , StorageType(..) , NodeEvacMode(..) , FileDriver(..) + , InstCreateMode(..) ) where import qualified Text.JSON as JSON @@ -259,3 +260,11 @@ $(THH.declareSADT "FileDriver" , ("FileBlktap", 'C.fdBlktap) ]) $(THH.makeJSONInstance ''FileDriver) + +-- | The instance create mode. +$(THH.declareSADT "InstCreateMode" + [ ("InstCreate", 'C.instanceCreate) + , ("InstImport", 'C.instanceImport) + , ("InstRemoteImport", 'C.instanceRemoteImport) + ]) +$(THH.makeJSONInstance ''InstCreateMode)