Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Query / Server.hs @ ae960018

History | View | Annotate | Download (9.6 kB)

1
{-# LANGUAGE BangPatterns #-}
2

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

    
5
-}
6

    
7
{-
8

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

    
140
  in return . Ok . J.makeObj $ obj
141

    
142
handleCall cfg (QueryTags kind) =
143
  let tags = case kind of
144
               TagCluster       -> Ok . clusterTags $ configCluster cfg
145
               TagGroup    name -> groupTags <$> Config.getGroup    cfg name
146
               TagNode     name -> nodeTags  <$> Config.getNode     cfg name
147
               TagInstance name -> instTags  <$> Config.getInstance cfg name
148
  in return (J.showJSON <$> tags)
149

    
150
handleCall cfg (Query qkind qfields qfilter) = do
151
  result <- query cfg True (Qlang.Query qkind qfields qfilter)
152
  return $ J.showJSON <$> result
153

    
154
handleCall _ (QueryFields qkind qfields) = do
155
  let result = queryFields (Qlang.QueryFields qkind qfields)
156
  return $ J.showJSON <$> result
157

    
158
handleCall cfg (QueryNodes names fields lock) =
159
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode)
160
    (map Left names) fields lock
161

    
162
handleCall cfg (QueryGroups names fields lock) =
163
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup)
164
    (map Left names) fields lock
165

    
166
handleCall cfg (QueryJobs names fields) =
167
  handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
168
    (map (Right . fromIntegral . fromJobId) names)  fields False
169

    
170
handleCall _ op =
171
  return . Bad $
172
    GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")
173

    
174

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

    
194
-- | Handles one iteration of the client protocol: receives message,
195
-- checks for validity and decods, returns response.
196
handleClient :: Client -> ConfigReader -> IO Bool
197
handleClient client creader = do
198
  !msg <- recvMsgExt client
199
  case msg of
200
    RecvConnClosed -> logDebug "Connection closed" >> return False
201
    RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
202
                     return False
203
    RecvOk payload ->
204
      case validateCall payload >>= decodeCall of
205
        Bad err -> do
206
             let errmsg = "Failed to parse request: " ++ err
207
             logWarning errmsg
208
             sendMsg client $ buildResponse False (showJSON errmsg)
209
             return False
210
        Ok args -> handleClientMsg client creader args
211

    
212
-- | Main client loop: runs one loop of 'handleClient', and if that
213
-- doesn't repot a finished (closed) connection, restarts itself.
214
clientLoop :: Client -> ConfigReader -> IO ()
215
clientLoop client creader = do
216
  result <- handleClient client creader
217
  if result
218
    then clientLoop client creader
219
    else closeClient client
220

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

    
229
-- | Function that prepares the server socket.
230
prepQueryD :: Maybe FilePath -> IO (FilePath, S.Socket)
231
prepQueryD fpath = do
232
  def_socket <- Path.defaultQuerySocket
233
  let socket_path = fromMaybe def_socket fpath
234
  cleanupSocket socket_path
235
  s <- describeError "binding to the Luxi socket"
236
         Nothing (Just socket_path) $ getServer socket_path
237
  return (socket_path, s)
238

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