From 53ec902212ffeca7cf27e06bd5379518f2f47ffe Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Tue, 14 Jul 2009 14:01:51 +0200
Subject: [PATCH] Initial commit of the luxi backend
This patch adds a luxi backend that allows direct query of the master
daemon on the local node. This patch doesn't enable the backend to be
used.
There are a couple of things still missing in the implementation:
- we don't have a master timeout in reads and writes, only a
per-recv/send-call one
- the failure reporting is not as good as it could be
---
Ganeti/HTools/Luxi.hs | 282 ++++++++++++++++++++++++++++++++++++++++++
1 file changed, 282 insertions(+)
create mode 100644 Ganeti/HTools/Luxi.hs
diff --git a/Ganeti/HTools/Luxi.hs b/Ganeti/HTools/Luxi.hs
new file mode 100644
index 000000000..68d5ffc0a
--- /dev/null
+++ b/Ganeti/HTools/Luxi.hs
@@ -0,0 +1,282 @@
+{-| Implementation of the LUXI client interface.
+
+-}
+
+{-
+
+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.Luxi
+ (
+ loadData
+ ) 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 Ganeti.HTools.Loader
+import Ganeti.HTools.Types
+import qualified Ganeti.HTools.Node as Node
+import qualified Ganeti.HTools.Instance as Instance
+
+-- * 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 =
+ case v of
+ 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, rbuf) = break ((==) eOM) (obuf ++ nbuf)
+ (if null msg
+ then _recv rbuf
+ else return (msg, drop 1 rbuf))
+ 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 =
+ 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]
+
+-- | The input data for instance query.
+queryInstancesMsg :: JSValue
+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]
+
+
+-- | Wraper over callMethod doing node query.
+queryNodes :: Client -> IO (Result JSValue)
+queryNodes = callMethod QueryNodes queryNodesMsg
+
+-- | Wraper over callMethod doing instance query.
+queryInstances :: Client -> IO (Result JSValue)
+queryInstances = callMethod QueryInstances queryInstancesMsg
+
+-- | Parse a instance list in JSON format.
+getInstances :: NameAssoc
+ -> JSValue
+ -> Result [(String, Instance.Instance)]
+getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
+
+-- | Construct an instance from a JSON object.
+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]
+ 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
+ return (xname, inst)
+
+parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
+
+-- | Parse a node list in JSON format.
+getNodes :: JSValue -> Result [(String, Node.Node)]
+getNodes arr = toArray arr >>= mapM parseNode
+
+-- | Construct a node from a JSON object.
+parseNode :: JSValue -> Result (String, Node.Node)
+parseNode (JSArray
+ (name:mtotal:mnode:mfree:dtotal:dfree:ctotal:offline:drained:[]))
+ = do
+ xname <- fromJVal name
+ xoffline <- fromJVal 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
+ return $ Node.create xname xmtotal xmnode xmfree
+ xdtotal xdfree xctotal (xoffline || xdrained))
+ return (xname, node)
+
+parseNode v = fail ("Invalid node query result: " ++ show v)
+
+-- * 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 = do -- IO monad
+ E.bracket
+ (getClient master)
+ 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)
+ )
--
GitLab