code.grnet.gr Git - ganeti-local/blob - htools/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     , checkRS
  51     ) where
  52
  53 import Control.Applicative
  54 import Data.Foldable
  55 import Data.Traversable (Traversable, traverse, fmapDefault, foldMapDefault)
  56 import Data.Ratio (numerator, denominator)
  57 import Text.JSON.Pretty (pp_value)
  58 import Text.JSON.Types
  59 import Text.JSON
  60 #ifndef NO_REGEX_PCRE
  61 import qualified Text.Regex.PCRE as PCRE
  62 #endif
  63
  64 import qualified Ganeti.Constants as C
  65 import Ganeti.THH
  66 import Ganeti.JSON
  67
  68 -- * THH declarations, that require ordering.
  69
  70 -- | Status of a query field.
  71 $(declareIADT "ResultStatus"
  72   [ ("RSNormal",  'C.rsNormal )
  73   , ("RSUnknown", 'C.rsUnknown )
  74   , ("RSNoData",  'C.rsNodata )
  75   , ("RSUnavail", 'C.rsUnavail )
  76   , ("RSOffline", 'C.rsOffline )
  77   ])
  78 $(makeJSONInstance ''ResultStatus)
  79
  80 -- | Check that ResultStatus is success or fail with descriptive
  81 -- message.
  82 checkRS :: (Monad m) => ResultStatus -> a -> m a
  83 checkRS RSNormal val = return val
  84 checkRS RSUnknown  _ = fail "Unknown field"
  85 checkRS RSNoData   _ = fail "No data for a field"
  86 checkRS RSUnavail  _ = fail "Ganeti reports unavailable data"
  87 checkRS RSOffline  _ = fail "Ganeti reports resource as offline"
  88
  89 -- | Type of a query field.
  90 $(declareSADT "FieldType"
  91   [ ("QFTUnknown",   'C.qftUnknown )
  92   , ("QFTText",      'C.qftText )
  93   , ("QFTBool",      'C.qftBool )
  94   , ("QFTNumber",    'C.qftNumber )
  95   , ("QFTUnit",      'C.qftUnit )
  96   , ("QFTTimestamp", 'C.qftTimestamp )
  97   , ("QFTOther",     'C.qftOther )
  98   ])
  99 $(makeJSONInstance ''FieldType)
 100
 101 -- | Supported items on which Qlang works.
 102 $(declareSADT "ItemType"
 103   [ ("QRCluster",  'C.qrCluster )
 104   , ("QRInstance", 'C.qrInstance )
 105   , ("QRNode",     'C.qrNode )
 106   , ("QRLock",     'C.qrLock )
 107   , ("QRGroup",    'C.qrGroup )
 108   , ("QROs",       'C.qrOs )
 109   , ("QRJob",      'C.qrJob )
 110   , ("QRExport",   'C.qrExport )
 111   ])
 112 $(makeJSONInstance ''ItemType)
 113
 114 -- * Sub data types for query2 queries and responses.
 115
 116 -- | Internal type of a regex expression (not exported).
 117 #ifndef NO_REGEX_PCRE
 118 type RegexType = PCRE.Regex
 119 #else
 120 type RegexType = ()
 121 #endif
 122
 123 -- | List of requested fields.
 124 type Fields = [ String ]
 125
 126 -- | Query2 filter expression. It's a parameteric type since we can
 127 -- filter different \"things\"; e.g. field names, or actual field
 128 -- getters, etc.
 129 data Filter a
 130     = EmptyFilter                   -- ^ No filter at all
 131     | AndFilter      [ Filter a ]   -- ^ & [<expression>, ...]
 132     | OrFilter       [ Filter a ]   -- ^ | [<expression>, ...]
 133     | NotFilter      (Filter a)     -- ^ ! <expression>
 134     | TrueFilter     a              -- ^ ? <field>
 135     | EQFilter       a FilterValue  -- ^ (=|!=) <field> <value>
 136     | LTFilter       a FilterValue  -- ^ < <field> <value>
 137     | GTFilter       a FilterValue  -- ^ > <field> <value>
 138     | LEFilter       a FilterValue  -- ^ <= <field> <value>
 139     | GEFilter       a FilterValue  -- ^ >= <field> <value>
 140     | RegexpFilter   a FilterRegex  -- ^ =~ <field> <regexp>
 141     | ContainsFilter a FilterValue  -- ^ =[] <list-field> <value>
 142       deriving (Show, Read, Eq)
 143
 144 -- | Serialiser for the 'Filter' data type.
 145 showFilter :: (JSON a) => Filter a -> JSValue
 146 showFilter (EmptyFilter)          = JSNull
 147 showFilter (AndFilter exprs)      =
 148   JSArray $ showJSON C.qlangOpAnd : map showJSON exprs
 149 showFilter (OrFilter  exprs)      =
 150   JSArray $ showJSON C.qlangOpOr : map showJSON exprs
 151 showFilter (NotFilter flt)        =
 152   JSArray [showJSON C.qlangOpNot, showJSON flt]
 153 showFilter (TrueFilter field)     =
 154   JSArray [showJSON C.qlangOpTrue, showJSON field]
 155 showFilter (EQFilter field value) =
 156   JSArray [showJSON C.qlangOpEqual, showJSON field, showJSON value]
 157 showFilter (LTFilter field value) =
 158   JSArray [showJSON C.qlangOpLt, showJSON field, showJSON value]
 159 showFilter (GTFilter field value) =
 160   JSArray [showJSON C.qlangOpGt, showJSON field, showJSON value]
 161 showFilter (LEFilter field value) =
 162   JSArray [showJSON C.qlangOpLe, showJSON field, showJSON value]
 163 showFilter (GEFilter field value) =
 164   JSArray [showJSON C.qlangOpGe, showJSON field, showJSON value]
 165 showFilter (RegexpFilter field regexp) =
 166   JSArray [showJSON C.qlangOpRegexp, showJSON field, showJSON regexp]
 167 showFilter (ContainsFilter field value) =
 168   JSArray [showJSON C.qlangOpContains, showJSON field, showJSON value]
 169
 170 -- | Deserializer for the 'Filter' data type.
 171 readFilter :: (JSON a) => JSValue -> Result (Filter a)
 172 readFilter JSNull = Ok EmptyFilter
 173 readFilter (JSArray (JSString op:args)) =
 174   readFilterArray (fromJSString op) args
 175 readFilter v =
 176   Error $ "Cannot deserialise filter: expected array [string, args], got " ++
 177         show (pp_value v)
 178
 179 -- | Helper to deserialise an array corresponding to a single filter
 180 -- and return the built filter. Note this looks generic but is (at
 181 -- least currently) only used for the NotFilter.
 182 readFilterArg :: (JSON a) =>
 183                  (Filter a -> Filter a) -- ^ Constructor
 184               -> [JSValue]              -- ^ Single argument
 185               -> Result (Filter a)
 186 readFilterArg constr [flt] = constr <$> readJSON flt
 187 readFilterArg _ v = Error $ "Cannot deserialise field, expected [filter]" ++
 188                             " but got " ++ show (pp_value (showJSON v))
 189
 190 -- | Helper to deserialise an array corresponding to a single field
 191 -- and return the built filter.
 192 readFilterField :: (JSON a) =>
 193                    (a -> Filter a)   -- ^ Constructor
 194                 -> [JSValue]         -- ^ Single argument
 195                 -> Result (Filter a)
 196 readFilterField constr [field] = constr <$> readJSON field
 197 readFilterField _ v = Error $ "Cannot deserialise field, expected" ++
 198                               " [fieldname] but got " ++
 199                               show (pp_value (showJSON v))
 200
 201 -- | Helper to deserialise an array corresponding to a field and
 202 -- value, returning the built filter.
 203 readFilterFieldValue :: (JSON a, JSON b) =>
 204                         (a -> b -> Filter a) -- ^ Constructor
 205                      -> [JSValue]            -- ^ Arguments array
 206                      -> Result (Filter a)
 207 readFilterFieldValue constr [field, value] =
 208   constr <$> readJSON field <*> readJSON value
 209 readFilterFieldValue _ v =
 210   Error $ "Cannot deserialise field/value pair, expected [fieldname, value]" ++
 211           " but got " ++ show (pp_value (showJSON v))
 212
 213 -- | Inner deserialiser for 'Filter'.
 214 readFilterArray :: (JSON a) => String -> [JSValue] -> Result (Filter a)
 215 readFilterArray op args
 216   | op == C.qlangOpAnd      = AndFilter <$> mapM readJSON args
 217   | op == C.qlangOpOr       = OrFilter  <$> mapM readJSON args
 218   | op == C.qlangOpNot      = readFilterArg        NotFilter args
 219   | op == C.qlangOpTrue     = readFilterField      TrueFilter args
 220   | op == C.qlangOpEqual    = readFilterFieldValue EQFilter args
 221   | op == C.qlangOpLt       = readFilterFieldValue LTFilter args
 222   | op == C.qlangOpGt       = readFilterFieldValue GTFilter args
 223   | op == C.qlangOpLe       = readFilterFieldValue LEFilter args
 224   | op == C.qlangOpGe       = readFilterFieldValue GEFilter args
 225   | op == C.qlangOpRegexp   = readFilterFieldValue RegexpFilter args
 226   | op == C.qlangOpContains = readFilterFieldValue ContainsFilter args
 227   | otherwise = Error $ "Unknown filter operand '" ++ op ++ "'"
 228
 229 instance (JSON a) => JSON (Filter a) where
 230   showJSON = showFilter
 231   readJSON = readFilter
 232
 233 -- Traversable implementation for 'Filter'.
 234 traverseFlt :: (Applicative f) => (a -> f b) -> Filter a -> f (Filter b)
 235 traverseFlt _ EmptyFilter       = pure EmptyFilter
 236 traverseFlt f (AndFilter flts)  = AndFilter <$> traverse (traverseFlt f) flts
 237 traverseFlt f (OrFilter  flts)  = OrFilter  <$> traverse (traverseFlt f) flts
 238 traverseFlt f (NotFilter flt)   = NotFilter <$> traverseFlt f flt
 239 traverseFlt f (TrueFilter a)    = TrueFilter <$> f a
 240 traverseFlt f (EQFilter a fval) = EQFilter <$> f a <*> pure fval
 241 traverseFlt f (LTFilter a fval) = LTFilter <$> f a <*> pure fval
 242 traverseFlt f (GTFilter a fval) = GTFilter <$> f a <*> pure fval
 243 traverseFlt f (LEFilter a fval) = LEFilter <$> f a <*> pure fval
 244 traverseFlt f (GEFilter a fval) = GEFilter <$> f a <*> pure fval
 245 traverseFlt f (RegexpFilter a re)     = RegexpFilter <$> f a <*> pure re
 246 traverseFlt f (ContainsFilter a fval) = ContainsFilter <$> f a <*> pure fval
 247
 248 instance Traversable Filter where
 249   traverse = traverseFlt
 250
 251 instance Functor Filter where
 252   fmap = fmapDefault
 253
 254 instance Foldable Filter where
 255   foldMap = foldMapDefault
 256
 257 -- | Field name to filter on.
 258 type FilterField = String
 259
 260 -- | Value to compare the field value to, for filtering purposes.
 261 data FilterValue = QuotedString String
 262                  | NumericValue Integer
 263                    deriving (Read, Show, Eq)
 264
 265 -- | Serialiser for 'FilterValue'. The Python code just sends this to
 266 -- JSON as-is, so we'll do the same.
 267 showFilterValue :: FilterValue -> JSValue
 268 showFilterValue (QuotedString str) = showJSON str
 269 showFilterValue (NumericValue val) = showJSON val
 270
 271 -- | Decoder for 'FilterValue'. We have to see what it contains, since
 272 -- the context doesn't give us hints on what to expect.
 273 readFilterValue :: JSValue -> Result FilterValue
 274 readFilterValue (JSString a) = Ok . QuotedString $ fromJSString a
 275 readFilterValue (JSRational _ x) =
 276   if denominator x /= 1
 277     then Error $ "Cannot deserialise numeric filter value," ++
 278                  " expecting integral but got a fractional value: " ++
 279                  show x
 280     else Ok . NumericValue $ numerator x
 281 readFilterValue v = Error $ "Cannot deserialise filter value, expecting" ++
 282                             " string or integer, got " ++ show (pp_value v)
 283
 284 instance JSON FilterValue where
 285   showJSON = showFilterValue
 286   readJSON = readFilterValue
 287
 288 -- | Regexp to apply to the filter value, for filtering purposes. It
 289 -- holds both the string format, and the \"compiled\" format, so that
 290 -- we don't re-compile the regex at each match attempt.
 291 data FilterRegex = FilterRegex
 292   { stringRegex   :: String      -- ^ The string version of the regex
 293   , compiledRegex :: RegexType   -- ^ The compiled regex
 294   }
 295
 296 -- | Builder for 'FilterRegex'. We always attempt to compile the
 297 -- regular expression on the initialisation of the data structure;
 298 -- this might fail, if the RE is not well-formed.
 299 mkRegex :: (Monad m) => String -> m FilterRegex
 300 #ifndef NO_REGEX_PCRE
 301 mkRegex str = do
 302   compiled <- case PCRE.getVersion of
 303                 Nothing -> fail $ "regex-pcre library compiled without" ++
 304                                   " libpcre, regex functionality not available"
 305                 _ -> PCRE.makeRegexM str
 306   return $ FilterRegex str compiled
 307 #else
 308 mkRegex _ =
 309   fail $ "regex-pcre not found at compile time," ++
 310          " regex functionality not available"
 311 #endif
 312
 313 -- | 'Show' instance: we show the constructor plus the string version
 314 -- of the regex.
 315 instance Show FilterRegex where
 316   show (FilterRegex re _) = "mkRegex " ++ show re
 317
 318 -- | 'Read' instance: we manually read \"mkRegex\" followed by a
 319 -- string, and build the 'FilterRegex' using that.
 320 instance Read FilterRegex where
 321   readsPrec _ str = do
 322     ("mkRegex", s') <- lex str
 323     (re, s'') <- reads s'
 324     filterre <- mkRegex re
 325     return (filterre, s'')
 326
 327 -- | 'Eq' instance: we only compare the string versions of the regexes.
 328 instance Eq FilterRegex where
 329   (FilterRegex re1 _) == (FilterRegex re2 _) = re1 == re2
 330
 331 -- | 'JSON' instance: like for show and read instances, we work only
 332 -- with the string component.
 333 instance JSON FilterRegex where
 334   showJSON (FilterRegex re _) = showJSON re
 335   readJSON s = do
 336     re <- readJSON s
 337     mkRegex re
 338
 339 -- | Name of a field.
 340 type FieldName = String
 341 -- | Title of a field, when represented in tabular format.
 342 type FieldTitle = String
 343 -- | Human redable description of a field.
 344 type FieldDoc = String
 345
 346 -- | Definition of a field.
 347 $(buildObject "FieldDefinition" "fdef"
 348   [ simpleField "name"  [t| FieldName  |] -- FIXME: the name has restrictions
 349   , simpleField "title" [t| FieldTitle |]
 350   , simpleField "kind"  [t| FieldType  |]
 351   , simpleField "doc"   [t| FieldDoc   |]
 352   ])
 353
 354 --- | Single field entry result.
 355 data ResultEntry = ResultEntry
 356   { rentryStatus :: ResultStatus      -- ^ The result status
 357   , rentryValue  :: Maybe ResultValue -- ^ The (optional) result value
 358   } deriving (Show, Read, Eq)
 359
 360 instance JSON ResultEntry where
 361   showJSON (ResultEntry rs rv) =
 362     showJSON (showJSON rs, maybe JSNull showJSON rv)
 363   readJSON v = do
 364     (rs, rv) <- readJSON v
 365     rv' <- case rv of
 366              JSNull -> return Nothing
 367              x -> Just <$> readJSON x
 368     return $ ResultEntry rs rv'
 369
 370 -- | The type of one result row.
 371 type ResultRow = [ ResultEntry ]
 372
 373 -- | Value of a field, in json encoding.
 374 -- (its type will be depending on ResultStatus and FieldType)
 375 type ResultValue = JSValue
 376
 377 -- * Main Qlang queries and responses.
 378
 379 -- | Query2 query.
 380 data Query = Query ItemType Fields (Filter FilterField)
 381
 382 -- | Query2 result.
 383 $(buildObject "QueryResult" "qres"
 384   [ simpleField "fields" [t| [ FieldDefinition ] |]
 385   , simpleField "data"   [t| [ ResultRow       ] |]
 386   ])
 387
 388 -- | Query2 Fields query.
 389 -- (to get supported fields names, descriptions, and types)
 390 data QueryFields = QueryFields ItemType Fields
 391
 392 -- | Query2 Fields result.
 393 $(buildObject "QueryFieldsResult" "qfieldres"
 394   [ simpleField "fields" [t| [FieldDefinition ] |]
 395   ])