code.grnet.gr Git - ganeti-local/blob - Ganeti/HTools/Luxi.hs

   1 {-| Implementation of the LUXI client interface.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009 Google Inc.
   8
   9 This program is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 2 of the License, or
  12 (at your option) any later version.
  13
  14 This program is distributed in the hope that it will be useful, but
  15 WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program; if not, write to the Free Software
  21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.
  23
  24 -}
  25
  26 module Ganeti.HTools.Luxi
  27     (
  28       loadData
  29     ) where
  30
  31 import Data.List
  32 import Data.IORef
  33 import qualified Control.Exception as E
  34 import Control.Monad
  35 import Text.JSON (JSObject, JSValue, toJSObject, encodeStrict
  36                  , decodeStrict, readJSON, JSON)
  37 import qualified Text.JSON as J
  38 import Text.JSON.Types
  39 import System.Timeout
  40 import qualified Network.Socket as S
  41
  42 import Ganeti.HTools.Utils
  43 import Ganeti.HTools.Loader
  44 import Ganeti.HTools.Types
  45 import qualified Ganeti.HTools.Node as Node
  46 import qualified Ganeti.HTools.Instance as Instance
  47
  48 -- * Utility functions
  49
  50 -- | Small wrapper over readJSON.
  51 fromJVal :: (Monad m, JSON a) => JSValue -> m a
  52 fromJVal v =
  53     case readJSON v of
  54       J.Error s -> fail ("Cannot convert value " ++ show v ++ ", error: " ++ s)
  55       J.Ok x -> return x
  56
  57 -- | Ensure a given JSValue is actually a JSArray.
  58 toArray :: (Monad m) => JSValue -> m [JSValue]
  59 toArray v =
  60     case v of
  61       JSArray arr -> return arr
  62       o -> fail ("Invalid input, expected array but got " ++ show o)
  63
  64 -- | Wrapper over System.Timeout.timeout that fails in the IO monad.
  65 withTimeout :: Int -> String -> IO a -> IO a
  66 withTimeout secs descr action = do
  67     result <- timeout (secs * 1000000) action
  68     (case result of
  69        Nothing -> fail $ "Timeout in " ++ descr
  70        Just v -> return v)
  71
  72 -- * Generic protocol functionality
  73
  74 -- | Currently supported Luxi operations.
  75 data LuxiOp = QueryInstances
  76             | QueryNodes
  77
  78 -- | The serialisation of LuxiOps into strings in messages.
  79 strOfOp :: LuxiOp -> String
  80 strOfOp QueryNodes = "QueryNodes"
  81 strOfOp QueryInstances = "QueryInstances"
  82
  83 -- | The end-of-message separator.
  84 eOM :: Char
  85 eOM = '\3'
  86
  87 -- | Valid keys in the requests and responses.
  88 data MsgKeys = Method
  89              | Args
  90              | Success
  91              | Result
  92
  93 -- | The serialisation of MsgKeys into strings in messages.
  94 strOfKey :: MsgKeys -> String
  95 strOfKey Method = "method"
  96 strOfKey Args = "args"
  97 strOfKey Success = "success"
  98 strOfKey Result = "result"
  99
 100 -- | Luxi client encapsulation.
 101 data Client = Client { socket :: S.Socket   -- ^ The socket of the client
 102                      , rbuf :: IORef String -- ^ Already received buffer
 103                      }
 104
 105 -- | Connects to the master daemon and returns a luxi Client.
 106 getClient :: String -> IO Client
 107 getClient path = do
 108     s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
 109     withTimeout connTimeout "creating luxi connection" $
 110                 S.connect s (S.SockAddrUnix path)
 111     rf <- newIORef ""
 112     return Client { socket=s, rbuf=rf}
 113
 114 -- | Closes the client socket.
 115 closeClient :: Client -> IO ()
 116 closeClient = S.sClose . socket
 117
 118 -- | Sends a message over a luxi transport.
 119 sendMsg :: Client -> String -> IO ()
 120 sendMsg s buf =
 121     let _send obuf = do
 122           sbytes <- withTimeout queryTimeout
 123                     "sending luxi message" $
 124                     S.send (socket s) obuf
 125           (if sbytes == length obuf
 126            then return ()
 127            else _send (drop sbytes obuf))
 128     in _send (buf ++ [eOM])
 129
 130 -- | Waits for a message over a luxi transport.
 131 recvMsg :: Client -> IO String
 132 recvMsg s = do
 133   let _recv obuf = do
 134               nbuf <- withTimeout queryTimeout "reading luxi response" $
 135                       S.recv (socket s) 4096
 136               let (msg, rbuf) = break ((==) eOM) (obuf ++ nbuf)
 137               (if null msg
 138                then _recv rbuf
 139                else return (msg, drop 1 rbuf))
 140   cbuf <- readIORef $ rbuf s
 141   (msg, nbuf) <- _recv cbuf
 142   writeIORef (rbuf s) nbuf
 143   return msg
 144
 145 -- | Serialize a request to String.
 146 buildCall :: LuxiOp  -- ^ The method
 147           -> JSValue -- ^ The arguments
 148           -> String  -- ^ The serialized form
 149 buildCall msg args =
 150     let ja = [(strOfKey Method,
 151                JSString $ toJSString $ strOfOp msg::JSValue),
 152               (strOfKey Args,
 153                args::JSValue)
 154              ]
 155         jo = toJSObject ja
 156     in encodeStrict jo
 157
 158 -- | Check that luxi responses contain the required keys and that the
 159 -- call was successful.
 160 validateResult :: String -> Result JSValue
 161 validateResult s = do
 162   arr <- fromJResult $ decodeStrict s::Result (JSObject JSValue)
 163   status <- fromObj (strOfKey Success) arr::Result Bool
 164   let rkey = strOfKey Result
 165   (if status
 166    then fromObj rkey arr
 167    else fromObj rkey arr >>= fail)
 168
 169 -- | Generic luxi method call.
 170 callMethod :: LuxiOp -> JSValue -> Client -> IO (Result JSValue)
 171 callMethod method args s = do
 172   sendMsg s $ buildCall method args
 173   result <- recvMsg s
 174   let rval = validateResult result
 175   return rval
 176
 177 -- * Data querying functionality
 178
 179 -- | The input data for node query.
 180 queryNodesMsg :: JSValue
 181 queryNodesMsg =
 182     let nnames = JSArray []
 183         fnames = ["name",
 184                   "mtotal", "mnode", "mfree",
 185                   "dtotal", "dfree",
 186                   "ctotal",
 187                   "offline", "drained"]
 188         fields = JSArray $ map (JSString . toJSString) fnames
 189         use_locking = JSBool False
 190     in JSArray [nnames, fields, use_locking]
 191
 192 -- | The input data for instance query.
 193 queryInstancesMsg :: JSValue
 194 queryInstancesMsg =
 195     let nnames = JSArray []
 196         fnames = ["name",
 197                   "disk_usage", "be/memory", "be/vcpus",
 198                   "status", "pnode", "snodes"]
 199         fields = JSArray $ map (JSString . toJSString) fnames
 200         use_locking = JSBool False
 201     in JSArray [nnames, fields, use_locking]
 202
 203
 204 -- | Wraper over callMethod doing node query.
 205 queryNodes :: Client -> IO (Result JSValue)
 206 queryNodes = callMethod QueryNodes queryNodesMsg
 207
 208 -- | Wraper over callMethod doing instance query.
 209 queryInstances :: Client -> IO (Result JSValue)
 210 queryInstances = callMethod QueryInstances queryInstancesMsg
 211
 212 -- | Parse a instance list in JSON format.
 213 getInstances :: NameAssoc
 214              -> JSValue
 215              -> Result [(String, Instance.Instance)]
 216 getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
 217
 218 -- | Construct an instance from a JSON object.
 219 parseInstance :: [(String, Ndx)]
 220               -> JSValue
 221               -> Result (String, Instance.Instance)
 222 parseInstance ktn (JSArray (name:disk:mem:vcpus:status:pnode:snodes:[])) = do
 223   xname <- fromJVal name
 224   xdisk <- fromJVal disk
 225   xmem <- fromJVal mem
 226   xvcpus <- fromJVal vcpus
 227   xpnode <- fromJVal pnode >>= lookupNode ktn xname
 228   xsnodes <- fromJVal snodes::Result [JSString]
 229   snode <- (if null xsnodes then return Node.noSecondary
 230             else lookupNode ktn xname (fromJSString $ head xsnodes))
 231   xrunning <- fromJVal status
 232   let inst = Instance.create xname xmem xdisk xvcpus xrunning xpnode snode
 233   return (xname, inst)
 234
 235 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
 236
 237 -- | Parse a node list in JSON format.
 238 getNodes :: JSValue -> Result [(String, Node.Node)]
 239 getNodes arr = toArray arr >>= mapM parseNode
 240
 241 -- | Construct a node from a JSON object.
 242 parseNode :: JSValue -> Result (String, Node.Node)
 243 parseNode (JSArray
 244            (name:mtotal:mnode:mfree:dtotal:dfree:ctotal:offline:drained:[]))
 245     = do
 246   xname <- fromJVal name
 247   xoffline <- fromJVal offline
 248   node <- (if xoffline
 249            then return $ Node.create xname 0 0 0 0 0 0 True
 250            else do
 251              xdrained <- fromJVal drained
 252              xmtotal  <- fromJVal mtotal
 253              xmnode   <- fromJVal mnode
 254              xmfree   <- fromJVal mfree
 255              xdtotal  <- fromJVal dtotal
 256              xdfree   <- fromJVal dfree
 257              xctotal  <- fromJVal ctotal
 258              return $ Node.create xname xmtotal xmnode xmfree
 259                     xdtotal xdfree xctotal (xoffline || xdrained))
 260   return (xname, node)
 261
 262 parseNode v = fail ("Invalid node query result: " ++ show v)
 263
 264 -- * Main loader functionality
 265
 266 -- | Builds the cluster data from an URL.
 267 loadData :: String -- ^ Unix socket to use as source
 268          -> IO (Result (Node.AssocList, Instance.AssocList))
 269 loadData master =
 270   E.bracket
 271        (getClient master)
 272        closeClient
 273        (\s -> do
 274           nodes <- queryNodes s
 275           instances <- queryInstances s
 276           return $ do -- Result monad
 277             node_data <- nodes >>= getNodes
 278             let (node_names, node_idx) = assignIndices node_data
 279             inst_data <- instances >>= getInstances node_names
 280             let (_, inst_idx) = assignIndices inst_data
 281             return (node_idx, inst_idx)
 282        )