Fix permission problem related to Issue 477

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

diff --git a/src/Ganeti/Query/Server.hs b/src/Ganeti/Query/Server.hs
index 3ab49b0..3839715 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
@@ -173,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
@@ -188,20 +189,23 @@ 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
 
 -- | Handles one iteration of the client protocol: receives message,
--- checks for validity and decods, returns response.
+-- checks it for validity and decodes it, returns response.
 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) >>
@@ -224,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)
+         Nothing (Just socket_path) $ getServer True socket_path
+  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)