X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/608efcce95d93c1228f526c5f3ed192650b6f2b7..20c891d0cb7c99cf6ef4e240b172ad89cd059f21:/Ganeti/HTools/Rapi.hs?ds=sidebyside diff --git a/Ganeti/HTools/Rapi.hs b/Ganeti/HTools/Rapi.hs index bdf2dff..623baeb 100644 --- a/Ganeti/HTools/Rapi.hs +++ b/Ganeti/HTools/Rapi.hs @@ -2,6 +2,27 @@ -} +{- + +Copyright (C) 2009 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.HTools.Rapi ( loadData @@ -12,7 +33,8 @@ import Network.Curl.Types () import Network.Curl.Code import Data.List import Control.Monad -import Text.JSON (JSObject, JSValue) +import Text.JSON (JSObject, JSValue, fromJSObject, decodeStrict) +import Text.JSON.Types (JSValue(..)) import Text.Printf (printf) import Ganeti.HTools.Utils @@ -21,77 +43,92 @@ import Ganeti.HTools.Types import qualified Ganeti.HTools.Node as Node import qualified Ganeti.HTools.Instance as Instance --- | Read an URL via curl and return the body if successful +-- | Read an URL via curl and return the body if successful. getUrl :: (Monad m) => String -> IO (m String) getUrl url = do (code, body) <- curlGetString url [CurlSSLVerifyPeer False, - CurlSSLVerifyHost 0] + CurlSSLVerifyHost 0, + CurlTimeout (fromIntegral queryTimeout), + CurlConnectTimeout + (fromIntegral connTimeout)] return (case code of CurlOK -> return body _ -> fail $ printf "Curl error for '%s', error %s" url (show code)) --- | Append the default port if not passed in +-- | Append the default port if not passed in. formatHost :: String -> String formatHost master = if elem ':' master then master else "https://" ++ master ++ ":5080" +-- | Parse a instance list in JSON format. getInstances :: NameAssoc -> String -> Result [(String, Instance.Instance)] -getInstances ktn body = do - arr <- loadJSArray body - ilist <- mapM (parseInstance ktn) arr - return ilist +getInstances ktn body = + loadJSArray body >>= mapM (parseInstance ktn . fromJSObject) +-- | Parse a node list in JSON format. getNodes :: String -> Result [(String, Node.Node)] -getNodes body = do - arr <- loadJSArray body - nlist <- mapM parseNode arr - return nlist +getNodes body = loadJSArray body >>= mapM (parseNode . fromJSObject) +-- | Construct an instance from a JSON object. parseInstance :: [(String, Ndx)] - -> JSObject JSValue + -> [(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" - pnode <- fromObj "pnode" a >>= lookupNode ktn name - snodes <- fromObj "snodes" a + name <- tryFromObj "Parsing new instance" a "name" + let owner_name = "Instance '" ++ name ++ "'" + let extract s x = tryFromObj owner_name x s + disk <- extract "disk_usage" a + beparams <- liftM fromJSObject (extract "beparams" a) + omem <- extract "oper_ram" a + mem <- (case omem of + JSRational _ _ -> annotateResult owner_name (fromJVal omem) + _ -> 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 - let inst = Instance.create name mem disk running pnode snode + running <- extract "status" a + tags <- extract "tags" a + let inst = Instance.create name mem disk vcpus running tags pnode snode return (name, inst) -parseNode :: JSObject JSValue -> Result (String, Node.Node) +-- | 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 - node <- (case offline of - True -> return $ Node.create name 0 0 0 0 0 True - _ -> 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 - return $ Node.create name mtotal mnode mfree - dtotal dfree (offline || drained)) - return (name, node) + name <- tryFromObj "Parsing new node" a "name" + let extract s = tryFromObj ("Node '" ++ name ++ "'") a s + offline <- extract "offline" + drained <- extract "drained" + node <- (if offline || drained + then return $ Node.create name 0 0 0 0 0 0 True + else do + 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 False) + return (name, node) +-- | Builds the cluster data from an URL. loadData :: String -- ^ Cluster or URL to use as source - -> IO (Result (Node.AssocList, Instance.AssocList)) + -> IO (Result (Node.AssocList, Instance.AssocList, [String])) loadData master = do -- IO monad let url = formatHost master node_body <- getUrl $ printf "%s/2/nodes?bulk=1" url inst_body <- getUrl $ printf "%s/2/instances?bulk=1" url + tags_body <- getUrl $ printf "%s/2/tags" url return $ do -- Result monad node_data <- node_body >>= getNodes let (node_names, node_idx) = assignIndices node_data inst_data <- inst_body >>= getInstances node_names let (_, inst_idx) = assignIndices inst_data - return (node_idx, inst_idx) + tags_data <- tags_body >>= (fromJResult . decodeStrict) + return (node_idx, inst_idx, tags_data)