content: -- | Client interface to the `ide-backend-server` process
  --
  -- It is important that none of the types here rely on the GHC library.
  {-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TupleSections #-}
  module IdeSession.GHC.Client (
      -- * Starting and stopping the server
      InProcess
    , GhcServer(..)
    , forkGhcServer
    , shutdownGhcServer
    , forceShutdownGhcServer
    , getGhcExitCode
      -- * Interacting with the server
    , RunActions(..)
    , runWaitAll
    , rpcCompile
    , rpcRun
    , rpcCrash
    , rpcSetEnv
    , rpcSetArgs
    , rpcBreakpoint
    , rpcPrint
    , rpcLoad
    , rpcUnload
    , rpcSetGhcOpts
    ) where
  
  import Control.Applicative ((<$>))
  import Control.Concurrent (killThread)
  import Control.Concurrent.Async (async, cancel, withAsync)
  import Control.Concurrent.Chan (Chan, newChan, writeChan)
  import Control.Concurrent.MVar (newMVar)
  import Control.Monad (when, forever)
  import Data.Typeable (Typeable)
  import Data.Binary (Binary)
  import System.Directory (removeFile)
  import System.Exit (ExitCode)
  import qualified Control.Exception as Ex
  import qualified Data.ByteString.Char8      as BSS
  import qualified Data.ByteString.Lazy.Char8 as BSL
  
  import IdeSession.Config
  import IdeSession.GHC.API
  import IdeSession.RPC.Client
  import IdeSession.State
  import IdeSession.Types.Private (RunResult(..))
  import IdeSession.Types.Progress
  import IdeSession.Util
  import IdeSession.Util.BlockingOps
  import IdeSession.Util.PortableProcess
  import qualified IdeSession.Types.Public as Public
  
  import Distribution.Simple (PackageDB(..), PackageDBStack)
  
  import IdeSession.RPC.Sockets
  
  {------------------------------------------------------------------------------
    Starting and stopping the server
  ------------------------------------------------------------------------------}
  
  -- | Start the ghc server
  forkGhcServer :: [String]      -- ^ Initial ghc options
                -> [FilePath]    -- ^ Relative includes
                -> [String]      -- ^ RTS options
                -> IdeStaticInfo -- ^ Session setup info
                -> IdeCallbacks  -- ^ Session callbacks
                -> IO (Either ExternalException (GhcServer, GhcVersion))
  forkGhcServer ghcOpts relIncls rtsOpts ideStaticInfo ideCallbacks = do
    let logFunc = ideCallbacksLogFunc ideCallbacks
    when configInProcess $
      fail "In-process ghc server not currently supported"
    mLoc <- findProgram logFunc searchPath ide_backend_server
    case mLoc of
      Nothing ->
        fail $ "Could not find ide-backend-server"
      Just prog -> do
        env     <- envWithPathOverride configExtraPathDirs
        server  <- OutProcess <$> forkRpcServer
                     prog
                     (["+RTS"] ++ rtsOpts ++ ["-RTS"])
                     (Just $ ideDataDir ideStaticInfo)
                     env
        version <- Ex.try $ do
          GhcInitResponse{..} <- rpcInit server GhcInitRequest {
              ghcInitClientApiVersion   = ideBackendApiVersion
            , ghcInitGenerateModInfo    = configGenerateModInfo
            , ghcInitOpts               = opts
            , ghcInitUserPackageDB      = userDB
            , ghcInitSpecificPackageDBs = specificDBs
            , ghcInitSourceDir          = ideSourceDir ideStaticInfo
            , ghcInitSessionDir         = ideSessionDir ideStaticInfo
            , ghcInitDistDir            = ideDistDir ideStaticInfo
            }
          return ghcInitVersion
        return ((server,) <$> version)
    where
      (userDB, specificDBs) = splitPackageDBStack configPackageDBStack
  
      opts :: [String]
      opts = "-XHaskell2010"  -- see #190
           : ghcOpts
          ++ relInclToOpts (ideSourceDir ideStaticInfo) relIncls
  
      (searchPath, ide_backend_server) = configIdeBackendServer
  
      SessionConfig{..} = ideConfig ideStaticInfo
  
  {- TODO: Reenable in-process
  forkGhcServer configGenerateModInfo opts workingDir True = do
    let conv a b = RpcConversation {
                     get = do bs <- $readChan a
                              case decode' bs of
                                Just x  -> return x
                                Nothing -> fail "JSON failure"
                   , put = writeChan b . encode
                   }
    a   <- newChan
    b   <- newChan
    tid <- forkIO $ ghcServerEngine configGenerateModInfo opts (conv a b)
    return $ InProcess (conv b a) tid
  -}
  
  splitPackageDBStack :: PackageDBStack -> (Bool, [String])
  splitPackageDBStack dbstack = case dbstack of
    (GlobalPackageDB:UserPackageDB:dbs) -> (True,  map specific dbs)
    (GlobalPackageDB:dbs)               -> (False, map specific dbs)
    _                                   -> ierror
    where
      specific (SpecificPackageDB db) = db
      specific _                      = ierror
  
      ierror :: a
      ierror = error $ "internal error: unexpected package db stack: "
                    ++ show dbstack
  
  shutdownGhcServer :: GhcServer -> IO ()
  shutdownGhcServer (OutProcess server) = shutdown server
  shutdownGhcServer (InProcess _ tid)   = killThread tid
  
  forceShutdownGhcServer :: GhcServer -> IO ()
  forceShutdownGhcServer (OutProcess server) = forceShutdown server
  forceShutdownGhcServer (InProcess _ tid)   = killThread tid
  
  getGhcExitCode :: GhcServer -> IO (Maybe ExitCode)
  getGhcExitCode (OutProcess server) =
    getRpcExitCode server
  getGhcExitCode (InProcess _ _) =
    fail "getGhcExitCode not supported for in-process server"
  
  {------------------------------------------------------------------------------
    Interacting with the server
  ------------------------------------------------------------------------------}
  
  -- | Repeatedly call 'runWait' until we receive a 'Right' result, while
  -- collecting all 'Left' results
  runWaitAll :: forall a. RunActions a -> IO (BSL.ByteString, a)
  runWaitAll RunActions{runWait} = go []
    where
      go :: [BSS.ByteString] -> IO (BSL.ByteString, a)
      go acc = do
        resp <- runWait
        case resp of
          Left  bs        -> go (bs : acc)
          Right runResult -> return (BSL.fromChunks (reverse acc), runResult)
  
  -- | Set the environment
  rpcSetEnv :: GhcServer -> [(String, Maybe String)] -> IO ()
  rpcSetEnv (OutProcess server) env =
    rpc server (ReqSetEnv env)
  rpcSetEnv (InProcess _ _) _ =
    error "rpcSetEnv not supported for in-process server"
  
  -- | Set command line arguments
  rpcSetArgs :: GhcServer -> [String] -> IO ()
  rpcSetArgs (OutProcess server) args =
    rpc server (ReqSetArgs args)
  rpcSetArgs (InProcess _ _) _ =
    error "rpcSetArgs not supported for in-process server"
  
  -- | Set ghc options
  rpcSetGhcOpts :: GhcServer -> [String] -> IO ([String], [String])
  rpcSetGhcOpts (OutProcess server) opts =
    rpc server (ReqSetGhcOpts opts)
  rpcSetGhcOpts (InProcess _ _) _ =
    error "rpcSetGhcOpts not supported for in-process server"
  
  -- | Compile or typecheck
  rpcCompile :: GhcServer                      -- ^ GHC server
             -> Bool                           -- ^ Should we generate code?
             -> Public.Targets                 -- ^ Targets
             -> (Public.UpdateStatus -> IO ()) -- ^ Progress callback
             -> IO GhcCompileResult
  rpcCompile server genCode targets updateStatus =
    ghcConversation server $ \RpcConversation{..} -> do
      put (ReqCompile genCode targets)
  
      let go = do response <- get
                  case response of
                    GhcCompileProgress pcounter -> do
                      updateStatus (Public.UpdateStatusProgress pcounter)
                      go
                    GhcCompileDone result -> return result
  
      go
  
  -- | Set breakpoint
  --
  -- Returns @Just@ the old value of the break if successful, or @Nothing@ if
  -- the breakpoint could not be found.
  rpcBreakpoint :: GhcServer
                -> Public.ModuleName -> Public.SourceSpan
                -> Bool
                -> IO (Maybe Bool)
  rpcBreakpoint server reqBreakpointModule reqBreakpointSpan reqBreakpointValue =
    ghcRpc server ReqBreakpoint{..}
  
  data SnippetAction =
         SnippetOutput BSS.ByteString
       | SnippetTerminated RunResult
       | SnippetForceTerminated
  
  -- | Run code
  --
  -- NOTE: This is an interruptible operation
  rpcRun :: forall a.
            GhcServer                 -- ^ GHC server
         -> RunCmd                    -- ^ Run command
         -> (Maybe RunResult -> IO a) -- ^ Translate run results
                                      -- @Nothing@ indicates force cancellation
         -> IO (RunActions a)
  rpcRun server cmd translateResult =
      Ex.mask_ $ do
        -- Communicate with the snippet using an independent, concurrent, conversation
        --
        -- We mask exceptions _completely_ while connecting to the server because
        -- we don't want an asynchronous exception against rpcRun to interrupt
        -- communication with the main server, because that would make the whole
        -- session unuseable.
        --
        -- TODO: This is of course a tad dangerous, because if for whatever reason
        -- the communication with the main server stalls we cannot interrupt it.
        -- Perhaps we should introduce a separate timeout for that?
        rpcRes <- Ex.uninterruptibleMask_ $ ghcRpc server (ReqRun cmd)
        case rpcRes of
          -- TODO maybe returnging a dummy RunActions is better than throwing an exception?
          -- ReqRunUnsupported msg -> return RunActions {
          --     runWait = fmap Right $ translateResult $ Just $ RunGhcException msg
          --   , interrupt = return ()
          --   , supplyStdin = const $ return ()
          --   , forceCancel = return ()
          -- }
          ReqRunUnsupported msg -> Ex.throwIO $ UnsupportedOnNonUnix msg
          ReqRunConversation pid stdin stdout errorLog ->
            -- Unmask exceptions only once we've installed an exception handler to
            -- cleanup the process again
            interruptible (aux pid stdin stdout errorLog) `Ex.onException` sigKillProcess pid
    where
      aux :: Pid -> WriteChannel -> ReadChannel -> FilePath -> IO (RunActions a)
      aux pid stdin stdout errorLog = do
        runWaitChan <- newChan :: IO (Chan SnippetAction)
        reqChan     <- newChan :: IO (Chan GhcRunRequest)
  
        respThread <- async . Ex.handle (handleExternalException runWaitChan) $ do
          connectToRpcServer stdin stdout errorLog $ \server' ->
            ghcConversation (OutProcess server') $ \RpcConversation{..} -> do
              -- This "respThread" is responsible for reading responses from the RPC
              -- conversation, and writing them to the runWaitChan channel. This thread
              -- terminates when the server replies with GhcRunDone.
              --
              -- In addition, we spawns a second "reqThread" which is responsible for
              -- reading requests from the reqChan and sending them to to server. We
              -- use withAsync so that when then we (the respThread) terminate the
              -- reqThread automatically gets cancelled.
              --
              -- If an exception happens in the respThread it will be written to the
              -- runWaitChan and the snippet will be considered terminated.
              --
              -- (TODO: What happens when an exception happens in the reqThread?)
              withAsync (sendRequests put reqChan) $ \_reqThread -> do
                let go = do resp <- get
                            case resp of
                              GhcRunDone result -> do
                                ignoreIOExceptions $ removeFile errorLog
                                writeChan runWaitChan (SnippetTerminated result)
                              GhcRunOutp bs -> do
                                writeChan runWaitChan (SnippetOutput bs)
                                go
                go
  
        -- runActionsState is used to make sure that once a snippet has terminated,
        -- any subsequent calls to runWait simply return the final result.
        -- This also makes sure that we call translateResult at most once.
        runActionsState <- newMVar Nothing
  
        return RunActions {
            runWait =
              $modifyMVar runActionsState $ \st ->
                case st of
                  Just outcome ->
                    return (Just outcome, Right outcome)
                  Nothing -> do
                    outcome <- $readChan runWaitChan
                    case outcome of
                      SnippetOutput bs ->
                        return (Nothing, Left bs)
                      SnippetForceTerminated -> do
                        res <- translateResult Nothing
                        return (Just res, Right res)
                      SnippetTerminated res' -> do
                        res <- translateResult (Just res')
                        return (Just res, Right res)
          , interrupt   = writeChan reqChan GhcRunInterrupt
          , supplyStdin = writeChan reqChan . GhcRunInput
          , forceCancel = do
              cancel respThread
              ignoreIOExceptions $ sigKillProcess pid
              ignoreIOExceptions $ removeFile errorLog
              writeChan runWaitChan SnippetForceTerminated
          }
  
      sendRequests :: (GhcRunRequest -> IO ()) -> Chan GhcRunRequest -> IO ()
      sendRequests put reqChan = forever $ put =<< $readChan reqChan
  
      -- TODO: should we restart the session when ghc crashes?
      -- Maybe recommend that the session is started on GhcExceptions?
      handleExternalException :: Chan SnippetAction
                              -> ExternalException
                              -> IO ()
      handleExternalException ch =
        writeChan ch . SnippetTerminated . RunGhcException . show
  
  -- | Print a variable
  rpcPrint :: GhcServer -> Public.Name -> Bool -> Bool -> IO Public.VariableEnv
  rpcPrint server var bind forceEval = ghcRpc server (ReqPrint var bind forceEval)
  
  -- | Load an object file
  rpcLoad :: GhcServer -> [FilePath] -> IO (Maybe String)
  rpcLoad server objects = ghcRpc server (ReqLoad objects)
  
  -- | Unload an object file
  rpcUnload :: GhcServer -> [FilePath] -> IO ()
  rpcUnload server objects = ghcRpc server (ReqUnload objects)
  
  -- | Crash the GHC server (for debugging purposes)
  rpcCrash :: GhcServer -> Maybe Int -> IO ()
  rpcCrash server delay = ghcConversation server $ \RpcConversation{..} ->
    put (ReqCrash delay)
  
  -- | Handshake with the server
  rpcInit :: GhcServer -> GhcInitRequest -> IO GhcInitResponse
  rpcInit = ghcRpc
  
  {------------------------------------------------------------------------------
    Internal
  ------------------------------------------------------------------------------}
  
  ghcConversation :: GhcServer -> (RpcConversation -> IO a) -> IO a
  ghcConversation (OutProcess server) = rpcConversation server
  ghcConversation (InProcess conv _)  = ($ conv)
  
  ghcRpc :: (Typeable req, Typeable resp, Binary req, Binary resp)
         => GhcServer -> req -> IO resp
  ghcRpc (OutProcess server) = rpc server
  ghcRpc (InProcess _ _)     = error "ghcRpc not implemented for in-process server"
  
  ignoreIOExceptions :: IO () -> IO ()
  ignoreIOExceptions = let handler :: Ex.IOException -> IO ()
                           handler _ = return ()
                       in Ex.handle handler
  