module IdeSession.Update (
initSession
, SessionInitParams(..)
, defaultSessionInitParams
, shutdownSession
, forceShutdownSession
, restartSession
, IdeSessionUpdate
, updateSession
, updateSourceFile
, updateSourceFileFromFile
, updateSourceFileDelete
, updateGhcOpts
, updateRtsOpts
, updateRelativeIncludes
, updateCodeGeneration
, updateDataFile
, updateDataFileFromFile
, updateDataFileDelete
, updateDeleteManagedFiles
, updateEnv
, updateArgs
, updateStdoutBufferMode
, updateStderrBufferMode
, updateTargets
, buildExe
, buildDoc
, buildLicenses
, runStmt
, runExe
, resume
, setBreakpoint
, printVar
, crashGhcServer
, buildLicsFromPkgs
, LicenseArgs(..)
)
where
import Prelude hiding (mod, span)
import Control.Concurrent (threadDelay)
import Control.Monad (when, unless)
import Control.Monad.IO.Class (liftIO)
import Data.Accessor (Accessor, (^.))
import Data.List (elemIndices, isPrefixOf)
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(..), (<>))
import Distribution.Simple (PackageDBStack, PackageDB(..))
import System.Environment (getEnv, getEnvironment)
import System.Exit (ExitCode(..))
import System.FilePath ((</>))
import System.IO.Temp (createTempDirectory)
import System.Posix.IO.ByteString
import System.Process (proc, CreateProcess(..), StdStream(..), createProcess, waitForProcess, interruptProcessGroupOf, terminateProcess)
import qualified Control.Exception as Ex
import qualified Data.ByteString as BSS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.UTF8 as BSL.UTF8
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified System.Directory as Dir
import qualified System.IO as IO
import IdeSession.Cabal
import IdeSession.Config
import IdeSession.GHC.API
import IdeSession.GHC.Client
import IdeSession.RPC.API (ExternalException(..))
import IdeSession.State
import IdeSession.Strict.Container
import IdeSession.Strict.MVar (newMVar, newEmptyMVar, StrictMVar)
import IdeSession.Types.Private hiding (RunResult(..))
import IdeSession.Types.Progress
import IdeSession.Types.Public (RunBufferMode(..))
import IdeSession.Update.ExecuteSessionUpdate
import IdeSession.Update.IdeSessionUpdate
import IdeSession.Util
import IdeSession.Util.BlockingOps
import qualified IdeSession.Query as Query
import qualified IdeSession.Strict.List as List
import qualified IdeSession.Strict.Map as Map
import qualified IdeSession.Strict.Maybe as Maybe
import qualified IdeSession.Types.Private as Private
import qualified IdeSession.Types.Public as Public
data SessionInitParams = SessionInitParams {
sessionInitCabalMacros :: Maybe BSL.ByteString
, sessionInitGhcOptions :: [String]
, sessionInitRelativeIncludes :: [FilePath]
, sessionInitTargets :: Public.Targets
, sessionInitRtsOpts :: [String]
}
deriving Show
defaultSessionInitParams :: SessionInitParams
defaultSessionInitParams = SessionInitParams {
sessionInitCabalMacros = Nothing
, sessionInitGhcOptions = []
, sessionInitRelativeIncludes = [""]
, sessionInitTargets = Public.TargetsExclude []
, sessionInitRtsOpts = ["-K8M"]
}
sessionRestartParams :: IdeIdleState -> IdeSessionUpdate -> SessionInitParams
sessionRestartParams st IdeSessionUpdate{..} = SessionInitParams {
sessionInitCabalMacros = Nothing
, sessionInitGhcOptions = fromMaybe (st ^. ideGhcOpts) ideUpdateGhcOpts
, sessionInitRelativeIncludes = fromMaybe (st ^. ideRelativeIncludes) ideUpdateRelIncls
, sessionInitTargets = fromMaybe (st ^. ideTargets) ideUpdateTargets
, sessionInitRtsOpts = fromMaybe (st ^. ideRtsOpts) ideUpdateRtsOpts
}
execInitParams :: IdeStaticInfo -> SessionInitParams -> IO ()
execInitParams staticInfo SessionInitParams{..} = do
writeMacros staticInfo sessionInitCabalMacros
writeMacros :: IdeStaticInfo -> Maybe BSL.ByteString -> IO ()
writeMacros IdeStaticInfo{ideConfig = SessionConfig {..}, ..}
configCabalMacros = do
macros <- case configCabalMacros of
Nothing -> generateMacros configPackageDBStack configExtraPathDirs
Just macros -> return (BSL.UTF8.toString macros)
writeFile (cabalMacrosLocation (ideSessionDistDir ideSessionDir)) macros
initSession :: SessionInitParams -> SessionConfig -> IO IdeSession
initSession initParams@SessionInitParams{..} ideConfig@SessionConfig{..} = do
verifyConfig ideConfig
configDirCanon <- Dir.canonicalizePath configDir
ideSessionDir <- createTempDirectory configDirCanon "session."
let ideStaticInfo = IdeStaticInfo{..}
Dir.createDirectoryIfMissing True (ideSessionSourceDir ideSessionDir)
Dir.createDirectoryIfMissing True (ideSessionDataDir ideSessionDir)
Dir.createDirectoryIfMissing True (ideSessionDistDir ideSessionDir)
Dir.createDirectoryIfMissing True (ideSessionObjDir ideSessionDir)
execInitParams ideStaticInfo initParams
mServer <- forkGhcServer sessionInitGhcOptions
sessionInitRelativeIncludes
sessionInitRtsOpts
ideStaticInfo
let (state, server, version) = case mServer of
Right (s, v) -> (IdeSessionIdle, s, v)
Left e -> (IdeSessionServerDied e, Ex.throw e, Ex.throw e)
let idleState = IdeIdleState {
_ideLogicalTimestamp = 86400
, _ideComputed = Maybe.nothing
, _ideGenerateCode = False
, _ideManagedFiles = ManagedFilesInternal [] []
, _ideObjectFiles = []
, _ideBuildExeStatus = Nothing
, _ideBuildDocStatus = Nothing
, _ideBuildLicensesStatus = Nothing
, _ideEnv = []
, _ideArgs = []
, _ideStdoutBufferMode = RunNoBuffering
, _ideStderrBufferMode = RunNoBuffering
, _ideBreakInfo = Maybe.nothing
, _ideGhcServer = server
, _ideGhcVersion = version
, _ideGhcOpts = sessionInitGhcOptions
, _ideRelativeIncludes = sessionInitRelativeIncludes
, _ideTargets = sessionInitTargets
, _ideRtsOpts = sessionInitRtsOpts
}
ideState <- newMVar (state idleState)
return IdeSession{..}
verifyConfig :: SessionConfig -> IO ()
verifyConfig SessionConfig{..} = do
unless (isValidPackageDB configPackageDBStack) $
Ex.throw . userError $ "Invalid package DB stack: "
++ show configPackageDBStack
checkPackageDbEnvVar
where
isValidPackageDB :: PackageDBStack -> Bool
isValidPackageDB stack =
elemIndices GlobalPackageDB stack == [0]
&& elemIndices UserPackageDB stack `elem` [[], [1]]
checkPackageDbEnvVar :: IO ()
checkPackageDbEnvVar = do
hasGPP <- (getEnv "GHC_PACKAGE_PATH" >> return True)
`catchIO` (\_ -> return False)
when hasGPP $
die $ "Use of GHC's environment variable GHC_PACKAGE_PATH is "
++ "incompatible with Cabal. Use the flag --package-db to specify a "
++ "package database (it can be used multiple times)."
where
die = Ex.throwIO . userError
catchIO :: IO a -> (IOError -> IO a) -> IO a
catchIO = Ex.catch
shutdownSession :: IdeSession -> IO ()
shutdownSession = shutdownSession' False
forceShutdownSession :: IdeSession -> IO ()
forceShutdownSession = shutdownSession' True
shutdownSession' :: Bool -> IdeSession -> IO ()
shutdownSession' forceTerminate IdeSession{ideState, ideStaticInfo} = do
$modifyStrictMVar_ ideState $ \state ->
case state of
IdeSessionIdle idleState -> do
if forceTerminate
then forceShutdownGhcServer $ _ideGhcServer idleState
else shutdownGhcServer $ _ideGhcServer idleState
cleanupDirs
return IdeSessionShutdown
IdeSessionShutdown ->
return IdeSessionShutdown
IdeSessionServerDied _ _ -> do
cleanupDirs
return IdeSessionShutdown
where
cleanupDirs :: IO ()
cleanupDirs =
when (configDeleteTempFiles . ideConfig $ ideStaticInfo) $
ignoreDoesNotExist $
Dir.removeDirectoryRecursive (ideSessionDir ideStaticInfo)
restartSession :: IdeSession -> IO ()
restartSession IdeSession{ideState} =
$modifyStrictMVar_ ideState $ \state ->
case state of
IdeSessionIdle idleState ->
return $ IdeSessionServerDied forcedRestart idleState
IdeSessionServerDied _ _ ->
return state
IdeSessionShutdown ->
fail "Shutdown session cannot be restarted."
data RestartResult =
ServerRestarted IdeIdleState IdeSessionUpdate
| ServerRestartFailed IdeIdleState
executeRestart :: SessionInitParams
-> IdeStaticInfo
-> IdeIdleState
-> IO RestartResult
executeRestart initParams@SessionInitParams{..} staticInfo idleState = do
forceShutdownGhcServer $ _ideGhcServer idleState
mServer <- forkGhcServer sessionInitGhcOptions
sessionInitRelativeIncludes
sessionInitRtsOpts
staticInfo
case mServer of
Right (server, version) -> do
execInitParams staticInfo initParams
let idleState' = idleState {
_ideComputed = Maybe.nothing
, _ideGhcOpts = sessionInitGhcOptions
, _ideRelativeIncludes = sessionInitRelativeIncludes
, _ideRtsOpts = sessionInitRtsOpts
, _ideGenerateCode = False
, _ideObjectFiles = []
, _ideEnv = []
, _ideArgs = []
, _ideGhcServer = server
, _ideGhcVersion = version
, _ideTargets = sessionInitTargets
}
let upd = mconcat [
updateEnv (idleState ^. ideEnv)
, updateArgs (idleState ^. ideArgs)
, updateCodeGeneration (idleState ^. ideGenerateCode)
]
return (ServerRestarted idleState' upd)
Left e -> do
let idleState' = idleState {
_ideGhcServer = Ex.throw e
, _ideGhcVersion = Ex.throw e
}
return (ServerRestartFailed idleState')
updateSession :: IdeSession -> IdeSessionUpdate -> (Progress -> IO ()) -> IO ()
updateSession = flip . updateSession'
updateSession' :: IdeSession -> (Progress -> IO ()) -> IdeSessionUpdate -> IO ()
updateSession' IdeSession{ideStaticInfo, ideState} callback = \update ->
$modifyStrictMVar_ ideState $ go False update
where
go :: Bool -> IdeSessionUpdate -> IdeSessionState -> IO IdeSessionState
go justRestarted update (IdeSessionIdle idleState) =
if not (requiresSessionRestart idleState update)
then do
(idleState', mex) <- runSessionUpdate justRestarted update ideStaticInfo callback idleState
case mex of
Nothing -> return $ IdeSessionIdle idleState'
Just ex -> return $ IdeSessionServerDied ex idleState'
else do
let restartParams = sessionRestartParams idleState update
restart justRestarted update restartParams idleState
go justRestarted update (IdeSessionServerDied _ex idleState) = do
let restartParams = sessionRestartParams idleState update
restart justRestarted update restartParams idleState
go _ _ IdeSessionShutdown =
Ex.throwIO (userError "Session already shut down.")
restart :: Bool -> IdeSessionUpdate -> SessionInitParams -> IdeIdleState -> IO IdeSessionState
restart True _ _ idleState =
return $ IdeSessionServerDied serverRestartLoop idleState
restart False update restartParams idleState = do
threadDelay 100000
restartResult <- executeRestart restartParams ideStaticInfo idleState
case restartResult of
ServerRestarted idleState' resetSession ->
go True (resetSession <> update) (IdeSessionIdle idleState')
ServerRestartFailed idleState' ->
return $ IdeSessionServerDied failedToRestart idleState'
requiresSessionRestart :: IdeIdleState -> IdeSessionUpdate -> Bool
requiresSessionRestart st IdeSessionUpdate{..} =
(ideUpdateRelIncls `changes` ideRelativeIncludes)
|| (ideUpdateTargets `changes` ideTargets)
|| (ideUpdateRtsOpts `changes` ideRtsOpts)
|| (any optRequiresRestart (listChanges' ideUpdateGhcOpts ideGhcOpts))
where
optRequiresRestart :: String -> Bool
optRequiresRestart str =
"-l" `isPrefixOf` str
changes :: Eq a => Maybe a -> Accessor IdeIdleState a -> Bool
changes Nothing _ = False
changes (Just x) y = x /= st ^. y
listChanges' :: Ord a => Maybe [a] -> Accessor IdeIdleState [a] -> [a]
listChanges' Nothing _ = []
listChanges' (Just xs) ys = listChanges xs (st ^. ys)
listChanges :: Ord a => [a] -> [a] -> [a]
listChanges xs ys =
Set.toList $ (a `Set.union` b) `Set.difference` (a `Set.intersection` b)
where
a = Set.fromList xs
b = Set.fromList ys
runStmt :: IdeSession -> String -> String -> IO (RunActions Public.RunResult)
runStmt ideSession m fun = runCmd ideSession $ \idleState -> RunStmt {
runCmdModule = m
, runCmdFunction = fun
, runCmdStdout = idleState ^. ideStdoutBufferMode
, runCmdStderr = idleState ^. ideStderrBufferMode
}
runExe :: IdeSession -> String -> IO (RunActions ExitCode)
runExe session m = do
let handleQueriesExc (_ :: Query.InvalidSessionStateQueries) =
fail $ "Wrong session state when trying to run an executable."
Ex.handle handleQueriesExc $ do
mstatus <- Query.getBuildExeStatus session
case mstatus of
Nothing ->
fail $ "No executable compilation initiated since session init."
(Just status@ExitFailure{}) ->
fail $ "Last executable compilation failed with status "
++ show status ++ "."
Just ExitSuccess -> do
distDir <- Query.getDistDir session
dataDir <- Query.getDataDir session
args <- Query.getArgs session
envInherited <- getEnvironment
envOverride <- Query.getEnv session
let overrideVar :: (String, Maybe String) -> Strict (Map String) String
-> Strict (Map String) String
overrideVar (var, Just val) env = Map.insert var val env
overrideVar (var, Nothing) env = Map.delete var env
envMap = foldr overrideVar (Map.fromList envInherited) envOverride
let exePath = distDir </> "build" </> m </> m
exeExists <- Dir.doesFileExist exePath
unless exeExists $
fail $ "No compiled executable file "
++ m ++ " exists at path "
++ exePath ++ "."
(stdRd, stdWr) <- liftIO createPipe
std_rd_hdl <- fdToHandle stdRd
std_wr_hdl <- fdToHandle stdWr
let cproc = (proc exePath args) { cwd = Just dataDir
, env = Just $ Map.toList envMap
, create_group = True
, std_in = CreatePipe
, std_out = UseHandle std_wr_hdl
, std_err = UseHandle std_wr_hdl
}
(Just stdin_hdl, Nothing, Nothing, ph) <- createProcess cproc
runActionsState <- newMVar Nothing
return $ RunActions
{ runWait = $modifyStrictMVar runActionsState $ \st -> case st of
Just outcome ->
return (Just outcome, Right outcome)
Nothing -> do
bs <- BSS.hGetSome std_rd_hdl blockSize
if BSS.null bs
then do
res <- waitForProcess ph
return (Just res, Right res)
else
return (Nothing, Left bs)
, interrupt = interruptProcessGroupOf ph
, supplyStdin = \bs -> BSS.hPut stdin_hdl bs >> IO.hFlush stdin_hdl
, forceCancel = terminateProcess ph
}
where
blockSize :: Int
blockSize = 4096
resume :: IdeSession -> IO (RunActions Public.RunResult)
resume ideSession = runCmd ideSession (const Resume)
runCmd :: IdeSession -> (IdeIdleState -> RunCmd) -> IO (RunActions Public.RunResult)
runCmd session mkCmd = modifyIdleState session $ \idleState ->
case (toLazyMaybe (idleState ^. ideComputed), idleState ^. ideGenerateCode) of
(Just comp, True) -> do
let cmd = mkCmd idleState
checkStateOk comp cmd
isBreak <- newEmptyMVar
runActions <- rpcRun (idleState ^. ideGhcServer)
cmd
(translateRunResult isBreak)
return (IdeSessionIdle idleState, runActions)
_ ->
fail "Cannot run before the code is generated."
where
checkStateOk :: Computed -> RunCmd -> IO ()
checkStateOk comp RunStmt{..} =
unless (Text.pack runCmdModule `List.elem` computedLoadedModules comp) $
fail $ "Module " ++ show runCmdModule
++ " not successfully loaded, when trying to run code."
checkStateOk _comp Resume =
return ()
translateRunResult :: StrictMVar (Strict Maybe BreakInfo)
-> Maybe Private.RunResult
-> IO Public.RunResult
translateRunResult isBreak (Just Private.RunOk) = do
$putStrictMVar isBreak Maybe.nothing
return $ Public.RunOk
translateRunResult isBreak (Just (Private.RunProgException str)) = do
$putStrictMVar isBreak Maybe.nothing
return $ Public.RunProgException str
translateRunResult isBreak (Just (Private.RunGhcException str)) = do
$putStrictMVar isBreak Maybe.nothing
return $ Public.RunGhcException str
translateRunResult isBreak (Just (Private.RunBreak breakInfo)) = do
$putStrictMVar isBreak (Maybe.just breakInfo)
return $ Public.RunBreak
translateRunResult isBreak Nothing = do
$putStrictMVar isBreak Maybe.nothing
return $ Public.RunForceCancelled
setBreakpoint :: IdeSession
-> ModuleName
-> Public.SourceSpan
-> Bool
-> IO (Maybe Bool)
setBreakpoint session mod span value = withIdleState session $ \idleState ->
rpcBreakpoint (idleState ^. ideGhcServer) mod span value
printVar :: IdeSession
-> Public.Name
-> Bool
-> Bool
-> IO Public.VariableEnv
printVar session var bind forceEval = withBreakInfo session $ \idleState _ ->
rpcPrint (idleState ^. ideGhcServer) var bind forceEval
crashGhcServer :: IdeSession -> Maybe Int -> IO ()
crashGhcServer IdeSession{..} delay = $withStrictMVar ideState $ \state ->
case state of
IdeSessionIdle idleState ->
rpcCrash (idleState ^. ideGhcServer) delay
_ ->
Ex.throwIO $ userError "State not idle"
withBreakInfo :: IdeSession -> (IdeIdleState -> Public.BreakInfo -> IO a) -> IO a
withBreakInfo session act = withIdleState session $ \idleState ->
case toLazyMaybe (idleState ^. ideBreakInfo) of
Just breakInfo -> act idleState breakInfo
Nothing -> Ex.throwIO (userError "Not in breakpoint state")
withIdleState :: IdeSession -> (IdeIdleState -> IO a) -> IO a
withIdleState session act = modifyIdleState session $ \idleState -> do
result <- act idleState
return (IdeSessionIdle idleState, result)
modifyIdleState :: IdeSession -> (IdeIdleState -> IO (IdeSessionState, a)) -> IO a
modifyIdleState IdeSession{..} act = $modifyStrictMVar ideState $ \state -> case state of
IdeSessionIdle idleState -> act idleState
_ -> Ex.throwIO $ userError "State not idle"
failedToRestart :: ExternalException
failedToRestart = ExternalException {
externalStdErr = "Failed to restart server"
, externalException = Nothing
}
forcedRestart :: ExternalException
forcedRestart = ExternalException {
externalStdErr = "Session manually restarted"
, externalException = Nothing
}
serverRestartLoop :: ExternalException
serverRestartLoop = ExternalException {
externalStdErr = "Server restart loop"
, externalException = Nothing
}