Language.hs 13.8 KB
Newer Older
Guido Trotter's avatar
Guido Trotter committed
1
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
{-# 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.

-}

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
    , checkRS
Guido Trotter's avatar
Guido Trotter committed
51
52
    ) where

53
import Control.Applicative
Iustin Pop's avatar
Iustin Pop committed
54
55
import Data.Foldable
import Data.Traversable (Traversable, traverse, fmapDefault, foldMapDefault)
56
57
import Data.Ratio (numerator, denominator)
import Text.JSON.Pretty (pp_value)
Guido Trotter's avatar
Guido Trotter committed
58
59
import Text.JSON.Types
import Text.JSON
60
import qualified Text.Regex.PCRE as PCRE
Guido Trotter's avatar
Guido Trotter committed
61
62
63

import qualified Ganeti.Constants as C
import Ganeti.THH
64
import Ganeti.JSON
Guido Trotter's avatar
Guido Trotter committed
65
66
67
68
69
70
71
72
73
74
75
76
77

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

78
79
80
81
82
83
84
85
86
-- | 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
87
88
89
90
91
92
93
94
95
96
97
98
-- | 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)

Iustin Pop's avatar
Iustin Pop committed
99
-- | Supported items on which Qlang works.
Guido Trotter's avatar
Guido Trotter committed
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
$(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 ]

Iustin Pop's avatar
Iustin Pop committed
117
118
119
120
121
122
123
124
125
126
127
128
129
130
-- | 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>
131
    | RegexpFilter   a FilterRegex  -- ^ =~ <field> <regexp>
Iustin Pop's avatar
Iustin Pop committed
132
    | ContainsFilter a FilterValue  -- ^ =[] <list-field> <value>
133
134
135
      deriving (Show, Read, Eq)

-- | Serialiser for the 'Filter' data type.
Iustin Pop's avatar
Iustin Pop committed
136
showFilter :: (JSON a) => Filter a -> JSValue
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
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.
Iustin Pop's avatar
Iustin Pop committed
162
readFilter :: (JSON a) => JSValue -> Result (Filter a)
163
164
165
166
167
168
169
170
171
172
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
173
174
175
176
readFilterArg :: (JSON a) =>
                 (Filter a -> Filter a) -- ^ Constructor
              -> [JSValue]              -- ^ Single argument
              -> Result (Filter a)
177
178
179
180
181
182
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.
Iustin Pop's avatar
Iustin Pop committed
183
184
185
186
readFilterField :: (JSON a) =>
                   (a -> Filter a)   -- ^ Constructor
                -> [JSValue]         -- ^ Single argument
                -> Result (Filter a)
187
188
189
190
191
192
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.
Iustin Pop's avatar
Iustin Pop committed
193
194
195
196
readFilterFieldValue :: (JSON a, JSON b) =>
                        (a -> b -> Filter a) -- ^ Constructor
                     -> [JSValue]            -- ^ Arguments array
                     -> Result (Filter a)
197
198
199
200
201
202
203
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'.
Iustin Pop's avatar
Iustin Pop committed
204
readFilterArray :: (JSON a) => String -> [JSValue] -> Result (Filter a)
205
206
207
208
209
210
211
212
213
214
215
216
217
218
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
219
instance (JSON a) => JSON (Filter a) where
220
221
  showJSON = showFilter
  readJSON = readFilter
Guido Trotter's avatar
Guido Trotter committed
222

Iustin Pop's avatar
Iustin Pop committed
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
-- 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

Guido Trotter's avatar
Guido Trotter committed
247
248
249
250
-- | Field name to filter on.
type FilterField = String

-- | Value to compare the field value to, for filtering purposes.
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
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
Guido Trotter's avatar
Guido Trotter committed
277

278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
-- | 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
  , compiledRegex :: PCRE.Regex  -- ^ The compiled regex
  }

-- | 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
mkRegex str = do
  compiled <- case PCRE.getVersion of
                Nothing -> fail "regex-pcre library compiled without\
                                \ libpcre, regex functionality not available"
                _ -> PCRE.makeRegexM str
  return $ FilterRegex str compiled

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

-- | 'Read' instance: we manually read \"mkRegex\" followed by a
-- string, and build the 'FilterRegex' using that.
instance Read FilterRegex where
  readsPrec _ str = do
    ("mkRegex", s') <- lex str
    (re, s'') <- reads s'
    filterre <- mkRegex re
    return (filterre, s'')

-- | '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
  readJSON s = do
    re <- readJSON s
    mkRegex re
Guido Trotter's avatar
Guido Trotter committed
322
323
324
325
326
327
328
329

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

330
331
332
333
334
335
336
337
-- | 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
338
--- | Single field entry result.
339
340
341
342
data ResultEntry = ResultEntry
  { rentryStatus :: ResultStatus      -- ^ The result status
  , rentryValue  :: Maybe ResultValue -- ^ The (optional) result value
  } deriving (Show, Read, Eq)
343
344
345
346
347
348
349
350
351
352
353
354
355

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 ]
Guido Trotter's avatar
Guido Trotter committed
356
357
358
359

-- | Value of a field, in json encoding.
-- (its type will be depending on ResultStatus and FieldType)
type ResultValue = JSValue
360
361
362
363

-- * Main Qlang queries and responses.

-- | Query2 query.
Iustin Pop's avatar
Iustin Pop committed
364
data Query = Query ItemType Fields (Filter FilterField)
365
366
367
368
369
370
371
372
373
374
375
376

-- | 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
377
378
379
$(buildObject "QueryFieldsResult" "qfieldres"
  [ simpleField "fields" [t| [FieldDefinition ] |]
  ])