1 {-# LANGUAGE BangPatterns #-}
3 {-| Implementation of the Ganeti confd types.
9 Copyright (C) 2012 Google Inc.
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.
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.
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
32 import Control.Applicative
33 import Control.Concurrent
34 import Control.Exception
35 import Data.Bits (bitSize)
37 import qualified Network.Socket as S
38 import qualified Text.JSON as J
39 import Text.JSON (showJSON, JSValue(..))
40 import Text.JSON.Pretty (pp_value)
41 import System.Info (arch)
43 import qualified Ganeti.Constants as C
45 import qualified Ganeti.Config as Config
46 import Ganeti.BasicTypes
51 -- | A type for functions that can return the configuration when
53 type ConfigReader = IO (Result ConfigData)
55 -- | Minimal wrapper to handle the missing config case.
56 handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (Result JSValue)
57 handleCallWrapper (Bad msg) _ =
58 return . Bad $ "I do not have access to a valid configuration, cannot\
59 \ process queries: " ++ msg
60 handleCallWrapper (Ok config) op = handleCall config op
62 -- | Actual luxi operation handler.
63 handleCall :: ConfigData -> LuxiOp -> IO (Result JSValue)
64 handleCall cdata QueryClusterInfo =
65 let cluster = configCluster cdata
66 hypervisors = clusterEnabledHypervisors cluster
67 bits = show (bitSize (0::Int)) ++ "bits"
68 arch_tuple = [bits, arch]
69 -- FIXME: this is for the missing *params fields
70 empty_params = showJSON $ J.makeObj ([]::[(String, JSValue)])
71 obj = [ ("software_version", showJSON $ C.releaseVersion)
72 , ("protocol_version", showJSON $ C.protocolVersion)
73 , ("config_version", showJSON $ C.configVersion)
74 , ("os_api_version", showJSON $ maximum C.osApiVersions)
75 , ("export_version", showJSON $ C.exportVersion)
76 , ("architecture", showJSON $ arch_tuple)
77 , ("name", showJSON $ clusterClusterName cluster)
78 , ("master", showJSON $ clusterMasterNode cluster)
79 , ("default_hypervisor", showJSON $ head hypervisors)
80 , ("enabled_hypervisors", showJSON $ hypervisors)
81 -- FIXME: *params missing
82 , ("hvparams", empty_params)
83 , ("os_hvp", empty_params)
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", empty_params)
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)
120 in return . Ok . J.makeObj $ obj
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)
131 return . Bad $ "Luxi call '" ++ strOfOp op ++ "' not implemented"
134 -- | Given a decoded luxi request, executes it and sends the luxi
135 -- response back to the client.
136 handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool
137 handleClientMsg client creader args = do
139 logDebug $ "Request: " ++ show args
140 call_result <- handleCallWrapper cfg args
144 logWarning $ "Failed to execute request: " ++ x
145 return (False, JSString $ J.toJSString x)
147 logDebug $ "Result " ++ show (pp_value result)
148 return (True, result)
149 sendMsg client $ buildResponse status rval
152 -- | Handles one iteration of the client protocol: receives message,
153 -- checks for validity and decods, returns response.
154 handleClient :: Client -> ConfigReader -> IO Bool
155 handleClient client creader = do
156 !msg <- recvMsgExt client
158 RecvConnClosed -> logDebug "Connection closed" >> return False
159 RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
162 case validateCall payload >>= decodeCall of
163 Bad err -> logWarning ("Failed to parse request: " ++ err) >>
165 Ok args -> handleClientMsg client creader args
167 -- | Main client loop: runs one loop of 'handleClient', and if that
168 -- doesn't repot a finished (closed) connection, restarts itself.
169 clientLoop :: Client -> ConfigReader -> IO ()
170 clientLoop client creader = do
171 result <- handleClient client creader
173 then clientLoop client creader
174 else closeClient client
176 -- | Main loop: accepts clients, forks an I/O thread to handle that
177 -- client, and then restarts.
178 mainLoop :: ConfigReader -> S.Socket -> IO ()
179 mainLoop creader socket = do
180 client <- acceptClient socket
181 _ <- forkIO $ clientLoop client creader
182 mainLoop creader socket
184 -- | Main function that runs the query endpoint. This should be the
185 -- only one exposed from this module.
186 runQueryD :: Maybe FilePath -> ConfigReader -> IO ()
187 runQueryD fpath creader = do
188 let socket_path = fromMaybe C.querySocket fpath
190 (getServer socket_path)
191 (closeServer socket_path)