Synnefo » snf-ganeti

{-| Implementation of the Ganeti LUXI interface.

-}

{-

Copyright (C) 2009 Google Inc.

This program is free software; you can redistribute it and/or modify

it under the terms of the GNU General Public License as published by

the Free Software Foundation; either version 2 of the License, or

(at your option) any later version.

This program is distributed in the hope that it will be useful, but

WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

General Public License for more details.

You should have received a copy of the GNU General Public License

along with this program; if not, write to the Free Software

Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA

02110-1301, USA.

-}

module Ganeti.Luxi

    ( LuxiOp(..)

    , Client

    , getClient

    , closeClient

    , callMethod

    , submitManyJobs

    , queryJobsStatus

    ) where

import Data.IORef

import Control.Monad

import Text.JSON (encodeStrict, decodeStrict)

import qualified Text.JSON as J

import Text.JSON.Types

import System.Timeout

import qualified Network.Socket as S

import Ganeti.HTools.Utils

import Ganeti.HTools.Types

import Ganeti.Jobs (JobStatus)

-- * Utility functions

-- | Wrapper over System.Timeout.timeout that fails in the IO monad.

withTimeout :: Int -> String -> IO a -> IO a

withTimeout secs descr action = do

    result <- timeout (secs * 1000000) action

    (case result of

       Nothing -> fail $ "Timeout in " ++ descr

       Just v -> return v)

-- * Generic protocol functionality

-- | Currently supported Luxi operations.

data LuxiOp = QueryInstances

            | QueryNodes

            | QueryJobs

            | QueryClusterInfo

            | SubmitManyJobs

-- | The serialisation of LuxiOps into strings in messages.

strOfOp :: LuxiOp -> String

strOfOp QueryNodes = "QueryNodes"

strOfOp QueryInstances = "QueryInstances"

strOfOp QueryJobs = "QueryJobs"

strOfOp QueryClusterInfo = "QueryClusterInfo"

strOfOp SubmitManyJobs = "SubmitManyJobs"

-- | The end-of-message separator.

eOM :: Char

eOM = '\3'

-- | Valid keys in the requests and responses.

data MsgKeys = Method

             | Args

             | Success

             | Result

-- | The serialisation of MsgKeys into strings in messages.

strOfKey :: MsgKeys -> String

strOfKey Method = "method"

strOfKey Args = "args"

strOfKey Success = "success"

strOfKey Result = "result"

-- | Luxi client encapsulation.

data Client = Client { socket :: S.Socket   -- ^ The socket of the client

                     , rbuf :: IORef String -- ^ Already received buffer

                     }

-- | Connects to the master daemon and returns a luxi Client.

getClient :: String -> IO Client

getClient path = do

    s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol

    withTimeout connTimeout "creating luxi connection" $

                S.connect s (S.SockAddrUnix path)

    rf <- newIORef ""

    return Client { socket=s, rbuf=rf}

-- | Closes the client socket.

closeClient :: Client -> IO ()

closeClient = S.sClose . socket

-- | Sends a message over a luxi transport.

sendMsg :: Client -> String -> IO ()

sendMsg s buf =

    let _send obuf = do

          sbytes <- withTimeout queryTimeout

                    "sending luxi message" $

                    S.send (socket s) obuf

          unless (sbytes == length obuf) $ _send (drop sbytes obuf)

    in _send (buf ++ [eOM])

-- | Waits for a message over a luxi transport.

recvMsg :: Client -> IO String

recvMsg s = do

  let _recv obuf = do

              nbuf <- withTimeout queryTimeout "reading luxi response" $

                      S.recv (socket s) 4096

              let (msg, remaining) = break (eOM ==) (obuf ++ nbuf)

              (if null remaining

               then _recv msg

               else return (msg, tail remaining))

  cbuf <- readIORef $ rbuf s

  (msg, nbuf) <- _recv cbuf

  writeIORef (rbuf s) nbuf

  return msg

-- | Serialize a request to String.

buildCall :: LuxiOp  -- ^ The method

          -> JSValue -- ^ The arguments

          -> String  -- ^ The serialized form

buildCall msg args =

    let ja = [(strOfKey Method,

               JSString $ toJSString $ strOfOp msg::JSValue),

              (strOfKey Args,

               args::JSValue)

             ]

        jo = toJSObject ja

    in encodeStrict jo

-- | Check that luxi responses contain the required keys and that the

-- call was successful.

validateResult :: String -> Result JSValue

validateResult s = do

  oarr <- fromJResult $ decodeStrict s::Result (JSObject JSValue)

  let arr = J.fromJSObject oarr

  status <- fromObj (strOfKey Success) arr::Result Bool

  let rkey = strOfKey Result

  (if status

   then fromObj rkey arr

   else fromObj rkey arr >>= fail)

-- | Generic luxi method call.

callMethod :: LuxiOp -> JSValue -> Client -> IO (Result JSValue)

callMethod method args s = do

  sendMsg s $ buildCall method args

  result <- recvMsg s

  let rval = validateResult result

  return rval

-- | Specialized submitManyJobs call.

submitManyJobs :: Client -> JSValue -> IO (Result [String])

submitManyJobs s jobs = do

  rval <- callMethod SubmitManyJobs jobs s

  -- map each result (status, payload) pair into a nice Result ADT

  return $ case rval of

             Bad x -> Bad x

             Ok (JSArray r) ->

                 mapM (\v -> case v of

                               JSArray [JSBool True, JSString x] ->

                                   Ok (fromJSString x)

                               JSArray [JSBool False, JSString x] ->

                                   Bad (fromJSString x)

                               _ -> Bad "Unknown result from the master daemon"

                      ) r

             x -> Bad ("Cannot parse response from Ganeti: " ++ show x)

-- | Custom queryJobs call.

queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])

queryJobsStatus s jids = do

  rval <- callMethod QueryJobs (J.showJSON (jids, ["status"])) s

  return $ case rval of

             Bad x -> Bad x

             Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of

                       J.Ok vals -> if any null vals

                                    then Bad "Missing job status field"

                                    else Ok (map head vals)

                       J.Error x -> Bad x