ide-backend-0.10.0.1: IdeSession/ExeCabalServer.hs

-- | Run Cabal functions upon receiving RPC requests, log output and provide
-- Progress updates.
module IdeSession.ExeCabalServer (
    exeCabalEngine
  ) where

import Control.Concurrent.Async (async, wait)
import System.Exit (ExitCode)
import System.IO (IOMode(..))
import System.IO.Error (isEOFError)
import qualified Control.Exception  as Ex
import qualified Data.ByteString    as BSS
import qualified Data.Text.Encoding as E
import qualified System.IO          as IO

import IdeSession.Cabal
import IdeSession.RPC.Server
import IdeSession.Types.Progress
import IdeSession.Util
import IdeSession.Util.PortableIO

-- | Handle RPC requests by calling Cabal functions, keeping track
-- of progress and passing the results.
exeCabalEngine :: FilePath -> RpcConversation -> IO ()
exeCabalEngine _errorLog conv@RpcConversation{..} = do
    -- Start handling RPC calls
    let go = do
          req <- get
          exitCode <- runExeCabal conv req
          put $ ExeCabalDone exitCode
          go  -- not long-running, but we can't exit or RPC would crash

    go

-- | Run the cabal functions inside the executable.
runExeCabal :: RpcConversation -> ExeCabalRequest -> IO ExitCode
runExeCabal conv req = do
   -- Create pipe
  (stdOutputRd, stdOutputWr) <- createPipe

  -- Backup stdout, then replace stdout with the pipe's write end
  (exitCode, stdoutThread) <- swizzleStdout stdOutputWr $ do
    -- Convert the read end to a handle
    stdOutputRdHandle <- fdToHandle stdOutputRd ReadMode
    IO.hSetBuffering stdOutputRdHandle IO.LineBuffering

    let stdoutLog = case req of
          ReqExeBuild buildExeArgs _ -> beStdoutLog buildExeArgs
          ReqExeDoc   buildExeArgs   -> beStdoutLog buildExeArgs
          ReqExeCc    runCcArgs      -> rcStdoutLog runCcArgs
          ReqExeLic   licenseArgs    -> liStdoutLog licenseArgs
    stdoutThread <- async $ readStdout conv stdOutputRdHandle stdoutLog

    exitCode <- case req of
      ReqExeBuild buildExeArgs modArgs ->
        configureAndBuild buildExeArgs modArgs
      ReqExeDoc buildExeArgs ->
        configureAndHaddock buildExeArgs
      ReqExeCc runCcArgs ->
        runComponentCc runCcArgs
      ReqExeLic licenseArgs ->
        buildLicsFromPkgs True licenseArgs

    return (exitCode, stdoutThread)

  -- Closing the write end of the stdout pipe will cause the stdout
  -- thread to terminate after it processed all remaining output;
  -- wait for this to happen
  closeFd stdOutputWr
  wait stdoutThread

  return exitCode

readStdout :: RpcConversation -> IO.Handle -> FilePath -> IO ()
readStdout RpcConversation{..} stdOutputRdHandle stdoutLog = do
  logHandle <- IO.openFile stdoutLog IO.WriteMode
  let go = do
        res <- Ex.try $ BSS.hGetLine stdOutputRdHandle
        case res of
          Left ex -> if isEOFError ex then return () else Ex.throw ex
          Right bs -> do
            progressCallback bs
            BSS.hPut logHandle bs
            BSS.hPut logHandle (BSS.singleton (0x0a))  -- \n
            go
  go
  IO.hClose logHandle
 where
    progressCallback :: BSS.ByteString -> IO ()
    progressCallback ghcMsg = do
      let ghcMsg' = E.decodeUtf8 ghcMsg
      case parseProgressMessage ghcMsg' of
        Right (step, numSteps, msg) ->
          put $ ExeCabalProgress $ Progress {
               progressStep      = step
             , progressNumSteps  = numSteps
             , progressParsedMsg = Just msg
             , progressOrigMsg   = Just ghcMsg'
             }
        _ ->
          -- Ignore messages we cannot parse
          return ()