Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Query / Server.hs @ 966e1580

History | View | Annotate | Download (10.1 kB)

1
{-# LANGUAGE BangPatterns #-}
2

    
3
{-| Implementation of the Ganeti Query2 server.
4

    
5
-}
6

    
7
{-
8

    
9
Copyright (C) 2012, 2013 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.Query.Server
29
  ( ConfigReader
30
  , prepQueryD
31
  , runQueryD
32
  ) where
33

    
34
import Control.Applicative
35
import Control.Concurrent
36
import Control.Exception
37
import Data.Bits (bitSize)
38
import Data.Maybe
39
import qualified Network.Socket as S
40
import qualified Text.JSON as J
41
import Text.JSON (showJSON, JSValue(..))
42
import System.Info (arch)
43

    
44
import qualified Ganeti.Constants as C
45
import Ganeti.Errors
46
import qualified Ganeti.Path as Path
47
import Ganeti.Daemon
48
import Ganeti.Objects
49
import qualified Ganeti.Config as Config
50
import Ganeti.BasicTypes
51
import Ganeti.Logging
52
import Ganeti.Luxi
53
import Ganeti.OpCodes (TagObject(..))
54
import qualified Ganeti.Query.Language as Qlang
55
import Ganeti.Query.Query
56
import Ganeti.Query.Filter (makeSimpleFilter)
57

    
58
-- | A type for functions that can return the configuration when
59
-- executed.
60
type ConfigReader = IO (Result ConfigData)
61

    
62
-- | Helper for classic queries.
63
handleClassicQuery :: ConfigData      -- ^ Cluster config
64
                   -> Qlang.ItemType  -- ^ Query type
65
                   -> [Either String Integer] -- ^ Requested names
66
                                              -- (empty means all)
67
                   -> [String]        -- ^ Requested fields
68
                   -> Bool            -- ^ Whether to do sync queries or not
69
                   -> IO (GenericResult GanetiException JSValue)
70
handleClassicQuery _ _ _ _ True =
71
  return . Bad $ OpPrereqError "Sync queries are not allowed" ECodeInval
72
handleClassicQuery cfg qkind names fields _ = do
73
  let flt = makeSimpleFilter (nameField qkind) names
74
  qr <- query cfg True (Qlang.Query qkind fields flt)
75
  return $ showJSON <$> (qr >>= queryCompat)
76

    
77
-- | Minimal wrapper to handle the missing config case.
78
handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
79
handleCallWrapper (Bad msg) _ =
80
  return . Bad . ConfigurationError $
81
           "I do not have access to a valid configuration, cannot\
82
           \ process queries: " ++ msg
83
handleCallWrapper (Ok config) op = handleCall config op
84

    
85
-- | Actual luxi operation handler.
86
handleCall :: ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
87
handleCall cdata QueryClusterInfo =
88
  let cluster = configCluster cdata
89
      hypervisors = clusterEnabledHypervisors cluster
90
      storageTypes = clusterEnabledStorageTypes cluster
91
      diskTemplates = clusterEnabledDiskTemplates cluster
92
      def_hv = case hypervisors of
93
                 x:_ -> showJSON x
94
                 [] -> JSNull
95
      bits = show (bitSize (0::Int)) ++ "bits"
96
      arch_tuple = [bits, arch]
97
      obj = [ ("software_version", showJSON C.releaseVersion)
98
            , ("protocol_version", showJSON C.protocolVersion)
99
            , ("config_version", showJSON C.configVersion)
100
            , ("os_api_version", showJSON $ maximum C.osApiVersions)
101
            , ("export_version", showJSON C.exportVersion)
102
            , ("architecture", showJSON arch_tuple)
103
            , ("name", showJSON $ clusterClusterName cluster)
104
            , ("master", showJSON $ clusterMasterNode cluster)
105
            , ("default_hypervisor", def_hv)
106
            , ("enabled_hypervisors", showJSON hypervisors)
107
            , ("hvparams", showJSON $ clusterHvparams cluster)
108
            , ("os_hvp", showJSON $ clusterOsHvp cluster)
109
            , ("beparams", showJSON $ clusterBeparams cluster)
110
            , ("osparams", showJSON $ clusterOsparams cluster)
111
            , ("ipolicy", showJSON $ clusterIpolicy cluster)
112
            , ("nicparams", showJSON $ clusterNicparams cluster)
113
            , ("ndparams", showJSON $ clusterNdparams cluster)
114
            , ("diskparams", showJSON $ clusterDiskparams cluster)
115
            , ("candidate_pool_size",
116
               showJSON $ clusterCandidatePoolSize cluster)
117
            , ("master_netdev",  showJSON $ clusterMasterNetdev cluster)
118
            , ("master_netmask", showJSON $ clusterMasterNetmask cluster)
119
            , ("use_external_mip_script",
120
               showJSON $ clusterUseExternalMipScript cluster)
121
            , ("volume_group_name",
122
               maybe JSNull showJSON (clusterVolumeGroupName cluster))
123
            , ("drbd_usermode_helper",
124
               maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster))
125
            , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster)
126
            , ("shared_file_storage_dir",
127
               showJSON $ clusterSharedFileStorageDir cluster)
128
            , ("maintain_node_health",
129
               showJSON $ clusterMaintainNodeHealth cluster)
130
            , ("ctime", showJSON $ clusterCtime cluster)
131
            , ("mtime", showJSON $ clusterMtime cluster)
132
            , ("uuid", showJSON $ clusterUuid cluster)
133
            , ("tags", showJSON $ clusterTags cluster)
134
            , ("uid_pool", showJSON $ clusterUidPool cluster)
135
            , ("default_iallocator",
136
               showJSON $ clusterDefaultIallocator cluster)
137
            , ("reserved_lvs", showJSON $ clusterReservedLvs cluster)
138
            , ("primary_ip_version",
139
               showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster)
140
            , ("prealloc_wipe_disks",
141
               showJSON $ clusterPreallocWipeDisks cluster)
142
            , ("hidden_os", showJSON $ clusterHiddenOs cluster)
143
            , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)
144
            -- FIXME: remove storage types once enabled disk templates are
145
            -- fully implemented.
146
            , ("enabled_storage_types", showJSON storageTypes)
147
            , ("enabled_disk_templates", showJSON diskTemplates)
148
            ]
149

    
150
  in return . Ok . J.makeObj $ obj
151

    
152
handleCall cfg (QueryTags kind) =
153
  let tags = case kind of
154
               TagCluster       -> Ok . clusterTags $ configCluster cfg
155
               TagGroup    name -> groupTags <$> Config.getGroup    cfg name
156
               TagNode     name -> nodeTags  <$> Config.getNode     cfg name
157
               TagInstance name -> instTags  <$> Config.getInstance cfg name
158
  in return (J.showJSON <$> tags)
159

    
160
handleCall cfg (Query qkind qfields qfilter) = do
161
  result <- query cfg True (Qlang.Query qkind qfields qfilter)
162
  return $ J.showJSON <$> result
163

    
164
handleCall _ (QueryFields qkind qfields) = do
165
  let result = queryFields (Qlang.QueryFields qkind qfields)
166
  return $ J.showJSON <$> result
167

    
168
handleCall cfg (QueryNodes names fields lock) =
169
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode)
170
    (map Left names) fields lock
171

    
172
handleCall cfg (QueryGroups names fields lock) =
173
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup)
174
    (map Left names) fields lock
175

    
176
handleCall cfg (QueryJobs names fields) =
177
  handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
178
    (map (Right . fromIntegral . fromJobId) names)  fields False
179

    
180
handleCall _ op =
181
  return . Bad $
182
    GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")
183

    
184

    
185
-- | Given a decoded luxi request, executes it and sends the luxi
186
-- response back to the client.
187
handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool
188
handleClientMsg client creader args = do
189
  cfg <- creader
190
  logDebug $ "Request: " ++ show args
191
  call_result <- handleCallWrapper cfg args
192
  (!status, !rval) <-
193
    case call_result of
194
      Bad err -> do
195
        logWarning $ "Failed to execute request: " ++ show err
196
        return (False, showJSON err)
197
      Ok result -> do
198
        -- only log the first 2,000 chars of the result
199
        logDebug $ "Result (truncated): " ++ take 2000 (J.encode result)
200
        return (True, result)
201
  sendMsg client $ buildResponse status rval
202
  return True
203

    
204
-- | Handles one iteration of the client protocol: receives message,
205
-- checks for validity and decods, returns response.
206
handleClient :: Client -> ConfigReader -> IO Bool
207
handleClient client creader = do
208
  !msg <- recvMsgExt client
209
  case msg of
210
    RecvConnClosed -> logDebug "Connection closed" >> return False
211
    RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
212
                     return False
213
    RecvOk payload ->
214
      case validateCall payload >>= decodeCall of
215
        Bad err -> do
216
             let errmsg = "Failed to parse request: " ++ err
217
             logWarning errmsg
218
             sendMsg client $ buildResponse False (showJSON errmsg)
219
             return False
220
        Ok args -> handleClientMsg client creader args
221

    
222
-- | Main client loop: runs one loop of 'handleClient', and if that
223
-- doesn't report a finished (closed) connection, restarts itself.
224
clientLoop :: Client -> ConfigReader -> IO ()
225
clientLoop client creader = do
226
  result <- handleClient client creader
227
  if result
228
    then clientLoop client creader
229
    else closeClient client
230

    
231
-- | Main loop: accepts clients, forks an I/O thread to handle that
232
-- client, and then restarts.
233
mainLoop :: ConfigReader -> S.Socket -> IO ()
234
mainLoop creader socket = do
235
  client <- acceptClient socket
236
  _ <- forkIO $ clientLoop client creader
237
  mainLoop creader socket
238

    
239
-- | Function that prepares the server socket.
240
prepQueryD :: Maybe FilePath -> IO (FilePath, S.Socket)
241
prepQueryD fpath = do
242
  def_socket <- Path.defaultQuerySocket
243
  let socket_path = fromMaybe def_socket fpath
244
  cleanupSocket socket_path
245
  s <- describeError "binding to the Luxi socket"
246
         Nothing (Just socket_path) $ getServer socket_path
247
  return (socket_path, s)
248

    
249
-- | Main function that runs the query endpoint.
250
runQueryD :: (FilePath, S.Socket) -> ConfigReader -> IO ()
251
runQueryD (socket_path, server) creader =
252
  finally
253
    (mainLoop creader server)
254
    (closeServer socket_path server)