Synnefo » snf-ganeti » ganeti-local

-- | Tests that filter regexes are serialised correctly.

prop_filterregex_instances :: FilterRegex -> Property

prop_filterregex_instances rex =

-- | Tests 'ResultStatus' serialisation.

prop_resultstatus_serialisation :: ResultStatus -> Property

data GenericResult a b

  = Bad a

  | Ok b

-- | Type alias for a string Result.

type Result = GenericResult String

                   | MultipleMatch

                   | PartialMatch

                   | FailMatch

-- | The result of a name lookup in a list.

data LookupResult = LookupResult

  { lrMatchPriority :: MatchPriority -- ^ The result type

  -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise

  , lrContent :: String

-- | Lookup results have an absolute preference ordering.

instance Eq LookupResult where

                   | OptComplString           -- ^ Arbitrary string

                   | OptComplChoices [String] -- ^ List of string choices

                   | OptComplSuggest [String] -- ^ Suggested choices

-- | Argument type. This differs from (and wraps) an Option by the

-- fact that it can (and usually does) support multiple repetitions of

-- the same argument, via a min and max limit.

data ArgCompletion = ArgCompletion OptCompletion Int (Maybe Int)

-- | Yes\/no choices completion.

optComplYesNo :: OptCompletion

data ConfdQuery = EmptyQuery

                | PlainQuery String

                | DictQuery  ConfdReqQ

instance JSON ConfdQuery where

  readJSON o = case o of

-- | The complete state for the balancing solution.

data Table = Table Node.List Instance.List Score [Placement]

-- | Cluster statistics data type.

data CStats = CStats

  , csNmem :: Integer -- ^ Node own memory

  , csScore :: Score  -- ^ The cluster score

  , csNinst :: Int    -- ^ The total number of instances

-- | A simple type for allocation functions.

type AllocMethod =  Node.List           -- ^ Node list

{-

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

  , allocPolicy :: T.AllocPolicy -- ^ The allocation policy for this group

  , iPolicy     :: T.IPolicy     -- ^ The instance policy for this group

  , allTags     :: [String]      -- ^ The tags for this group

-- Note: we use the name as the alias, and the UUID as the official

-- name

  , spindleUse   :: Int       -- ^ The numbers of used spindles

  , allTags      :: [String]  -- ^ List of all instance tags

  , exclTags     :: [String]  -- ^ List of instance exclusion tags

instance T.Element Instance where

  nameOf   = name

  | NodeEvacuate [Idx] EvacMode              -- ^ node-evacuate mode

  | ChangeGroup [Gdx] [Idx]                  -- ^ Multi-relocate mode

  | MultiAllocate [(Instance.Instance, Int)] -- ^ Multi-allocate mode

-- | A complete request, as received from Ganeti.

data Request = Request RqType ClusterData

-- | The cluster state.

data ClusterData = ClusterData

  , cdInstances :: Instance.List -- ^ The instance list

  , cdTags      :: [String]      -- ^ The cluster tags

  , cdIPolicy   :: IPolicy       -- ^ The cluster instance policy

-- | An empty cluster.

emptyCluster :: ClusterData

  , pTags    :: TagMap    -- ^ Primary instance exclusion tags and their count

  , group    :: T.Gdx     -- ^ The node's group (index)

  , iPolicy  :: T.IPolicy -- ^ The instance policy (of the node's group)

instance T.Element Node where

  nameOf = name

data MirrorType = MirrorNone     -- ^ No mirroring/movability

                | MirrorInternal -- ^ DRBD-type mirroring

                | MirrorExternal -- ^ Shared-storage type mirroring

-- | Correspondence between disk template and mirror type.

templateMirrorType :: DiskTemplate -> MirrorType

  { rspecCpu  :: Int  -- ^ Requested VCPUs

  , rspecMem  :: Int  -- ^ Requested memory

  , rspecDsk  :: Int  -- ^ Requested disk

-- | Allocation stats type. This is used instead of 'RSpec' (which was

-- used at first), because we need to track more stats. The actual

  , allocInfoNCpus :: Double -- ^ Normalised CPUs

  , allocInfoMem   :: Int    -- ^ Memory

  , allocInfoDisk  :: Int    -- ^ Disk

-- | Currently used, possibly to allocate, unallocable.

type AllocStats = (AllocInfo, AllocInfo, AllocInfo)

  , memWeight :: Weight -- ^ Standardised memory load

  , dskWeight :: Weight -- ^ Standardised disk I\/O usage

  , netWeight :: Weight -- ^ Standardised network usage

-- | Initial empty utilisation.

zeroUtil :: DynUtil

           | ReplaceSecondary Ndx    -- ^ Replace secondary (r:ns)

           | ReplaceAndFailover Ndx  -- ^ Replace secondary, failover (r:np, f)

           | FailoverAndReplace Ndx  -- ^ Failover, replace secondary (f, r:ns)

-- | Formatted solution output for one move (involved nodes and

-- commands.

              | FailCPU  -- ^ Failed due to not enough CPU capacity

              | FailN1   -- ^ Failed due to not passing N1 checks

              | FailTags -- ^ Failed due to tag exclusion

-- | List with failure statistics.

type FailStats = [(FailMode, Int)]

-- | The container type, a wrapper over Data.Map

newtype GenericContainer a b =

  GenericContainer { fromContainer :: Map.Map a b }

-- | Type alias for string keys.

type Container = GenericContainer String

data RecvResult = RecvConnClosed    -- ^ Connection closed

                | RecvError String  -- ^ Any other error

                | RecvOk String     -- ^ Successfull receive

-- | The Ganeti job type.

type JobId = Int

  | LIDFile FileDriver String -- ^ Driver, path

  | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)

  | LIDRados String String -- ^ Unused, path

-- | Mapping from a logical id to a disk type.

lidDiskType :: DiskLogicalId -> DiskType

  , diskIvName     :: String

  , diskSize       :: Int

  , diskMode       :: DiskMode

$(buildObjectSerialisation "Disk"

  [ customField 'decodeDLId 'encodeFullDLId $

               | TagNode     String

               | TagGroup    String

               | TagCluster

-- | Tag type for a given tag object.

tagTypeOf :: TagObject -> TagType

-- | Disk index type (embedding constraints on the index value via a

-- smart constructor).

newtype DiskIndex = DiskIndex { unDiskIndex :: Int }

-- | Smart constructor for 'DiskIndex'.

mkDiskIndex :: (Monad m) => Int -> m DiskIndex

  = RecreateDisksAll

  | RecreateDisksIndices (NonEmpty DiskIndex)

  | RecreateDisksParams (NonEmpty (DiskIndex, IDiskParams))

readRecreateDisks :: JSValue -> Text.JSON.Result RecreateDisksInfo

readRecreateDisks (JSArray []) = return RecreateDisksAll

-- | Simple type for old-style ddm changes.

data DdmOldChanges = DdmOldIndex (NonNegative Int)

                   | DdmOldMod DdmSimple

readDdmOldChanges :: JSValue -> Text.JSON.Result DdmOldChanges

readDdmOldChanges v =

  = SetParamsEmpty

  | SetParamsDeprecated (NonEmpty (DdmOldChanges, a))

  | SetParamsNew (NonEmpty (DdmFull, Int, a))

-- | Custom deserialiser for 'SetParamsMods'.

readSetParams :: (JSON a) => JSValue -> Text.JSON.Result (SetParamsMods a)

-- tests). But the proper type could be parsed if we wanted.

data ExportTarget = ExportTargetLocal NonEmptyString

                  | ExportTargetRemote UncheckedList

-- | Custom reader for 'ExportTarget'.

readExportTarget :: JSValue -> Text.JSON.Result ExportTarget

-- | Overall query type.

data ItemType = ItemTypeLuxi QueryTypeLuxi

              | ItemTypeOpCode QueryTypeOp

-- | Custom JSON decoder for 'ItemType'.

decodeItemType :: (Monad m) => JSValue -> m ItemType

    | GEFilter       a FilterValue  -- ^ @>=@ /field/ /value/

    | RegexpFilter   a FilterRegex  -- ^ @=~@ /field/ /regexp/

    | ContainsFilter a FilterValue  -- ^ @=[]@ /list-field/ /value/

-- | Serialiser for the 'Filter' data type.

showFilter :: (JSON a) => Filter a -> JSValue

-- | Value to compare the field value to, for filtering purposes.

data FilterValue = QuotedString String

                 | NumericValue Integer

-- | Serialiser for 'FilterValue'. The Python code just sends this to

-- JSON as-is, so we'll do the same.

instance Show FilterRegex where

  show (FilterRegex re _) = "mkRegex " ++ show re

-- | 'Eq' instance: we only compare the string versions of the regexes.

instance Eq FilterRegex where

  (FilterRegex re1 _) == (FilterRegex re2 _) = re1 == re2

data ResultEntry = ResultEntry

  { rentryStatus :: ResultStatus      -- ^ The result status

  , rentryValue  :: Maybe ResultValue -- ^ The (optional) result value

instance JSON ResultEntry where

  showJSON (ResultEntry rs rv) =

-- Query node version.

-- Note: We can't use THH as it does not know what to do with empty dict

data RpcCallVersion = RpcCallVersion {}

instance J.JSON RpcCallVersion where

  showJSON _ = J.JSNull

  decl_d <- mapM (\(cname, fields) -> do

                    fields' <- mapM (buildConsField . snd) fields

                    return $ NormalC (mkName cname) fields') cons

-- | Generate the save function for a given type.

genSaveSimpleObj :: Name                            -- ^ Object type

strADTDecl name constructors =

  DataD [] name []

          (map (flip NormalC [] . mkName) constructors)

-- | Generates a toRaw function.

--

                    fields' <- mapM (fieldTypeInfo "op") fields

                    return $ RecC (mkName cname) fields')

            cons

  (savesig, savefn) <- genSaveOpCode tname "saveOpCode" cons

                         (uncurry saveConstructor)

                    let fields'' = zip (repeat NotStrict) fields'

                    return $ NormalC (mkName cname) fields'')

            cons

  (savesig, savefn) <- genSaveOpCode tname "opToArgs"

                         cons saveLuxiConstructor

  req_defs <- declareSADT "LuxiReq" .

  let name = mkName sname

  fields_d <- mapM (fieldTypeInfo field_pfx) fields

  let decl_d = RecC name fields_d

  ser_decls <- buildObjectSerialisation sname fields

  return $ declD:ser_decls

  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields

  let decl_f = RecC name_f fields_f

      decl_p = RecC name_p fields_p

  ser_decls_f <- buildObjectSerialisation sname_f fields

  ser_decls_p <- buildPParamSerialisation sname_p fields

  fill_decls <- fillParam sname field_pfx fields

-- | Type that holds a non-negative value.

newtype NonNegative a = NonNegative { fromNonNegative :: a }

-- | Smart constructor for 'NonNegative'.

mkNonNegative :: (Monad m, Num a, Ord a, Show a) => a -> m (NonNegative a)

-- | Type that holds a positive value.

newtype Positive a = Positive { fromPositive :: a }

-- | Smart constructor for 'Positive'.

mkPositive :: (Monad m, Num a, Ord a, Show a) => a -> m (Positive a)

-- | Type that holds a non-null list.

newtype NonEmpty a = NonEmpty { fromNonEmpty :: [a] }

-- | Smart constructor for 'NonEmpty'.

mkNonEmpty :: (Monad m) => [a] -> m (NonEmpty a)