/ - Diff - snf-ganeti - Greek Research and Technology Network's projects

Revision d79a6502

       , queryJobsStatus
       , buildCall
       , buildResponse
       , validateCall
       , decodeCall
       , decodeLuxiCall
       , recvMsg
       , recvMsgExt
       , sendMsg
-...
     import Control.Monad
     import qualified Data.ByteString.UTF8 as UTF8
     import Data.Functor ((<$>))
     import Text.JSON (encodeStrict, decodeStrict)
     import qualified Text.JSON as J
     import Text.JSON.Pretty (pp_value)
-...
     -- | The serialisation of LuxiOps into strings in messages.
     $(genStrOfOp ''LuxiOp "strOfOp")
     -- | Type holding the initial (unparsed) Luxi call.
     data LuxiCall = LuxiCall LuxiReq JSValue
     luxiConnectConfig :: ConnectConfig
     luxiConnectConfig = ConnectConfig { connDaemon = GanetiLuxid
-...
           jo = toJSObject ja
       in encodeStrict jo
     -- | Check that luxi request contains the required keys and parse it.
     validateCall :: String -> Result LuxiCall
     validateCall s = uncurry LuxiCall <$> parseCall s
     -- | Converts Luxi call arguments into a 'LuxiOp' data structure.
     -- This is used for building a Luxi 'Handler'.
     --
     -- This is currently hand-coded until we make it more uniform so that
     -- it can be generated using TH.
     decodeCall :: LuxiCall -> Result LuxiOp
     decodeCall (LuxiCall call args) =
     decodeLuxiCall :: JSValue -> JSValue -> Result LuxiOp
     decodeLuxiCall method args = do
       call <- fromJResult "Unable to parse LUXI request method" $ J.readJSON method
       case call of
         ReqQueryJobs -> do
                   (jids, jargs) <- fromJVal args

     {-# LANGUAGE BangPatterns #-}
     {-| Implementation of the Ganeti Query2 server.
     -}
-...
     import Ganeti.Query.Query
     import Ganeti.Query.Filter (makeSimpleFilter)
     import Ganeti.Types
     import qualified Ganeti.UDSServer as U
     import Ganeti.Utils (lockFile, exitIfBad, watchFile)
     import qualified Ganeti.Version as Version
-...
       logDebug $ "Updates for job " ++ sjid ++ " are " ++ encode (rfields, rlogs)
       return (JSArray rfields, rlogs)
     -- | Given a decoded luxi request, executes it and sends the luxi
     -- response back to the client.
     handleClientMsg :: MVar () -> JQStatus -> Client -> ConfigReader
                        -> LuxiOp -> IO Bool
     handleClientMsg qlock qstat client creader args = do
     type LuxiConfig = (MVar (), JQStatus, ConfigReader)
     luxiExec
         :: LuxiConfig
         -> LuxiOp
         -> IO (Bool, GenericResult GanetiException JSValue)
     luxiExec (qlock, qstat, creader) args = do
       cfg <- creader
       logDebug $ "Request: " ++ show args
       call_result <- handleCallWrapper qlock qstat cfg args
       (!status, !rval) <-
         case call_result of
           Bad err -> do
             logWarning $ "Failed to execute request " ++ show args ++ ": "
                          ++ show err
             return (False, showJSON err)
           Ok result -> do
             -- only log the first 2,000 chars of the result
             logDebug $ "Result (truncated): " ++ take 2000 (J.encode result)
             logInfo $ "Successfully handled " ++ strOfOp args
             return (True, result)
       sendMsg client $ buildResponse status rval
       return True
     -- | Handles one iteration of the client protocol: receives message,
     -- checks it for validity and decodes it, returns response.
     handleClient :: MVar () -> JQStatus -> Client -> ConfigReader -> IO Bool
     handleClient qlock qstat client creader = do
       !msg <- recvMsgExt client
       result <- handleCallWrapper qlock qstat cfg args
       return (True, result)
     luxiHandler :: LuxiConfig -> U.Handler LuxiOp JSValue
     luxiHandler cfg = U.Handler { U.hParse         = decodeLuxiCall
                                 , U.hInputLogShort = strOfOp
                                 , U.hInputLogLong  = show
                                 , U.hExec          = luxiExec cfg
+                                }
     -- | Logs an outgoing message.
     logMsg
         :: (Show e, J.JSON e, MonadLog m)
         => U.Handler i o
         -> i                          -- ^ the received request (used for logging)
         -> GenericResult e J.JSValue  -- ^ A message to be sent
         -> m ()
     logMsg handler req (Bad err) =
       logWarning $ "Failed to execute request "
                    ++ U.hInputLogLong handler req ++ ": "
                    ++ show err
     logMsg handler req (Ok result) = do
       -- only log the first 2,000 chars of the result
       logDebug $ "Result (truncated): " ++ take 2000 (J.encode result)
       logInfo $ "Successfully handled " ++ U.hInputLogShort handler req
     -- | Prepares an outgoing message.
     prepareMsg
         :: (J.JSON e)
         => GenericResult e J.JSValue  -- ^ A message to be sent
         -> (Bool, J.JSValue)
     prepareMsg (Bad err)   = (False, J.showJSON err)
     prepareMsg (Ok result) = (True, result)
     handleJsonMessage
         :: (J.JSON o)
         => U.Handler i o              -- ^ handler
         -> i                        -- ^ parsed input
         -> U.HandlerResult J.JSValue
     handleJsonMessage handler req = do
       (close, call_result) <- U.hExec handler req
       return (close, fmap J.showJSON call_result)
     -- | Takes a request as a 'String', parses it, passes it to a handler and
     -- formats its response.
     handleRawMessage
         :: (J.JSON o)
         => U.Handler i o              -- ^ handler
         -> String                   -- ^ raw unparsed input
         -> IO (Bool, String)
     handleRawMessage handler payload =
       case U.parseCall payload >>= uncurry (U.hParse handler) of
         Bad err -> do
              let errmsg = "Failed to parse request: " ++ err
              logWarning errmsg
              return (False, buildResponse False (J.showJSON errmsg))
         Ok req -> do
             logDebug $ "Request: " ++ U.hInputLogLong handler req
             (close, call_result_json) <- handleJsonMessage handler req
             logMsg handler req call_result_json
             let (status, response) = prepareMsg call_result_json
             return (close, buildResponse status response)
     -- | Reads a request, passes it to a handler and sends a response back to the
     -- client.
     handleClient
         :: (J.JSON o)
         => U.Handler i o
         -> Client
         -> IO Bool
     handleClient handler client = do
       msg <- recvMsgExt client
       logDebug $ "Received message: " ++ show msg
       case msg of
         RecvConnClosed -> logDebug "Connection closed" >> return False
         RecvConnClosed -> logDebug "Connection closed" >>
                           return False
         RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
                          return False
         RecvOk payload ->
           case validateCall payload >>= decodeCall of
             Bad err -> do
                  let errmsg = "Failed to parse request: " ++ err
                  logWarning errmsg
                  sendMsg client $ buildResponse False (showJSON errmsg)
                  return False
             Ok args -> handleClientMsg qlock qstat client creader args
         RecvOk payload -> do
           (close, outMsg) <- handleRawMessage handler payload
           sendMsg client outMsg
           return close
     -- | Main client loop: runs one loop of 'handleClient', and if that
     -- doesn't report a finished (closed) connection, restarts itself.
     clientLoop :: MVar () -> JQStatus -> Client -> ConfigReader -> IO ()
     clientLoop qlock qstat client creader = do
       result <- handleClient qlock qstat client creader
     clientLoop
         :: (J.JSON o)
         => U.Handler i o
         -> Client
         -> IO ()
     clientLoop handler client = do
       result <- handleClient handler client
       if result
         then clientLoop qlock qstat client creader
         then clientLoop handler client
         else closeClient client
     -- | Main listener loop: accepts clients, forks an I/O thread to handle
     -- that client.
     listener :: MVar () -> JQStatus -> ConfigReader -> Server -> IO ()
     listener qlock qstat creader socket = do
       client <- acceptClient socket
       _ <- forkIO $ clientLoop qlock qstat client creader
     listener
         :: (J.JSON o)
         => U.Handler i o
         -> Server
         -> IO ()
     listener handler server = do
       client <- acceptClient server
       _ <- forkIO $ clientLoop handler client
       return ()
     -- | Type alias for prepMain results
     type PrepResult = (Server, IORef (Result ConfigData), JQStatus)
-...
       qlock <- newMVar ()
       finally
         (forever $ listener qlock jq creader server)
         (forever $ listener (luxiHandler (qlock, jq, creader)) server)
         (closeServer server)

       , recvMsg
       , recvMsgExt
       , sendMsg
       -- * Client handler
       , Handler(..)
       , HandlerResult
       ) where
     import Control.Applicative
-...
     import Text.JSON.Types
     import Ganeti.BasicTypes
     import Ganeti.Errors (GanetiException)
     import Ganeti.JSON
     import Ganeti.Runtime (GanetiDaemon(..), MiscGroup(..), GanetiGroup(..))
     import Ganeti.THH
-...
     -- | Parse the required keys out of a call.
     parseCall :: (J.JSON mth) => String -> Result (mth, JSValue)
     parseCall :: (J.JSON mth, J.JSON args) => String -> Result (mth, args)
     parseCall s = do
       arr <- fromJResult "parsing top-level JSON message" $
                decodeStrict s :: Result (JSObject JSValue)
-...
                , (strOfKey Result, args)]
           jo = toJSObject ja
       in encodeStrict jo
     -- * Processing client requests
     type HandlerResult o = IO (Bool, GenericResult GanetiException o)
     data Handler i o = Handler
       { hParse         :: J.JSValue -> J.JSValue -> Result i
         -- ^ parses method and its arguments into the input type
       , hInputLogShort :: i -> String
         -- ^ short description of an input, for the INFO logging level
       , hInputLogLong  :: i -> String
         -- ^ long description of an input, for the DEBUG logging level
       , hExec          :: i -> HandlerResult o
         -- ^ executes the handler on an input
+      }

     import Ganeti.BasicTypes
     import qualified Ganeti.Luxi as Luxi
     import qualified Ganeti.UDSServer as US
     {-# ANN module "HLint: ignore Use camelCase" #-}
-...
     -- | Simple check that encoding/decoding of LuxiOp works.
     prop_CallEncoding :: Luxi.LuxiOp -> Property
     prop_CallEncoding op =
       (Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Ok op
       (US.parseCall (Luxi.buildCall op) >>= uncurry Luxi.decodeLuxiCall) ==? Ok op
     -- | Helper to a get a temporary file name.
     getTempFileName :: IO FilePath

Also available in: Unified diff

Synnefo » snf-ganeti

Revision d79a6502