/ - Diff - snf-ganeti - Greek Research and Technology Network's projects

     import Data.List
     import qualified Control.Exception as E
     import Control.Monad
     import Text.JSON (JSValue, readJSON, JSON)
     import qualified Text.JSON as J
     import Text.JSON.Types
     import qualified Ganeti.Luxi as L
-...
     import Ganeti.HTools.Types
     import qualified Ganeti.HTools.Node as Node
     import qualified Ganeti.HTools.Instance as Instance
     import Ganeti.HTools.Utils (fromJVal, annotateResult)
     -- * Utility functions
     -- | Small wrapper over readJSON.
     fromJVal :: (Monad m, JSON a) => JSValue -> m a
     fromJVal v =
         case readJSON v of
           J.Error s -> fail ("Cannot convert value " ++ show v ++ ", error: " ++ s)
           J.Ok x -> return x
     -- | Ensure a given JSValue is actually a JSArray.
     toArray :: (Monad m) => JSValue -> m [JSValue]
     toArray v =
-...
                   -> JSValue
                   -> Result (String, Instance.Instance)
     parseInstance ktn (JSArray (name:disk:mem:vcpus:status:pnode:snodes:[])) = do
       xname <- fromJVal name
       xdisk <- fromJVal disk
       xmem <- fromJVal mem
       xvcpus <- fromJVal vcpus
       xpnode <- fromJVal pnode >>= lookupNode ktn xname
       xsnodes <- fromJVal snodes::Result [JSString]
       xname <- annotateResult "Parsing new instance" (fromJVal name)
       let convert v = annotateResult ("Instance '" ++ xname ++ "'") (fromJVal v)
       xdisk <- convert disk
       xmem <- convert mem
       xvcpus <- convert vcpus
       xpnode <- convert pnode >>= lookupNode ktn xname
       xsnodes <- convert snodes::Result [JSString]
       snode <- (if null xsnodes then return Node.noSecondary
                 else lookupNode ktn xname (fromJSString $ head xsnodes))
       xrunning <- fromJVal status
       xrunning <- convert status
       let inst = Instance.create xname xmem xdisk xvcpus xrunning xpnode snode
       return (xname, inst)
-...
     parseNode (JSArray
                (name:mtotal:mnode:mfree:dtotal:dfree:ctotal:offline:drained:[]))
         = do
       xname <- fromJVal name
       xoffline <- fromJVal offline
       xname <- annotateResult "Parsing new node" (fromJVal name)
       let convert v = annotateResult ("Node '" ++ xname ++ "'") (fromJVal v)
       xoffline <- convert offline
       node <- (if xoffline
                then return $ Node.create xname 0 0 0 0 0 0 True
                else do
                  xdrained <- fromJVal drained
                  xmtotal  <- fromJVal mtotal
                  xmnode   <- fromJVal mnode
                  xmfree   <- fromJVal mfree
                  xdtotal  <- fromJVal dtotal
                  xdfree   <- fromJVal dfree
                  xctotal  <- fromJVal ctotal
                  xdrained <- convert drained
                  xmtotal  <- convert mtotal
                  xmnode   <- convert mnode
                  xmfree   <- convert mfree
                  xdtotal  <- convert dtotal
                  xdfree   <- convert dfree
                  xctotal  <- convert ctotal
                  return $ Node.create xname xmtotal xmnode xmfree
                         xdtotal xdfree xctotal (xoffline || xdrained))
       return (xname, node)

                   -> [(String, JSValue)]
                   -> Result (String, Instance.Instance)
     parseInstance ktn a = do
       name <- fromObj "name" a
       disk <- fromObj "disk_usage" a
       mem <- fromObj "beparams" a >>= fromObj "memory" . fromJSObject
       vcpus <- fromObj "beparams" a >>= fromObj "vcpus" . fromJSObject
       pnode <- fromObj "pnode" a >>= lookupNode ktn name
       snodes <- fromObj "snodes" a
       name <- tryFromObj "Parsing new instance" a "name"
       let extract s x = tryFromObj ("Instance '" ++ name ++ "'") x s
       disk <- extract "disk_usage" a
       beparams <- liftM fromJSObject (extract "beparams" a)
       mem <- extract "memory" beparams
       vcpus <- extract "vcpus" beparams
       pnode <- extract "pnode" a >>= lookupNode ktn name
       snodes <- extract "snodes" a
       snode <- (if null snodes then return Node.noSecondary
                 else readEitherString (head snodes) >>= lookupNode ktn name)
       running <- fromObj "status" a
       running <- extract "status" a
       let inst = Instance.create name mem disk vcpus running pnode snode
       return (name, inst)
     -- | Construct a node from a JSON object.
     parseNode :: [(String, JSValue)] -> Result (String, Node.Node)
     parseNode a = do
       name <- fromObj "name" a
       offline <- fromObj "offline" a
       name <- tryFromObj "Parsing new node" a "name"
       let extract s = tryFromObj ("Node '" ++ name ++ "'") a s
       offline <- extract "offline"
       node <- (if offline
                then return $ Node.create name 0 0 0 0 0 0 True
                else do
                  drained <- fromObj "drained" a
                  mtotal  <- fromObj "mtotal"  a
                  mnode   <- fromObj "mnode"   a
                  mfree   <- fromObj "mfree"   a
                  dtotal  <- fromObj "dtotal"  a
                  dfree   <- fromObj "dfree"   a
                  ctotal  <- fromObj "ctotal"  a
                  drained <- extract "drained"
                  mtotal  <- extract "mtotal"
                  mnode   <- extract "mnode"
                  mfree   <- extract "mfree"
                  dtotal  <- extract "dtotal"
                  dfree   <- extract "dfree"
                  ctotal  <- extract "ctotal"
                  return $ Node.create name mtotal mnode mfree
                         dtotal dfree ctotal (offline || drained))
       return (name, node)

         , readEitherString
         , loadJSArray
         , fromObj
         , tryFromObj
         , fromJVal
         , asJSObject
         , asObjectList
         , fromJResult
         , tryRead
         , formatTable
         , annotateResult
         ) where
     import Data.List
-...
     import Debug.Trace
     import Ganeti.HTools.Types
     -- * Debug functions
     -- | To be used only for debugging, breaks referential integrity.
-...
           Nothing -> fail $ printf "key '%s' not found in %s" k (show o)
           Just val -> fromJResult $ J.readJSON val
     -- | Annotate a Result with an ownership information
     annotateResult :: String -> Result a -> Result a
     annotateResult owner (Bad s) = Bad $ owner ++ ": " ++ s
     annotateResult _ v = v
     -- | Try to extract a key from a object with better error reporting
     -- than fromObj
     tryFromObj :: (J.JSON a) =>
                   String -> [(String, J.JSValue)] -> String -> Result a
     tryFromObj t o k = annotateResult (t ++ " key '" ++ k ++ "'") (fromObj k o)
     -- | Small wrapper over readJSON.
     fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
     fromJVal v =
         case J.readJSON v of
           J.Error s -> fail ("Cannot convert value " ++ show v ++ ", error: " ++ s)
           J.Ok x -> return x
     -- | Converts a JSON value into a JSON object.
     asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
     asJSObject (J.JSObject a) = return a

Synnefo » snf-ganeti

Revision 117dc2d8