Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Query / Language.hs @ 3b89cb1b

History | View | Annotate | Download (15.2 kB)

1 7ae97c33 Iustin Pop
{-# LANGUAGE TemplateHaskell, CPP #-}
2 ac13f473 Guido Trotter
3 ac13f473 Guido Trotter
{-| Implementation of the Ganeti Query2 language.
4 ac13f473 Guido Trotter
5 ac13f473 Guido Trotter
 -}
6 ac13f473 Guido Trotter
7 ac13f473 Guido Trotter
{-
8 ac13f473 Guido Trotter
9 ac13f473 Guido Trotter
Copyright (C) 2012 Google Inc.
10 ac13f473 Guido Trotter
11 ac13f473 Guido Trotter
This program is free software; you can redistribute it and/or modify
12 ac13f473 Guido Trotter
it under the terms of the GNU General Public License as published by
13 ac13f473 Guido Trotter
the Free Software Foundation; either version 2 of the License, or
14 ac13f473 Guido Trotter
(at your option) any later version.
15 ac13f473 Guido Trotter
16 ac13f473 Guido Trotter
This program is distributed in the hope that it will be useful, but
17 ac13f473 Guido Trotter
WITHOUT ANY WARRANTY; without even the implied warranty of
18 ac13f473 Guido Trotter
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19 ac13f473 Guido Trotter
General Public License for more details.
20 ac13f473 Guido Trotter
21 ac13f473 Guido Trotter
You should have received a copy of the GNU General Public License
22 ac13f473 Guido Trotter
along with this program; if not, write to the Free Software
23 ac13f473 Guido Trotter
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 ac13f473 Guido Trotter
02110-1301, USA.
25 ac13f473 Guido Trotter
26 ac13f473 Guido Trotter
-}
27 ac13f473 Guido Trotter
28 4cab6703 Iustin Pop
module Ganeti.Query.Language
29 b647b6d7 Iustin Pop
    ( Filter(..)
30 05ac718f Iustin Pop
    , FilterField
31 e8a25d62 Iustin Pop
    , FilterValue(..)
32 01606931 Iustin Pop
    , FilterRegex -- note: we don't export the constructor, must use helpers
33 01606931 Iustin Pop
    , mkRegex
34 01606931 Iustin Pop
    , stringRegex
35 01606931 Iustin Pop
    , compiledRegex
36 4cbe9bda Iustin Pop
    , Fields
37 b647b6d7 Iustin Pop
    , Query(..)
38 b647b6d7 Iustin Pop
    , QueryResult(..)
39 b647b6d7 Iustin Pop
    , QueryFields(..)
40 b647b6d7 Iustin Pop
    , QueryFieldsResult(..)
41 046fe3f5 Iustin Pop
    , FieldName
42 046fe3f5 Iustin Pop
    , FieldTitle
43 4cbe9bda Iustin Pop
    , FieldType(..)
44 046fe3f5 Iustin Pop
    , FieldDoc
45 b647b6d7 Iustin Pop
    , FieldDefinition(..)
46 b647b6d7 Iustin Pop
    , ResultEntry(..)
47 4cbe9bda Iustin Pop
    , ResultStatus(..)
48 046fe3f5 Iustin Pop
    , ResultValue
49 8a9ee1e9 Iustin Pop
    , ItemType(..)
50 1283cc38 Iustin Pop
    , QueryTypeOp(..)
51 ad1c1e41 Iustin Pop
    , queryTypeOpToRaw
52 1283cc38 Iustin Pop
    , QueryTypeLuxi(..)
53 62377cf5 Iustin Pop
    , checkRS
54 ac13f473 Guido Trotter
    ) where
55 ac13f473 Guido Trotter
56 e8a25d62 Iustin Pop
import Control.Applicative
57 13b17073 Iustin Pop
import Control.DeepSeq
58 05ac718f Iustin Pop
import Data.Foldable
59 05ac718f Iustin Pop
import Data.Traversable (Traversable, traverse, fmapDefault, foldMapDefault)
60 e8a25d62 Iustin Pop
import Data.Ratio (numerator, denominator)
61 e8a25d62 Iustin Pop
import Text.JSON.Pretty (pp_value)
62 ac13f473 Guido Trotter
import Text.JSON.Types
63 ac13f473 Guido Trotter
import Text.JSON
64 7ae97c33 Iustin Pop
#ifndef NO_REGEX_PCRE
65 01606931 Iustin Pop
import qualified Text.Regex.PCRE as PCRE
66 7ae97c33 Iustin Pop
#endif
67 ac13f473 Guido Trotter
68 ac13f473 Guido Trotter
import qualified Ganeti.Constants as C
69 ac13f473 Guido Trotter
import Ganeti.THH
70 ac13f473 Guido Trotter
71 ac13f473 Guido Trotter
-- * THH declarations, that require ordering.
72 ac13f473 Guido Trotter
73 ac13f473 Guido Trotter
-- | Status of a query field.
74 ac13f473 Guido Trotter
$(declareIADT "ResultStatus"
75 ac13f473 Guido Trotter
  [ ("RSNormal",  'C.rsNormal )
76 ac13f473 Guido Trotter
  , ("RSUnknown", 'C.rsUnknown )
77 ac13f473 Guido Trotter
  , ("RSNoData",  'C.rsNodata )
78 ac13f473 Guido Trotter
  , ("RSUnavail", 'C.rsUnavail )
79 ac13f473 Guido Trotter
  , ("RSOffline", 'C.rsOffline )
80 ac13f473 Guido Trotter
  ])
81 ac13f473 Guido Trotter
$(makeJSONInstance ''ResultStatus)
82 ac13f473 Guido Trotter
83 13b17073 Iustin Pop
-- | No-op 'NFData' instance for 'ResultStatus', since it's a single
84 13b17073 Iustin Pop
-- constructor data-type.
85 13b17073 Iustin Pop
instance NFData ResultStatus
86 13b17073 Iustin Pop
87 62377cf5 Iustin Pop
-- | Check that ResultStatus is success or fail with descriptive
88 62377cf5 Iustin Pop
-- message.
89 62377cf5 Iustin Pop
checkRS :: (Monad m) => ResultStatus -> a -> m a
90 62377cf5 Iustin Pop
checkRS RSNormal val = return val
91 62377cf5 Iustin Pop
checkRS RSUnknown  _ = fail "Unknown field"
92 62377cf5 Iustin Pop
checkRS RSNoData   _ = fail "No data for a field"
93 62377cf5 Iustin Pop
checkRS RSUnavail  _ = fail "Ganeti reports unavailable data"
94 62377cf5 Iustin Pop
checkRS RSOffline  _ = fail "Ganeti reports resource as offline"
95 62377cf5 Iustin Pop
96 ac13f473 Guido Trotter
-- | Type of a query field.
97 ac13f473 Guido Trotter
$(declareSADT "FieldType"
98 ac13f473 Guido Trotter
  [ ("QFTUnknown",   'C.qftUnknown )
99 ac13f473 Guido Trotter
  , ("QFTText",      'C.qftText )
100 ac13f473 Guido Trotter
  , ("QFTBool",      'C.qftBool )
101 ac13f473 Guido Trotter
  , ("QFTNumber",    'C.qftNumber )
102 ac13f473 Guido Trotter
  , ("QFTUnit",      'C.qftUnit )
103 ac13f473 Guido Trotter
  , ("QFTTimestamp", 'C.qftTimestamp )
104 ac13f473 Guido Trotter
  , ("QFTOther",     'C.qftOther )
105 ac13f473 Guido Trotter
  ])
106 ac13f473 Guido Trotter
$(makeJSONInstance ''FieldType)
107 ac13f473 Guido Trotter
108 dc6a0f82 Iustin Pop
-- | Supported items on which Qlang works.
109 1283cc38 Iustin Pop
$(declareSADT "QueryTypeOp"
110 ac13f473 Guido Trotter
  [ ("QRCluster",  'C.qrCluster )
111 ac13f473 Guido Trotter
  , ("QRInstance", 'C.qrInstance )
112 ac13f473 Guido Trotter
  , ("QRNode",     'C.qrNode )
113 ac13f473 Guido Trotter
  , ("QRGroup",    'C.qrGroup )
114 ac13f473 Guido Trotter
  , ("QROs",       'C.qrOs )
115 ac13f473 Guido Trotter
  , ("QRExport",   'C.qrExport )
116 05092772 Helga Velroyen
  , ("QRNetwork",  'C.qrNetwork )
117 ac13f473 Guido Trotter
  ])
118 1283cc38 Iustin Pop
$(makeJSONInstance ''QueryTypeOp)
119 1283cc38 Iustin Pop
120 1283cc38 Iustin Pop
-- | Supported items on which Qlang works.
121 1283cc38 Iustin Pop
$(declareSADT "QueryTypeLuxi"
122 1283cc38 Iustin Pop
  [ ("QRLock",     'C.qrLock )
123 1283cc38 Iustin Pop
  , ("QRJob",      'C.qrJob )
124 1283cc38 Iustin Pop
  ])
125 1283cc38 Iustin Pop
$(makeJSONInstance ''QueryTypeLuxi)
126 1283cc38 Iustin Pop
127 1283cc38 Iustin Pop
-- | Overall query type.
128 1283cc38 Iustin Pop
data ItemType = ItemTypeLuxi QueryTypeLuxi
129 1283cc38 Iustin Pop
              | ItemTypeOpCode QueryTypeOp
130 139c0683 Iustin Pop
                deriving (Show, Eq)
131 1283cc38 Iustin Pop
132 1283cc38 Iustin Pop
-- | Custom JSON decoder for 'ItemType'.
133 1283cc38 Iustin Pop
decodeItemType :: (Monad m) => JSValue -> m ItemType
134 1283cc38 Iustin Pop
decodeItemType (JSString s) =
135 1283cc38 Iustin Pop
  case queryTypeOpFromRaw s' of
136 1283cc38 Iustin Pop
    Just v -> return $ ItemTypeOpCode v
137 1283cc38 Iustin Pop
    Nothing ->
138 1283cc38 Iustin Pop
      case queryTypeLuxiFromRaw s' of
139 1283cc38 Iustin Pop
        Just v -> return $ ItemTypeLuxi v
140 1283cc38 Iustin Pop
        Nothing ->
141 1283cc38 Iustin Pop
          fail $ "Can't parse value '" ++ s' ++ "' as neither"
142 1283cc38 Iustin Pop
                 ++ "QueryTypeLuxi nor QueryTypeOp"
143 1283cc38 Iustin Pop
  where s' = fromJSString s
144 1283cc38 Iustin Pop
decodeItemType v = fail $ "Invalid value '" ++ show (pp_value v) ++
145 1283cc38 Iustin Pop
                   "for query type"
146 1283cc38 Iustin Pop
147 1283cc38 Iustin Pop
-- | Custom JSON instance for 'ItemType' since its encoding is not
148 1283cc38 Iustin Pop
-- consistent with the data type itself.
149 1283cc38 Iustin Pop
instance JSON ItemType where
150 1283cc38 Iustin Pop
  showJSON (ItemTypeLuxi x)  = showJSON x
151 1283cc38 Iustin Pop
  showJSON (ItemTypeOpCode y) = showJSON y
152 1283cc38 Iustin Pop
  readJSON = decodeItemType
153 ac13f473 Guido Trotter
154 ac13f473 Guido Trotter
-- * Sub data types for query2 queries and responses.
155 ac13f473 Guido Trotter
156 7ae97c33 Iustin Pop
-- | Internal type of a regex expression (not exported).
157 7ae97c33 Iustin Pop
#ifndef NO_REGEX_PCRE
158 7ae97c33 Iustin Pop
type RegexType = PCRE.Regex
159 7ae97c33 Iustin Pop
#else
160 7ae97c33 Iustin Pop
type RegexType = ()
161 7ae97c33 Iustin Pop
#endif
162 7ae97c33 Iustin Pop
163 ac13f473 Guido Trotter
-- | List of requested fields.
164 ac13f473 Guido Trotter
type Fields = [ String ]
165 ac13f473 Guido Trotter
166 05ac718f Iustin Pop
-- | Query2 filter expression. It's a parameteric type since we can
167 05ac718f Iustin Pop
-- filter different \"things\"; e.g. field names, or actual field
168 05ac718f Iustin Pop
-- getters, etc.
169 05ac718f Iustin Pop
data Filter a
170 05ac718f Iustin Pop
    = EmptyFilter                   -- ^ No filter at all
171 51d991d7 Iustin Pop
    | AndFilter      [ Filter a ]   -- ^ @&@ [/expression/, ...]
172 51d991d7 Iustin Pop
    | OrFilter       [ Filter a ]   -- ^ @|@ [/expression/, ...]
173 51d991d7 Iustin Pop
    | NotFilter      (Filter a)     -- ^ @!@ /expression/
174 51d991d7 Iustin Pop
    | TrueFilter     a              -- ^ @?@ /field/
175 51d991d7 Iustin Pop
    | EQFilter       a FilterValue  -- ^ @(=|!=)@ /field/ /value/
176 51d991d7 Iustin Pop
    | LTFilter       a FilterValue  -- ^ @<@ /field/ /value/
177 51d991d7 Iustin Pop
    | GTFilter       a FilterValue  -- ^ @>@ /field/ /value/
178 51d991d7 Iustin Pop
    | LEFilter       a FilterValue  -- ^ @<=@ /field/ /value/
179 51d991d7 Iustin Pop
    | GEFilter       a FilterValue  -- ^ @>=@ /field/ /value/
180 51d991d7 Iustin Pop
    | RegexpFilter   a FilterRegex  -- ^ @=~@ /field/ /regexp/
181 51d991d7 Iustin Pop
    | ContainsFilter a FilterValue  -- ^ @=[]@ /list-field/ /value/
182 139c0683 Iustin Pop
      deriving (Show, Eq)
183 e8a25d62 Iustin Pop
184 e8a25d62 Iustin Pop
-- | Serialiser for the 'Filter' data type.
185 05ac718f Iustin Pop
showFilter :: (JSON a) => Filter a -> JSValue
186 e8a25d62 Iustin Pop
showFilter (EmptyFilter)          = JSNull
187 e8a25d62 Iustin Pop
showFilter (AndFilter exprs)      =
188 5b11f8db Iustin Pop
  JSArray $ showJSON C.qlangOpAnd : map showJSON exprs
189 e8a25d62 Iustin Pop
showFilter (OrFilter  exprs)      =
190 5b11f8db Iustin Pop
  JSArray $ showJSON C.qlangOpOr : map showJSON exprs
191 e8a25d62 Iustin Pop
showFilter (NotFilter flt)        =
192 e8a25d62 Iustin Pop
  JSArray [showJSON C.qlangOpNot, showJSON flt]
193 e8a25d62 Iustin Pop
showFilter (TrueFilter field)     =
194 e8a25d62 Iustin Pop
  JSArray [showJSON C.qlangOpTrue, showJSON field]
195 e8a25d62 Iustin Pop
showFilter (EQFilter field value) =
196 e8a25d62 Iustin Pop
  JSArray [showJSON C.qlangOpEqual, showJSON field, showJSON value]
197 e8a25d62 Iustin Pop
showFilter (LTFilter field value) =
198 e8a25d62 Iustin Pop
  JSArray [showJSON C.qlangOpLt, showJSON field, showJSON value]
199 e8a25d62 Iustin Pop
showFilter (GTFilter field value) =
200 e8a25d62 Iustin Pop
  JSArray [showJSON C.qlangOpGt, showJSON field, showJSON value]
201 e8a25d62 Iustin Pop
showFilter (LEFilter field value) =
202 e8a25d62 Iustin Pop
  JSArray [showJSON C.qlangOpLe, showJSON field, showJSON value]
203 e8a25d62 Iustin Pop
showFilter (GEFilter field value) =
204 e8a25d62 Iustin Pop
  JSArray [showJSON C.qlangOpGe, showJSON field, showJSON value]
205 e8a25d62 Iustin Pop
showFilter (RegexpFilter field regexp) =
206 e8a25d62 Iustin Pop
  JSArray [showJSON C.qlangOpRegexp, showJSON field, showJSON regexp]
207 e8a25d62 Iustin Pop
showFilter (ContainsFilter field value) =
208 e8a25d62 Iustin Pop
  JSArray [showJSON C.qlangOpContains, showJSON field, showJSON value]
209 e8a25d62 Iustin Pop
210 e8a25d62 Iustin Pop
-- | Deserializer for the 'Filter' data type.
211 05ac718f Iustin Pop
readFilter :: (JSON a) => JSValue -> Result (Filter a)
212 e8a25d62 Iustin Pop
readFilter JSNull = Ok EmptyFilter
213 e8a25d62 Iustin Pop
readFilter (JSArray (JSString op:args)) =
214 e8a25d62 Iustin Pop
  readFilterArray (fromJSString op) args
215 e8a25d62 Iustin Pop
readFilter v =
216 e8a25d62 Iustin Pop
  Error $ "Cannot deserialise filter: expected array [string, args], got " ++
217 e8a25d62 Iustin Pop
        show (pp_value v)
218 e8a25d62 Iustin Pop
219 e8a25d62 Iustin Pop
-- | Helper to deserialise an array corresponding to a single filter
220 e8a25d62 Iustin Pop
-- and return the built filter. Note this looks generic but is (at
221 e8a25d62 Iustin Pop
-- least currently) only used for the NotFilter.
222 05ac718f Iustin Pop
readFilterArg :: (JSON a) =>
223 05ac718f Iustin Pop
                 (Filter a -> Filter a) -- ^ Constructor
224 05ac718f Iustin Pop
              -> [JSValue]              -- ^ Single argument
225 05ac718f Iustin Pop
              -> Result (Filter a)
226 e8a25d62 Iustin Pop
readFilterArg constr [flt] = constr <$> readJSON flt
227 7ae97c33 Iustin Pop
readFilterArg _ v = Error $ "Cannot deserialise field, expected [filter]" ++
228 7ae97c33 Iustin Pop
                            " but got " ++ show (pp_value (showJSON v))
229 e8a25d62 Iustin Pop
230 e8a25d62 Iustin Pop
-- | Helper to deserialise an array corresponding to a single field
231 e8a25d62 Iustin Pop
-- and return the built filter.
232 05ac718f Iustin Pop
readFilterField :: (JSON a) =>
233 05ac718f Iustin Pop
                   (a -> Filter a)   -- ^ Constructor
234 05ac718f Iustin Pop
                -> [JSValue]         -- ^ Single argument
235 05ac718f Iustin Pop
                -> Result (Filter a)
236 e8a25d62 Iustin Pop
readFilterField constr [field] = constr <$> readJSON field
237 7ae97c33 Iustin Pop
readFilterField _ v = Error $ "Cannot deserialise field, expected" ++
238 7ae97c33 Iustin Pop
                              " [fieldname] but got " ++
239 7ae97c33 Iustin Pop
                              show (pp_value (showJSON v))
240 e8a25d62 Iustin Pop
241 e8a25d62 Iustin Pop
-- | Helper to deserialise an array corresponding to a field and
242 e8a25d62 Iustin Pop
-- value, returning the built filter.
243 05ac718f Iustin Pop
readFilterFieldValue :: (JSON a, JSON b) =>
244 05ac718f Iustin Pop
                        (a -> b -> Filter a) -- ^ Constructor
245 05ac718f Iustin Pop
                     -> [JSValue]            -- ^ Arguments array
246 05ac718f Iustin Pop
                     -> Result (Filter a)
247 e8a25d62 Iustin Pop
readFilterFieldValue constr [field, value] =
248 e8a25d62 Iustin Pop
  constr <$> readJSON field <*> readJSON value
249 e8a25d62 Iustin Pop
readFilterFieldValue _ v =
250 7ae97c33 Iustin Pop
  Error $ "Cannot deserialise field/value pair, expected [fieldname, value]" ++
251 7ae97c33 Iustin Pop
          " but got " ++ show (pp_value (showJSON v))
252 e8a25d62 Iustin Pop
253 e8a25d62 Iustin Pop
-- | Inner deserialiser for 'Filter'.
254 05ac718f Iustin Pop
readFilterArray :: (JSON a) => String -> [JSValue] -> Result (Filter a)
255 e8a25d62 Iustin Pop
readFilterArray op args
256 e8a25d62 Iustin Pop
  | op == C.qlangOpAnd      = AndFilter <$> mapM readJSON args
257 e8a25d62 Iustin Pop
  | op == C.qlangOpOr       = OrFilter  <$> mapM readJSON args
258 e8a25d62 Iustin Pop
  | op == C.qlangOpNot      = readFilterArg        NotFilter args
259 e8a25d62 Iustin Pop
  | op == C.qlangOpTrue     = readFilterField      TrueFilter args
260 e8a25d62 Iustin Pop
  | op == C.qlangOpEqual    = readFilterFieldValue EQFilter args
261 e8a25d62 Iustin Pop
  | op == C.qlangOpLt       = readFilterFieldValue LTFilter args
262 e8a25d62 Iustin Pop
  | op == C.qlangOpGt       = readFilterFieldValue GTFilter args
263 e8a25d62 Iustin Pop
  | op == C.qlangOpLe       = readFilterFieldValue LEFilter args
264 e8a25d62 Iustin Pop
  | op == C.qlangOpGe       = readFilterFieldValue GEFilter args
265 e8a25d62 Iustin Pop
  | op == C.qlangOpRegexp   = readFilterFieldValue RegexpFilter args
266 e8a25d62 Iustin Pop
  | op == C.qlangOpContains = readFilterFieldValue ContainsFilter args
267 e8a25d62 Iustin Pop
  | otherwise = Error $ "Unknown filter operand '" ++ op ++ "'"
268 e8a25d62 Iustin Pop
269 05ac718f Iustin Pop
instance (JSON a) => JSON (Filter a) where
270 e8a25d62 Iustin Pop
  showJSON = showFilter
271 e8a25d62 Iustin Pop
  readJSON = readFilter
272 ac13f473 Guido Trotter
273 05ac718f Iustin Pop
-- Traversable implementation for 'Filter'.
274 05ac718f Iustin Pop
traverseFlt :: (Applicative f) => (a -> f b) -> Filter a -> f (Filter b)
275 05ac718f Iustin Pop
traverseFlt _ EmptyFilter       = pure EmptyFilter
276 5b11f8db Iustin Pop
traverseFlt f (AndFilter flts)  = AndFilter <$> traverse (traverseFlt f) flts
277 5b11f8db Iustin Pop
traverseFlt f (OrFilter  flts)  = OrFilter  <$> traverse (traverseFlt f) flts
278 5b11f8db Iustin Pop
traverseFlt f (NotFilter flt)   = NotFilter <$> traverseFlt f flt
279 05ac718f Iustin Pop
traverseFlt f (TrueFilter a)    = TrueFilter <$> f a
280 05ac718f Iustin Pop
traverseFlt f (EQFilter a fval) = EQFilter <$> f a <*> pure fval
281 05ac718f Iustin Pop
traverseFlt f (LTFilter a fval) = LTFilter <$> f a <*> pure fval
282 05ac718f Iustin Pop
traverseFlt f (GTFilter a fval) = GTFilter <$> f a <*> pure fval
283 05ac718f Iustin Pop
traverseFlt f (LEFilter a fval) = LEFilter <$> f a <*> pure fval
284 05ac718f Iustin Pop
traverseFlt f (GEFilter a fval) = GEFilter <$> f a <*> pure fval
285 05ac718f Iustin Pop
traverseFlt f (RegexpFilter a re)     = RegexpFilter <$> f a <*> pure re
286 05ac718f Iustin Pop
traverseFlt f (ContainsFilter a fval) = ContainsFilter <$> f a <*> pure fval
287 05ac718f Iustin Pop
288 05ac718f Iustin Pop
instance Traversable Filter where
289 05ac718f Iustin Pop
  traverse = traverseFlt
290 05ac718f Iustin Pop
291 05ac718f Iustin Pop
instance Functor Filter where
292 05ac718f Iustin Pop
  fmap = fmapDefault
293 05ac718f Iustin Pop
294 05ac718f Iustin Pop
instance Foldable Filter where
295 05ac718f Iustin Pop
  foldMap = foldMapDefault
296 05ac718f Iustin Pop
297 ac13f473 Guido Trotter
-- | Field name to filter on.
298 ac13f473 Guido Trotter
type FilterField = String
299 ac13f473 Guido Trotter
300 ac13f473 Guido Trotter
-- | Value to compare the field value to, for filtering purposes.
301 e8a25d62 Iustin Pop
data FilterValue = QuotedString String
302 e8a25d62 Iustin Pop
                 | NumericValue Integer
303 139c0683 Iustin Pop
                   deriving (Show, Eq)
304 e8a25d62 Iustin Pop
305 e8a25d62 Iustin Pop
-- | Serialiser for 'FilterValue'. The Python code just sends this to
306 e8a25d62 Iustin Pop
-- JSON as-is, so we'll do the same.
307 e8a25d62 Iustin Pop
showFilterValue :: FilterValue -> JSValue
308 e8a25d62 Iustin Pop
showFilterValue (QuotedString str) = showJSON str
309 e8a25d62 Iustin Pop
showFilterValue (NumericValue val) = showJSON val
310 e8a25d62 Iustin Pop
311 e8a25d62 Iustin Pop
-- | Decoder for 'FilterValue'. We have to see what it contains, since
312 e8a25d62 Iustin Pop
-- the context doesn't give us hints on what to expect.
313 e8a25d62 Iustin Pop
readFilterValue :: JSValue -> Result FilterValue
314 e8a25d62 Iustin Pop
readFilterValue (JSString a) = Ok . QuotedString $ fromJSString a
315 e8a25d62 Iustin Pop
readFilterValue (JSRational _ x) =
316 e8a25d62 Iustin Pop
  if denominator x /= 1
317 7ae97c33 Iustin Pop
    then Error $ "Cannot deserialise numeric filter value," ++
318 7ae97c33 Iustin Pop
                 " expecting integral but got a fractional value: " ++
319 7ae97c33 Iustin Pop
                 show x
320 e8a25d62 Iustin Pop
    else Ok . NumericValue $ numerator x
321 7ae97c33 Iustin Pop
readFilterValue v = Error $ "Cannot deserialise filter value, expecting" ++
322 7ae97c33 Iustin Pop
                            " string or integer, got " ++ show (pp_value v)
323 e8a25d62 Iustin Pop
324 e8a25d62 Iustin Pop
instance JSON FilterValue where
325 e8a25d62 Iustin Pop
  showJSON = showFilterValue
326 e8a25d62 Iustin Pop
  readJSON = readFilterValue
327 ac13f473 Guido Trotter
328 01606931 Iustin Pop
-- | Regexp to apply to the filter value, for filtering purposes. It
329 01606931 Iustin Pop
-- holds both the string format, and the \"compiled\" format, so that
330 01606931 Iustin Pop
-- we don't re-compile the regex at each match attempt.
331 01606931 Iustin Pop
data FilterRegex = FilterRegex
332 01606931 Iustin Pop
  { stringRegex   :: String      -- ^ The string version of the regex
333 7ae97c33 Iustin Pop
  , compiledRegex :: RegexType   -- ^ The compiled regex
334 01606931 Iustin Pop
  }
335 01606931 Iustin Pop
336 01606931 Iustin Pop
-- | Builder for 'FilterRegex'. We always attempt to compile the
337 01606931 Iustin Pop
-- regular expression on the initialisation of the data structure;
338 01606931 Iustin Pop
-- this might fail, if the RE is not well-formed.
339 01606931 Iustin Pop
mkRegex :: (Monad m) => String -> m FilterRegex
340 7ae97c33 Iustin Pop
#ifndef NO_REGEX_PCRE
341 01606931 Iustin Pop
mkRegex str = do
342 01606931 Iustin Pop
  compiled <- case PCRE.getVersion of
343 7ae97c33 Iustin Pop
                Nothing -> fail $ "regex-pcre library compiled without" ++
344 7ae97c33 Iustin Pop
                                  " libpcre, regex functionality not available"
345 01606931 Iustin Pop
                _ -> PCRE.makeRegexM str
346 01606931 Iustin Pop
  return $ FilterRegex str compiled
347 7ae97c33 Iustin Pop
#else
348 7ae97c33 Iustin Pop
mkRegex _ =
349 7ae97c33 Iustin Pop
  fail $ "regex-pcre not found at compile time," ++
350 7ae97c33 Iustin Pop
         " regex functionality not available"
351 7ae97c33 Iustin Pop
#endif
352 01606931 Iustin Pop
353 01606931 Iustin Pop
-- | 'Show' instance: we show the constructor plus the string version
354 01606931 Iustin Pop
-- of the regex.
355 01606931 Iustin Pop
instance Show FilterRegex where
356 01606931 Iustin Pop
  show (FilterRegex re _) = "mkRegex " ++ show re
357 01606931 Iustin Pop
358 01606931 Iustin Pop
-- | 'Eq' instance: we only compare the string versions of the regexes.
359 01606931 Iustin Pop
instance Eq FilterRegex where
360 01606931 Iustin Pop
  (FilterRegex re1 _) == (FilterRegex re2 _) = re1 == re2
361 01606931 Iustin Pop
362 01606931 Iustin Pop
-- | 'JSON' instance: like for show and read instances, we work only
363 01606931 Iustin Pop
-- with the string component.
364 01606931 Iustin Pop
instance JSON FilterRegex where
365 01606931 Iustin Pop
  showJSON (FilterRegex re _) = showJSON re
366 a1d137f6 Iustin Pop
  readJSON s = readJSON s >>= mkRegex
367 ac13f473 Guido Trotter
368 ac13f473 Guido Trotter
-- | Name of a field.
369 ac13f473 Guido Trotter
type FieldName = String
370 ac13f473 Guido Trotter
-- | Title of a field, when represented in tabular format.
371 ac13f473 Guido Trotter
type FieldTitle = String
372 ac13f473 Guido Trotter
-- | Human redable description of a field.
373 ac13f473 Guido Trotter
type FieldDoc = String
374 ac13f473 Guido Trotter
375 4cbe9bda Iustin Pop
-- | Definition of a field.
376 4cbe9bda Iustin Pop
$(buildObject "FieldDefinition" "fdef"
377 4cbe9bda Iustin Pop
  [ simpleField "name"  [t| FieldName  |] -- FIXME: the name has restrictions
378 4cbe9bda Iustin Pop
  , simpleField "title" [t| FieldTitle |]
379 4cbe9bda Iustin Pop
  , simpleField "kind"  [t| FieldType  |]
380 4cbe9bda Iustin Pop
  , simpleField "doc"   [t| FieldDoc   |]
381 4cbe9bda Iustin Pop
  ])
382 4cbe9bda Iustin Pop
383 ac13f473 Guido Trotter
--- | Single field entry result.
384 b9bdc10e Iustin Pop
data ResultEntry = ResultEntry
385 b9bdc10e Iustin Pop
  { rentryStatus :: ResultStatus      -- ^ The result status
386 b9bdc10e Iustin Pop
  , rentryValue  :: Maybe ResultValue -- ^ The (optional) result value
387 139c0683 Iustin Pop
  } deriving (Show, Eq)
388 4cbe9bda Iustin Pop
389 13b17073 Iustin Pop
instance NFData ResultEntry where
390 13b17073 Iustin Pop
  rnf (ResultEntry rs rv) = rnf rs `seq` rnf rv
391 13b17073 Iustin Pop
392 4cbe9bda Iustin Pop
instance JSON ResultEntry where
393 4cbe9bda Iustin Pop
  showJSON (ResultEntry rs rv) =
394 4cbe9bda Iustin Pop
    showJSON (showJSON rs, maybe JSNull showJSON rv)
395 4cbe9bda Iustin Pop
  readJSON v = do
396 4cbe9bda Iustin Pop
    (rs, rv) <- readJSON v
397 4cbe9bda Iustin Pop
    rv' <- case rv of
398 4cbe9bda Iustin Pop
             JSNull -> return Nothing
399 3ce788db Iustin Pop
             x -> Just <$> readJSON x
400 4cbe9bda Iustin Pop
    return $ ResultEntry rs rv'
401 4cbe9bda Iustin Pop
402 4cbe9bda Iustin Pop
-- | The type of one result row.
403 4cbe9bda Iustin Pop
type ResultRow = [ ResultEntry ]
404 ac13f473 Guido Trotter
405 ac13f473 Guido Trotter
-- | Value of a field, in json encoding.
406 ac13f473 Guido Trotter
-- (its type will be depending on ResultStatus and FieldType)
407 ac13f473 Guido Trotter
type ResultValue = JSValue
408 4cbe9bda Iustin Pop
409 4cbe9bda Iustin Pop
-- * Main Qlang queries and responses.
410 4cbe9bda Iustin Pop
411 4cbe9bda Iustin Pop
-- | Query2 query.
412 05ac718f Iustin Pop
data Query = Query ItemType Fields (Filter FilterField)
413 4cbe9bda Iustin Pop
414 4cbe9bda Iustin Pop
-- | Query2 result.
415 4cbe9bda Iustin Pop
$(buildObject "QueryResult" "qres"
416 4cbe9bda Iustin Pop
  [ simpleField "fields" [t| [ FieldDefinition ] |]
417 4cbe9bda Iustin Pop
  , simpleField "data"   [t| [ ResultRow       ] |]
418 4cbe9bda Iustin Pop
  ])
419 4cbe9bda Iustin Pop
420 4cbe9bda Iustin Pop
-- | Query2 Fields query.
421 4cbe9bda Iustin Pop
-- (to get supported fields names, descriptions, and types)
422 4cbe9bda Iustin Pop
data QueryFields = QueryFields ItemType Fields
423 4cbe9bda Iustin Pop
424 4cbe9bda Iustin Pop
-- | Query2 Fields result.
425 518023a9 Iustin Pop
$(buildObject "QueryFieldsResult" "qfieldres"
426 518023a9 Iustin Pop
  [ simpleField "fields" [t| [FieldDefinition ] |]
427 518023a9 Iustin Pop
  ])