Synnefo » snf-ganeti

	htools/Ganeti/Query/Language.hs \

	htools/Ganeti/Query/Server.hs \

	htools/Ganeti/Rpc.hs \

import Ganeti.Query.Server (runQueryD)

import qualified Ganeti.Query.Language as Qlang

import qualified Ganeti.Query.Language as Qlang

import qualified Ganeti.Query.Language as Qlang

import Ganeti.Query.Language

import Ganeti.Query.Language

{-# LANGUAGE TemplateHaskell #-}

{-| Implementation of the Ganeti Query2 language.

 -}

{-

Copyright (C) 2012 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.Query.Language

    ( Filter(..)

    , FilterField

    , FilterValue(..)

    , Fields

    , Query(..)

    , QueryResult(..)

    , QueryFields(..)

    , QueryFieldsResult(..)

    , FieldName

    , FieldTitle

    , FieldType(..)

    , FieldDoc

    , FieldDefinition(..)

    , ResultEntry(..)

    , ResultStatus(..)

    , ResultValue

    , ItemType(..)

    , checkRS

    ) where

import Control.Applicative

import Data.Foldable

import Data.Traversable (Traversable, traverse, fmapDefault, foldMapDefault)

import Data.Ratio (numerator, denominator)

import Text.JSON.Pretty (pp_value)

import Text.JSON.Types

import Text.JSON

import qualified Ganeti.Constants as C

import Ganeti.THH

import Ganeti.HTools.JSON

-- * THH declarations, that require ordering.

-- | Status of a query field.

$(declareIADT "ResultStatus"

  [ ("RSNormal",  'C.rsNormal )

  , ("RSUnknown", 'C.rsUnknown )

  , ("RSNoData",  'C.rsNodata )

  , ("RSUnavail", 'C.rsUnavail )

  , ("RSOffline", 'C.rsOffline )

  ])

$(makeJSONInstance ''ResultStatus)

-- | Check that ResultStatus is success or fail with descriptive

-- message.

checkRS :: (Monad m) => ResultStatus -> a -> m a

checkRS RSNormal val = return val

checkRS RSUnknown  _ = fail "Unknown field"

checkRS RSNoData   _ = fail "No data for a field"

checkRS RSUnavail  _ = fail "Ganeti reports unavailable data"

checkRS RSOffline  _ = fail "Ganeti reports resource as offline"

-- | Type of a query field.

$(declareSADT "FieldType"

  [ ("QFTUnknown",   'C.qftUnknown )

  , ("QFTText",      'C.qftText )

  , ("QFTBool",      'C.qftBool )

  , ("QFTNumber",    'C.qftNumber )

  , ("QFTUnit",      'C.qftUnit )

  , ("QFTTimestamp", 'C.qftTimestamp )

  , ("QFTOther",     'C.qftOther )

  ])

$(makeJSONInstance ''FieldType)

-- | Supported items on which Qlang works.

$(declareSADT "ItemType"

  [ ("QRCluster",  'C.qrCluster )

  , ("QRInstance", 'C.qrInstance )

  , ("QRNode",     'C.qrNode )

  , ("QRLock",     'C.qrLock )

  , ("QRGroup",    'C.qrGroup )

  , ("QROs",       'C.qrOs )

  , ("QRJob",      'C.qrJob )

  , ("QRExport",   'C.qrExport )

  ])

$(makeJSONInstance ''ItemType)

-- * Sub data types for query2 queries and responses.

-- | List of requested fields.

type Fields = [ String ]

-- | Query2 filter expression. It's a parameteric type since we can

-- filter different \"things\"; e.g. field names, or actual field

-- getters, etc.

data Filter a

    = EmptyFilter                   -- ^ No filter at all

    | AndFilter      [ Filter a ]   -- ^ & [<expression>, ...]

    | OrFilter       [ Filter a ]   -- ^ | [<expression>, ...]

    | NotFilter      (Filter a)     -- ^ ! <expression>

    | TrueFilter     a              -- ^ ? <field>

    | EQFilter       a FilterValue  -- ^ (=|!=) <field> <value>

    | LTFilter       a FilterValue  -- ^ < <field> <value>

    | GTFilter       a FilterValue  -- ^ > <field> <value>

    | LEFilter       a FilterValue  -- ^ <= <field> <value>

    | GEFilter       a FilterValue  -- ^ >= <field> <value>

    | RegexpFilter   a FilterRegexp -- ^ =~ <field> <regexp>

    | ContainsFilter a FilterValue  -- ^ =[] <list-field> <value>

      deriving (Show, Read, Eq)

-- | Serialiser for the 'Filter' data type.

showFilter :: (JSON a) => Filter a -> JSValue

showFilter (EmptyFilter)          = JSNull

showFilter (AndFilter exprs)      =

  JSArray $ (showJSON C.qlangOpAnd):(map showJSON exprs)

showFilter (OrFilter  exprs)      =

  JSArray $ (showJSON C.qlangOpOr):(map showJSON exprs)

showFilter (NotFilter flt)        =

  JSArray [showJSON C.qlangOpNot, showJSON flt]

showFilter (TrueFilter field)     =

  JSArray [showJSON C.qlangOpTrue, showJSON field]

showFilter (EQFilter field value) =

  JSArray [showJSON C.qlangOpEqual, showJSON field, showJSON value]

showFilter (LTFilter field value) =

  JSArray [showJSON C.qlangOpLt, showJSON field, showJSON value]

showFilter (GTFilter field value) =

  JSArray [showJSON C.qlangOpGt, showJSON field, showJSON value]

showFilter (LEFilter field value) =

  JSArray [showJSON C.qlangOpLe, showJSON field, showJSON value]

showFilter (GEFilter field value) =

  JSArray [showJSON C.qlangOpGe, showJSON field, showJSON value]

showFilter (RegexpFilter field regexp) =

  JSArray [showJSON C.qlangOpRegexp, showJSON field, showJSON regexp]

showFilter (ContainsFilter field value) =

  JSArray [showJSON C.qlangOpContains, showJSON field, showJSON value]

-- | Deserializer for the 'Filter' data type.

readFilter :: (JSON a) => JSValue -> Result (Filter a)

readFilter JSNull = Ok EmptyFilter

readFilter (JSArray (JSString op:args)) =

  readFilterArray (fromJSString op) args

readFilter v =

  Error $ "Cannot deserialise filter: expected array [string, args], got " ++

        show (pp_value v)

-- | Helper to deserialise an array corresponding to a single filter

-- and return the built filter. Note this looks generic but is (at

-- least currently) only used for the NotFilter.

readFilterArg :: (JSON a) =>

                 (Filter a -> Filter a) -- ^ Constructor

              -> [JSValue]              -- ^ Single argument

              -> Result (Filter a)

readFilterArg constr [flt] = constr <$> readJSON flt

readFilterArg _ v = Error $ "Cannot deserialise field, expected [filter]\

                            \ but got " ++ show (pp_value (showJSON v))

-- | Helper to deserialise an array corresponding to a single field

-- and return the built filter.

readFilterField :: (JSON a) =>

                   (a -> Filter a)   -- ^ Constructor

                -> [JSValue]         -- ^ Single argument

                -> Result (Filter a)

readFilterField constr [field] = constr <$> readJSON field

readFilterField _ v = Error $ "Cannot deserialise field, expected [fieldname]\

                              \ but got " ++ show (pp_value (showJSON v))

-- | Helper to deserialise an array corresponding to a field and

-- value, returning the built filter.

readFilterFieldValue :: (JSON a, JSON b) =>

                        (a -> b -> Filter a) -- ^ Constructor

                     -> [JSValue]            -- ^ Arguments array

                     -> Result (Filter a)

readFilterFieldValue constr [field, value] =

  constr <$> readJSON field <*> readJSON value

readFilterFieldValue _ v =

  Error $ "Cannot deserialise field/value pair, expected [fieldname, value]\

          \ but got " ++ show (pp_value (showJSON v))

-- | Inner deserialiser for 'Filter'.

readFilterArray :: (JSON a) => String -> [JSValue] -> Result (Filter a)

readFilterArray op args

  | op == C.qlangOpAnd      = AndFilter <$> mapM readJSON args

  | op == C.qlangOpOr       = OrFilter  <$> mapM readJSON args

  | op == C.qlangOpNot      = readFilterArg        NotFilter args

  | op == C.qlangOpTrue     = readFilterField      TrueFilter args

  | op == C.qlangOpEqual    = readFilterFieldValue EQFilter args

  | op == C.qlangOpLt       = readFilterFieldValue LTFilter args

  | op == C.qlangOpGt       = readFilterFieldValue GTFilter args

  | op == C.qlangOpLe       = readFilterFieldValue LEFilter args

  | op == C.qlangOpGe       = readFilterFieldValue GEFilter args

  | op == C.qlangOpRegexp   = readFilterFieldValue RegexpFilter args

  | op == C.qlangOpContains = readFilterFieldValue ContainsFilter args

  | otherwise = Error $ "Unknown filter operand '" ++ op ++ "'"

instance (JSON a) => JSON (Filter a) where

  showJSON = showFilter

  readJSON = readFilter

-- Traversable implementation for 'Filter'.

traverseFlt :: (Applicative f) => (a -> f b) -> Filter a -> f (Filter b)

traverseFlt _ EmptyFilter       = pure EmptyFilter

traverseFlt f (AndFilter flts)  = AndFilter <$> (traverse (traverseFlt f) flts)

traverseFlt f (OrFilter  flts)  = OrFilter  <$> (traverse (traverseFlt f) flts)

traverseFlt f (NotFilter flt)   = NotFilter <$> (traverseFlt f flt)

traverseFlt f (TrueFilter a)    = TrueFilter <$> f a

traverseFlt f (EQFilter a fval) = EQFilter <$> f a <*> pure fval

traverseFlt f (LTFilter a fval) = LTFilter <$> f a <*> pure fval

traverseFlt f (GTFilter a fval) = GTFilter <$> f a <*> pure fval

traverseFlt f (LEFilter a fval) = LEFilter <$> f a <*> pure fval

traverseFlt f (GEFilter a fval) = GEFilter <$> f a <*> pure fval

traverseFlt f (RegexpFilter a re)     = RegexpFilter <$> f a <*> pure re

traverseFlt f (ContainsFilter a fval) = ContainsFilter <$> f a <*> pure fval

instance Traversable Filter where

  traverse = traverseFlt

instance Functor Filter where

  fmap = fmapDefault

instance Foldable Filter where

  foldMap = foldMapDefault

-- | Field name to filter on.

type FilterField = String

-- | Value to compare the field value to, for filtering purposes.

data FilterValue = QuotedString String

                 | NumericValue Integer

                   deriving (Read, Show, Eq)

-- | Serialiser for 'FilterValue'. The Python code just sends this to

-- JSON as-is, so we'll do the same.

showFilterValue :: FilterValue -> JSValue

showFilterValue (QuotedString str) = showJSON str

showFilterValue (NumericValue val) = showJSON val

-- | Decoder for 'FilterValue'. We have to see what it contains, since

-- the context doesn't give us hints on what to expect.

readFilterValue :: JSValue -> Result FilterValue

readFilterValue (JSString a) = Ok . QuotedString $ fromJSString a

readFilterValue (JSRational _ x) =

  if denominator x /= 1

    then Error $ "Cannot deserialise numeric filter value,\

                 \ expecting integral but\

                 \ got a fractional value: " ++ show x

    else Ok . NumericValue $ numerator x

readFilterValue v = Error $ "Cannot deserialise filter value, expecting\

                            \ string or integer, got " ++ show (pp_value v)

instance JSON FilterValue where

  showJSON = showFilterValue

  readJSON = readFilterValue

-- | Regexp to apply to the filter value, for filteriong purposes.

type FilterRegexp = String

-- | Name of a field.

type FieldName = String

-- | Title of a field, when represented in tabular format.

type FieldTitle = String

-- | Human redable description of a field.

type FieldDoc = String

-- | Definition of a field.

$(buildObject "FieldDefinition" "fdef"

  [ simpleField "name"  [t| FieldName  |] -- FIXME: the name has restrictions

  , simpleField "title" [t| FieldTitle |]

  , simpleField "kind"  [t| FieldType  |]

  , simpleField "doc"   [t| FieldDoc   |]

  ])

--- | Single field entry result.

data ResultEntry = ResultEntry ResultStatus (Maybe ResultValue)

                   deriving (Show, Read, Eq)

instance JSON ResultEntry where

  showJSON (ResultEntry rs rv) =

    showJSON (showJSON rs, maybe JSNull showJSON rv)

  readJSON v = do

    (rs, rv) <- readJSON v

    rv' <- case rv of

             JSNull -> return Nothing

             x -> readJSON x

    return $ ResultEntry rs rv'

-- | The type of one result row.

type ResultRow = [ ResultEntry ]

-- | Value of a field, in json encoding.

-- (its type will be depending on ResultStatus and FieldType)

type ResultValue = JSValue

-- * Main Qlang queries and responses.

-- | Query2 query.

data Query = Query ItemType Fields (Filter FilterField)

-- | Query2 result.

$(buildObject "QueryResult" "qres"

  [ simpleField "fields" [t| [ FieldDefinition ] |]

  , simpleField "data"   [t| [ ResultRow       ] |]

  ])

-- | Query2 Fields query.

-- (to get supported fields names, descriptions, and types)

data QueryFields = QueryFields ItemType Fields

-- | Query2 Fields result.

$(buildObject "QueryFieldsResult" "qfieldres"

  [ simpleField "fields" [t| [FieldDefinition ] |]

  ])

import Ganeti.Query.Language

import Ganeti.Query.Language

{-# LANGUAGE BangPatterns #-}

{-| Implementation of the Ganeti confd types.

-}

{-

Copyright (C) 2012 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.Query.Server

  ( ConfigReader

  , runQueryD

  ) where

import Control.Applicative

import Control.Concurrent

import Control.Exception

import Data.Bits (bitSize)

import Data.Maybe

import qualified Network.Socket as S

import qualified Text.JSON as J

import Text.JSON (showJSON, JSValue(..))

import Text.JSON.Pretty (pp_value)

import System.Info (arch)

import qualified Ganeti.Constants as C

import Ganeti.Daemon

import Ganeti.Objects

import qualified Ganeti.Config as Config

import Ganeti.BasicTypes

import Ganeti.Logging

import Ganeti.Luxi

import qualified Ganeti.Query.Language as Qlang

import Ganeti.Query.Query

-- | A type for functions that can return the configuration when

-- executed.

type ConfigReader = IO (Result ConfigData)

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

handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (Result JSValue)

handleCallWrapper (Bad msg) _ =

  return . Bad $ "I do not have access to a valid configuration, cannot\

                 \ process queries: " ++ msg

handleCallWrapper (Ok config) op = handleCall config op

-- | Actual luxi operation handler.

handleCall :: ConfigData -> LuxiOp -> IO (Result JSValue)

handleCall cdata QueryClusterInfo =

  let cluster = configCluster cdata

      hypervisors = clusterEnabledHypervisors cluster

      bits = show (bitSize (0::Int)) ++ "bits"

      arch_tuple = [bits, arch]

      obj = [ ("software_version", showJSON $ C.releaseVersion)

            , ("protocol_version", showJSON $ C.protocolVersion)

            , ("config_version", showJSON $ C.configVersion)

            , ("os_api_version", showJSON $ maximum C.osApiVersions)

            , ("export_version", showJSON $ C.exportVersion)

            , ("architecture", showJSON $ arch_tuple)

            , ("name", showJSON $ clusterClusterName cluster)

            , ("master", showJSON $ clusterMasterNode cluster)

            , ("default_hypervisor", showJSON $ head hypervisors)

            , ("enabled_hypervisors", showJSON $ hypervisors)

            , ("hvparams", showJSON $ clusterHvparams cluster)

            , ("os_hvp", showJSON $ clusterOsHvp cluster)

            , ("beparams", showJSON $ clusterBeparams cluster)

            , ("osparams", showJSON $ clusterOsparams cluster)

            , ("ipolicy", showJSON $ clusterIpolicy cluster)

            , ("nicparams", showJSON $ clusterNicparams cluster)

            , ("ndparams", showJSON $ clusterNdparams cluster)

            , ("diskparams", showJSON $ clusterDiskparams cluster)

            , ("candidate_pool_size",

               showJSON $ clusterCandidatePoolSize cluster)

            , ("master_netdev",  showJSON $ clusterMasterNetdev cluster)

            , ("master_netmask", showJSON $ clusterMasterNetmask cluster)

            , ("use_external_mip_script",

               showJSON $ clusterUseExternalMipScript cluster)

            , ("volume_group_name", showJSON $clusterVolumeGroupName cluster)

            , ("drbd_usermode_helper",

               maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster))

            , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster)

            , ("shared_file_storage_dir",

               showJSON $ clusterSharedFileStorageDir cluster)

            , ("maintain_node_health",

               showJSON $ clusterMaintainNodeHealth cluster)

            , ("ctime", showJSON $ clusterCtime cluster)

            , ("mtime", showJSON $ clusterMtime cluster)

            , ("uuid", showJSON $ clusterUuid cluster)

            , ("tags", showJSON $ clusterTags cluster)

            , ("uid_pool", showJSON $ clusterUidPool cluster)

            , ("default_iallocator",

               showJSON $ clusterDefaultIallocator cluster)

            , ("reserved_lvs", showJSON $ clusterReservedLvs cluster)

            , ("primary_ip_version",

               showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster)

             , ("prealloc_wipe_disks",

                showJSON $ clusterPreallocWipeDisks cluster)

             , ("hidden_os", showJSON $ clusterHiddenOs cluster)

             , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)

            ]

  in return . Ok . J.makeObj $ obj

handleCall cfg (QueryTags kind name) =

  let tags = case kind of

               TagCluster -> Ok . clusterTags $ configCluster cfg

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

               TagNode -> nodeTags <$> Config.getNode cfg name

               TagInstance -> instTags <$> Config.getInstance cfg name

  in return (J.showJSON <$> tags)

handleCall cfg (Query qkind qfields qfilter) = do

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

  return $ J.showJSON <$> result

handleCall _ (QueryFields qkind qfields) = do

  let result = queryFields (Qlang.QueryFields qkind qfields)

  return $ J.showJSON <$> result

handleCall _ op =

  return . Bad $ "Luxi call '" ++ strOfOp op ++ "' not implemented"

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

-- response back to the client.

handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool

handleClientMsg client creader args = do

  cfg <- creader

  logDebug $ "Request: " ++ show args

  call_result <- handleCallWrapper cfg args

  (!status, !rval) <-

    case call_result of

      Bad err -> do

        let errmsg = "Failed to execute request: " ++ err

        logWarning errmsg

        return (False, showJSON errmsg)

      Ok result -> do

        logDebug $ "Result " ++ show (pp_value result)

        return (True, result)

  sendMsg client $ buildResponse status rval

  return True

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

-- checks for validity and decods, returns response.

handleClient :: Client -> ConfigReader -> IO Bool

handleClient client creader = do

  !msg <- recvMsgExt client

  case msg of

    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 client creader args

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

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

clientLoop :: Client -> ConfigReader -> IO ()

clientLoop client creader = do

  result <- handleClient client creader

  if result

    then clientLoop client creader

    else closeClient client

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

-- client, and then restarts.

mainLoop :: ConfigReader -> S.Socket -> IO ()

mainLoop creader socket = do

  client <- acceptClient socket

  _ <- forkIO $ clientLoop client creader

  mainLoop creader socket

-- | Main function that runs the query endpoint. This should be the

-- only one exposed from this module.

runQueryD :: Maybe FilePath -> ConfigReader -> IO ()

runQueryD fpath creader = do

  let socket_path = fromMaybe C.querySocket fpath

  cleanupSocket socket_path

  bracket

    (getServer socket_path)

    (closeServer socket_path)

    (mainLoop creader)

import Ganeti.Query.Language