Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Query / Server.hs @ 3e02cd3c

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

    
144
  in return . Ok . J.makeObj $ obj
145

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

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

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

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

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

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

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

    
178

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

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

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

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

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

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