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   ) where
  41
  42 import Data.IORef
  43 import Control.Monad
  44 import Text.JSON (encodeStrict, decodeStrict)
  45 import qualified Text.JSON as J
  46 import Text.JSON.Types
  47 import System.Timeout
  48 import qualified Network.Socket as S
  49
  50 import Ganeti.HTools.JSON
  51 import Ganeti.HTools.Types
  52
  53 import Ganeti.Constants
  54 import Ganeti.Jobs (JobStatus)
  55 import Ganeti.OpCodes (OpCode)
  56 import Ganeti.THH
  57
  58 -- * Utility functions
  59
  60 -- | Wrapper over System.Timeout.timeout that fails in the IO monad.
  61 withTimeout :: Int -> String -> IO a -> IO a
  62 withTimeout secs descr action = do
  63   result <- timeout (secs * 1000000) action
  64   case result of
  65     Nothing -> fail $ "Timeout in " ++ descr
  66     Just v -> return v
  67
  68 -- * Generic protocol functionality
  69
  70 $(declareSADT "QrViaLuxi"
  71   [ ("QRLock", 'qrLock)
  72   , ("QRInstance", 'qrInstance)
  73   , ("QRNode", 'qrNode)
  74   , ("QRGroup", 'qrGroup)
  75   , ("QROs", 'qrOs)
  76   ])
  77 $(makeJSONInstance ''QrViaLuxi)
  78
  79 -- | Currently supported Luxi operations and JSON serialization.
  80 $(genLuxiOp "LuxiOp"
  81   [(luxiReqQuery,
  82     [ ("what",    [t| QrViaLuxi |], [| id |])
  83     , ("fields",  [t| [String]  |], [| id |])
  84     , ("qfilter", [t| ()        |], [| const JSNull |])
  85     ])
  86   , (luxiReqQueryNodes,
  87      [ ("names",  [t| [String] |], [| id |])
  88      , ("fields", [t| [String] |], [| id |])
  89      , ("lock",   [t| Bool     |], [| id |])
  90      ])
  91   , (luxiReqQueryGroups,
  92      [ ("names",  [t| [String] |], [| id |])
  93      , ("fields", [t| [String] |], [| id |])
  94      , ("lock",   [t| Bool     |], [| id |])
  95      ])
  96   , (luxiReqQueryInstances,
  97      [ ("names",  [t| [String] |], [| id |])
  98      , ("fields", [t| [String] |], [| id |])
  99      , ("lock",   [t| Bool     |], [| id |])
 100      ])
 101   , (luxiReqQueryJobs,
 102      [ ("ids",    [t| [Int]    |], [| map show |])
 103      , ("fields", [t| [String] |], [| id |])
 104      ])
 105   , (luxiReqQueryExports,
 106      [ ("nodes", [t| [String] |], [| id |])
 107      , ("lock",  [t| Bool     |], [| id |])
 108      ])
 109   , (luxiReqQueryConfigValues,
 110      [ ("fields", [t| [String] |], [| id |]) ]
 111     )
 112   , (luxiReqQueryClusterInfo, [])
 113   , (luxiReqQueryTags,
 114      [ ("kind", [t| String |], [| id |])
 115      , ("name", [t| String |], [| id |])
 116      ])
 117   , (luxiReqSubmitJob,
 118      [ ("job", [t| [OpCode] |], [| id |]) ]
 119     )
 120   , (luxiReqSubmitManyJobs,
 121      [ ("ops", [t| [[OpCode]] |], [| id |]) ]
 122     )
 123   , (luxiReqWaitForJobChange,
 124      [ ("job",      [t| Int     |], [| id |])
 125      , ("fields",   [t| [String]|], [| id |])
 126      , ("prev_job", [t| JSValue |], [| id |])
 127      , ("prev_log", [t| JSValue |], [| id |])
 128      , ("tmout",    [t| Int     |], [| id |])
 129      ])
 130   , (luxiReqArchiveJob,
 131      [ ("job", [t| Int |], [| show |]) ]
 132     )
 133   , (luxiReqAutoArchiveJobs,
 134      [ ("age",   [t| Int |], [| id |])
 135      , ("tmout", [t| Int |], [| id |])
 136      ])
 137   , (luxiReqCancelJob,
 138      [ ("job", [t| Int |], [| show |]) ]
 139     )
 140   , (luxiReqSetDrainFlag,
 141      [ ("flag", [t| Bool |], [| id |]) ]
 142     )
 143   , (luxiReqSetWatcherPause,
 144      [ ("duration", [t| Double |], [| id |]) ]
 145     )
 146   ])
 147
 148 $(makeJSONInstance ''LuxiReq)
 149
 150 -- | The serialisation of LuxiOps into strings in messages.
 151 $(genStrOfOp ''LuxiOp "strOfOp")
 152
 153 $(declareIADT "ResultStatus"
 154   [ ("RSNormal", 'rsNormal)
 155   , ("RSUnknown", 'rsUnknown)
 156   , ("RSNoData", 'rsNodata)
 157   , ("RSUnavailable", 'rsUnavail)
 158   , ("RSOffline", 'rsOffline)
 159   ])
 160
 161 $(makeJSONInstance ''ResultStatus)
 162
 163 -- | Check that ResultStatus is success or fail with descriptive message.
 164 checkRS :: (Monad m) => ResultStatus -> a -> m a
 165 checkRS RSNormal val    = return val
 166 checkRS RSUnknown _     = fail "Unknown field"
 167 checkRS RSNoData _      = fail "No data for a field"
 168 checkRS RSUnavailable _ = fail "Ganeti reports unavailable data"
 169 checkRS RSOffline _     = fail "Ganeti reports resource as offline"
 170
 171 -- | The end-of-message separator.
 172 eOM :: Char
 173 eOM = '\3'
 174
 175 -- | Valid keys in the requests and responses.
 176 data MsgKeys = Method
 177              | Args
 178              | Success
 179              | Result
 180
 181 -- | The serialisation of MsgKeys into strings in messages.
 182 $(genStrOfKey ''MsgKeys "strOfKey")
 183
 184 -- | Luxi client encapsulation.
 185 data Client = Client { socket :: S.Socket   -- ^ The socket of the client
 186                      , rbuf :: IORef String -- ^ Already received buffer
 187                      }
 188
 189 -- | Connects to the master daemon and returns a luxi Client.
 190 getClient :: String -> IO Client
 191 getClient path = do
 192   s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
 193   withTimeout connTimeout "creating luxi connection" $
 194               S.connect s (S.SockAddrUnix path)
 195   rf <- newIORef ""
 196   return Client { socket=s, rbuf=rf}
 197
 198 -- | Closes the client socket.
 199 closeClient :: Client -> IO ()
 200 closeClient = S.sClose . socket
 201
 202 -- | Sends a message over a luxi transport.
 203 sendMsg :: Client -> String -> IO ()
 204 sendMsg s buf =
 205   let _send obuf = do
 206         sbytes <- withTimeout queryTimeout
 207                   "sending luxi message" $
 208                   S.send (socket s) obuf
 209         unless (sbytes == length obuf) $ _send (drop sbytes obuf)
 210   in _send (buf ++ [eOM])
 211
 212 -- | Waits for a message over a luxi transport.
 213 recvMsg :: Client -> IO String
 214 recvMsg s = do
 215   let _recv obuf = do
 216               nbuf <- withTimeout queryTimeout "reading luxi response" $
 217                       S.recv (socket s) 4096
 218               let (msg, remaining) = break (eOM ==) nbuf
 219               if null remaining
 220                 then _recv (obuf ++ msg)
 221                 else return (obuf ++ msg, tail remaining)
 222   cbuf <- readIORef $ rbuf s
 223   let (imsg, ibuf) = break (eOM ==) cbuf
 224   (msg, nbuf) <-
 225     if null ibuf      -- if old buffer didn't contain a full message
 226       then _recv cbuf   -- then we read from network
 227       else return (imsg, tail ibuf) -- else we return data from our buffer
 228   writeIORef (rbuf s) nbuf
 229   return msg
 230
 231 -- | Serialize a request to String.
 232 buildCall :: LuxiOp  -- ^ The method
 233           -> String  -- ^ The serialized form
 234 buildCall lo =
 235   let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
 236            , (strOfKey Args, opToArgs lo::JSValue)
 237            ]
 238       jo = toJSObject ja
 239   in encodeStrict jo
 240
 241 -- | Check that luxi responses contain the required keys and that the
 242 -- call was successful.
 243 validateResult :: String -> Result JSValue
 244 validateResult s = do
 245   oarr <- fromJResult "Parsing LUXI response"
 246           (decodeStrict s)::Result (JSObject JSValue)
 247   let arr = J.fromJSObject oarr
 248   status <- fromObj arr (strOfKey Success)::Result Bool
 249   let rkey = strOfKey Result
 250   if status
 251     then fromObj arr rkey
 252     else fromObj arr rkey >>= fail
 253
 254 -- | Generic luxi method call.
 255 callMethod :: LuxiOp -> Client -> IO (Result JSValue)
 256 callMethod method s = do
 257   sendMsg s $ buildCall method
 258   result <- recvMsg s
 259   let rval = validateResult result
 260   return rval
 261
 262 -- | Specialized submitManyJobs call.
 263 submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String])
 264 submitManyJobs s jobs = do
 265   rval <- callMethod (SubmitManyJobs jobs) s
 266   -- map each result (status, payload) pair into a nice Result ADT
 267   return $ case rval of
 268              Bad x -> Bad x
 269              Ok (JSArray r) ->
 270                  mapM (\v -> case v of
 271                                JSArray [JSBool True, JSString x] ->
 272                                    Ok (fromJSString x)
 273                                JSArray [JSBool False, JSString x] ->
 274                                    Bad (fromJSString x)
 275                                _ -> Bad "Unknown result from the master daemon"
 276                       ) r
 277              x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
 278
 279 -- | Custom queryJobs call.
 280 queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
 281 queryJobsStatus s jids = do
 282   rval <- callMethod (QueryJobs (map read jids) ["status"]) s
 283   return $ case rval of
 284              Bad x -> Bad x
 285              Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
 286                        J.Ok vals -> if any null vals
 287                                     then Bad "Missing job status field"
 288                                     else Ok (map head vals)
 289                        J.Error x -> Bad x