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