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

   1 {-| Implementation of the Ganeti LUXI interface.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009 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.List
  37 import Data.IORef
  38 import Control.Monad
  39 import Text.JSON (JSObject, JSValue, toJSObject, encodeStrict, decodeStrict)
  40 import qualified Text.JSON as J
  41 import Text.JSON.Types
  42 import System.Timeout
  43 import qualified Network.Socket as S
  44
  45 import Ganeti.HTools.Utils
  46 import Ganeti.HTools.Types
  47
  48 import Ganeti.Jobs (JobStatus)
  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
  64             | QueryNodes
  65             | QueryJobs
  66             | SubmitManyJobs
  67
  68 -- | The serialisation of LuxiOps into strings in messages.
  69 strOfOp :: LuxiOp -> String
  70 strOfOp QueryNodes = "QueryNodes"
  71 strOfOp QueryInstances = "QueryInstances"
  72 strOfOp QueryJobs = "QueryJobs"
  73 strOfOp SubmitManyJobs = "SubmitManyJobs"
  74
  75 -- | The end-of-message separator.
  76 eOM :: Char
  77 eOM = '\3'
  78
  79 -- | Valid keys in the requests and responses.
  80 data MsgKeys = Method
  81              | Args
  82              | Success
  83              | Result
  84
  85 -- | The serialisation of MsgKeys into strings in messages.
  86 strOfKey :: MsgKeys -> String
  87 strOfKey Method = "method"
  88 strOfKey Args = "args"
  89 strOfKey Success = "success"
  90 strOfKey Result = "result"
  91
  92 -- | Luxi client encapsulation.
  93 data Client = Client { socket :: S.Socket   -- ^ The socket of the client
  94                      , rbuf :: IORef String -- ^ Already received buffer
  95                      }
  96
  97 -- | Connects to the master daemon and returns a luxi Client.
  98 getClient :: String -> IO Client
  99 getClient path = do
 100     s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
 101     withTimeout connTimeout "creating luxi connection" $
 102                 S.connect s (S.SockAddrUnix path)
 103     rf <- newIORef ""
 104     return Client { socket=s, rbuf=rf}
 105
 106 -- | Closes the client socket.
 107 closeClient :: Client -> IO ()
 108 closeClient = S.sClose . socket
 109
 110 -- | Sends a message over a luxi transport.
 111 sendMsg :: Client -> String -> IO ()
 112 sendMsg s buf =
 113     let _send obuf = do
 114           sbytes <- withTimeout queryTimeout
 115                     "sending luxi message" $
 116                     S.send (socket s) obuf
 117           unless (sbytes == length obuf) $ _send (drop sbytes obuf)
 118     in _send (buf ++ [eOM])
 119
 120 -- | Waits for a message over a luxi transport.
 121 recvMsg :: Client -> IO String
 122 recvMsg s = do
 123   let _recv obuf = do
 124               nbuf <- withTimeout queryTimeout "reading luxi response" $
 125                       S.recv (socket s) 4096
 126               let (msg, remaining) = break ((==) eOM) (obuf ++ nbuf)
 127               (if null remaining
 128                then _recv msg
 129                else return (msg, tail remaining))
 130   cbuf <- readIORef $ rbuf s
 131   (msg, nbuf) <- _recv cbuf
 132   writeIORef (rbuf s) nbuf
 133   return msg
 134
 135 -- | Serialize a request to String.
 136 buildCall :: LuxiOp  -- ^ The method
 137           -> JSValue -- ^ The arguments
 138           -> String  -- ^ The serialized form
 139 buildCall msg args =
 140     let ja = [(strOfKey Method,
 141                JSString $ toJSString $ strOfOp msg::JSValue),
 142               (strOfKey Args,
 143                args::JSValue)
 144              ]
 145         jo = toJSObject ja
 146     in encodeStrict jo
 147
 148 -- | Check that luxi responses contain the required keys and that the
 149 -- call was successful.
 150 validateResult :: String -> Result JSValue
 151 validateResult s = do
 152   arr <- fromJResult $ decodeStrict s::Result (JSObject JSValue)
 153   status <- fromObj (strOfKey Success) arr::Result Bool
 154   let rkey = strOfKey Result
 155   (if status
 156    then fromObj rkey arr
 157    else fromObj rkey arr >>= fail)
 158
 159 -- | Generic luxi method call.
 160 callMethod :: LuxiOp -> JSValue -> Client -> IO (Result JSValue)
 161 callMethod method args s = do
 162   sendMsg s $ buildCall method args
 163   result <- recvMsg s
 164   let rval = validateResult result
 165   return rval
 166
 167 -- | Specialized submitManyJobs call.
 168 submitManyJobs :: Client -> JSValue -> IO (Result [String])
 169 submitManyJobs s jobs = do
 170   rval <- callMethod SubmitManyJobs jobs s
 171   -- map each result (status, payload) pair into a nice Result ADT
 172   return $ case rval of
 173              Bad x -> Bad x
 174              Ok (JSArray r) ->
 175                  mapM (\v -> case v of
 176                                JSArray [JSBool True, JSString x] ->
 177                                    Ok (fromJSString x)
 178                                JSArray [JSBool False, JSString x] ->
 179                                    Bad (fromJSString x)
 180                                _ -> Bad "Unknown result from the master daemon"
 181                       ) r
 182              x -> Bad ("Cannot parse response from Ganeti: " ++ show x)
 183
 184 -- | Custom queryJobs call.
 185 queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
 186 queryJobsStatus s jids = do
 187   rval <- callMethod QueryJobs (J.showJSON (jids, ["status"])) s
 188   return $ case rval of
 189              Bad x -> Bad x
 190              Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
 191                        J.Ok vals -> if any null vals
 192                                     then Bad "Missing job status field"
 193                                     else Ok (map head vals)
 194                        J.Error x -> Bad x