Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Queryd.hs @ 4cbe9bda

History | View | Annotate | Download (7.8 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 _ op =
135
  return . Bad $ "Luxi call '" ++ strOfOp op ++ "' not implemented"
136

    
137

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

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

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

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

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