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