Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Query / Server.hs @ 385d4574

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

    
146
  in return . Ok . J.makeObj $ obj
147

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

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

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

    
164
handleCall cfg (QueryNodes names fields lock) =
165
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode)
166
    (map Left names) fields lock
167

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

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

    
176
handleCall _ op =
177
  return . Bad $
178
    GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")
179

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

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

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

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

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

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