Synnefo » snf-ganeti

{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

{-| Data types for Xen-specific hypervisor functionalities.

-}

{-

Copyright (C) 2013 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.Hypervisor.Xen.Types

  ( LispConfig(..)

  , Domain(..)

  , FromLispConfig(..)

  , ActualState(..)

  ) where

import qualified Text.JSON as J

import Ganeti.BasicTypes

-- | Data type representing configuration data as produced by the

-- @xm list --long@ command.

data LispConfig = LCList [LispConfig]

                | LCString String

                | LCDouble Double

                deriving (Eq, Show)

-- | Data type representing a Xen Domain.

data Domain = Domain

  { domId      :: Int

  , domName    :: String

  , domCpuTime :: Double

  , domState   :: ActualState

  , domIsHung  :: Maybe Bool

  } deriving (Show, Eq)

-- | Class representing all the types that can be extracted from LispConfig.

class FromLispConfig a where

  fromLispConfig :: LispConfig -> Result a

-- | Instance of FromLispConfig for Int.

instance FromLispConfig Int where

  fromLispConfig (LCDouble d) = Ok $ floor d

  fromLispConfig (LCList (LCString _:LCDouble d:[])) = Ok $ floor d

  fromLispConfig c =

    Bad $ "Unable to extract a Int from this configuration: "

      ++ show c

-- | Instance of FromLispConfig for Double.

instance FromLispConfig Double where

  fromLispConfig (LCDouble d) = Ok d

  fromLispConfig (LCList (LCString _:LCDouble d:[])) = Ok d

  fromLispConfig c =

    Bad $ "Unable to extract a Double from this configuration: "

      ++ show c

-- | Instance of FromLispConfig for String

instance FromLispConfig String where

  fromLispConfig (LCString s) = Ok s

  fromLispConfig (LCList (LCString _:LCString s:[])) = Ok s

  fromLispConfig c =

    Bad $ "Unable to extract a String from this configuration: "

      ++ show c

-- | Instance of FromLispConfig for [LispConfig]

instance FromLispConfig [LispConfig] where

  fromLispConfig (LCList l) = Ok l

  fromLispConfig c =

    Bad $ "Unable to extract a List from this configuration: "

      ++ show c

data ActualState = ActualRunning  -- ^ The instance is running

                 | ActualBlocked  -- ^ The instance is not running or runnable

                 | ActualPaused   -- ^ The instance has been paused

                 | ActualShutdown -- ^ The instance is shut down

                 | ActualCrashed  -- ^ The instance has crashed

                 | ActualDying    -- ^ The instance is in process of dying

                 | ActualHung     -- ^ The instance is hung

                 | ActualUnknown  -- ^ Unknown state. Parsing error.

                 deriving (Show, Eq)

instance J.JSON ActualState where

  showJSON ActualRunning = J.showJSON "running"

  showJSON ActualBlocked = J.showJSON "blocked"

  showJSON ActualPaused = J.showJSON "paused"

  showJSON ActualShutdown = J.showJSON "shutdown"

  showJSON ActualCrashed = J.showJSON "crashed"

  showJSON ActualDying = J.showJSON "dying"

  showJSON ActualHung = J.showJSON "hung"

  showJSON ActualUnknown = J.showJSON "unknown"

  readJSON = error "JSON read instance not implemented for type ActualState"