Synnefo » snf-ganeti

-- 'Allocate' request share some common properties, which are read by

-- this function.

parseBaseInstance :: String

                  -> Result (String, Instance.Instance)

parseBaseInstance n a = do

  let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x

  return (n, Instance.create n mem disk vcpus running tags True 0 0)

-- | Parses an instance as found in the cluster instance listg.

              -> Result (String, Instance.Instance)

parseInstance ktn n a = do

  base <- parseBaseInstance n a

  return (n, Instance.setBoth (snd base) pidx sidx)

-- | Parses a node as found in the cluster node list.

          -> Result (String, Node.Node)

parseNode ktg n a = do

  let desc = "invalid data for node '" ++ n ++ "'"

  return (n, node)

-- | Parses a group as found in the cluster group list.

           -> Result (String, Group.Group)

parseGroup u a = do

  let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x

  apol <- extract "alloc_policy"

  return (u, Group.create name u apol)

                  -> Result [Gdx]

parseTargetGroups req map_g = do

  group_uuids <- fromObjWithDefault req "target_groups" []

import Network.Curl.Types ()

#endif

import Control.Monad

import Text.JSON.Types (JSValue(..))

import Text.Printf (printf)

-- | Construct an instance from a JSON object.

parseInstance :: NameAssoc

              -> Result (String, Instance.Instance)

parseInstance ktn a = do

  name <- tryFromObj "Parsing new instance" a "name"

  return (name, inst)

-- | Construct a node from a JSON object.

parseNode ktg a = do

  name <- tryFromObj "Parsing new node" a "name"

  let desc = "Node '" ++ name ++ "', error while parsing data"

  return (name, node)

-- | Construct a group from a JSON object.

parseGroup a = do

  name <- tryFromObj "Parsing new group" a "name"

  let extract s = tryFromObj ("Group '" ++ name ++ "'") a s

    , stdDev

    , commaJoin

    , readEitherString

    , loadJSArray

    , fromObj

    , fromObjWithDefault

-- * JSON-related functions

-- | Converts a JSON Result into a monadic value.

fromJResult :: Monad m => String -> J.Result a -> m a

fromJResult s (J.Error x) = fail (s ++ ": " ++ x)

loadJSArray s = fromJResult s . J.decodeStrict

-- | Reads the value of a key in a JSON object.

fromObj o k =

    case lookup k o of

      Nothing -> fail $ printf "key '%s' not found, object contains only %s"

-- | Reads the value of an optional key in a JSON object.

maybeFromObj :: (J.JSON a, Monad m) =>

maybeFromObj o k =

    case lookup k o of

      Nothing -> return Nothing

-- | Reads the value of a key in a JSON object with a default if missing.

fromObjWithDefault :: (J.JSON a, Monad m) =>

fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k

-- | Reads a JValue, that originated from an object key

-- | Try to extract a key from a object with better error reporting

-- than fromObj

tryFromObj :: (J.JSON a) =>

           -> Result a

tryFromObj t o = annotateResult t . fromObj o