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     ) where
  33
  34 import Data.List
  35 import Data.IORef
  36 import Control.Monad
  37 import Text.JSON (JSObject, JSValue, toJSObject, encodeStrict, decodeStrict)
  38 import qualified Text.JSON as J
  39 import Text.JSON.Types
  40 import System.Timeout
  41 import qualified Network.Socket as S
  42
  43 import Ganeti.HTools.Utils
  44 import Ganeti.HTools.Types
  45
  46 -- * Utility functions
  47
  48 -- | Wrapper over System.Timeout.timeout that fails in the IO monad.
  49 withTimeout :: Int -> String -> IO a -> IO a
  50 withTimeout secs descr action = do
  51     result <- timeout (secs * 1000000) action
  52     (case result of
  53        Nothing -> fail $ "Timeout in " ++ descr
  54        Just v -> return v)
  55
  56 -- * Generic protocol functionality
  57
  58 -- | Currently supported Luxi operations.
  59 data LuxiOp = QueryInstances
  60             | QueryNodes
  61
  62 -- | The serialisation of LuxiOps into strings in messages.
  63 strOfOp :: LuxiOp -> String
  64 strOfOp QueryNodes = "QueryNodes"
  65 strOfOp QueryInstances = "QueryInstances"
  66
  67 -- | The end-of-message separator.
  68 eOM :: Char
  69 eOM = '\3'
  70
  71 -- | Valid keys in the requests and responses.
  72 data MsgKeys = Method
  73              | Args
  74              | Success
  75              | Result
  76
  77 -- | The serialisation of MsgKeys into strings in messages.
  78 strOfKey :: MsgKeys -> String
  79 strOfKey Method = "method"
  80 strOfKey Args = "args"
  81 strOfKey Success = "success"
  82 strOfKey Result = "result"
  83
  84 -- | Luxi client encapsulation.
  85 data Client = Client { socket :: S.Socket   -- ^ The socket of the client
  86                      , rbuf :: IORef String -- ^ Already received buffer
  87                      }
  88
  89 -- | Connects to the master daemon and returns a luxi Client.
  90 getClient :: String -> IO Client
  91 getClient path = do
  92     s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
  93     withTimeout connTimeout "creating luxi connection" $
  94                 S.connect s (S.SockAddrUnix path)
  95     rf <- newIORef ""
  96     return Client { socket=s, rbuf=rf}
  97
  98 -- | Closes the client socket.
  99 closeClient :: Client -> IO ()
 100 closeClient = S.sClose . socket
 101
 102 -- | Sends a message over a luxi transport.
 103 sendMsg :: Client -> String -> IO ()
 104 sendMsg s buf =
 105     let _send obuf = do
 106           sbytes <- withTimeout queryTimeout
 107                     "sending luxi message" $
 108                     S.send (socket s) obuf
 109           (if sbytes == length obuf
 110            then return ()
 111            else _send (drop sbytes obuf))
 112     in _send (buf ++ [eOM])
 113
 114 -- | Waits for a message over a luxi transport.
 115 recvMsg :: Client -> IO String
 116 recvMsg s = do
 117   let _recv obuf = do
 118               nbuf <- withTimeout queryTimeout "reading luxi response" $
 119                       S.recv (socket s) 4096
 120               let (msg, remaining) = break ((==) eOM) (obuf ++ nbuf)
 121               (if null remaining
 122                then _recv msg
 123                else return (msg, tail remaining))
 124   cbuf <- readIORef $ rbuf s
 125   (msg, nbuf) <- _recv cbuf
 126   writeIORef (rbuf s) nbuf
 127   return msg
 128
 129 -- | Serialize a request to String.
 130 buildCall :: LuxiOp  -- ^ The method
 131           -> JSValue -- ^ The arguments
 132           -> String  -- ^ The serialized form
 133 buildCall msg args =
 134     let ja = [(strOfKey Method,
 135                JSString $ toJSString $ strOfOp msg::JSValue),
 136               (strOfKey Args,
 137                args::JSValue)
 138              ]
 139         jo = toJSObject ja
 140     in encodeStrict jo
 141
 142 -- | Check that luxi responses contain the required keys and that the
 143 -- call was successful.
 144 validateResult :: String -> Result JSValue
 145 validateResult s = do
 146   arr <- fromJResult $ decodeStrict s::Result (JSObject JSValue)
 147   status <- fromObj (strOfKey Success) arr::Result Bool
 148   let rkey = strOfKey Result
 149   (if status
 150    then fromObj rkey arr
 151    else fromObj rkey arr >>= fail)
 152
 153 -- | Generic luxi method call.
 154 callMethod :: LuxiOp -> JSValue -> Client -> IO (Result JSValue)
 155 callMethod method args s = do
 156   sendMsg s $ buildCall method args
 157   result <- recvMsg s
 158   let rval = validateResult result
 159   return rval