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

   1 {-| Implementation of the Ganeti LUXI interface.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009, 2010, 2011 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.Luxi
  27     ( LuxiOp(..)
  28     , Client
  29     , getClient
  30     , closeClient
  31     , callMethod
  32     , submitManyJobs
  33     , queryJobsStatus
  34     ) where
  35
  36 import Data.IORef
  37 import Control.Monad
  38 import Text.JSON (encodeStrict, decodeStrict)
  39 import qualified Text.JSON as J
  40 import Text.JSON.Types
  41 import System.Timeout
  42 import qualified Network.Socket as S
  43
  44 import Ganeti.HTools.Utils
  45 import Ganeti.HTools.Types
  46
  47 import Ganeti.Jobs (JobStatus)
  48 import Ganeti.OpCodes (OpCode)
  49
  50 -- * Utility functions
  51
  52 -- | Wrapper over System.Timeout.timeout that fails in the IO monad.
  53 withTimeout :: Int -> String -> IO a -> IO a
  54 withTimeout secs descr action = do
  55     result <- timeout (secs * 1000000) action
  56     (case result of
  57        Nothing -> fail $ "Timeout in " ++ descr
  58        Just v -> return v)
  59
  60 -- * Generic protocol functionality
  61
  62 -- | Currently supported Luxi operations.
  63 data LuxiOp = QueryInstances [String] [String] Bool
  64             | QueryNodes [String] [String] Bool
  65             | QueryGroups [String] [String] Bool
  66             | QueryJobs [Int] [String]
  67             | QueryExports [String] Bool
  68             | QueryConfigValues [String]
  69             | QueryClusterInfo
  70             | QueryTags String String
  71             | SubmitJob [OpCode]
  72             | SubmitManyJobs [[OpCode]]
  73             | WaitForJobChange Int [String] JSValue JSValue Int
  74             | ArchiveJob Int
  75             | AutoArchiveJobs Int Int
  76             | CancelJob Int
  77             | SetDrainFlag Bool
  78             | SetWatcherPause Double
  79               deriving (Show, Read)
  80
  81 -- | The serialisation of LuxiOps into strings in messages.
  82 strOfOp :: LuxiOp -> String
  83 strOfOp QueryNodes {}        = "QueryNodes"
  84 strOfOp QueryGroups {}       = "QueryGroups"
  85 strOfOp QueryInstances {}    = "QueryInstances"
  86 strOfOp QueryJobs {}         = "QueryJobs"
  87 strOfOp QueryExports {}      = "QueryExports"
  88 strOfOp QueryConfigValues {} = "QueryConfigValues"
  89 strOfOp QueryClusterInfo {}  = "QueryClusterInfo"
  90 strOfOp QueryTags {}         = "QueryTags"
  91 strOfOp SubmitManyJobs {}    = "SubmitManyJobs"
  92 strOfOp WaitForJobChange {}  = "WaitForJobChange"
  93 strOfOp SubmitJob {}         = "SubmitJob"
  94 strOfOp ArchiveJob {}        = "ArchiveJob"
  95 strOfOp AutoArchiveJobs {}   = "AutoArchiveJobs"
  96 strOfOp CancelJob {}         = "CancelJob"
  97 strOfOp SetDrainFlag {}      = "SetDrainFlag"
  98 strOfOp SetWatcherPause {}   = "SetWatcherPause"
  99
 100 -- | The end-of-message separator.
 101 eOM :: Char
 102 eOM = '\3'
 103
 104 -- | Valid keys in the requests and responses.
 105 data MsgKeys = Method
 106              | Args
 107              | Success
 108              | Result
 109
 110 -- | The serialisation of MsgKeys into strings in messages.
 111 strOfKey :: MsgKeys -> String
 112 strOfKey Method = "method"
 113 strOfKey Args = "args"
 114 strOfKey Success = "success"
 115 strOfKey Result = "result"
 116
 117 -- | Luxi client encapsulation.
 118 data Client = Client { socket :: S.Socket   -- ^ The socket of the client
 119                      , rbuf :: IORef String -- ^ Already received buffer
 120                      }
 121
 122 -- | Connects to the master daemon and returns a luxi Client.
 123 getClient :: String -> IO Client
 124 getClient path = do
 125     s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
 126     withTimeout connTimeout "creating luxi connection" $
 127                 S.connect s (S.SockAddrUnix path)
 128     rf <- newIORef ""
 129     return Client { socket=s, rbuf=rf}
 130
 131 -- | Closes the client socket.
 132 closeClient :: Client -> IO ()
 133 closeClient = S.sClose . socket
 134
 135 -- | Sends a message over a luxi transport.
 136 sendMsg :: Client -> String -> IO ()
 137 sendMsg s buf =
 138     let _send obuf = do
 139           sbytes <- withTimeout queryTimeout
 140                     "sending luxi message" $
 141                     S.send (socket s) obuf
 142           unless (sbytes == length obuf) $ _send (drop sbytes obuf)
 143     in _send (buf ++ [eOM])
 144
 145 -- | Waits for a message over a luxi transport.
 146 recvMsg :: Client -> IO String
 147 recvMsg s = do
 148   let _recv obuf = do
 149               nbuf <- withTimeout queryTimeout "reading luxi response" $
 150                       S.recv (socket s) 4096
 151               let (msg, remaining) = break (eOM ==) nbuf
 152               (if null remaining
 153                then _recv (obuf ++ msg)
 154                else return (obuf ++ msg, tail remaining))
 155   cbuf <- readIORef $ rbuf s
 156   let (imsg, ibuf) = break (eOM ==) cbuf
 157   (msg, nbuf) <-
 158       (if null ibuf      -- if old buffer didn't contain a full message
 159        then _recv cbuf   -- then we read from network
 160        else return (imsg, tail ibuf)) -- else we return data from our buffer
 161   writeIORef (rbuf s) nbuf
 162   return msg
 163
 164 -- | Compute the serialized form of a Luxi operation
 165 opToArgs :: LuxiOp -> JSValue
 166 opToArgs (QueryNodes names fields lock) = J.showJSON (names, fields, lock)
 167 opToArgs (QueryGroups names fields lock) = J.showJSON (names, fields, lock)
 168 opToArgs (QueryInstances names fields lock) = J.showJSON (names, fields, lock)
 169 opToArgs (QueryJobs ids fields) = J.showJSON (map show ids, fields)
 170 opToArgs (QueryExports nodes lock) = J.showJSON (nodes, lock)
 171 opToArgs (QueryConfigValues fields) = J.showJSON fields
 172 opToArgs (QueryClusterInfo) = J.showJSON ()
 173 opToArgs (QueryTags kind name) =  J.showJSON (kind, name)
 174 opToArgs (SubmitJob j) = J.showJSON j
 175 opToArgs (SubmitManyJobs ops) = J.showJSON ops
 176 -- This is special, since the JSON library doesn't export an instance
 177 -- of a 5-tuple
 178 opToArgs (WaitForJobChange a b c d e) =
 179     JSArray [ J.showJSON a, J.showJSON b, J.showJSON c
 180             , J.showJSON d, J.showJSON e]
 181 opToArgs (ArchiveJob a) = J.showJSON (show a)
 182 opToArgs (AutoArchiveJobs a b) = J.showJSON (a, b)
 183 opToArgs (CancelJob a) = J.showJSON (show a)
 184 opToArgs (SetDrainFlag flag) = J.showJSON flag
 185 opToArgs (SetWatcherPause duration) = J.showJSON [duration]
 186
 187 -- | Serialize a request to String.
 188 buildCall :: LuxiOp  -- ^ The method
 189           -> String  -- ^ The serialized form
 190 buildCall lo =
 191     let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
 192              , (strOfKey Args, opToArgs lo::JSValue)
 193              ]
 194         jo = toJSObject ja
 195     in encodeStrict jo
 196
 197 -- | Check that luxi responses contain the required keys and that the
 198 -- call was successful.
 199 validateResult :: String -> Result JSValue
 200 validateResult s = do
 201   oarr <- fromJResult "Parsing LUXI response"
 202           (decodeStrict s)::Result (JSObject JSValue)
 203   let arr = J.fromJSObject oarr
 204   status <- fromObj arr (strOfKey Success)::Result Bool
 205   let rkey = strOfKey Result
 206   (if status
 207    then fromObj arr rkey
 208    else fromObj arr rkey >>= fail)
 209
 210 -- | Generic luxi method call.
 211 callMethod :: LuxiOp -> Client -> IO (Result JSValue)
 212 callMethod method s = do
 213   sendMsg s $ buildCall method
 214   result <- recvMsg s
 215   let rval = validateResult result
 216   return rval
 217
 218 -- | Specialized submitManyJobs call.
 219 submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String])
 220 submitManyJobs s jobs = do
 221   rval <- callMethod (SubmitManyJobs jobs) s
 222   -- map each result (status, payload) pair into a nice Result ADT
 223   return $ case rval of
 224              Bad x -> Bad x
 225              Ok (JSArray r) ->
 226                  mapM (\v -> case v of
 227                                JSArray [JSBool True, JSString x] ->
 228                                    Ok (fromJSString x)
 229                                JSArray [JSBool False, JSString x] ->
 230                                    Bad (fromJSString x)
 231                                _ -> Bad "Unknown result from the master daemon"
 232                       ) r
 233              x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
 234
 235 -- | Custom queryJobs call.
 236 queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
 237 queryJobsStatus s jids = do
 238   rval <- callMethod (QueryJobs (map read jids) ["status"]) s
 239   return $ case rval of
 240              Bad x -> Bad x
 241              Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
 242                        J.Ok vals -> if any null vals
 243                                     then Bad "Missing job status field"
 244                                     else Ok (map head vals)
 245                        J.Error x -> Bad x