Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Query / Language.hs @ e78a8c0b

History | View | Annotate | Download (15.2 kB)

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
  ])