Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Queryd.hs @ 518023a9

History | View | Annotate | Download (7.9 kB)

1
{-# LANGUAGE BangPatterns #-}
2

    
3
{-| Implementation of the Ganeti confd types.
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.Queryd
29
  ( ConfigReader
30
  , runQueryD
31
  ) where
32

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

    
44
import qualified Ganeti.Constants as C
45
import Ganeti.Daemon
46
import Ganeti.Objects
47
import qualified Ganeti.Config as Config
48
import Ganeti.BasicTypes
49
import Ganeti.Logging
50
import Ganeti.Luxi
51
import qualified Ganeti.Qlang as Qlang
52
import Ganeti.Query.Query
53

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

    
58
-- | Minimal wrapper to handle the missing config case.
59
handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (Result JSValue)
60
handleCallWrapper (Bad msg) _ =
61
  return . Bad $ "I do not have access to a valid configuration, cannot\
62
                 \ process queries: " ++ msg
63
handleCallWrapper (Ok config) op = handleCall config op
64

    
65
-- | Actual luxi operation handler.
66
handleCall :: ConfigData -> LuxiOp -> IO (Result JSValue)
67
handleCall cdata QueryClusterInfo =
68
  let cluster = configCluster cdata
69
      hypervisors = clusterEnabledHypervisors cluster
70
      bits = show (bitSize (0::Int)) ++ "bits"
71
      arch_tuple = [bits, arch]
72
      obj = [ ("software_version", showJSON $ C.releaseVersion)
73
            , ("protocol_version", showJSON $ C.protocolVersion)
74
            , ("config_version", showJSON $ C.configVersion)
75
            , ("os_api_version", showJSON $ maximum C.osApiVersions)
76
            , ("export_version", showJSON $ C.exportVersion)
77
            , ("architecture", showJSON $ arch_tuple)
78
            , ("name", showJSON $ clusterClusterName cluster)
79
            , ("master", showJSON $ clusterMasterNode cluster)
80
            , ("default_hypervisor", showJSON $ head hypervisors)
81
            , ("enabled_hypervisors", showJSON $ hypervisors)
82
            , ("hvparams", showJSON $ clusterHvparams cluster)
83
            , ("os_hvp", showJSON $ clusterOsHvp cluster)
84
            , ("beparams", showJSON $ clusterBeparams cluster)
85
            , ("osparams", showJSON $ clusterOsparams cluster)
86
            , ("ipolicy", showJSON $ clusterIpolicy cluster)
87
            , ("nicparams", showJSON $ clusterNicparams cluster)
88
            , ("ndparams", showJSON $ clusterNdparams cluster)
89
            , ("diskparams", showJSON $ clusterDiskparams cluster)
90
            , ("candidate_pool_size",
91
               showJSON $ clusterCandidatePoolSize cluster)
92
            , ("master_netdev",  showJSON $ clusterMasterNetdev cluster)
93
            , ("master_netmask", showJSON $ clusterMasterNetmask cluster)
94
            , ("use_external_mip_script",
95
               showJSON $ clusterUseExternalMipScript cluster)
96
            , ("volume_group_name", showJSON $clusterVolumeGroupName cluster)
97
            , ("drbd_usermode_helper",
98
               maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster))
99
            , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster)
100
            , ("shared_file_storage_dir",
101
               showJSON $ clusterSharedFileStorageDir cluster)
102
            , ("maintain_node_health",
103
               showJSON $ clusterMaintainNodeHealth cluster)
104
            , ("ctime", showJSON $ clusterCtime cluster)
105
            , ("mtime", showJSON $ clusterMtime cluster)
106
            , ("uuid", showJSON $ clusterUuid cluster)
107
            , ("tags", showJSON $ clusterTags cluster)
108
            , ("uid_pool", showJSON $ clusterUidPool cluster)
109
            , ("default_iallocator",
110
               showJSON $ clusterDefaultIallocator cluster)
111
            , ("reserved_lvs", showJSON $ clusterReservedLvs cluster)
112
            , ("primary_ip_version",
113
               showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster)
114
             , ("prealloc_wipe_disks",
115
                showJSON $ clusterPreallocWipeDisks cluster)
116
             , ("hidden_os", showJSON $ clusterHiddenOs cluster)
117
             , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)
118
            ]
119

    
120
  in return . Ok . J.makeObj $ obj
121

    
122
handleCall cfg (QueryTags kind name) =
123
  let tags = case kind of
124
               TagCluster -> Ok . clusterTags $ configCluster cfg
125
               TagGroup -> groupTags <$> Config.getGroup cfg name
126
               TagNode -> nodeTags <$> Config.getNode cfg name
127
               TagInstance -> instTags <$> Config.getInstance cfg name
128
  in return (J.showJSON <$> tags)
129

    
130
handleCall cfg (Query qkind qfields qfilter) = do
131
  result <- query cfg (Qlang.Query qkind qfields qfilter)
132
  return $ J.showJSON <$> result
133

    
134
handleCall _ (QueryFields qkind qfields) = do
135
  let result = queryFields (Qlang.QueryFields qkind qfields)
136
  return $ J.showJSON <$> result
137

    
138
handleCall _ op =
139
  return . Bad $ "Luxi call '" ++ strOfOp op ++ "' not implemented"
140

    
141

    
142
-- | Given a decoded luxi request, executes it and sends the luxi
143
-- response back to the client.
144
handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool
145
handleClientMsg client creader args = do
146
  cfg <- creader
147
  logDebug $ "Request: " ++ show args
148
  call_result <- handleCallWrapper cfg args
149
  (!status, !rval) <-
150
    case call_result of
151
      Bad err -> do
152
        let errmsg = "Failed to execute request: " ++ err
153
        logWarning errmsg
154
        return (False, showJSON errmsg)
155
      Ok result -> do
156
        logDebug $ "Result " ++ show (pp_value result)
157
        return (True, result)
158
  sendMsg client $ buildResponse status rval
159
  return True
160

    
161
-- | Handles one iteration of the client protocol: receives message,
162
-- checks for validity and decods, returns response.
163
handleClient :: Client -> ConfigReader -> IO Bool
164
handleClient client creader = do
165
  !msg <- recvMsgExt client
166
  case msg of
167
    RecvConnClosed -> logDebug "Connection closed" >> return False
168
    RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
169
                     return False
170
    RecvOk payload ->
171
      case validateCall payload >>= decodeCall of
172
        Bad err -> do
173
             let errmsg = "Failed to parse request: " ++ err
174
             logWarning errmsg
175
             sendMsg client $ buildResponse False (showJSON errmsg)
176
             return False
177
        Ok args -> handleClientMsg client creader args
178

    
179
-- | Main client loop: runs one loop of 'handleClient', and if that
180
-- doesn't repot a finished (closed) connection, restarts itself.
181
clientLoop :: Client -> ConfigReader -> IO ()
182
clientLoop client creader = do
183
  result <- handleClient client creader
184
  if result
185
    then clientLoop client creader
186
    else closeClient client
187

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

    
196
-- | Main function that runs the query endpoint. This should be the
197
-- only one exposed from this module.
198
runQueryD :: Maybe FilePath -> ConfigReader -> IO ()
199
runQueryD fpath creader = do
200
  let socket_path = fromMaybe C.querySocket fpath
201
  cleanupSocket socket_path
202
  bracket
203
    (getServer socket_path)
204
    (closeServer socket_path)
205
    (mainLoop creader)