Common.hs 8.85 KB
Newer Older
1
2
3
4
5
6
{-| Implementation of the Ganeti Query2 common objects.

 -}

{-

Iustin Pop's avatar
Iustin Pop committed
7
Copyright (C) 2012, 2013 Google Inc.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

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.

-}

module Ganeti.Query.Common
27
28
  ( NoDataRuntime(..)
  , rsNoData
Iustin Pop's avatar
Iustin Pop committed
29
  , rsUnavail
30
  , rsNormal
31
32
  , rsMaybeNoData
  , rsMaybeUnavail
33
  , rsErrorNoData
34
35
  , rsUnknown
  , missingRuntime
36
  , rpcErrorToStatus
37
38
39
40
41
42
  , timeStampFields
  , uuidFields
  , serialFields
  , tagsFields
  , dictFieldGetter
  , buildNdParamField
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
43
44
  , buildBeParamField
  , buildHvParamField
45
46
  , getDefaultHypervisorSpec
  , getHvParamsFromCluster
47
  , aliasFields
48
49
  ) where

50
import Control.Monad (guard)
51
52
53
54
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Text.JSON (JSON, showJSON)

55
import Ganeti.BasicTypes
56
57
import qualified Ganeti.Constants as C
import Ganeti.Config
58
import Ganeti.Errors
59
import Ganeti.JSON
60
import Ganeti.Objects
61
import Ganeti.Rpc
62
import Ganeti.Query.Language
63
import Ganeti.Query.Types
64
import Ganeti.Types
65

66
67
68
-- | The runtime used by queries which retrieve no live data.
data NoDataRuntime = NoDataRuntime

69
70
71
72
73
74
75
76
77
-- * Generic functions

-- | Conversion from 'VType' to 'FieldType'.
vTypeToQFT :: VType -> FieldType
vTypeToQFT VTypeString      = QFTOther
vTypeToQFT VTypeMaybeString = QFTOther
vTypeToQFT VTypeBool        = QFTBool
vTypeToQFT VTypeSize        = QFTUnit
vTypeToQFT VTypeInt         = QFTNumber
Klaus Aehlig's avatar
Klaus Aehlig committed
78
vTypeToQFT VTypeFloat       = QFTNumberFloat
79
80
81
82
83
84
85

-- * Result helpers

-- | Helper for a result with no data.
rsNoData :: ResultEntry
rsNoData = ResultEntry RSNoData Nothing

Iustin Pop's avatar
Iustin Pop committed
86
87
88
89
-- | Helper for result for an entity which supports no such field.
rsUnavail :: ResultEntry
rsUnavail = ResultEntry RSUnavail Nothing

90
91
92
93
94
95
96
97
-- | Helper to declare a normal result.
rsNormal :: (JSON a) => a -> ResultEntry
rsNormal a = ResultEntry RSNormal $ Just (showJSON a)

-- | Helper to declare a result from a 'Maybe' (the item might be
-- missing, in which case we return no data). Note that there's some
-- ambiguity here: in some cases, we mean 'RSNoData', but in other
-- 'RSUnavail'; this is easy to solve in simple cases, but not in
98
99
100
101
102
-- nested dicts. If you want to return 'RSUnavail' in case of 'Nothing'
-- use the function 'rsMaybeUnavail'.
rsMaybeNoData :: (JSON a) => Maybe a -> ResultEntry
rsMaybeNoData = maybe rsNoData rsNormal

103
104
105
106
107
108
109
110
-- | Helper to declare a result from a 'ErrorResult' (an error happened
-- while retrieving the data from a config, or there was no data).
-- This function should be used if an error signals there was no data.
rsErrorNoData :: (JSON a) => ErrorResult a -> ResultEntry
rsErrorNoData res = case res of
  Ok  x -> rsNormal x
  Bad _ -> rsNoData

111
112
113
114
115
116
-- | Helper to declare a result from a 'Maybe'. This version returns
-- a 'RSUnavail' in case of 'Nothing'. It should be used for optional
-- fields that are not set. For cases where 'Nothing' means that there
-- was an error, consider using 'rsMaybe' instead.
rsMaybeUnavail :: (JSON a) => Maybe a -> ResultEntry
rsMaybeUnavail = maybe rsUnavail rsNormal
117
118
119
120
121
122
123
124
125

-- | Helper for unknown field result.
rsUnknown :: ResultEntry
rsUnknown = ResultEntry RSUnknown Nothing

-- | Helper for a missing runtime parameter.
missingRuntime :: FieldGetter a b
missingRuntime = FieldRuntime (\_ _ -> ResultEntry RSNoData Nothing)

126
127
128
129
-- * Error conversion

-- | Convert RpcError to ResultStatus
rpcErrorToStatus :: RpcError -> ResultStatus
Iustin Pop's avatar
Iustin Pop committed
130
rpcErrorToStatus OfflineNodeError = RSOffline
131
132
rpcErrorToStatus _ = RSNoData

133
134
135
136
137
138
-- * Common fields

-- | The list of timestamp fields.
timeStampFields :: (TimeStampObject a) => FieldList a b
timeStampFields =
  [ (FieldDefinition "ctime" "CTime" QFTTimestamp "Creation timestamp",
139
     FieldSimple (rsNormal . TimeAsDoubleJSON . cTimeOf), QffNormal)
140
  , (FieldDefinition "mtime" "MTime" QFTTimestamp "Modification timestamp",
141
     FieldSimple (rsNormal . TimeAsDoubleJSON . mTimeOf), QffNormal)
142
143
144
145
146
147
  ]

-- | The list of UUID fields.
uuidFields :: (UuidObject a) => String -> FieldList a b
uuidFields name =
  [ (FieldDefinition "uuid" "UUID" QFTText  (name ++ " UUID"),
148
     FieldSimple (rsNormal . uuidOf), QffNormal) ]
149
150
151
152
153
154

-- | The list of serial number fields.
serialFields :: (SerialNoObject a) => String -> FieldList a b
serialFields name =
  [ (FieldDefinition "serial_no" "SerialNo" QFTNumber
     (name ++ " object serial number, incremented on each modification"),
155
     FieldSimple (rsNormal . serialOf), QffNormal) ]
156
157
158
159
160

-- | The list of tag fields.
tagsFields :: (TagsObject a) => FieldList a b
tagsFields =
  [ (FieldDefinition "tags" "Tags" QFTOther "Tags",
161
     FieldSimple (rsNormal . tagsOf), QffNormal) ]
162
163
164
165
166
167
168
169

-- * Generic parameter functions

-- | Returns a field from a (possibly missing) 'DictObject'. This is
-- used by parameter dictionaries, usually. Note that we have two
-- levels of maybe: the top level dict might be missing, or one key in
-- the dictionary might be.
dictFieldGetter :: (DictObject a) => String -> Maybe a -> ResultEntry
170
dictFieldGetter k = maybe rsNoData (rsMaybeNoData . lookup k . toDict)
171
172
173

-- | Ndparams optimised lookup map.
ndParamTypes :: Map.Map String FieldType
174
ndParamTypes = Map.map vTypeToQFT C.ndsParameterTypes
175
176
177

-- | Ndparams title map.
ndParamTitles :: Map.Map String FieldTitle
178
ndParamTitles = C.ndsParameterTitles
179
180
181
182
183
184
185
186
187
188
189
190

-- | Ndparam getter builder: given a field, it returns a FieldConfig
-- getter, that is a function that takes the config and the object and
-- returns the Ndparam field specified when the getter was built.
ndParamGetter :: (NdParamObject a) =>
                 String -- ^ The field we're building the getter for
              -> ConfigData -> a -> ResultEntry
ndParamGetter field config =
  dictFieldGetter field . getNdParamsOf config

-- | Builds the ndparam fields for an object.
buildNdParamField :: (NdParamObject a) => String -> FieldData a b
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
buildNdParamField =
  buildParamField "ndp" "node" ndParamTitles ndParamTypes ndParamGetter

-- | Beparams optimised lookup map.
beParamTypes :: Map.Map String FieldType
beParamTypes = Map.map vTypeToQFT C.besParameterTypes

-- | Builds the beparam fields for an object.
buildBeParamField :: (String -> ConfigData -> a -> ResultEntry)
                  -> String
                  -> FieldData a b
buildBeParamField =
  buildParamField "be" "backend" C.besParameterTitles beParamTypes

-- | Hvparams optimised lookup map.
hvParamTypes :: Map.Map String FieldType
hvParamTypes = Map.map vTypeToQFT C.hvsParameterTypes

-- | Builds the beparam fields for an object.
buildHvParamField :: (String -> ConfigData -> a -> ResultEntry)
                  -> String
                  -> FieldData a b
buildHvParamField =
  buildParamField "hv" "hypervisor" C.hvsParameterTitles hvParamTypes

-- | Builds a param field for a certain getter class
buildParamField :: String -- ^ Prefix
                -> String -- ^ Parameter group name
                -> Map.Map String String -- ^ Parameter title map
                -> Map.Map String FieldType -- ^ Parameter type map
                -> (String -> ConfigData -> a -> ResultEntry)
                -> String -- ^ The parameter name
                -> FieldData a b
buildParamField prefix paramGroupName titleMap typeMap getter field =
  let full_name = prefix ++ "/" ++ field
      title = fromMaybe full_name $ field `Map.lookup` titleMap
      qft = fromMaybe QFTOther $ field `Map.lookup` typeMap
      desc = "The \"" ++ field ++ "\" " ++ paramGroupName ++ " parameter"
  in ( FieldDefinition full_name title qft desc
     , FieldConfig (getter field), QffNormal
     )
232
233
234
235
236
237
238
239
240
241
242
243

-- | Looks up the default hypervisor and its hvparams
getDefaultHypervisorSpec :: ConfigData -> (Hypervisor, HvParams)
getDefaultHypervisorSpec cfg = (hv, getHvParamsFromCluster cfg hv)
  where hv = getDefaultHypervisor cfg

-- | Looks up the cluster's hvparams of the given hypervisor
getHvParamsFromCluster :: ConfigData -> Hypervisor -> HvParams
getHvParamsFromCluster cfg hv =
  fromMaybe (GenericContainer Map.empty) .
    Map.lookup (hypervisorToRaw hv) .
      fromContainer . clusterHvparams $ configCluster cfg
244
245
246
247
248
249
250
251
252
253

-- | Given an alias list and a field list, copies field definitions under a
-- new field name. Aliases should be tested - see the test module
-- 'Test.Ganeti.Query.Aliases'!
aliasFields :: [(FieldName, FieldName)] -> FieldList a b -> FieldList a b
aliasFields aliases fieldList = fieldList ++ do
  alias <- aliases
  (FieldDefinition name d1 d2 d3, v1, v2) <- fieldList
  guard (snd alias == name)
  return (FieldDefinition (fst alias) d1 d2 d3, v1, v2)