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, 2012 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   , LuxiReq(..)
  33   , Client
  34   , checkRS
  35   , getClient
  36   , closeClient
  37   , callMethod
  38   , submitManyJobs
  39   , queryJobsStatus
  40   , buildCall
  41   , validateCall
  42   , decodeCall
  43   ) where
  44
  45 import Data.IORef
  46 import Control.Monad
  47 import Text.JSON (encodeStrict, decodeStrict)
  48 import qualified Text.JSON as J
  49 import Text.JSON.Types
  50 import System.Timeout
  51 import qualified Network.Socket as S
  52
  53 import Ganeti.HTools.JSON
  54 import Ganeti.HTools.Types
  55 import Ganeti.HTools.Utils
  56
  57 import Ganeti.Constants
  58 import Ganeti.Jobs (JobStatus)
  59 import Ganeti.OpCodes (OpCode)
  60 import Ganeti.THH
  61
  62 -- * Utility functions
  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 $(declareSADT "QrViaLuxi"
  75   [ ("QRLock", 'qrLock)
  76   , ("QRInstance", 'qrInstance)
  77   , ("QRNode", 'qrNode)
  78   , ("QRGroup", 'qrGroup)
  79   , ("QROs", 'qrOs)
  80   ])
  81 $(makeJSONInstance ''QrViaLuxi)
  82
  83 -- | Currently supported Luxi operations and JSON serialization.
  84 $(genLuxiOp "LuxiOp"
  85   [(luxiReqQuery,
  86     [ ("what",    [t| QrViaLuxi |], [| id |])
  87     , ("fields",  [t| [String]  |], [| id |])
  88     , ("qfilter", [t| ()        |], [| const JSNull |])
  89     ])
  90   , (luxiReqQueryNodes,
  91      [ ("names",  [t| [String] |], [| id |])
  92      , ("fields", [t| [String] |], [| id |])
  93      , ("lock",   [t| Bool     |], [| id |])
  94      ])
  95   , (luxiReqQueryGroups,
  96      [ ("names",  [t| [String] |], [| id |])
  97      , ("fields", [t| [String] |], [| id |])
  98      , ("lock",   [t| Bool     |], [| id |])
  99      ])
 100   , (luxiReqQueryInstances,
 101      [ ("names",  [t| [String] |], [| id |])
 102      , ("fields", [t| [String] |], [| id |])
 103      , ("lock",   [t| Bool     |], [| id |])
 104      ])
 105   , (luxiReqQueryJobs,
 106      [ ("ids",    [t| [Int]    |], [| map show |])
 107      , ("fields", [t| [String] |], [| id |])
 108      ])
 109   , (luxiReqQueryExports,
 110      [ ("nodes", [t| [String] |], [| id |])
 111      , ("lock",  [t| Bool     |], [| id |])
 112      ])
 113   , (luxiReqQueryConfigValues,
 114      [ ("fields", [t| [String] |], [| id |]) ]
 115     )
 116   , (luxiReqQueryClusterInfo, [])
 117   , (luxiReqQueryTags,
 118      [ ("kind", [t| String |], [| id |])
 119      , ("name", [t| String |], [| id |])
 120      ])
 121   , (luxiReqSubmitJob,
 122      [ ("job", [t| [OpCode] |], [| id |]) ]
 123     )
 124   , (luxiReqSubmitManyJobs,
 125      [ ("ops", [t| [[OpCode]] |], [| id |]) ]
 126     )
 127   , (luxiReqWaitForJobChange,
 128      [ ("job",      [t| Int     |], [| show |])
 129      , ("fields",   [t| [String]|], [| id |])
 130      , ("prev_job", [t| JSValue |], [| id |])
 131      , ("prev_log", [t| JSValue |], [| id |])
 132      , ("tmout",    [t| Int     |], [| id |])
 133      ])
 134   , (luxiReqArchiveJob,
 135      [ ("job", [t| Int |], [| show |]) ]
 136     )
 137   , (luxiReqAutoArchiveJobs,
 138      [ ("age",   [t| Int |], [| id |])
 139      , ("tmout", [t| Int |], [| id |])
 140      ])
 141   , (luxiReqCancelJob,
 142      [ ("job", [t| Int |], [| show |]) ]
 143     )
 144   , (luxiReqSetDrainFlag,
 145      [ ("flag", [t| Bool |], [| id |]) ]
 146     )
 147   , (luxiReqSetWatcherPause,
 148      [ ("duration", [t| Double |], [| id |]) ]
 149     )
 150   ])
 151
 152 $(makeJSONInstance ''LuxiReq)
 153
 154 -- | The serialisation of LuxiOps into strings in messages.
 155 $(genStrOfOp ''LuxiOp "strOfOp")
 156
 157 $(declareIADT "ResultStatus"
 158   [ ("RSNormal", 'rsNormal)
 159   , ("RSUnknown", 'rsUnknown)
 160   , ("RSNoData", 'rsNodata)
 161   , ("RSUnavailable", 'rsUnavail)
 162   , ("RSOffline", 'rsOffline)
 163   ])
 164
 165 $(makeJSONInstance ''ResultStatus)
 166
 167 -- | Type holding the initial (unparsed) Luxi call.
 168 data LuxiCall = LuxiCall LuxiReq JSValue
 169
 170 -- | Check that ResultStatus is success or fail with descriptive message.
 171 checkRS :: (Monad m) => ResultStatus -> a -> m a
 172 checkRS RSNormal val    = return val
 173 checkRS RSUnknown _     = fail "Unknown field"
 174 checkRS RSNoData _      = fail "No data for a field"
 175 checkRS RSUnavailable _ = fail "Ganeti reports unavailable data"
 176 checkRS RSOffline _     = fail "Ganeti reports resource as offline"
 177
 178 -- | The end-of-message separator.
 179 eOM :: Char
 180 eOM = '\3'
 181
 182 -- | Valid keys in the requests and responses.
 183 data MsgKeys = Method
 184              | Args
 185              | Success
 186              | Result
 187
 188 -- | The serialisation of MsgKeys into strings in messages.
 189 $(genStrOfKey ''MsgKeys "strOfKey")
 190
 191 -- | Luxi client encapsulation.
 192 data Client = Client { socket :: S.Socket   -- ^ The socket of the client
 193                      , rbuf :: IORef String -- ^ Already received buffer
 194                      }
 195
 196 -- | Connects to the master daemon and returns a luxi Client.
 197 getClient :: String -> IO Client
 198 getClient path = do
 199   s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
 200   withTimeout connTimeout "creating luxi connection" $
 201               S.connect s (S.SockAddrUnix path)
 202   rf <- newIORef ""
 203   return Client { socket=s, rbuf=rf}
 204
 205 -- | Closes the client socket.
 206 closeClient :: Client -> IO ()
 207 closeClient = S.sClose . socket
 208
 209 -- | Sends a message over a luxi transport.
 210 sendMsg :: Client -> String -> IO ()
 211 sendMsg s buf =
 212   let _send obuf = do
 213         sbytes <- withTimeout queryTimeout
 214                   "sending luxi message" $
 215                   S.send (socket s) obuf
 216         unless (sbytes == length obuf) $ _send (drop sbytes obuf)
 217   in _send (buf ++ [eOM])
 218
 219 -- | Waits for a message over a luxi transport.
 220 recvMsg :: Client -> IO String
 221 recvMsg s = do
 222   let _recv obuf = do
 223               nbuf <- withTimeout queryTimeout "reading luxi response" $
 224                       S.recv (socket s) 4096
 225               let (msg, remaining) = break (eOM ==) nbuf
 226               if null remaining
 227                 then _recv (obuf ++ msg)
 228                 else return (obuf ++ msg, tail remaining)
 229   cbuf <- readIORef $ rbuf s
 230   let (imsg, ibuf) = break (eOM ==) cbuf
 231   (msg, nbuf) <-
 232     if null ibuf      -- if old buffer didn't contain a full message
 233       then _recv cbuf   -- then we read from network
 234       else return (imsg, tail ibuf) -- else we return data from our buffer
 235   writeIORef (rbuf s) nbuf
 236   return msg
 237
 238 -- | Serialize a request to String.
 239 buildCall :: LuxiOp  -- ^ The method
 240           -> String  -- ^ The serialized form
 241 buildCall lo =
 242   let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
 243            , (strOfKey Args, opToArgs lo::JSValue)
 244            ]
 245       jo = toJSObject ja
 246   in encodeStrict jo
 247
 248 -- | Check that luxi request contains the required keys and parse it.
 249 validateCall :: String -> Result LuxiCall
 250 validateCall s = do
 251   arr <- fromJResult "luxi call" $ decodeStrict s::Result (JSObject JSValue)
 252   let aobj = fromJSObject arr
 253   call <- fromObj aobj (strOfKey Method)::Result LuxiReq
 254   args <- fromObj aobj (strOfKey Args)
 255   return (LuxiCall call args)
 256
 257 -- | Converts Luxi call arguments into a 'LuxiOp' data structure.
 258 --
 259 -- This is currently hand-coded until we make it more uniform so that
 260 -- it can be generated using TH.
 261 decodeCall :: LuxiCall -> Result LuxiOp
 262 decodeCall (LuxiCall call args) =
 263   case call of
 264     ReqQueryJobs -> do
 265               (jid, jargs) <- fromJVal args
 266               rid <- mapM (tryRead "parsing job ID" . fromJSString) jid
 267               let rargs = map fromJSString jargs
 268               return $ QueryJobs rid rargs
 269     ReqQueryInstances -> do
 270               (names, fields, locking) <- fromJVal args
 271               return $ QueryInstances names fields locking
 272     ReqQueryNodes -> do
 273               (names, fields, locking) <- fromJVal args
 274               return $ QueryNodes names fields locking
 275     ReqQueryGroups -> do
 276               (names, fields, locking) <- fromJVal args
 277               return $ QueryGroups names fields locking
 278     ReqQueryClusterInfo -> do
 279               return QueryClusterInfo
 280     ReqQuery -> do
 281               (what, fields, _) <-
 282                 fromJVal args::Result (QrViaLuxi, [String], JSValue)
 283               return $ Query what fields ()
 284     ReqSubmitJob -> do
 285               [ops1] <- fromJVal args
 286               ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
 287               return $ SubmitJob ops2
 288     ReqSubmitManyJobs -> do
 289               [ops1] <- fromJVal args
 290               ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
 291               return $ SubmitManyJobs ops2
 292     ReqWaitForJobChange -> do
 293               (jid, fields, pinfo, pidx, wtmout) <-
 294                 -- No instance for 5-tuple, code copied from the
 295                 -- json sources and adapted
 296                 fromJResult "Parsing WaitForJobChange message" $
 297                 case args of
 298                   JSArray [a, b, c, d, e] ->
 299                     (,,,,) `fmap`
 300                     J.readJSON a `ap`
 301                     J.readJSON b `ap`
 302                     J.readJSON c `ap`
 303                     J.readJSON d `ap`
 304                     J.readJSON e
 305                   _ -> J.Error "Not enough values"
 306               rid <- tryRead "parsing job ID" jid
 307               return $ WaitForJobChange rid fields pinfo pidx wtmout
 308     ReqArchiveJob -> do
 309               [jid] <- fromJVal args
 310               rid <- tryRead "parsing job ID" jid
 311               return $ ArchiveJob rid
 312     ReqAutoArchiveJobs -> do
 313               (age, tmout) <- fromJVal args
 314               return $ AutoArchiveJobs age tmout
 315     ReqQueryExports -> do
 316               (nodes, lock) <- fromJVal args
 317               return $ QueryExports nodes lock
 318     ReqQueryConfigValues -> do
 319               [fields] <- fromJVal args
 320               return $ QueryConfigValues fields
 321     ReqQueryTags -> do
 322               (kind, name) <- fromJVal args
 323               return $ QueryTags kind name
 324     ReqCancelJob -> do
 325               [job] <- fromJVal args
 326               rid <- tryRead "parsing job ID" job
 327               return $ CancelJob rid
 328     ReqSetDrainFlag -> do
 329               [flag] <- fromJVal args
 330               return $ SetDrainFlag flag
 331     ReqSetWatcherPause -> do
 332               [duration] <- fromJVal args
 333               return $ SetWatcherPause duration
 334
 335 -- | Check that luxi responses contain the required keys and that the
 336 -- call was successful.
 337 validateResult :: String -> Result JSValue
 338 validateResult s = do
 339   oarr <- fromJResult "Parsing LUXI response"
 340           (decodeStrict s)::Result (JSObject JSValue)
 341   let arr = J.fromJSObject oarr
 342   status <- fromObj arr (strOfKey Success)::Result Bool
 343   let rkey = strOfKey Result
 344   if status
 345     then fromObj arr rkey
 346     else fromObj arr rkey >>= fail
 347
 348 -- | Generic luxi method call.
 349 callMethod :: LuxiOp -> Client -> IO (Result JSValue)
 350 callMethod method s = do
 351   sendMsg s $ buildCall method
 352   result <- recvMsg s
 353   let rval = validateResult result
 354   return rval
 355
 356 -- | Specialized submitManyJobs call.
 357 submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String])
 358 submitManyJobs s jobs = do
 359   rval <- callMethod (SubmitManyJobs jobs) s
 360   -- map each result (status, payload) pair into a nice Result ADT
 361   return $ case rval of
 362              Bad x -> Bad x
 363              Ok (JSArray r) ->
 364                  mapM (\v -> case v of
 365                                JSArray [JSBool True, JSString x] ->
 366                                    Ok (fromJSString x)
 367                                JSArray [JSBool False, JSString x] ->
 368                                    Bad (fromJSString x)
 369                                _ -> Bad "Unknown result from the master daemon"
 370                       ) r
 371              x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
 372
 373 -- | Custom queryJobs call.
 374 queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
 375 queryJobsStatus s jids = do
 376   rval <- callMethod (QueryJobs (map read jids) ["status"]) s
 377   return $ case rval of
 378              Bad x -> Bad x
 379              Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
 380                        J.Ok vals -> if any null vals
 381                                     then Bad "Missing job status field"
 382                                     else Ok (map head vals)
 383                        J.Error x -> Bad x