Synnefo » snf-ganeti

import Control.Applicative

import Control.Concurrent

import Control.Exception

import Data.Bits (bitSize)

import qualified Data.Set as Set (toList)

import Data.IORef

import qualified Ganeti.Config as Config

import Ganeti.ConfigReader

import Ganeti.BasicTypes

import Ganeti.Logging

import Ganeti.Luxi

import qualified Ganeti.Query.Language as Qlang

import qualified Ganeti.Query.Cluster as QCluster

import Ganeti.Query.Query

import Ganeti.Query.Filter (makeSimpleFilter)

import Ganeti.Types

-- | Helper for classic queries.

handleClassicQuery :: ConfigData      -- ^ Cluster config

  return $ showJSON <$> (qr >>= queryCompat)

-- | Minimal wrapper to handle the missing config case.

  return . Bad . ConfigurationError $

           "I do not have access to a valid configuration, cannot\

           \ process queries: " ++ msg

-- | Actual luxi operation handler.

  let cluster = configCluster cdata

      master = QCluster.clusterMasterNodeName cdata

      hypervisors = clusterEnabledHypervisors cluster

    Ok _ -> return . Ok . J.makeObj $ obj

    Bad ex -> return $ Bad ex

  let tags = case kind of

               TagKindCluster  -> Ok . clusterTags $ configCluster cfg

               TagKindGroup    -> groupTags <$> Config.getGroup    cfg name

                                        ECodeInval

  return (J.showJSON <$> tags)

  result <- query cfg True (Qlang.Query qkind qfields qfilter)

  return $ J.showJSON <$> result

  let result = queryFields (Qlang.QueryFields qkind qfields)

  return $ J.showJSON <$> result

  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode)

    (map Left names) fields lock

  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup)

    (map Left names) fields lock

  handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)

    (map (Right . fromIntegral . fromJobId) names)  fields False

  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNetwork)

    (map Left names) fields lock

  return . Bad $

    GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")

-- | Given a decoded luxi request, executes it and sends the luxi

-- response back to the client.

  cfg <- creader

  logDebug $ "Request: " ++ show args

  (!status, !rval) <-

    case call_result of

      Bad err -> do

-- | Handles one iteration of the client protocol: receives message,

-- checks it for validity and decodes it, returns response.

  !msg <- recvMsgExt client

  logDebug $ "Received message: " ++ show msg

  case msg of

             logWarning errmsg

             sendMsg client $ buildResponse False (showJSON errmsg)

             return False

-- | Main client loop: runs one loop of 'handleClient', and if that

-- doesn't report a finished (closed) connection, restarts itself.

  if result

    else closeClient client

-- | Main listener loop: accepts clients, forks an I/O thread to handle

-- that client.

  client <- acceptClient socket

  return ()

-- | Type alias for prepMain results

main _ _ (socket_path, server, cref) = do

  initConfigReader id cref

  let creader = readIORef cref

  finally

    (closeServer socket_path server)