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

   1 {-# LANGUAGE TemplateHaskell #-}
   2
   3 {-| Implementation of the Ganeti LUXI interface.
   4
   5 -}
   6
   7 {-
   8
   9 Copyright (C) 2009, 2010, 2011 Google Inc.
  10
  11 This program is free software; you can redistribute it and/or modify
  12 it under the terms of the GNU General Public License as published by
  13 the Free Software Foundation; either version 2 of the License, or
  14 (at your option) any later version.
  15
  16 This program is distributed in the hope that it will be useful, but
  17 WITHOUT ANY WARRANTY; without even the implied warranty of
  18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 General Public License for more details.
  20
  21 You should have received a copy of the GNU General Public License
  22 along with this program; if not, write to the Free Software
  23 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  24 02110-1301, USA.
  25
  26 -}
  27
  28 module Ganeti.Luxi
  29   ( LuxiOp(..)
  30   , QrViaLuxi(..)
  31   , ResultStatus(..)
  32   , Client
  33   , checkRS
  34   , getClient
  35   , closeClient
  36   , callMethod
  37   , submitManyJobs
  38   , queryJobsStatus
  39   ) where
  40
  41 import Data.IORef
  42 import Control.Monad
  43 import Text.JSON (encodeStrict, decodeStrict)
  44 import qualified Text.JSON as J
  45 import Text.JSON.Types
  46 import System.Timeout
  47 import qualified Network.Socket as S
  48
  49 import Ganeti.HTools.JSON
  50 import Ganeti.HTools.Types
  51
  52 import Ganeti.Constants
  53 import Ganeti.Jobs (JobStatus)
  54 import Ganeti.OpCodes (OpCode)
  55 import Ganeti.THH
  56
  57 -- * Utility functions
  58
  59 -- | Wrapper over System.Timeout.timeout that fails in the IO monad.
  60 withTimeout :: Int -> String -> IO a -> IO a
  61 withTimeout secs descr action = do
  62   result <- timeout (secs * 1000000) action
  63   case result of
  64     Nothing -> fail $ "Timeout in " ++ descr
  65     Just v -> return v
  66
  67 -- * Generic protocol functionality
  68
  69 $(declareSADT "QrViaLuxi"
  70   [ ("QRLock", 'qrLock)
  71   , ("QRInstance", 'qrInstance)
  72   , ("QRNode", 'qrNode)
  73   , ("QRGroup", 'qrGroup)
  74   , ("QROs", 'qrOs)
  75   ])
  76 $(makeJSONInstance ''QrViaLuxi)
  77
  78 -- | Currently supported Luxi operations and JSON serialization.
  79 $(genLuxiOp "LuxiOp"
  80   [("Query" ,
  81     [ ("what",    [t| QrViaLuxi |], [| id |])
  82     , ("fields",  [t| [String]  |], [| id |])
  83     , ("qfilter", [t| ()        |], [| const JSNull |])
  84     ])
  85   , ("QueryNodes",
  86      [ ("names",  [t| [String] |], [| id |])
  87      , ("fields", [t| [String] |], [| id |])
  88      , ("lock",   [t| Bool     |], [| id |])
  89      ])
  90   , ("QueryGroups",
  91      [ ("names",  [t| [String] |], [| id |])
  92      , ("fields", [t| [String] |], [| id |])
  93      , ("lock",   [t| Bool     |], [| id |])
  94      ])
  95   , ("QueryInstances",
  96      [ ("names",  [t| [String] |], [| id |])
  97      , ("fields", [t| [String] |], [| id |])
  98      , ("lock",   [t| Bool     |], [| id |])
  99      ])
 100   , ("QueryJobs",
 101      [ ("ids",    [t| [Int]    |], [| map show |])
 102      , ("fields", [t| [String] |], [| id |])
 103      ])
 104   , ("QueryExports",
 105      [ ("nodes", [t| [String] |], [| id |])
 106      , ("lock",  [t| Bool     |], [| id |])
 107      ])
 108   , ("QueryConfigValues",
 109      [ ("fields", [t| [String] |], [| id |]) ]
 110     )
 111   , ("QueryClusterInfo", [])
 112   , ("QueryTags",
 113      [ ("kind", [t| String |], [| id |])
 114      , ("name", [t| String |], [| id |])
 115      ])
 116   , ("SubmitJob",
 117      [ ("job", [t| [OpCode] |], [| id |]) ]
 118     )
 119   , ("SubmitManyJobs",
 120      [ ("ops", [t| [[OpCode]] |], [| id |]) ]
 121     )
 122   , ("WaitForJobChange",
 123      [ ("job",      [t| Int     |], [| id |])
 124      , ("fields",   [t| [String]|], [| id |])
 125      , ("prev_job", [t| JSValue |], [| id |])
 126      , ("prev_log", [t| JSValue |], [| id |])
 127      , ("tmout",    [t| Int     |], [| id |])
 128      ])
 129   , ("ArchiveJob",
 130      [ ("job", [t| Int |], [| show |]) ]
 131     )
 132   , ("AutoArchiveJobs",
 133      [ ("age",   [t| Int |], [| id |])
 134      , ("tmout", [t| Int |], [| id |])
 135      ])
 136   , ("CancelJob",
 137      [ ("job", [t| Int |], [| show |]) ]
 138     )
 139   , ("SetDrainFlag",
 140      [ ("flag", [t| Bool |], [| id |]) ]
 141     )
 142   , ("SetWatcherPause",
 143      [ ("duration", [t| Double |], [| id |]) ]
 144     )
 145   ])
 146
 147 -- | The serialisation of LuxiOps into strings in messages.
 148 $(genStrOfOp ''LuxiOp "strOfOp")
 149
 150 $(declareIADT "ResultStatus"
 151   [ ("RSNormal", 'rsNormal)
 152   , ("RSUnknown", 'rsUnknown)
 153   , ("RSNoData", 'rsNodata)
 154   , ("RSUnavailable", 'rsUnavail)
 155   , ("RSOffline", 'rsOffline)
 156   ])
 157
 158 $(makeJSONInstance ''ResultStatus)
 159
 160 -- | Check that ResultStatus is success or fail with descriptive message.
 161 checkRS :: (Monad m) => ResultStatus -> a -> m a
 162 checkRS RSNormal val    = return val
 163 checkRS RSUnknown _     = fail "Unknown field"
 164 checkRS RSNoData _      = fail "No data for a field"
 165 checkRS RSUnavailable _ = fail "Ganeti reports unavailable data"
 166 checkRS RSOffline _     = fail "Ganeti reports resource as offline"
 167
 168 -- | The end-of-message separator.
 169 eOM :: Char
 170 eOM = '\3'
 171
 172 -- | Valid keys in the requests and responses.
 173 data MsgKeys = Method
 174              | Args
 175              | Success
 176              | Result
 177
 178 -- | The serialisation of MsgKeys into strings in messages.
 179 $(genStrOfKey ''MsgKeys "strOfKey")
 180
 181 -- | Luxi client encapsulation.
 182 data Client = Client { socket :: S.Socket   -- ^ The socket of the client
 183                      , rbuf :: IORef String -- ^ Already received buffer
 184                      }
 185
 186 -- | Connects to the master daemon and returns a luxi Client.
 187 getClient :: String -> IO Client
 188 getClient path = do
 189   s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
 190   withTimeout connTimeout "creating luxi connection" $
 191               S.connect s (S.SockAddrUnix path)
 192   rf <- newIORef ""
 193   return Client { socket=s, rbuf=rf}
 194
 195 -- | Closes the client socket.
 196 closeClient :: Client -> IO ()
 197 closeClient = S.sClose . socket
 198
 199 -- | Sends a message over a luxi transport.
 200 sendMsg :: Client -> String -> IO ()
 201 sendMsg s buf =
 202   let _send obuf = do
 203         sbytes <- withTimeout queryTimeout
 204                   "sending luxi message" $
 205                   S.send (socket s) obuf
 206         unless (sbytes == length obuf) $ _send (drop sbytes obuf)
 207   in _send (buf ++ [eOM])
 208
 209 -- | Waits for a message over a luxi transport.
 210 recvMsg :: Client -> IO String
 211 recvMsg s = do
 212   let _recv obuf = do
 213               nbuf <- withTimeout queryTimeout "reading luxi response" $
 214                       S.recv (socket s) 4096
 215               let (msg, remaining) = break (eOM ==) nbuf
 216               if null remaining
 217                 then _recv (obuf ++ msg)
 218                 else return (obuf ++ msg, tail remaining)
 219   cbuf <- readIORef $ rbuf s
 220   let (imsg, ibuf) = break (eOM ==) cbuf
 221   (msg, nbuf) <-
 222     if null ibuf      -- if old buffer didn't contain a full message
 223       then _recv cbuf   -- then we read from network
 224       else return (imsg, tail ibuf) -- else we return data from our buffer
 225   writeIORef (rbuf s) nbuf
 226   return msg
 227
 228 -- | Serialize a request to String.
 229 buildCall :: LuxiOp  -- ^ The method
 230           -> String  -- ^ The serialized form
 231 buildCall lo =
 232   let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
 233            , (strOfKey Args, opToArgs lo::JSValue)
 234            ]
 235       jo = toJSObject ja
 236   in encodeStrict jo
 237
 238 -- | Check that luxi responses contain the required keys and that the
 239 -- call was successful.
 240 validateResult :: String -> Result JSValue
 241 validateResult s = do
 242   oarr <- fromJResult "Parsing LUXI response"
 243           (decodeStrict s)::Result (JSObject JSValue)
 244   let arr = J.fromJSObject oarr
 245   status <- fromObj arr (strOfKey Success)::Result Bool
 246   let rkey = strOfKey Result
 247   if status
 248     then fromObj arr rkey
 249     else fromObj arr rkey >>= fail
 250
 251 -- | Generic luxi method call.
 252 callMethod :: LuxiOp -> Client -> IO (Result JSValue)
 253 callMethod method s = do
 254   sendMsg s $ buildCall method
 255   result <- recvMsg s
 256   let rval = validateResult result
 257   return rval
 258
 259 -- | Specialized submitManyJobs call.
 260 submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String])
 261 submitManyJobs s jobs = do
 262   rval <- callMethod (SubmitManyJobs jobs) s
 263   -- map each result (status, payload) pair into a nice Result ADT
 264   return $ case rval of
 265              Bad x -> Bad x
 266              Ok (JSArray r) ->
 267                  mapM (\v -> case v of
 268                                JSArray [JSBool True, JSString x] ->
 269                                    Ok (fromJSString x)
 270                                JSArray [JSBool False, JSString x] ->
 271                                    Bad (fromJSString x)
 272                                _ -> Bad "Unknown result from the master daemon"
 273                       ) r
 274              x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
 275
 276 -- | Custom queryJobs call.
 277 queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
 278 queryJobsStatus s jids = do
 279   rval <- callMethod (QueryJobs (map read jids) ["status"]) s
 280   return $ case rval of
 281              Bad x -> Bad x
 282              Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
 283                        J.Ok vals -> if any null vals
 284                                     then Bad "Missing job status field"
 285                                     else Ok (map head vals)
 286                        J.Error x -> Bad x