Synnefo » snf-ganeti

import Ganeti.ConfigReader

import Ganeti.BasicTypes

import Ganeti.JQueue

import Ganeti.Logging

import Ganeti.Luxi

import qualified Ganeti.Query.Language as Qlang

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

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

                     -> LuxiOp -> IO (ErrorResult JSValue)

  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.QRInstance)

    (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

  do

    let mcs = Config.getMasterCandidates cfg

    jobid <- allocateJobId mcs qlock

          Bad s -> return . Bad . GenericError $ s

          Ok () -> do

            _ <- replicateManyJobs qDir mcs [job]

            return . Ok . showJSON . fromJobId $ jid

  do

    open <- isQueueOpen

    if not open

       then return . Bad . GenericError $ "Queue drained"

  do

    open <- isQueueOpen

    if not open

            when (any isBad write_results) . logWarning

              $ "Writing some jobs failed " ++ show annotated_results

            replicateManyJobs qDir mcs succeeded

            return . Ok . JSArray

              . map (\(res, job) ->

                      if isOk res

                        else showJSON (False, genericResult id (const "") res))

              $ annotated_results

  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

-- | Check function for luxid.

checkMain :: CheckFn ()

  s <- describeError "binding to the Luxi socket"

         Nothing (Just socket_path) $ getServer True socket_path

  cref <- newIORef (Bad "Configuration not yet loaded")

-- | Main function.

main :: MainFn () PrepResult

  initConfigReader id cref

  let creader = readIORef cref

  qlockFile <- jobQueueLockFile

  lockFile qlockFile >>= exitIfBad "Failed to obtain the job-queue lock"

  qlock <- newMVar ()

  finally

    (closeServer socket_path server)