Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Qlang.hs @ 4cbe9bda

History | View | Annotate | Download (10.5 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
    , FieldType(..)
37
    , FieldDefinition(..)
38
    , ResultEntry(..)
39
    , ResultStatus(..)
40
    , ItemType(..)
41
    , checkRS
42
    ) where
43

    
44
import Control.Applicative
45
import Data.Ratio (numerator, denominator)
46
import Text.JSON.Pretty (pp_value)
47
import Text.JSON.Types
48
import Text.JSON
49

    
50
import qualified Ganeti.Constants as C
51
import Ganeti.THH
52
import Ganeti.HTools.JSON
53

    
54
-- * THH declarations, that require ordering.
55

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

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

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

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

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

    
102
-- | List of requested fields.
103
type Fields = [ String ]
104

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

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

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

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

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

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

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

    
203
instance JSON Filter where
204
  showJSON = showFilter
205
  readJSON = readFilter
206

    
207
-- | Field name to filter on.
208
type FilterField = String
209

    
210
-- | Value to compare the field value to, for filtering purposes.
211
data FilterValue = QuotedString String
212
                 | NumericValue Integer
213
                   deriving (Read, Show, Eq)
214

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

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

    
234
instance JSON FilterValue where
235
  showJSON = showFilterValue
236
  readJSON = readFilterValue
237

    
238
-- | Regexp to apply to the filter value, for filteriong purposes.
239
type FilterRegexp = String
240

    
241
-- | Name of a field.
242
type FieldName = String
243
-- | Title of a field, when represented in tabular format.
244
type FieldTitle = String
245
-- | Human redable description of a field.
246
type FieldDoc = String
247

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

    
256
--- | Single field entry result.
257
data ResultEntry = ResultEntry ResultStatus (Maybe ResultValue)
258
                   deriving (Show, Read, Eq)
259

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

    
270
-- | The type of one result row.
271
type ResultRow = [ ResultEntry ]
272

    
273
-- | Value of a field, in json encoding.
274
-- (its type will be depending on ResultStatus and FieldType)
275
type ResultValue = JSValue
276

    
277
-- * Main Qlang queries and responses.
278

    
279
-- | Query2 query.
280
data Query = Query ItemType Fields Filter
281

    
282
-- | Query2 result.
283
$(buildObject "QueryResult" "qres"
284
  [ simpleField "fields" [t| [ FieldDefinition ] |]
285
  , simpleField "data"   [t| [ ResultRow       ] |]
286
  ])
287

    
288
-- | Query2 Fields query.
289
-- (to get supported fields names, descriptions, and types)
290
data QueryFields = QueryFields ItemType Fields
291

    
292
-- | Query2 Fields result.
293
data QueryFieldsResult = QueryFieldsResult [ FieldDefinition ]