{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.ServerConnection -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | Server functionality -- ----------------------------------------------------------------------------- module IDE.Utils.ServerConnection ( doServerCommand, ) where import IDE.Core.State import Network (connectTo,PortID(..)) import Network.Socket (PortNumber(..)) import IDE.Utils.Tool (runProcess) import GHC.Conc(threadDelay) import System.IO import Control.Exception (SomeException(..), catch) import Prelude hiding(catch) import Control.Concurrent(forkIO, newEmptyMVar, putMVar, takeMVar, tryTakeMVar) import Graphics.UI.Gtk(postGUIAsync) import Control.Event(triggerEvent) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (ask) import System.Log.Logger (getLevel, getRootLogger, debugM) import Control.Monad (void, forever) import qualified Data.Text as T (pack, unpack) import Data.Monoid ((<>)) doServerCommand :: ServerCommand -> (ServerAnswer -> IDEM ()) -> IDEAction doServerCommand command cont = do q' <- readIDE serverQueue q <- case q' of Just q -> return q Nothing -> do q <- liftIO $ newEmptyMVar modifyIDE_ (\ ide -> ide{serverQueue = Just q}) ideR <- ask liftIO . forkIO . forever $ do debugM "leksah" $ "Ready for command" (command, cont) <- takeMVar q reflectIDE (doServerCommand' command cont) ideR return q liftIO $ do tryTakeMVar q debugM "leksah" $ "Queue new command " ++ show command putMVar q (command, cont) doServerCommand' :: ServerCommand -> (ServerAnswer -> IDEM ()) -> IDEAction doServerCommand' command cont = do server' <- readIDE server case server' of Just handle -> do isOpen <- liftIO $ hIsOpen handle if isOpen then void (doCommand handle) else do modifyIDE_ (\ ide -> ide{server = Nothing}) doServerCommand command cont Nothing -> do prefs' <- readIDE prefs handle <- reifyIDE $ \ideR -> catch (connectTo (T.unpack $ serverIP prefs') (PortNumber (fromIntegral $ serverPort prefs'))) (\(exc :: SomeException) -> do catch (startServer (serverPort prefs')) (\(exc :: SomeException) -> throwIDE ("Can't start leksah-server" <> T.pack (show exc))) mbHandle <- waitForServer prefs' 100 case mbHandle of Just handle -> return handle Nothing -> throwIDE "Can't connect to leksah-server") modifyIDE_ (\ ide -> ide{server = Just handle}) doCommand handle return () where doCommand handle = do postAsyncIDE . void $ triggerEventIDE (StatusbarChanged [CompartmentCollect True]) resp <- liftIO $ do debugM "leksah" $ "Sending server command " ++ show command hPrint handle command hFlush handle debugM "leksah" $ "Waiting on server command " ++ show command hGetLine handle liftIO . debugM "leksah" $ "Server result " ++ resp postAsyncIDE $ do triggerEventIDE (StatusbarChanged [CompartmentCollect False]) cont (read resp) startServer :: Int -> IO () startServer port = do logger <- getRootLogger let verbosity = case getLevel logger of Just level -> ["--verbosity=" ++ show level] Nothing -> [] runProcess "leksah-server" (["--server=" ++ show port, "+RTS", "-N2", "-RTS"] ++ verbosity) Nothing Nothing Nothing Nothing Nothing return () -- | s is in tenth's of seconds waitForServer :: Prefs -> Int -> IO (Maybe Handle) waitForServer _ 0 = return Nothing waitForServer prefs s = do threadDelay 100000 -- 0.1 second catch (do handle <- liftIO $ connectTo (T.unpack $ serverIP prefs) (PortNumber (fromIntegral $ serverPort prefs)) return (Just handle)) (\(exc :: SomeException) -> waitForServer prefs (s-1))