Language.hs 15.2 KB
Newer Older
1
{-# LANGUAGE TemplateHaskell, CPP #-}
Guido Trotter's avatar
Guido Trotter committed
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

{-| 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.

-}

28
module Ganeti.Query.Language
29
    ( Filter(..)
Iustin Pop's avatar
Iustin Pop committed
30
    , FilterField
31
    , FilterValue(..)
32
33
34
35
    , FilterRegex -- note: we don't export the constructor, must use helpers
    , mkRegex
    , stringRegex
    , compiledRegex
36
    , Fields
37
38
39
40
    , Query(..)
    , QueryResult(..)
    , QueryFields(..)
    , QueryFieldsResult(..)
41
42
    , FieldName
    , FieldTitle
43
    , FieldType(..)
44
    , FieldDoc
45
46
    , FieldDefinition(..)
    , ResultEntry(..)
47
    , ResultStatus(..)
48
    , ResultValue
Iustin Pop's avatar
Iustin Pop committed
49
    , ItemType(..)
50
    , QueryTypeOp(..)
Iustin Pop's avatar
Iustin Pop committed
51
    , queryTypeOpToRaw
52
    , QueryTypeLuxi(..)
53
    , checkRS
Guido Trotter's avatar
Guido Trotter committed
54
55
    ) where

56
import Control.Applicative
57
import Control.DeepSeq
Iustin Pop's avatar
Iustin Pop committed
58
59
import Data.Foldable
import Data.Traversable (Traversable, traverse, fmapDefault, foldMapDefault)
60
61
import Data.Ratio (numerator, denominator)
import Text.JSON.Pretty (pp_value)
Guido Trotter's avatar
Guido Trotter committed
62
63
import Text.JSON.Types
import Text.JSON
64
#ifndef NO_REGEX_PCRE
65
import qualified Text.Regex.PCRE as PCRE
66
#endif
Guido Trotter's avatar
Guido Trotter committed
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82

import qualified Ganeti.Constants as C
import Ganeti.THH

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

83
84
85
86
-- | No-op 'NFData' instance for 'ResultStatus', since it's a single
-- constructor data-type.
instance NFData ResultStatus

87
88
89
90
91
92
93
94
95
-- | 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"

Guido Trotter's avatar
Guido Trotter committed
96
97
98
99
100
101
-- | Type of a query field.
$(declareSADT "FieldType"
  [ ("QFTUnknown",   'C.qftUnknown )
  , ("QFTText",      'C.qftText )
  , ("QFTBool",      'C.qftBool )
  , ("QFTNumber",    'C.qftNumber )
Klaus Aehlig's avatar
Klaus Aehlig committed
102
  , ("QFTNumberFloat", 'C.qftNumberFloat )
Guido Trotter's avatar
Guido Trotter committed
103
104
105
106
107
108
  , ("QFTUnit",      'C.qftUnit )
  , ("QFTTimestamp", 'C.qftTimestamp )
  , ("QFTOther",     'C.qftOther )
  ])
$(makeJSONInstance ''FieldType)

Iustin Pop's avatar
Iustin Pop committed
109
-- | Supported items on which Qlang works.
110
$(declareSADT "QueryTypeOp"
Guido Trotter's avatar
Guido Trotter committed
111
112
113
114
115
116
  [ ("QRCluster",  'C.qrCluster )
  , ("QRInstance", 'C.qrInstance )
  , ("QRNode",     'C.qrNode )
  , ("QRGroup",    'C.qrGroup )
  , ("QROs",       'C.qrOs )
  , ("QRExport",   'C.qrExport )
117
  , ("QRNetwork",  'C.qrNetwork )
Guido Trotter's avatar
Guido Trotter committed
118
  ])
119
120
121
122
123
124
125
126
127
128
129
130
$(makeJSONInstance ''QueryTypeOp)

-- | Supported items on which Qlang works.
$(declareSADT "QueryTypeLuxi"
  [ ("QRLock",     'C.qrLock )
  , ("QRJob",      'C.qrJob )
  ])
$(makeJSONInstance ''QueryTypeLuxi)

-- | Overall query type.
data ItemType = ItemTypeLuxi QueryTypeLuxi
              | ItemTypeOpCode QueryTypeOp
131
                deriving (Show, Eq)
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153

-- | Custom JSON decoder for 'ItemType'.
decodeItemType :: (Monad m) => JSValue -> m ItemType
decodeItemType (JSString s) =
  case queryTypeOpFromRaw s' of
    Just v -> return $ ItemTypeOpCode v
    Nothing ->
      case queryTypeLuxiFromRaw s' of
        Just v -> return $ ItemTypeLuxi v
        Nothing ->
          fail $ "Can't parse value '" ++ s' ++ "' as neither"
                 ++ "QueryTypeLuxi nor QueryTypeOp"
  where s' = fromJSString s
decodeItemType v = fail $ "Invalid value '" ++ show (pp_value v) ++
                   "for query type"

-- | Custom JSON instance for 'ItemType' since its encoding is not
-- consistent with the data type itself.
instance JSON ItemType where
  showJSON (ItemTypeLuxi x)  = showJSON x
  showJSON (ItemTypeOpCode y) = showJSON y
  readJSON = decodeItemType
Guido Trotter's avatar
Guido Trotter committed
154
155
156

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

157
158
159
160
161
162
163
-- | Internal type of a regex expression (not exported).
#ifndef NO_REGEX_PCRE
type RegexType = PCRE.Regex
#else
type RegexType = ()
#endif

Guido Trotter's avatar
Guido Trotter committed
164
165
166
-- | List of requested fields.
type Fields = [ String ]

Iustin Pop's avatar
Iustin Pop committed
167
168
169
170
171
-- | 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
172
173
174
175
176
177
178
179
180
181
182
    | 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 FilterRegex  -- ^ @=~@ /field/ /regexp/
    | ContainsFilter a FilterValue  -- ^ @=[]@ /list-field/ /value/
183
      deriving (Show, Eq)
184
185

-- | Serialiser for the 'Filter' data type.
Iustin Pop's avatar
Iustin Pop committed
186
showFilter :: (JSON a) => Filter a -> JSValue
187
188
showFilter (EmptyFilter)          = JSNull
showFilter (AndFilter exprs)      =
Iustin Pop's avatar
Iustin Pop committed
189
  JSArray $ showJSON C.qlangOpAnd : map showJSON exprs
190
showFilter (OrFilter  exprs)      =
Iustin Pop's avatar
Iustin Pop committed
191
  JSArray $ showJSON C.qlangOpOr : map showJSON exprs
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
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.
Iustin Pop's avatar
Iustin Pop committed
212
readFilter :: (JSON a) => JSValue -> Result (Filter a)
213
214
215
216
217
218
219
220
221
222
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.
Iustin Pop's avatar
Iustin Pop committed
223
224
225
226
readFilterArg :: (JSON a) =>
                 (Filter a -> Filter a) -- ^ Constructor
              -> [JSValue]              -- ^ Single argument
              -> Result (Filter a)
227
readFilterArg constr [flt] = constr <$> readJSON flt
228
229
readFilterArg _ v = Error $ "Cannot deserialise field, expected [filter]" ++
                            " but got " ++ show (pp_value (showJSON v))
230
231
232

-- | Helper to deserialise an array corresponding to a single field
-- and return the built filter.
Iustin Pop's avatar
Iustin Pop committed
233
234
235
236
readFilterField :: (JSON a) =>
                   (a -> Filter a)   -- ^ Constructor
                -> [JSValue]         -- ^ Single argument
                -> Result (Filter a)
237
readFilterField constr [field] = constr <$> readJSON field
238
239
240
readFilterField _ v = Error $ "Cannot deserialise field, expected" ++
                              " [fieldname] but got " ++
                              show (pp_value (showJSON v))
241
242
243

-- | Helper to deserialise an array corresponding to a field and
-- value, returning the built filter.
Iustin Pop's avatar
Iustin Pop committed
244
245
246
247
readFilterFieldValue :: (JSON a, JSON b) =>
                        (a -> b -> Filter a) -- ^ Constructor
                     -> [JSValue]            -- ^ Arguments array
                     -> Result (Filter a)
248
249
250
readFilterFieldValue constr [field, value] =
  constr <$> readJSON field <*> readJSON value
readFilterFieldValue _ v =
251
252
  Error $ "Cannot deserialise field/value pair, expected [fieldname, value]" ++
          " but got " ++ show (pp_value (showJSON v))
253
254

-- | Inner deserialiser for 'Filter'.
Iustin Pop's avatar
Iustin Pop committed
255
readFilterArray :: (JSON a) => String -> [JSValue] -> Result (Filter a)
256
257
258
259
260
261
262
263
264
265
266
267
268
269
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 ++ "'"

Iustin Pop's avatar
Iustin Pop committed
270
instance (JSON a) => JSON (Filter a) where
271
272
  showJSON = showFilter
  readJSON = readFilter
Guido Trotter's avatar
Guido Trotter committed
273

Iustin Pop's avatar
Iustin Pop committed
274
275
276
-- Traversable implementation for 'Filter'.
traverseFlt :: (Applicative f) => (a -> f b) -> Filter a -> f (Filter b)
traverseFlt _ EmptyFilter       = pure EmptyFilter
Iustin Pop's avatar
Iustin Pop committed
277
278
279
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
Iustin Pop's avatar
Iustin Pop committed
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
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

Guido Trotter's avatar
Guido Trotter committed
298
299
300
301
-- | Field name to filter on.
type FilterField = String

-- | Value to compare the field value to, for filtering purposes.
302
303
data FilterValue = QuotedString String
                 | NumericValue Integer
304
                   deriving (Show, Eq)
305
306
307
308
309
310
311
312
313
314
315
316
317

-- | 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
318
319
320
    then Error $ "Cannot deserialise numeric filter value," ++
                 " expecting integral but got a fractional value: " ++
                 show x
321
    else Ok . NumericValue $ numerator x
322
323
readFilterValue v = Error $ "Cannot deserialise filter value, expecting" ++
                            " string or integer, got " ++ show (pp_value v)
324
325
326
327

instance JSON FilterValue where
  showJSON = showFilterValue
  readJSON = readFilterValue
Guido Trotter's avatar
Guido Trotter committed
328

329
330
331
332
333
-- | Regexp to apply to the filter value, for filtering purposes. It
-- holds both the string format, and the \"compiled\" format, so that
-- we don't re-compile the regex at each match attempt.
data FilterRegex = FilterRegex
  { stringRegex   :: String      -- ^ The string version of the regex
334
  , compiledRegex :: RegexType   -- ^ The compiled regex
335
336
337
338
339
340
  }

-- | Builder for 'FilterRegex'. We always attempt to compile the
-- regular expression on the initialisation of the data structure;
-- this might fail, if the RE is not well-formed.
mkRegex :: (Monad m) => String -> m FilterRegex
341
#ifndef NO_REGEX_PCRE
342
343
mkRegex str = do
  compiled <- case PCRE.getVersion of
344
345
                Nothing -> fail $ "regex-pcre library compiled without" ++
                                  " libpcre, regex functionality not available"
346
347
                _ -> PCRE.makeRegexM str
  return $ FilterRegex str compiled
348
349
350
351
352
#else
mkRegex _ =
  fail $ "regex-pcre not found at compile time," ++
         " regex functionality not available"
#endif
353
354
355
356
357
358
359
360
361
362
363
364
365
366

-- | 'Show' instance: we show the constructor plus the string version
-- of the regex.
instance Show FilterRegex where
  show (FilterRegex re _) = "mkRegex " ++ show re

-- | 'Eq' instance: we only compare the string versions of the regexes.
instance Eq FilterRegex where
  (FilterRegex re1 _) == (FilterRegex re2 _) = re1 == re2

-- | 'JSON' instance: like for show and read instances, we work only
-- with the string component.
instance JSON FilterRegex where
  showJSON (FilterRegex re _) = showJSON re
367
  readJSON s = readJSON s >>= mkRegex
Guido Trotter's avatar
Guido Trotter committed
368
369
370
371
372
373
374
375

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

376
377
378
379
380
381
382
383
-- | 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   |]
  ])

Guido Trotter's avatar
Guido Trotter committed
384
--- | Single field entry result.
385
386
387
data ResultEntry = ResultEntry
  { rentryStatus :: ResultStatus      -- ^ The result status
  , rentryValue  :: Maybe ResultValue -- ^ The (optional) result value
388
  } deriving (Show, Eq)
389

390
391
392
instance NFData ResultEntry where
  rnf (ResultEntry rs rv) = rnf rs `seq` rnf rv

393
394
395
396
397
398
399
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
400
             x -> Just <$> readJSON x
401
402
403
404
    return $ ResultEntry rs rv'

-- | The type of one result row.
type ResultRow = [ ResultEntry ]
Guido Trotter's avatar
Guido Trotter committed
405
406
407
408

-- | Value of a field, in json encoding.
-- (its type will be depending on ResultStatus and FieldType)
type ResultValue = JSValue
409
410
411
412

-- * Main Qlang queries and responses.

-- | Query2 query.
Iustin Pop's avatar
Iustin Pop committed
413
data Query = Query ItemType Fields (Filter FilterField)
414
415
416
417
418
419
420
421
422
423
424
425

-- | 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.
Iustin Pop's avatar
Iustin Pop committed
426
427
428
$(buildObject "QueryFieldsResult" "qfieldres"
  [ simpleField "fields" [t| [FieldDefinition ] |]
  ])