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)
import Graphics.UI.Gtk(postGUIAsync)
import Control.Event(triggerEvent)
import Control.Monad.IO.Class (MonadIO(..))
import System.Log.Logger (getLevel, getRootLogger)
doServerCommand :: ServerCommand -> (ServerAnswer -> IDEM alpha) -> IDEAction
doServerCommand command cont = do
server' <- readIDE server
case server' of
Just handle -> do
isOpen <- liftIO $ hIsOpen handle
if isOpen
then doCommand handle >> return ()
else do
modifyIDE_ (\ ide -> ide{server = Nothing})
doServerCommand command cont
Nothing -> do
prefs' <- readIDE prefs
handle <- reifyIDE $ \ideR -> do
catch (connectTo (serverIP prefs') (PortNumber(PortNum (fromIntegral $ serverPort prefs'))))
(\(exc :: SomeException) -> do
catch (startServer (serverPort prefs'))
(\(exc :: SomeException) -> throwIDE ("Can't start leksah-server" ++ 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
triggerEventIDE (StatusbarChanged [CompartmentCollect True])
reifyIDE $ \ideR -> forkIO $ do
hPutStrLn handle (show command)
hFlush handle
resp <- hGetLine handle
postGUIAsync (reflectIDE (do
triggerEvent ideR (StatusbarChanged [CompartmentCollect False])
cont (read resp)
return ()) ideR)
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 ()
waitForServer :: Prefs -> Int -> IO (Maybe Handle)
waitForServer _ 0 = return Nothing
waitForServer prefs s = do
threadDelay 100000
catch (do
handle <- liftIO $ connectTo (serverIP prefs) (PortNumber(PortNum (fromIntegral $ serverPort prefs)))
return (Just handle))
(\(exc :: SomeException) -> waitForServer prefs (s1))