Statistics
| Branch: | Tag: | Revision:

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

History | View | Annotate | Download (9.6 kB)

1 25b54de0 Iustin Pop
{-# LANGUAGE BangPatterns #-}
2 25b54de0 Iustin Pop
3 d120506c Agata Murawska
{-| Implementation of the Ganeti Query2 server.
4 25b54de0 Iustin Pop
5 25b54de0 Iustin Pop
-}
6 25b54de0 Iustin Pop
7 25b54de0 Iustin Pop
{-
8 25b54de0 Iustin Pop
9 25b54de0 Iustin Pop
Copyright (C) 2012 Google Inc.
10 25b54de0 Iustin Pop
11 25b54de0 Iustin Pop
This program is free software; you can redistribute it and/or modify
12 25b54de0 Iustin Pop
it under the terms of the GNU General Public License as published by
13 25b54de0 Iustin Pop
the Free Software Foundation; either version 2 of the License, or
14 25b54de0 Iustin Pop
(at your option) any later version.
15 25b54de0 Iustin Pop
16 25b54de0 Iustin Pop
This program is distributed in the hope that it will be useful, but
17 25b54de0 Iustin Pop
WITHOUT ANY WARRANTY; without even the implied warranty of
18 25b54de0 Iustin Pop
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19 25b54de0 Iustin Pop
General Public License for more details.
20 25b54de0 Iustin Pop
21 25b54de0 Iustin Pop
You should have received a copy of the GNU General Public License
22 25b54de0 Iustin Pop
along with this program; if not, write to the Free Software
23 25b54de0 Iustin Pop
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 25b54de0 Iustin Pop
02110-1301, USA.
25 25b54de0 Iustin Pop
26 25b54de0 Iustin Pop
-}
27 25b54de0 Iustin Pop
28 4cab6703 Iustin Pop
module Ganeti.Query.Server
29 0d0ac025 Iustin Pop
  ( ConfigReader
30 4c3f55b8 Iustin Pop
  , prepQueryD
31 0d0ac025 Iustin Pop
  , runQueryD
32 0d0ac025 Iustin Pop
  ) where
33 25b54de0 Iustin Pop
34 f2374060 Iustin Pop
import Control.Applicative
35 25b54de0 Iustin Pop
import Control.Concurrent
36 25b54de0 Iustin Pop
import Control.Exception
37 25b54de0 Iustin Pop
import Data.Bits (bitSize)
38 25b54de0 Iustin Pop
import Data.Maybe
39 25b54de0 Iustin Pop
import qualified Network.Socket as S
40 25b54de0 Iustin Pop
import qualified Text.JSON as J
41 25b54de0 Iustin Pop
import Text.JSON (showJSON, JSValue(..))
42 25b54de0 Iustin Pop
import System.Info (arch)
43 25b54de0 Iustin Pop
44 25b54de0 Iustin Pop
import qualified Ganeti.Constants as C
45 5183e8be Iustin Pop
import Ganeti.Errors
46 9eeb0aa5 Michael Hanselmann
import qualified Ganeti.Path as Path
47 0d0ac025 Iustin Pop
import Ganeti.Daemon
48 25b54de0 Iustin Pop
import Ganeti.Objects
49 f2374060 Iustin Pop
import qualified Ganeti.Config as Config
50 25b54de0 Iustin Pop
import Ganeti.BasicTypes
51 25b54de0 Iustin Pop
import Ganeti.Logging
52 25b54de0 Iustin Pop
import Ganeti.Luxi
53 367c4241 Dato Simó
import Ganeti.OpCodes (TagObject(..))
54 4cab6703 Iustin Pop
import qualified Ganeti.Query.Language as Qlang
55 4cbe9bda Iustin Pop
import Ganeti.Query.Query
56 cd67e337 Iustin Pop
import Ganeti.Query.Filter (makeSimpleFilter)
57 25b54de0 Iustin Pop
58 25b54de0 Iustin Pop
-- | A type for functions that can return the configuration when
59 25b54de0 Iustin Pop
-- executed.
60 25b54de0 Iustin Pop
type ConfigReader = IO (Result ConfigData)
61 25b54de0 Iustin Pop
62 cd67e337 Iustin Pop
-- | Helper for classic queries.
63 cd67e337 Iustin Pop
handleClassicQuery :: ConfigData      -- ^ Cluster config
64 cd67e337 Iustin Pop
                   -> Qlang.ItemType  -- ^ Query type
65 037762a9 Iustin Pop
                   -> [Either String Integer] -- ^ Requested names
66 037762a9 Iustin Pop
                                              -- (empty means all)
67 cd67e337 Iustin Pop
                   -> [String]        -- ^ Requested fields
68 cd67e337 Iustin Pop
                   -> Bool            -- ^ Whether to do sync queries or not
69 5183e8be Iustin Pop
                   -> IO (GenericResult GanetiException JSValue)
70 5183e8be Iustin Pop
handleClassicQuery _ _ _ _ True =
71 5183e8be Iustin Pop
  return . Bad $ OpPrereqError "Sync queries are not allowed" ECodeInval
72 cd67e337 Iustin Pop
handleClassicQuery cfg qkind names fields _ = do
73 cd67e337 Iustin Pop
  let flt = makeSimpleFilter (nameField qkind) names
74 cd67e337 Iustin Pop
  qr <- query cfg True (Qlang.Query qkind fields flt)
75 cd67e337 Iustin Pop
  return $ showJSON <$> (qr >>= queryCompat)
76 cd67e337 Iustin Pop
77 25b54de0 Iustin Pop
-- | Minimal wrapper to handle the missing config case.
78 5183e8be Iustin Pop
handleCallWrapper :: Result ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
79 25b54de0 Iustin Pop
handleCallWrapper (Bad msg) _ =
80 5183e8be Iustin Pop
  return . Bad . ConfigurationError $
81 5183e8be Iustin Pop
           "I do not have access to a valid configuration, cannot\
82 5183e8be Iustin Pop
           \ process queries: " ++ msg
83 25b54de0 Iustin Pop
handleCallWrapper (Ok config) op = handleCall config op
84 25b54de0 Iustin Pop
85 25b54de0 Iustin Pop
-- | Actual luxi operation handler.
86 5183e8be Iustin Pop
handleCall :: ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
87 25b54de0 Iustin Pop
handleCall cdata QueryClusterInfo =
88 25b54de0 Iustin Pop
  let cluster = configCluster cdata
89 25b54de0 Iustin Pop
      hypervisors = clusterEnabledHypervisors cluster
90 25b54de0 Iustin Pop
      bits = show (bitSize (0::Int)) ++ "bits"
91 25b54de0 Iustin Pop
      arch_tuple = [bits, arch]
92 5b11f8db Iustin Pop
      obj = [ ("software_version", showJSON C.releaseVersion)
93 5b11f8db Iustin Pop
            , ("protocol_version", showJSON C.protocolVersion)
94 5b11f8db Iustin Pop
            , ("config_version", showJSON C.configVersion)
95 25b54de0 Iustin Pop
            , ("os_api_version", showJSON $ maximum C.osApiVersions)
96 5b11f8db Iustin Pop
            , ("export_version", showJSON C.exportVersion)
97 5b11f8db Iustin Pop
            , ("architecture", showJSON arch_tuple)
98 25b54de0 Iustin Pop
            , ("name", showJSON $ clusterClusterName cluster)
99 25b54de0 Iustin Pop
            , ("master", showJSON $ clusterMasterNode cluster)
100 25b54de0 Iustin Pop
            , ("default_hypervisor", showJSON $ head hypervisors)
101 5b11f8db Iustin Pop
            , ("enabled_hypervisors", showJSON hypervisors)
102 a2160e57 Iustin Pop
            , ("hvparams", showJSON $ clusterHvparams cluster)
103 a2160e57 Iustin Pop
            , ("os_hvp", showJSON $ clusterOsHvp cluster)
104 25b54de0 Iustin Pop
            , ("beparams", showJSON $ clusterBeparams cluster)
105 25b54de0 Iustin Pop
            , ("osparams", showJSON $ clusterOsparams cluster)
106 25b54de0 Iustin Pop
            , ("ipolicy", showJSON $ clusterIpolicy cluster)
107 25b54de0 Iustin Pop
            , ("nicparams", showJSON $ clusterNicparams cluster)
108 25b54de0 Iustin Pop
            , ("ndparams", showJSON $ clusterNdparams cluster)
109 a2160e57 Iustin Pop
            , ("diskparams", showJSON $ clusterDiskparams cluster)
110 25b54de0 Iustin Pop
            , ("candidate_pool_size",
111 25b54de0 Iustin Pop
               showJSON $ clusterCandidatePoolSize cluster)
112 25b54de0 Iustin Pop
            , ("master_netdev",  showJSON $ clusterMasterNetdev cluster)
113 25b54de0 Iustin Pop
            , ("master_netmask", showJSON $ clusterMasterNetmask cluster)
114 25b54de0 Iustin Pop
            , ("use_external_mip_script",
115 25b54de0 Iustin Pop
               showJSON $ clusterUseExternalMipScript cluster)
116 5b11f8db Iustin Pop
            , ("volume_group_name", showJSON $ clusterVolumeGroupName cluster)
117 25b54de0 Iustin Pop
            , ("drbd_usermode_helper",
118 25b54de0 Iustin Pop
               maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster))
119 25b54de0 Iustin Pop
            , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster)
120 25b54de0 Iustin Pop
            , ("shared_file_storage_dir",
121 25b54de0 Iustin Pop
               showJSON $ clusterSharedFileStorageDir cluster)
122 25b54de0 Iustin Pop
            , ("maintain_node_health",
123 25b54de0 Iustin Pop
               showJSON $ clusterMaintainNodeHealth cluster)
124 25b54de0 Iustin Pop
            , ("ctime", showJSON $ clusterCtime cluster)
125 25b54de0 Iustin Pop
            , ("mtime", showJSON $ clusterMtime cluster)
126 25b54de0 Iustin Pop
            , ("uuid", showJSON $ clusterUuid cluster)
127 25b54de0 Iustin Pop
            , ("tags", showJSON $ clusterTags cluster)
128 25b54de0 Iustin Pop
            , ("uid_pool", showJSON $ clusterUidPool cluster)
129 25b54de0 Iustin Pop
            , ("default_iallocator",
130 25b54de0 Iustin Pop
               showJSON $ clusterDefaultIallocator cluster)
131 25b54de0 Iustin Pop
            , ("reserved_lvs", showJSON $ clusterReservedLvs cluster)
132 25b54de0 Iustin Pop
            , ("primary_ip_version",
133 25b54de0 Iustin Pop
               showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster)
134 25b54de0 Iustin Pop
             , ("prealloc_wipe_disks",
135 25b54de0 Iustin Pop
                showJSON $ clusterPreallocWipeDisks cluster)
136 25b54de0 Iustin Pop
             , ("hidden_os", showJSON $ clusterHiddenOs cluster)
137 25b54de0 Iustin Pop
             , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)
138 25b54de0 Iustin Pop
            ]
139 25b54de0 Iustin Pop
140 25b54de0 Iustin Pop
  in return . Ok . J.makeObj $ obj
141 25b54de0 Iustin Pop
142 d8e7c45e Iustin Pop
handleCall cfg (QueryTags kind) =
143 f2374060 Iustin Pop
  let tags = case kind of
144 d8e7c45e Iustin Pop
               TagCluster       -> Ok . clusterTags $ configCluster cfg
145 d8e7c45e Iustin Pop
               TagGroup    name -> groupTags <$> Config.getGroup    cfg name
146 d8e7c45e Iustin Pop
               TagNode     name -> nodeTags  <$> Config.getNode     cfg name
147 d8e7c45e Iustin Pop
               TagInstance name -> instTags  <$> Config.getInstance cfg name
148 f2374060 Iustin Pop
  in return (J.showJSON <$> tags)
149 f2374060 Iustin Pop
150 4cbe9bda Iustin Pop
handleCall cfg (Query qkind qfields qfilter) = do
151 fa2c927c Agata Murawska
  result <- query cfg True (Qlang.Query qkind qfields qfilter)
152 4cbe9bda Iustin Pop
  return $ J.showJSON <$> result
153 4cbe9bda Iustin Pop
154 518023a9 Iustin Pop
handleCall _ (QueryFields qkind qfields) = do
155 518023a9 Iustin Pop
  let result = queryFields (Qlang.QueryFields qkind qfields)
156 518023a9 Iustin Pop
  return $ J.showJSON <$> result
157 518023a9 Iustin Pop
158 cd67e337 Iustin Pop
handleCall cfg (QueryNodes names fields lock) =
159 037762a9 Iustin Pop
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode)
160 037762a9 Iustin Pop
    (map Left names) fields lock
161 cd67e337 Iustin Pop
162 cd67e337 Iustin Pop
handleCall cfg (QueryGroups names fields lock) =
163 037762a9 Iustin Pop
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup)
164 037762a9 Iustin Pop
    (map Left names) fields lock
165 cd67e337 Iustin Pop
166 a7e484c4 Iustin Pop
handleCall cfg (QueryJobs names fields) =
167 a7e484c4 Iustin Pop
  handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
168 a7e484c4 Iustin Pop
    (map (Right . fromIntegral . fromJobId) names)  fields False
169 a7e484c4 Iustin Pop
170 25b54de0 Iustin Pop
handleCall _ op =
171 5183e8be Iustin Pop
  return . Bad $
172 5183e8be Iustin Pop
    GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")
173 25b54de0 Iustin Pop
174 25b54de0 Iustin Pop
175 25b54de0 Iustin Pop
-- | Given a decoded luxi request, executes it and sends the luxi
176 25b54de0 Iustin Pop
-- response back to the client.
177 25b54de0 Iustin Pop
handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool
178 25b54de0 Iustin Pop
handleClientMsg client creader args = do
179 25b54de0 Iustin Pop
  cfg <- creader
180 25b54de0 Iustin Pop
  logDebug $ "Request: " ++ show args
181 25b54de0 Iustin Pop
  call_result <- handleCallWrapper cfg args
182 25b54de0 Iustin Pop
  (!status, !rval) <-
183 25b54de0 Iustin Pop
    case call_result of
184 9abbb084 Iustin Pop
      Bad err -> do
185 5183e8be Iustin Pop
        logWarning $ "Failed to execute request: " ++ show err
186 5183e8be Iustin Pop
        return (False, showJSON err)
187 25b54de0 Iustin Pop
      Ok result -> do
188 f74b88fa Iustin Pop
        -- only log the first 2,000 chars of the result
189 f74b88fa Iustin Pop
        logDebug $ "Result (truncated): " ++ take 2000 (J.encode result)
190 25b54de0 Iustin Pop
        return (True, result)
191 25b54de0 Iustin Pop
  sendMsg client $ buildResponse status rval
192 25b54de0 Iustin Pop
  return True
193 25b54de0 Iustin Pop
194 25b54de0 Iustin Pop
-- | Handles one iteration of the client protocol: receives message,
195 25b54de0 Iustin Pop
-- checks for validity and decods, returns response.
196 25b54de0 Iustin Pop
handleClient :: Client -> ConfigReader -> IO Bool
197 25b54de0 Iustin Pop
handleClient client creader = do
198 25b54de0 Iustin Pop
  !msg <- recvMsgExt client
199 25b54de0 Iustin Pop
  case msg of
200 25b54de0 Iustin Pop
    RecvConnClosed -> logDebug "Connection closed" >> return False
201 25b54de0 Iustin Pop
    RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
202 25b54de0 Iustin Pop
                     return False
203 25b54de0 Iustin Pop
    RecvOk payload ->
204 25b54de0 Iustin Pop
      case validateCall payload >>= decodeCall of
205 9abbb084 Iustin Pop
        Bad err -> do
206 9abbb084 Iustin Pop
             let errmsg = "Failed to parse request: " ++ err
207 9abbb084 Iustin Pop
             logWarning errmsg
208 9abbb084 Iustin Pop
             sendMsg client $ buildResponse False (showJSON errmsg)
209 9abbb084 Iustin Pop
             return False
210 25b54de0 Iustin Pop
        Ok args -> handleClientMsg client creader args
211 25b54de0 Iustin Pop
212 25b54de0 Iustin Pop
-- | Main client loop: runs one loop of 'handleClient', and if that
213 25b54de0 Iustin Pop
-- doesn't repot a finished (closed) connection, restarts itself.
214 25b54de0 Iustin Pop
clientLoop :: Client -> ConfigReader -> IO ()
215 25b54de0 Iustin Pop
clientLoop client creader = do
216 25b54de0 Iustin Pop
  result <- handleClient client creader
217 25b54de0 Iustin Pop
  if result
218 25b54de0 Iustin Pop
    then clientLoop client creader
219 25b54de0 Iustin Pop
    else closeClient client
220 25b54de0 Iustin Pop
221 25b54de0 Iustin Pop
-- | Main loop: accepts clients, forks an I/O thread to handle that
222 25b54de0 Iustin Pop
-- client, and then restarts.
223 25b54de0 Iustin Pop
mainLoop :: ConfigReader -> S.Socket -> IO ()
224 25b54de0 Iustin Pop
mainLoop creader socket = do
225 25b54de0 Iustin Pop
  client <- acceptClient socket
226 25b54de0 Iustin Pop
  _ <- forkIO $ clientLoop client creader
227 25b54de0 Iustin Pop
  mainLoop creader socket
228 25b54de0 Iustin Pop
229 4c3f55b8 Iustin Pop
-- | Function that prepares the server socket.
230 4c3f55b8 Iustin Pop
prepQueryD :: Maybe FilePath -> IO (FilePath, S.Socket)
231 4c3f55b8 Iustin Pop
prepQueryD fpath = do
232 29a30533 Iustin Pop
  def_socket <- Path.defaultQuerySocket
233 29a30533 Iustin Pop
  let socket_path = fromMaybe def_socket fpath
234 0d0ac025 Iustin Pop
  cleanupSocket socket_path
235 73b16ca1 Iustin Pop
  s <- describeError "binding to the Luxi socket"
236 73b16ca1 Iustin Pop
         Nothing (Just socket_path) $ getServer socket_path
237 4c3f55b8 Iustin Pop
  return (socket_path, s)
238 4c3f55b8 Iustin Pop
239 4c3f55b8 Iustin Pop
-- | Main function that runs the query endpoint.
240 4c3f55b8 Iustin Pop
runQueryD :: (FilePath, S.Socket) -> ConfigReader -> IO ()
241 4c3f55b8 Iustin Pop
runQueryD (socket_path, server) creader =
242 4c3f55b8 Iustin Pop
  finally
243 4c3f55b8 Iustin Pop
    (mainLoop creader server)
244 4c3f55b8 Iustin Pop
    (closeServer socket_path server)