Rename queryd to luxid

[ganeti-local] / src / Ganeti / Query / Server.hs

diff --git a/src/Ganeti/Query/Server.hs b/src/Ganeti/Query/Server.hs
index f4a9e78..53f0d29 100644 (file)
--- a/src/Ganeti/Query/Server.hs
+++ b/src/Ganeti/Query/Server.hs
@@ -26,16 +26,17 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 -}
 
 module Ganeti.Query.Server
-  ( ConfigReader
-  , prepQueryD
-  , runQueryD
+  ( main
+  , checkMain
+  , prepMain
   ) where
 
 import Control.Applicative
 import Control.Concurrent
 import Control.Exception
+import Control.Monad (forever)
 import Data.Bits (bitSize)
-import Data.Maybe
+import Data.IORef
 import qualified Network.Socket as S
 import qualified Text.JSON as J
 import Text.JSON (showJSON, JSValue(..))
@@ -47,6 +48,7 @@ import qualified Ganeti.Path as Path
 import Ganeti.Daemon
 import Ganeti.Objects
 import qualified Ganeti.Config as Config
+import Ganeti.ConfigReader
 import Ganeti.BasicTypes
 import Ganeti.Logging
 import Ganeti.Luxi
@@ -55,10 +57,6 @@ import qualified Ganeti.Query.Language as Qlang
 import Ganeti.Query.Query
 import Ganeti.Query.Filter (makeSimpleFilter)
 
--- | A type for functions that can return the configuration when
--- executed.
-type ConfigReader = IO (Result ConfigData)
-
 -- | Helper for classic queries.
 handleClassicQuery :: ConfigData      -- ^ Cluster config
                    -> Qlang.ItemType  -- ^ Query type
@@ -87,6 +85,7 @@ handleCall :: ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
 handleCall cdata QueryClusterInfo =
   let cluster = configCluster cdata
       hypervisors = clusterEnabledHypervisors cluster
+      diskTemplates = clusterEnabledDiskTemplates cluster
       def_hv = case hypervisors of
                  x:_ -> showJSON x
                  [] -> JSNull
@@ -135,10 +134,11 @@ handleCall cdata QueryClusterInfo =
             , ("reserved_lvs", showJSON $ clusterReservedLvs cluster)
             , ("primary_ip_version",
                showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster)
-             , ("prealloc_wipe_disks",
-                showJSON $ clusterPreallocWipeDisks cluster)
-             , ("hidden_os", showJSON $ clusterHiddenOs cluster)
-             , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)
+            , ("prealloc_wipe_disks",
+               showJSON $ clusterPreallocWipeDisks cluster)
+            , ("hidden_os", showJSON $ clusterHiddenOs cluster)
+            , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)
+            , ("enabled_disk_templates", showJSON diskTemplates)
             ]
 
   in return . Ok . J.makeObj $ obj
@@ -171,11 +171,14 @@ handleCall cfg (QueryJobs names fields) =
   handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
     (map (Right . fromIntegral . fromJobId) names)  fields False
 
+handleCall cfg (QueryNetworks names fields lock) =
+  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNetwork)
+    (map Left names) fields lock
+
 handleCall _ op =
   return . Bad $
     GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")
 
-
 -- | Given a decoded luxi request, executes it and sends the luxi
 -- response back to the client.
 handleClientMsg :: Client -> ConfigReader -> LuxiOp -> IO Bool
@@ -186,11 +189,13 @@ handleClientMsg client creader args = do
   (!status, !rval) <-
     case call_result of
       Bad err -> do
-        logWarning $ "Failed to execute request: " ++ show err
+        logWarning $ "Failed to execute request " ++ show args ++ ": "
+                     ++ show err
         return (False, showJSON err)
       Ok result -> do
         -- only log the first 2,000 chars of the result
         logDebug $ "Result (truncated): " ++ take 2000 (J.encode result)
+        logInfo $ "Successfully handled " ++ strOfOp args
         return (True, result)
   sendMsg client $ buildResponse status rval
   return True
@@ -200,6 +205,7 @@ handleClientMsg client creader args = do
 handleClient :: Client -> ConfigReader -> IO Bool
 handleClient client creader = do
   !msg <- recvMsgExt client
+  logDebug $ "Received message: " ++ show msg
   case msg of
     RecvConnClosed -> logDebug "Connection closed" >> return False
     RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
@@ -214,7 +220,7 @@ handleClient client creader = do
         Ok args -> handleClientMsg client creader args
 
 -- | Main client loop: runs one loop of 'handleClient', and if that
--- doesn't repot a finished (closed) connection, restarts itself.
+-- doesn't report a finished (closed) connection, restarts itself.
 clientLoop :: Client -> ConfigReader -> IO ()
 clientLoop client creader = do
   result <- handleClient client creader
@@ -222,27 +228,37 @@ clientLoop client creader = do
     then clientLoop client creader
     else closeClient client
 
--- | Main loop: accepts clients, forks an I/O thread to handle that
--- client, and then restarts.
-mainLoop :: ConfigReader -> S.Socket -> IO ()
-mainLoop creader socket = do
+-- | Main listener loop: accepts clients, forks an I/O thread to handle
+-- that client.
+listener :: ConfigReader -> S.Socket -> IO ()
+listener creader socket = do
   client <- acceptClient socket
   _ <- forkIO $ clientLoop client creader
-  mainLoop creader socket
+  return ()
 
--- | Function that prepares the server socket.
-prepQueryD :: Maybe FilePath -> IO (FilePath, S.Socket)
-prepQueryD fpath = do
-  def_socket <- Path.defaultQuerySocket
-  let socket_path = fromMaybe def_socket fpath
+-- | Type alias for prepMain results
+type PrepResult = (FilePath, S.Socket, IORef (Result ConfigData))
+
+-- | Check function for luxid.
+checkMain :: CheckFn ()
+checkMain _ = return $ Right ()
+
+-- | Prepare function for luxid.
+prepMain :: PrepFn () PrepResult
+prepMain _ _ = do
+  socket_path <- Path.defaultQuerySocket
   cleanupSocket socket_path
   s <- describeError "binding to the Luxi socket"
          Nothing (Just socket_path) $ getServer socket_path
-  return (socket_path, s)
+  cref <- newIORef (Bad "Configuration not yet loaded")
+  return (socket_path, s, cref)
+
+-- | Main function.
+main :: MainFn () PrepResult
+main _ _ (socket_path, server, cref) = do
+  initConfigReader id cref
+  let creader = readIORef cref
 
--- | Main function that runs the query endpoint.
-runQueryD :: (FilePath, S.Socket) -> ConfigReader -> IO ()
-runQueryD (socket_path, server) creader =
   finally
-    (mainLoop creader server)
+    (forever $ listener creader server)
     (closeServer socket_path server)