code.grnet.gr Git - ganeti-local/blob - src/Ganeti/Query/Language.hs

   1 {-# LANGUAGE TemplateHaskell, CPP #-}
   2
   3 {-| Implementation of the Ganeti Query2 language.
   4
   5  -}
   6
   7 {-
   8
   9 Copyright (C) 2012 Google Inc.
  10
  11 This program is free software; you can redistribute it and/or modify
  12 it under the terms of the GNU General Public License as published by
  13 the Free Software Foundation; either version 2 of the License, or
  14 (at your option) any later version.
  15
  16 This program is distributed in the hope that it will be useful, but
  17 WITHOUT ANY WARRANTY; without even the implied warranty of
  18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 General Public License for more details.
  20
  21 You should have received a copy of the GNU General Public License
  22 along with this program; if not, write to the Free Software
  23 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  24 02110-1301, USA.
  25
  26 -}
  27
  28 module Ganeti.Query.Language
  29     ( Filter(..)
  30     , FilterField
  31     , FilterValue(..)
  32     , FilterRegex -- note: we don't export the constructor, must use helpers
  33     , mkRegex
  34     , stringRegex
  35     , compiledRegex
  36     , Fields
  37     , Query(..)
  38     , QueryResult(..)
  39     , QueryFields(..)
  40     , QueryFieldsResult(..)
  41     , FieldName
  42     , FieldTitle
  43     , FieldType(..)
  44     , FieldDoc
  45     , FieldDefinition(..)
  46     , ResultEntry(..)
  47     , ResultStatus(..)
  48     , ResultValue
  49     , ItemType(..)
  50     , QueryTypeOp(..)
  51     , queryTypeOpToRaw
  52     , QueryTypeLuxi(..)
  53     , checkRS
  54     ) where
  55
  56 import Control.Applicative
  57 import Control.DeepSeq
  58 import Data.Foldable
  59 import Data.Traversable (Traversable, traverse, fmapDefault, foldMapDefault)
  60 import Data.Ratio (numerator, denominator)
  61 import Text.JSON.Pretty (pp_value)
  62 import Text.JSON.Types
  63 import Text.JSON
  64 #ifndef NO_REGEX_PCRE
  65 import qualified Text.Regex.PCRE as PCRE
  66 #endif
  67
  68 import qualified Ganeti.Constants as C
  69 import Ganeti.THH
  70
  71 -- * THH declarations, that require ordering.
  72
  73 -- | Status of a query field.
  74 $(declareIADT "ResultStatus"
  75   [ ("RSNormal",  'C.rsNormal )
  76   , ("RSUnknown", 'C.rsUnknown )
  77   , ("RSNoData",  'C.rsNodata )
  78   , ("RSUnavail", 'C.rsUnavail )
  79   , ("RSOffline", 'C.rsOffline )
  80   ])
  81 $(makeJSONInstance ''ResultStatus)
  82
  83 -- | No-op 'NFData' instance for 'ResultStatus', since it's a single
  84 -- constructor data-type.
  85 instance NFData ResultStatus
  86
  87 -- | Check that ResultStatus is success or fail with descriptive
  88 -- message.
  89 checkRS :: (Monad m) => ResultStatus -> a -> m a
  90 checkRS RSNormal val = return val
  91 checkRS RSUnknown  _ = fail "Unknown field"
  92 checkRS RSNoData   _ = fail "No data for a field"
  93 checkRS RSUnavail  _ = fail "Ganeti reports unavailable data"
  94 checkRS RSOffline  _ = fail "Ganeti reports resource as offline"
  95
  96 -- | Type of a query field.
  97 $(declareSADT "FieldType"
  98   [ ("QFTUnknown",   'C.qftUnknown )
  99   , ("QFTText",      'C.qftText )
 100   , ("QFTBool",      'C.qftBool )
 101   , ("QFTNumber",    'C.qftNumber )
 102   , ("QFTUnit",      'C.qftUnit )
 103   , ("QFTTimestamp", 'C.qftTimestamp )
 104   , ("QFTOther",     'C.qftOther )
 105   ])
 106 $(makeJSONInstance ''FieldType)
 107
 108 -- | Supported items on which Qlang works.
 109 $(declareSADT "QueryTypeOp"
 110   [ ("QRCluster",  'C.qrCluster )
 111   , ("QRInstance", 'C.qrInstance )
 112   , ("QRNode",     'C.qrNode )
 113   , ("QRGroup",    'C.qrGroup )
 114   , ("QROs",       'C.qrOs )
 115   , ("QRExport",   'C.qrExport )
 116   , ("QRNetwork",  'C.qrNetwork )
 117   ])
 118 $(makeJSONInstance ''QueryTypeOp)
 119
 120 -- | Supported items on which Qlang works.
 121 $(declareSADT "QueryTypeLuxi"
 122   [ ("QRLock",     'C.qrLock )
 123   , ("QRJob",      'C.qrJob )
 124   ])
 125 $(makeJSONInstance ''QueryTypeLuxi)
 126
 127 -- | Overall query type.
 128 data ItemType = ItemTypeLuxi QueryTypeLuxi
 129               | ItemTypeOpCode QueryTypeOp
 130                 deriving (Show, Eq)
 131
 132 -- | Custom JSON decoder for 'ItemType'.
 133 decodeItemType :: (Monad m) => JSValue -> m ItemType
 134 decodeItemType (JSString s) =
 135   case queryTypeOpFromRaw s' of
 136     Just v -> return $ ItemTypeOpCode v
 137     Nothing ->
 138       case queryTypeLuxiFromRaw s' of
 139         Just v -> return $ ItemTypeLuxi v
 140         Nothing ->
 141           fail $ "Can't parse value '" ++ s' ++ "' as neither"
 142                  ++ "QueryTypeLuxi nor QueryTypeOp"
 143   where s' = fromJSString s
 144 decodeItemType v = fail $ "Invalid value '" ++ show (pp_value v) ++
 145                    "for query type"
 146
 147 -- | Custom JSON instance for 'ItemType' since its encoding is not
 148 -- consistent with the data type itself.
 149 instance JSON ItemType where
 150   showJSON (ItemTypeLuxi x)  = showJSON x
 151   showJSON (ItemTypeOpCode y) = showJSON y
 152   readJSON = decodeItemType
 153
 154 -- * Sub data types for query2 queries and responses.
 155
 156 -- | Internal type of a regex expression (not exported).
 157 #ifndef NO_REGEX_PCRE
 158 type RegexType = PCRE.Regex
 159 #else
 160 type RegexType = ()
 161 #endif
 162
 163 -- | List of requested fields.
 164 type Fields = [ String ]
 165
 166 -- | Query2 filter expression. It's a parameteric type since we can
 167 -- filter different \"things\"; e.g. field names, or actual field
 168 -- getters, etc.
 169 data Filter a
 170     = EmptyFilter                   -- ^ No filter at all
 171     | AndFilter      [ Filter a ]   -- ^ @&@ [/expression/, ...]
 172     | OrFilter       [ Filter a ]   -- ^ @|@ [/expression/, ...]
 173     | NotFilter      (Filter a)     -- ^ @!@ /expression/
 174     | TrueFilter     a              -- ^ @?@ /field/
 175     | EQFilter       a FilterValue  -- ^ @(=|!=)@ /field/ /value/
 176     | LTFilter       a FilterValue  -- ^ @<@ /field/ /value/
 177     | GTFilter       a FilterValue  -- ^ @>@ /field/ /value/
 178     | LEFilter       a FilterValue  -- ^ @<=@ /field/ /value/
 179     | GEFilter       a FilterValue  -- ^ @>=@ /field/ /value/
 180     | RegexpFilter   a FilterRegex  -- ^ @=~@ /field/ /regexp/
 181     | ContainsFilter a FilterValue  -- ^ @=[]@ /list-field/ /value/
 182       deriving (Show, Eq)
 183
 184 -- | Serialiser for the 'Filter' data type.
 185 showFilter :: (JSON a) => Filter a -> JSValue
 186 showFilter (EmptyFilter)          = JSNull
 187 showFilter (AndFilter exprs)      =
 188   JSArray $ showJSON C.qlangOpAnd : map showJSON exprs
 189 showFilter (OrFilter  exprs)      =
 190   JSArray $ showJSON C.qlangOpOr : map showJSON exprs
 191 showFilter (NotFilter flt)        =
 192   JSArray [showJSON C.qlangOpNot, showJSON flt]
 193 showFilter (TrueFilter field)     =
 194   JSArray [showJSON C.qlangOpTrue, showJSON field]
 195 showFilter (EQFilter field value) =
 196   JSArray [showJSON C.qlangOpEqual, showJSON field, showJSON value]
 197 showFilter (LTFilter field value) =
 198   JSArray [showJSON C.qlangOpLt, showJSON field, showJSON value]
 199 showFilter (GTFilter field value) =
 200   JSArray [showJSON C.qlangOpGt, showJSON field, showJSON value]
 201 showFilter (LEFilter field value) =
 202   JSArray [showJSON C.qlangOpLe, showJSON field, showJSON value]
 203 showFilter (GEFilter field value) =
 204   JSArray [showJSON C.qlangOpGe, showJSON field, showJSON value]
 205 showFilter (RegexpFilter field regexp) =
 206   JSArray [showJSON C.qlangOpRegexp, showJSON field, showJSON regexp]
 207 showFilter (ContainsFilter field value) =
 208   JSArray [showJSON C.qlangOpContains, showJSON field, showJSON value]
 209
 210 -- | Deserializer for the 'Filter' data type.
 211 readFilter :: (JSON a) => JSValue -> Result (Filter a)
 212 readFilter JSNull = Ok EmptyFilter
 213 readFilter (JSArray (JSString op:args)) =
 214   readFilterArray (fromJSString op) args
 215 readFilter v =
 216   Error $ "Cannot deserialise filter: expected array [string, args], got " ++
 217         show (pp_value v)
 218
 219 -- | Helper to deserialise an array corresponding to a single filter
 220 -- and return the built filter. Note this looks generic but is (at
 221 -- least currently) only used for the NotFilter.
 222 readFilterArg :: (JSON a) =>
 223                  (Filter a -> Filter a) -- ^ Constructor
 224               -> [JSValue]              -- ^ Single argument
 225               -> Result (Filter a)
 226 readFilterArg constr [flt] = constr <$> readJSON flt
 227 readFilterArg _ v = Error $ "Cannot deserialise field, expected [filter]" ++
 228                             " but got " ++ show (pp_value (showJSON v))
 229
 230 -- | Helper to deserialise an array corresponding to a single field
 231 -- and return the built filter.
 232 readFilterField :: (JSON a) =>
 233                    (a -> Filter a)   -- ^ Constructor
 234                 -> [JSValue]         -- ^ Single argument
 235                 -> Result (Filter a)
 236 readFilterField constr [field] = constr <$> readJSON field
 237 readFilterField _ v = Error $ "Cannot deserialise field, expected" ++
 238                               " [fieldname] but got " ++
 239                               show (pp_value (showJSON v))
 240
 241 -- | Helper to deserialise an array corresponding to a field and
 242 -- value, returning the built filter.
 243 readFilterFieldValue :: (JSON a, JSON b) =>
 244                         (a -> b -> Filter a) -- ^ Constructor
 245                      -> [JSValue]            -- ^ Arguments array
 246                      -> Result (Filter a)
 247 readFilterFieldValue constr [field, value] =
 248   constr <$> readJSON field <*> readJSON value
 249 readFilterFieldValue _ v =
 250   Error $ "Cannot deserialise field/value pair, expected [fieldname, value]" ++
 251           " but got " ++ show (pp_value (showJSON v))
 252
 253 -- | Inner deserialiser for 'Filter'.
 254 readFilterArray :: (JSON a) => String -> [JSValue] -> Result (Filter a)
 255 readFilterArray op args
 256   | op == C.qlangOpAnd      = AndFilter <$> mapM readJSON args
 257   | op == C.qlangOpOr       = OrFilter  <$> mapM readJSON args
 258   | op == C.qlangOpNot      = readFilterArg        NotFilter args
 259   | op == C.qlangOpTrue     = readFilterField      TrueFilter args
 260   | op == C.qlangOpEqual    = readFilterFieldValue EQFilter args
 261   | op == C.qlangOpLt       = readFilterFieldValue LTFilter args
 262   | op == C.qlangOpGt       = readFilterFieldValue GTFilter args
 263   | op == C.qlangOpLe       = readFilterFieldValue LEFilter args
 264   | op == C.qlangOpGe       = readFilterFieldValue GEFilter args
 265   | op == C.qlangOpRegexp   = readFilterFieldValue RegexpFilter args
 266   | op == C.qlangOpContains = readFilterFieldValue ContainsFilter args
 267   | otherwise = Error $ "Unknown filter operand '" ++ op ++ "'"
 268
 269 instance (JSON a) => JSON (Filter a) where
 270   showJSON = showFilter
 271   readJSON = readFilter
 272
 273 -- Traversable implementation for 'Filter'.
 274 traverseFlt :: (Applicative f) => (a -> f b) -> Filter a -> f (Filter b)
 275 traverseFlt _ EmptyFilter       = pure EmptyFilter
 276 traverseFlt f (AndFilter flts)  = AndFilter <$> traverse (traverseFlt f) flts
 277 traverseFlt f (OrFilter  flts)  = OrFilter  <$> traverse (traverseFlt f) flts
 278 traverseFlt f (NotFilter flt)   = NotFilter <$> traverseFlt f flt
 279 traverseFlt f (TrueFilter a)    = TrueFilter <$> f a
 280 traverseFlt f (EQFilter a fval) = EQFilter <$> f a <*> pure fval
 281 traverseFlt f (LTFilter a fval) = LTFilter <$> f a <*> pure fval
 282 traverseFlt f (GTFilter a fval) = GTFilter <$> f a <*> pure fval
 283 traverseFlt f (LEFilter a fval) = LEFilter <$> f a <*> pure fval
 284 traverseFlt f (GEFilter a fval) = GEFilter <$> f a <*> pure fval
 285 traverseFlt f (RegexpFilter a re)     = RegexpFilter <$> f a <*> pure re
 286 traverseFlt f (ContainsFilter a fval) = ContainsFilter <$> f a <*> pure fval
 287
 288 instance Traversable Filter where
 289   traverse = traverseFlt
 290
 291 instance Functor Filter where
 292   fmap = fmapDefault
 293
 294 instance Foldable Filter where
 295   foldMap = foldMapDefault
 296
 297 -- | Field name to filter on.
 298 type FilterField = String
 299
 300 -- | Value to compare the field value to, for filtering purposes.
 301 data FilterValue = QuotedString String
 302                  | NumericValue Integer
 303                    deriving (Show, Eq)
 304
 305 -- | Serialiser for 'FilterValue'. The Python code just sends this to
 306 -- JSON as-is, so we'll do the same.
 307 showFilterValue :: FilterValue -> JSValue
 308 showFilterValue (QuotedString str) = showJSON str
 309 showFilterValue (NumericValue val) = showJSON val
 310
 311 -- | Decoder for 'FilterValue'. We have to see what it contains, since
 312 -- the context doesn't give us hints on what to expect.
 313 readFilterValue :: JSValue -> Result FilterValue
 314 readFilterValue (JSString a) = Ok . QuotedString $ fromJSString a
 315 readFilterValue (JSRational _ x) =
 316   if denominator x /= 1
 317     then Error $ "Cannot deserialise numeric filter value," ++
 318                  " expecting integral but got a fractional value: " ++
 319                  show x
 320     else Ok . NumericValue $ numerator x
 321 readFilterValue v = Error $ "Cannot deserialise filter value, expecting" ++
 322                             " string or integer, got " ++ show (pp_value v)
 323
 324 instance JSON FilterValue where
 325   showJSON = showFilterValue
 326   readJSON = readFilterValue
 327
 328 -- | Regexp to apply to the filter value, for filtering purposes. It
 329 -- holds both the string format, and the \"compiled\" format, so that
 330 -- we don't re-compile the regex at each match attempt.
 331 data FilterRegex = FilterRegex
 332   { stringRegex   :: String      -- ^ The string version of the regex
 333   , compiledRegex :: RegexType   -- ^ The compiled regex
 334   }
 335
 336 -- | Builder for 'FilterRegex'. We always attempt to compile the
 337 -- regular expression on the initialisation of the data structure;
 338 -- this might fail, if the RE is not well-formed.
 339 mkRegex :: (Monad m) => String -> m FilterRegex
 340 #ifndef NO_REGEX_PCRE
 341 mkRegex str = do
 342   compiled <- case PCRE.getVersion of
 343                 Nothing -> fail $ "regex-pcre library compiled without" ++
 344                                   " libpcre, regex functionality not available"
 345                 _ -> PCRE.makeRegexM str
 346   return $ FilterRegex str compiled
 347 #else
 348 mkRegex _ =
 349   fail $ "regex-pcre not found at compile time," ++
 350          " regex functionality not available"
 351 #endif
 352
 353 -- | 'Show' instance: we show the constructor plus the string version
 354 -- of the regex.
 355 instance Show FilterRegex where
 356   show (FilterRegex re _) = "mkRegex " ++ show re
 357
 358 -- | 'Eq' instance: we only compare the string versions of the regexes.
 359 instance Eq FilterRegex where
 360   (FilterRegex re1 _) == (FilterRegex re2 _) = re1 == re2
 361
 362 -- | 'JSON' instance: like for show and read instances, we work only
 363 -- with the string component.
 364 instance JSON FilterRegex where
 365   showJSON (FilterRegex re _) = showJSON re
 366   readJSON s = readJSON s >>= mkRegex
 367
 368 -- | Name of a field.
 369 type FieldName = String
 370 -- | Title of a field, when represented in tabular format.
 371 type FieldTitle = String
 372 -- | Human redable description of a field.
 373 type FieldDoc = String
 374
 375 -- | Definition of a field.
 376 $(buildObject "FieldDefinition" "fdef"
 377   [ simpleField "name"  [t| FieldName  |] -- FIXME: the name has restrictions
 378   , simpleField "title" [t| FieldTitle |]
 379   , simpleField "kind"  [t| FieldType  |]
 380   , simpleField "doc"   [t| FieldDoc   |]
 381   ])
 382
 383 --- | Single field entry result.
 384 data ResultEntry = ResultEntry
 385   { rentryStatus :: ResultStatus      -- ^ The result status
 386   , rentryValue  :: Maybe ResultValue -- ^ The (optional) result value
 387   } deriving (Show, Eq)
 388
 389 instance NFData ResultEntry where
 390   rnf (ResultEntry rs rv) = rnf rs `seq` rnf rv
 391
 392 instance JSON ResultEntry where
 393   showJSON (ResultEntry rs rv) =
 394     showJSON (showJSON rs, maybe JSNull showJSON rv)
 395   readJSON v = do
 396     (rs, rv) <- readJSON v
 397     rv' <- case rv of
 398              JSNull -> return Nothing
 399              x -> Just <$> readJSON x
 400     return $ ResultEntry rs rv'
 401
 402 -- | The type of one result row.
 403 type ResultRow = [ ResultEntry ]
 404
 405 -- | Value of a field, in json encoding.
 406 -- (its type will be depending on ResultStatus and FieldType)
 407 type ResultValue = JSValue
 408
 409 -- * Main Qlang queries and responses.
 410
 411 -- | Query2 query.
 412 data Query = Query ItemType Fields (Filter FilterField)
 413
 414 -- | Query2 result.
 415 $(buildObject "QueryResult" "qres"
 416   [ simpleField "fields" [t| [ FieldDefinition ] |]
 417   , simpleField "data"   [t| [ ResultRow       ] |]
 418   ])
 419
 420 -- | Query2 Fields query.
 421 -- (to get supported fields names, descriptions, and types)
 422 data QueryFields = QueryFields ItemType Fields
 423
 424 -- | Query2 Fields result.
 425 $(buildObject "QueryFieldsResult" "qfieldres"
 426   [ simpleField "fields" [t| [FieldDefinition ] |]
 427   ])