Server.hs 9.86 KB
Newer Older
1
2
{-# LANGUAGE BangPatterns #-}

3
{-| Implementation of the Ganeti Query2 server.
4
5
6
7
8

-}

{-

9
Copyright (C) 2012, 2013 Google Inc.
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

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.

-}

28
module Ganeti.Query.Server
29
  ( ConfigReader
30
  , prepQueryD
31
32
  , runQueryD
  ) where
33

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

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
51
52
import Ganeti.BasicTypes
import Ganeti.Logging
import Ganeti.Luxi
53
import Ganeti.OpCodes (TagObject(..))
54
import qualified Ganeti.Query.Language as Qlang
55
import Ganeti.Query.Query
Iustin Pop's avatar
Iustin Pop committed
56
import Ganeti.Query.Filter (makeSimpleFilter)
57
58
59
60
61

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

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

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

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

  in return . Ok . J.makeObj $ obj

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

156
handleCall cfg (Query qkind qfields qfilter) = do
Agata Murawska's avatar
Agata Murawska committed
157
  result <- query cfg True (Qlang.Query qkind qfields qfilter)
158
159
  return $ J.showJSON <$> result

Iustin Pop's avatar
Iustin Pop committed
160
161
162
163
handleCall _ (QueryFields qkind qfields) = do
  let result = queryFields (Qlang.QueryFields qkind qfields)
  return $ J.showJSON <$> result

Iustin Pop's avatar
Iustin Pop committed
164
handleCall cfg (QueryNodes names fields lock) =
165
166
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode)
    (map Left names) fields lock
Iustin Pop's avatar
Iustin Pop committed
167
168

handleCall cfg (QueryGroups names fields lock) =
169
170
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup)
    (map Left names) fields lock
Iustin Pop's avatar
Iustin Pop committed
171

172
173
174
175
handleCall cfg (QueryJobs names fields) =
  handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
    (map (Right . fromIntegral . fromJobId) names)  fields False

176
handleCall _ op =
177
178
  return . Bad $
    GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")
179
180
181
182
183
184
185
186
187
188
189


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

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

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

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

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

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