Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Qlang.hs @ 046fe3f5

History | View | Annotate | Download (10.6 kB)

1
{-# LANGUAGE TemplateHaskell #-}
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.Qlang
29
    ( Filter(..)
30
    , FilterValue(..)
31
    , Fields
32
    , Query(..)
33
    , QueryResult(..)
34
    , QueryFields(..)
35
    , QueryFieldsResult(..)
36
    , FieldName
37
    , FieldTitle
38
    , FieldType(..)
39
    , FieldDoc
40
    , FieldDefinition(..)
41
    , ResultEntry(..)
42
    , ResultStatus(..)
43
    , ResultValue
44
    , ItemType(..)
45
    , checkRS
46
    ) where
47

    
48
import Control.Applicative
49
import Data.Ratio (numerator, denominator)
50
import Text.JSON.Pretty (pp_value)
51
import Text.JSON.Types
52
import Text.JSON
53

    
54
import qualified Ganeti.Constants as C
55
import Ganeti.THH
56
import Ganeti.HTools.JSON
57

    
58
-- * THH declarations, that require ordering.
59

    
60
-- | Status of a query field.
61
$(declareIADT "ResultStatus"
62
  [ ("RSNormal",  'C.rsNormal )
63
  , ("RSUnknown", 'C.rsUnknown )
64
  , ("RSNoData",  'C.rsNodata )
65
  , ("RSUnavail", 'C.rsUnavail )
66
  , ("RSOffline", 'C.rsOffline )
67
  ])
68
$(makeJSONInstance ''ResultStatus)
69

    
70
-- | Check that ResultStatus is success or fail with descriptive
71
-- message.
72
checkRS :: (Monad m) => ResultStatus -> a -> m a
73
checkRS RSNormal val = return val
74
checkRS RSUnknown  _ = fail "Unknown field"
75
checkRS RSNoData   _ = fail "No data for a field"
76
checkRS RSUnavail  _ = fail "Ganeti reports unavailable data"
77
checkRS RSOffline  _ = fail "Ganeti reports resource as offline"
78

    
79
-- | Type of a query field.
80
$(declareSADT "FieldType"
81
  [ ("QFTUnknown",   'C.qftUnknown )
82
  , ("QFTText",      'C.qftText )
83
  , ("QFTBool",      'C.qftBool )
84
  , ("QFTNumber",    'C.qftNumber )
85
  , ("QFTUnit",      'C.qftUnit )
86
  , ("QFTTimestamp", 'C.qftTimestamp )
87
  , ("QFTOther",     'C.qftOther )
88
  ])
89
$(makeJSONInstance ''FieldType)
90

    
91
-- | Supported items on which Qlang works.
92
$(declareSADT "ItemType"
93
  [ ("QRCluster",  'C.qrCluster )
94
  , ("QRInstance", 'C.qrInstance )
95
  , ("QRNode",     'C.qrNode )
96
  , ("QRLock",     'C.qrLock )
97
  , ("QRGroup",    'C.qrGroup )
98
  , ("QROs",       'C.qrOs )
99
  , ("QRJob",      'C.qrJob )
100
  , ("QRExport",   'C.qrExport )
101
  ])
102
$(makeJSONInstance ''ItemType)
103

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

    
106
-- | List of requested fields.
107
type Fields = [ String ]
108

    
109
-- | Query2 filter expression.
110
data Filter
111
    = EmptyFilter                             -- ^ No filter at all
112
    | AndFilter      [ Filter ]               -- ^ & [<expression>, ...]
113
    | OrFilter       [ Filter ]               -- ^ | [<expression>, ...]
114
    | NotFilter      Filter                   -- ^ ! <expression>
115
    | TrueFilter     FilterField              -- ^ ? <field>
116
    | EQFilter       FilterField FilterValue  -- ^ (=|!=) <field> <value>
117
    | LTFilter       FilterField FilterValue  -- ^ < <field> <value>
118
    | GTFilter       FilterField FilterValue  -- ^ > <field> <value>
119
    | LEFilter       FilterField FilterValue  -- ^ <= <field> <value>
120
    | GEFilter       FilterField FilterValue  -- ^ >= <field> <value>
121
    | RegexpFilter   FilterField FilterRegexp -- ^ =~ <field> <regexp>
122
    | ContainsFilter FilterField FilterValue  -- ^ =[] <list-field> <value>
123
      deriving (Show, Read, Eq)
124

    
125
-- | Serialiser for the 'Filter' data type.
126
showFilter :: Filter -> JSValue
127
showFilter (EmptyFilter)          = JSNull
128
showFilter (AndFilter exprs)      =
129
  JSArray $ (showJSON C.qlangOpAnd):(map showJSON exprs)
130
showFilter (OrFilter  exprs)      =
131
  JSArray $ (showJSON C.qlangOpOr):(map showJSON exprs)
132
showFilter (NotFilter flt)        =
133
  JSArray [showJSON C.qlangOpNot, showJSON flt]
134
showFilter (TrueFilter field)     =
135
  JSArray [showJSON C.qlangOpTrue, showJSON field]
136
showFilter (EQFilter field value) =
137
  JSArray [showJSON C.qlangOpEqual, showJSON field, showJSON value]
138
showFilter (LTFilter field value) =
139
  JSArray [showJSON C.qlangOpLt, showJSON field, showJSON value]
140
showFilter (GTFilter field value) =
141
  JSArray [showJSON C.qlangOpGt, showJSON field, showJSON value]
142
showFilter (LEFilter field value) =
143
  JSArray [showJSON C.qlangOpLe, showJSON field, showJSON value]
144
showFilter (GEFilter field value) =
145
  JSArray [showJSON C.qlangOpGe, showJSON field, showJSON value]
146
showFilter (RegexpFilter field regexp) =
147
  JSArray [showJSON C.qlangOpRegexp, showJSON field, showJSON regexp]
148
showFilter (ContainsFilter field value) =
149
  JSArray [showJSON C.qlangOpContains, showJSON field, showJSON value]
150

    
151
-- | Deserializer for the 'Filter' data type.
152
readFilter :: JSValue -> Result Filter
153
readFilter JSNull = Ok EmptyFilter
154
readFilter (JSArray (JSString op:args)) =
155
  readFilterArray (fromJSString op) args
156
readFilter v =
157
  Error $ "Cannot deserialise filter: expected array [string, args], got " ++
158
        show (pp_value v)
159

    
160
-- | Helper to deserialise an array corresponding to a single filter
161
-- and return the built filter. Note this looks generic but is (at
162
-- least currently) only used for the NotFilter.
163
readFilterArg :: (Filter -> Filter) -- ^ Constructor
164
              -> [JSValue]          -- ^ Single argument
165
              -> Result Filter
166
readFilterArg constr [flt] = constr <$> readJSON flt
167
readFilterArg _ v = Error $ "Cannot deserialise field, expected [filter]\
168
                            \ but got " ++ show (pp_value (showJSON v))
169

    
170
-- | Helper to deserialise an array corresponding to a single field
171
-- and return the built filter.
172
readFilterField :: (FilterField -> Filter) -- ^ Constructor
173
                -> [JSValue]               -- ^ Single argument
174
                -> Result Filter
175
readFilterField constr [field] = constr <$> readJSON field
176
readFilterField _ v = Error $ "Cannot deserialise field, expected [fieldname]\
177
                              \ but got " ++ show (pp_value (showJSON v))
178

    
179
-- | Helper to deserialise an array corresponding to a field and
180
-- value, returning the built filter.
181
readFilterFieldValue :: (JSON a) =>
182
                        (FilterField -> a -> Filter) -- ^ Constructor
183
                     -> [JSValue] -- ^ Arguments array
184
                     -> Result Filter
185
readFilterFieldValue constr [field, value] =
186
  constr <$> readJSON field <*> readJSON value
187
readFilterFieldValue _ v =
188
  Error $ "Cannot deserialise field/value pair, expected [fieldname, value]\
189
          \ but got " ++ show (pp_value (showJSON v))
190

    
191
-- | Inner deserialiser for 'Filter'.
192
readFilterArray :: String -> [JSValue] -> Result Filter
193
readFilterArray op args
194
  | op == C.qlangOpAnd      = AndFilter <$> mapM readJSON args
195
  | op == C.qlangOpOr       = OrFilter  <$> mapM readJSON args
196
  | op == C.qlangOpNot      = readFilterArg        NotFilter args
197
  | op == C.qlangOpTrue     = readFilterField      TrueFilter args
198
  | op == C.qlangOpEqual    = readFilterFieldValue EQFilter args
199
  | op == C.qlangOpLt       = readFilterFieldValue LTFilter args
200
  | op == C.qlangOpGt       = readFilterFieldValue GTFilter args
201
  | op == C.qlangOpLe       = readFilterFieldValue LEFilter args
202
  | op == C.qlangOpGe       = readFilterFieldValue GEFilter args
203
  | op == C.qlangOpRegexp   = readFilterFieldValue RegexpFilter args
204
  | op == C.qlangOpContains = readFilterFieldValue ContainsFilter args
205
  | otherwise = Error $ "Unknown filter operand '" ++ op ++ "'"
206

    
207
instance JSON Filter where
208
  showJSON = showFilter
209
  readJSON = readFilter
210

    
211
-- | Field name to filter on.
212
type FilterField = String
213

    
214
-- | Value to compare the field value to, for filtering purposes.
215
data FilterValue = QuotedString String
216
                 | NumericValue Integer
217
                   deriving (Read, Show, Eq)
218

    
219
-- | Serialiser for 'FilterValue'. The Python code just sends this to
220
-- JSON as-is, so we'll do the same.
221
showFilterValue :: FilterValue -> JSValue
222
showFilterValue (QuotedString str) = showJSON str
223
showFilterValue (NumericValue val) = showJSON val
224

    
225
-- | Decoder for 'FilterValue'. We have to see what it contains, since
226
-- the context doesn't give us hints on what to expect.
227
readFilterValue :: JSValue -> Result FilterValue
228
readFilterValue (JSString a) = Ok . QuotedString $ fromJSString a
229
readFilterValue (JSRational _ x) =
230
  if denominator x /= 1
231
    then Error $ "Cannot deserialise numeric filter value,\
232
                 \ expecting integral but\
233
                 \ got a fractional value: " ++ show x
234
    else Ok . NumericValue $ numerator x
235
readFilterValue v = Error $ "Cannot deserialise filter value, expecting\
236
                            \ string or integer, got " ++ show (pp_value v)
237

    
238
instance JSON FilterValue where
239
  showJSON = showFilterValue
240
  readJSON = readFilterValue
241

    
242
-- | Regexp to apply to the filter value, for filteriong purposes.
243
type FilterRegexp = String
244

    
245
-- | Name of a field.
246
type FieldName = String
247
-- | Title of a field, when represented in tabular format.
248
type FieldTitle = String
249
-- | Human redable description of a field.
250
type FieldDoc = String
251

    
252
-- | Definition of a field.
253
$(buildObject "FieldDefinition" "fdef"
254
  [ simpleField "name"  [t| FieldName  |] -- FIXME: the name has restrictions
255
  , simpleField "title" [t| FieldTitle |]
256
  , simpleField "kind"  [t| FieldType  |]
257
  , simpleField "doc"   [t| FieldDoc   |]
258
  ])
259

    
260
--- | Single field entry result.
261
data ResultEntry = ResultEntry ResultStatus (Maybe ResultValue)
262
                   deriving (Show, Read, Eq)
263

    
264
instance JSON ResultEntry where
265
  showJSON (ResultEntry rs rv) =
266
    showJSON (showJSON rs, maybe JSNull showJSON rv)
267
  readJSON v = do
268
    (rs, rv) <- readJSON v
269
    rv' <- case rv of
270
             JSNull -> return Nothing
271
             x -> readJSON x
272
    return $ ResultEntry rs rv'
273

    
274
-- | The type of one result row.
275
type ResultRow = [ ResultEntry ]
276

    
277
-- | Value of a field, in json encoding.
278
-- (its type will be depending on ResultStatus and FieldType)
279
type ResultValue = JSValue
280

    
281
-- * Main Qlang queries and responses.
282

    
283
-- | Query2 query.
284
data Query = Query ItemType Fields Filter
285

    
286
-- | Query2 result.
287
$(buildObject "QueryResult" "qres"
288
  [ simpleField "fields" [t| [ FieldDefinition ] |]
289
  , simpleField "data"   [t| [ ResultRow       ] |]
290
  ])
291

    
292
-- | Query2 Fields query.
293
-- (to get supported fields names, descriptions, and types)
294
data QueryFields = QueryFields ItemType Fields
295

    
296
-- | Query2 Fields result.
297
data QueryFieldsResult = QueryFieldsResult [ FieldDefinition ]