-{-| Implementation of the LUXI client interface.
+{-| Implementation of the LUXI loader.
-}
{-
-Copyright (C) 2009 Google Inc.
+Copyright (C) 2009, 2010 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
module Ganeti.HTools.Luxi
(
loadData
+ , parseData
) where
-import Data.List
-import Data.IORef
import qualified Control.Exception as E
-import Control.Monad
-import Text.JSON (JSObject, JSValue, toJSObject, encodeStrict
- , decodeStrict, readJSON, JSON)
-import qualified Text.JSON as J
import Text.JSON.Types
-import System.Timeout
-import qualified Network.Socket as S
-import Ganeti.HTools.Utils
+import qualified Ganeti.Luxi as L
import Ganeti.HTools.Loader
import Ganeti.HTools.Types
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
+import Ganeti.HTools.Utils (fromJVal, annotateResult, tryFromObj, asJSObject)
-- * 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 =
JSArray arr -> return arr
o -> fail ("Invalid input, expected array but got " ++ show o)
--- | Wrapper over System.Timeout.timeout that fails in the IO monad.
-withTimeout :: Int -> String -> IO a -> IO a
-withTimeout secs descr action = do
- result <- timeout (secs * 1000000) action
- (case result of
- Nothing -> fail $ "Timeout in " ++ descr
- Just v -> return v)
-
--- * Generic protocol functionality
-
--- | Currently supported Luxi operations.
-data LuxiOp = QueryInstances
- | QueryNodes
-
--- | The serialisation of LuxiOps into strings in messages.
-strOfOp :: LuxiOp -> String
-strOfOp QueryNodes = "QueryNodes"
-strOfOp QueryInstances = "QueryInstances"
-
--- | The end-of-message separator.
-eOM :: Char
-eOM = '\3'
-
--- | Valid keys in the requests and responses.
-data MsgKeys = Method
- | Args
- | Success
- | Result
-
--- | The serialisation of MsgKeys into strings in messages.
-strOfKey :: MsgKeys -> String
-strOfKey Method = "method"
-strOfKey Args = "args"
-strOfKey Success = "success"
-strOfKey Result = "result"
-
--- | Luxi client encapsulation.
-data Client = Client { socket :: S.Socket -- ^ The socket of the client
- , rbuf :: IORef String -- ^ Already received buffer
- }
-
--- | Connects to the master daemon and returns a luxi Client.
-getClient :: String -> IO Client
-getClient path = do
- s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
- withTimeout connTimeout "creating luxi connection" $
- S.connect s (S.SockAddrUnix path)
- rf <- newIORef ""
- return Client { socket=s, rbuf=rf}
-
--- | Closes the client socket.
-closeClient :: Client -> IO ()
-closeClient = S.sClose . socket
-
--- | Sends a message over a luxi transport.
-sendMsg :: Client -> String -> IO ()
-sendMsg s buf =
- let _send obuf = do
- sbytes <- withTimeout queryTimeout
- "sending luxi message" $
- S.send (socket s) obuf
- (if sbytes == length obuf
- then return ()
- else _send (drop sbytes obuf))
- in _send (buf ++ [eOM])
-
--- | Waits for a message over a luxi transport.
-recvMsg :: Client -> IO String
-recvMsg s = do
- let _recv obuf = do
- nbuf <- withTimeout queryTimeout "reading luxi response" $
- S.recv (socket s) 4096
- let (msg, remaining) = break ((==) eOM) (obuf ++ nbuf)
- (if null remaining
- then _recv msg
- else return (msg, tail remaining))
- cbuf <- readIORef $ rbuf s
- (msg, nbuf) <- _recv cbuf
- writeIORef (rbuf s) nbuf
- return msg
-
--- | Serialize a request to String.
-buildCall :: LuxiOp -- ^ The method
- -> JSValue -- ^ The arguments
- -> String -- ^ The serialized form
-buildCall msg args =
- let ja = [(strOfKey Method,
- JSString $ toJSString $ strOfOp msg::JSValue),
- (strOfKey Args,
- args::JSValue)
- ]
- jo = toJSObject ja
- in encodeStrict jo
-
--- | Check that luxi responses contain the required keys and that the
--- call was successful.
-validateResult :: String -> Result JSValue
-validateResult s = do
- arr <- fromJResult $ decodeStrict s::Result (JSObject JSValue)
- status <- fromObj (strOfKey Success) arr::Result Bool
- let rkey = strOfKey Result
- (if status
- then fromObj rkey arr
- else fromObj rkey arr >>= fail)
-
--- | Generic luxi method call.
-callMethod :: LuxiOp -> JSValue -> Client -> IO (Result JSValue)
-callMethod method args s = do
- sendMsg s $ buildCall method args
- result <- recvMsg s
- let rval = validateResult result
- return rval
-
-- * Data querying functionality
-- | The input data for node query.
-queryNodesMsg :: JSValue
+queryNodesMsg :: L.LuxiOp
queryNodesMsg =
- let nnames = JSArray []
- fnames = ["name",
- "mtotal", "mnode", "mfree",
- "dtotal", "dfree",
- "ctotal",
- "offline", "drained"]
- fields = JSArray $ map (JSString . toJSString) fnames
- use_locking = JSBool False
- in JSArray [nnames, fields, use_locking]
+ L.QueryNodes [] ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
+ "ctotal", "offline", "drained", "vm_capable",
+ "group.uuid"] False
-- | The input data for instance query.
-queryInstancesMsg :: JSValue
+queryInstancesMsg :: L.LuxiOp
queryInstancesMsg =
- let nnames = JSArray []
- fnames = ["name",
- "disk_usage", "be/memory", "be/vcpus",
- "status", "pnode", "snodes"]
- fields = JSArray $ map (JSString . toJSString) fnames
- use_locking = JSBool False
- in JSArray [nnames, fields, use_locking]
+ L.QueryInstances [] ["name", "disk_usage", "be/memory", "be/vcpus",
+ "status", "pnode", "snodes", "tags", "oper_ram"] False
+-- | The input data for cluster query
+queryClusterInfoMsg :: L.LuxiOp
+queryClusterInfoMsg = L.QueryClusterInfo
-- | Wraper over callMethod doing node query.
-queryNodes :: Client -> IO (Result JSValue)
-queryNodes = callMethod QueryNodes queryNodesMsg
+queryNodes :: L.Client -> IO (Result JSValue)
+queryNodes = L.callMethod queryNodesMsg
-- | Wraper over callMethod doing instance query.
-queryInstances :: Client -> IO (Result JSValue)
-queryInstances = callMethod QueryInstances queryInstancesMsg
+queryInstances :: L.Client -> IO (Result JSValue)
+queryInstances = L.callMethod queryInstancesMsg
+
+queryClusterInfo :: L.Client -> IO (Result JSValue)
+queryClusterInfo = L.callMethod queryClusterInfoMsg
-- | Parse a instance list in JSON format.
getInstances :: NameAssoc
parseInstance :: [(String, Ndx)]
-> 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]
+parseInstance ktn (JSArray [ name, disk, mem, vcpus
+ , status, pnode, snodes, tags, oram ]) = do
+ xname <- annotateResult "Parsing new instance" (fromJVal name)
+ let convert v = annotateResult ("Instance '" ++ xname ++ "'") (fromJVal v)
+ xdisk <- convert disk
+ xmem <- (case oram of
+ JSRational _ _ -> convert oram
+ _ -> 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
- let inst = Instance.create xname xmem xdisk xvcpus xrunning xpnode snode
+ xrunning <- convert status
+ xtags <- convert tags
+ let inst = Instance.create xname xmem xdisk xvcpus
+ xrunning xtags xpnode snode
return (xname, inst)
parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
-- | Construct a node from a JSON object.
parseNode :: JSValue -> Result (String, Node.Node)
-parseNode (JSArray
- (name:mtotal:mnode:mfree:dtotal:dfree:ctotal:offline:drained:[]))
+parseNode (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
+ , ctotal, offline, drained, vm_capable, g_uuid ])
= do
- xname <- fromJVal name
- xoffline <- fromJVal offline
- node <- (if xoffline
- then return $ Node.create xname 0 0 0 0 0 0 True
+ xname <- annotateResult "Parsing new node" (fromJVal name)
+ let convert v = annotateResult ("Node '" ++ xname ++ "'") (fromJVal v)
+ xoffline <- convert offline
+ xdrained <- convert drained
+ xvm_capable <- convert vm_capable
+ xguuid <- convert g_uuid
+ node <- (if xoffline || xdrained || not xvm_capable
+ then return $ Node.create xname 0 0 0 0 0 0 True xguuid
else do
- xdrained <- fromJVal drained
- xmtotal <- fromJVal mtotal
- xmnode <- fromJVal mnode
- xmfree <- fromJVal mfree
- xdtotal <- fromJVal dtotal
- xdfree <- fromJVal dfree
- xctotal <- fromJVal ctotal
+ 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))
+ xdtotal xdfree xctotal False xguuid)
return (xname, node)
parseNode v = fail ("Invalid node query result: " ++ show v)
+getClusterTags :: JSValue -> Result [String]
+getClusterTags v = do
+ let errmsg = "Parsing cluster info"
+ obj <- annotateResult errmsg $ asJSObject v
+ tryFromObj errmsg (fromJSObject obj) "tags"
+
-- * Main loader functionality
-- | Builds the cluster data from an URL.
-loadData :: String -- ^ Unix socket to use as source
- -> IO (Result (Node.AssocList, Instance.AssocList))
-loadData master =
+readData :: String -- ^ Unix socket to use as source
+ -> IO (Result JSValue, Result JSValue, Result JSValue)
+readData master =
E.bracket
- (getClient master)
- closeClient
+ (L.getClient master)
+ L.closeClient
(\s -> do
nodes <- queryNodes s
instances <- queryInstances s
- return $ do -- Result monad
- node_data <- nodes >>= getNodes
- let (node_names, node_idx) = assignIndices node_data
- inst_data <- instances >>= getInstances node_names
- let (_, inst_idx) = assignIndices inst_data
- return (node_idx, inst_idx)
+ cinfo <- queryClusterInfo s
+ return (nodes, instances, cinfo)
)
+
+parseData :: (Result JSValue, Result JSValue, Result JSValue)
+ -> Result (Node.AssocList, Instance.AssocList, [String])
+parseData (nodes, instances, cinfo) = do
+ node_data <- nodes >>= getNodes
+ let (node_names, node_idx) = assignIndices node_data
+ inst_data <- instances >>= getInstances node_names
+ let (_, inst_idx) = assignIndices inst_data
+ ctags <- cinfo >>= getClusterTags
+ return (node_idx, inst_idx, ctags)
+
+-- | Top level function for data loading
+loadData :: String -- ^ Unix socket to use as source
+ -> IO (Result (Node.AssocList, Instance.AssocList, [String]))
+loadData master = readData master >>= return . parseData
projects / ganeti-local / blobdiff