{-# LANGUAGE CPP, TemplateHaskell, ScopedTypeVariables #-}

-- A module that handles request running. This is taken out of Server to allow
-- for conditional compilation on non-Unix platforms.
module RequestRunning (runCommand) where

import IdeSession.RPC.API
import IdeSession.GHC.Requests
import GhcMonad(Ghc(..))

#ifdef VERSION_unix

-- Unix specific imports
import System.Posix (createSession)
import System.Posix.Process (forkProcess, getProcessStatus)
import System.Posix.Terminal (openPseudoTerminal)
#ifdef PTY_SUPPORT
import qualified Posix
#endif

-- General imports
import Network
import Control.Concurrent (ThreadId, throwTo, forkIO, myThreadId)
import Control.Concurrent.Async (async, withAsync)
import Control.Concurrent.MVar (MVar, newEmptyMVar)
import Control.Monad (void, unless, forever)
import Data.Function (fix)
import Foreign.C.Types (CFile)
import Foreign.Ptr (Ptr, nullPtr)
import GHC.IO.Exception (IOException(..), IOErrorType(..))
import System.Environment (withArgs, getEnvironment, setEnv)
import System.IO (Handle, hFlush, hClose, IOMode(..))
import System.IO.Temp (openTempFile)
import System.Mem (performGC)
import qualified Control.Exception as Ex
import qualified Data.ByteString   as BSS
import qualified System.Directory  as Dir

import qualified GHC

import IdeSession.RPC.Server
import IdeSession.GHC.API
import IdeSession.RPC.Sockets
import IdeSession.Types.Private
import IdeSession.Util
import IdeSession.Util.PortableProcess
import IdeSession.Util.PortableIO
import IdeSession.Util.BlockingOps
import Run
import Auxiliary
import Debug

foreign import ccall "fflush" fflush :: Ptr CFile -> IO ()

#else

import Control.Monad.Trans (liftIO)
import IdeSession.Util

#endif


runCommand :: RpcConversation -> [String] -> FilePath -> RunCmd -> Ghc [String]


#ifndef VERSION_unix
runCommand RpcConversation{..} args _ _ = do
  liftIO $ put $ ReqRunUnsupported "Cannot run commands on non-Unix platforms"
  return args
#else
runCommand conv args sessionDir runCmd
  | runCmdPty runCmd = do
#if PTY_SUPPORT
        fds <- liftIO openPseudoTerminal
        conversationTuple <- startConcurrentConversation $ \_ _ _ ->
          ghcWithArgs args $ ghcHandleRunPtySlave fds runCmd
        liftIO $ runPtyMaster fds conversationTuple
        rpcConversationTuple conv conversationTuple
        return args
#else
        --TODO: fail more gracefully than this?
        fail "ide-backend-server not build with -DPTY_SUPPORT / pty-support cabal flag"
#endif
  | otherwise = do
        conversationTuple <- startConcurrentConversation $
          ghcConcurrentConversation $ \_errorLog' conv' ->
            ghcWithArgs args $ ghcHandleRun conv' runCmd
        rpcConversationTuple conv conversationTuple
        return args

rpcConversationTuple :: RpcConversation -> (Pid, Socket, Socket, FilePath) -> Ghc ()
rpcConversationTuple RpcConversation{..} (pid, stdin, stdout, errorLogPath) = do
  [stdinPort, stdoutPort] <- liftIO $ mapM socketPort [stdin, stdout]
  liftIO $ put $ ReqRunConversation pid (WriteChannel stdinPort) (ReadChannel stdoutPort) errorLogPath

-- | Handle a run request
ghcHandleRun :: RpcConversation -> RunCmd -> Ghc ()
ghcHandleRun RpcConversation{..} runCmd = do
    (stdOutputRd, stdOutputBackup, stdErrorBackup) <- redirectStdout
    (stdInputWr,  stdInputBackup)                  <- redirectStdin

    -- We don't need to keep a reference to the reqThread: when the snippet
    -- terminates, the whole server process terminates with it and hence
    -- so does the reqThread. If we wanted to reuse this server process we
    -- would need to have some sort of handshake so make sure that the client
    -- and the server both agree that further requests are no longer accepted
    -- (we used to do that when we ran snippets inside the main server process).
    ghcThread    <- liftIO newEmptyMVar :: Ghc (MVar (Maybe ThreadId))
    _reqThread   <- liftIO . async $ readRunRequests ghcThread stdInputWr
    stdoutThread <- liftIO . async $ readStdout stdOutputRd

    -- This is a little tricky. We only want to deliver the UserInterrupt
    -- exceptions when we are running 'runInGhc'. If the UserInterrupt arrives
    -- before we even get a chance to call 'runInGhc' the exception should not
    -- be delivered until we are in a position to catch it; after 'runInGhc'
    -- completes we should just ignore any further 'GhcRunInterrupt' requests.
    --
    -- We achieve this by
    --
    -- 1. The thread ID is stored in an MVar ('ghcThread'). Initially this
    --    MVar is empty, so if a 'GhcRunInterrupt' arrives before we are ready
    --    to deal with it the 'reqThread' will block
    -- 2. We install an exception handler before putting the thread ID into
    --    the MVar
    -- 3. We override the MVar with Nothing before leaving the exception handler
    -- 4. In the 'reqThread' we ignore GhcRunInterrupts once the 'MVar' is
    --    'Nothing'

    runOutcome <- ghandle ghcException . ghandleJust isUserInterrupt return $
      GHC.gbracket
        (liftIO (myThreadId >>= $putMVar ghcThread . Just))
        (\() -> liftIO $ $modifyMVar_ ghcThread (\_ -> return Nothing))
        (\() -> runInGhc runCmd)

    liftIO $ do
      -- Make sure the C buffers are also flushed before swapping the handles
      fflush nullPtr

      -- Restore stdin and stdout
      dupTo stdOutputBackup stdOutput >> closeFd stdOutputBackup
      dupTo stdErrorBackup  stdError  >> closeFd stdErrorBackup
      dupTo stdInputBackup  stdInput  >> closeFd stdInputBackup

      -- 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
      $wait stdoutThread

      -- Report the final result
      liftIO $ debug dVerbosity $ "returned from ghcHandleRun with "
                                  ++ show runOutcome
      put $ GhcRunDone runOutcome
  where
    -- Wait for and execute run requests from the client
    readRunRequests :: MVar (Maybe ThreadId) -> Handle -> IO ()
    readRunRequests ghcThread stdInputWr =
      let go = do request <- get
                  case request of
                    GhcRunInterrupt -> do
                      $withMVar ghcThread $ \mTid -> do
                        case mTid of
                          Just tid -> throwTo tid Ex.UserInterrupt
                          Nothing  -> return () -- See above
                      go
                    GhcRunInput bs -> do
                      BSS.hPut stdInputWr bs
                      hFlush stdInputWr
                      go
      in go

    -- Wait for the process to output something or terminate
    readStdout :: Handle -> IO ()
    readStdout stdOutputRd =
      let go = do
            mbs <- Ex.try $ BSS.hGetSome stdOutputRd blockSize
            case mbs of
              Right bs -> unless (BSS.null bs) $ put (GhcRunOutp bs) >> go
              -- hGetSome might throw some very unpleasant exceptions in case
              -- someone force cancels the operation
              -- (which triggered some weird race conditions in test220 in Issues.hs)
              -- Swallowing everything, since an exception here implies that there
              -- is no more output to read
              Left (_ :: Ex.SomeException) -> return ()
      in go

    -- Turn an asynchronous exception into a RunResult
    isUserInterrupt :: Ex.AsyncException -> Maybe RunResult
    isUserInterrupt ex@Ex.UserInterrupt =
      Just . RunProgException . showExWithClass . Ex.toException $ ex
    isUserInterrupt _ =
      Nothing

    -- Turn a GHC exception into a RunResult
    ghcException :: GhcException -> Ghc RunResult
    ghcException = return . RunGhcException . show

    -- TODO: What is a good value here?
    blockSize :: Int
    blockSize = 4096

    -- Setup loopback pipe so we can capture runStmt's stdout/stderr
    redirectStdout :: Ghc (Handle, FileDescriptor, FileDescriptor)
    redirectStdout = liftIO $ do
      -- Create pipe
      (stdOutputRd, stdOutputWr) <- liftIO createPipe

      -- Backup stdout, then replace stdout and stderr with the pipe's write end
      stdOutputBackup <- liftIO $ dup stdOutput
      stdErrorBackup  <- liftIO $ dup stdError
      _ <- dupTo stdOutputWr stdOutput
      _ <- dupTo stdOutputWr stdError
      closeFd stdOutputWr

      -- Convert to the read end to a handle and return
      stdOutputRd' <- fdToHandle stdOutputRd ReadMode
      return (stdOutputRd', stdOutputBackup, stdErrorBackup)

    -- Setup loopback pipe so we can write to runStmt's stdin
    redirectStdin :: Ghc (Handle, FileDescriptor)
    redirectStdin = liftIO $ do
      -- Create pipe
      (stdInputRd, stdInputWr) <- liftIO createPipe

      -- Swizzle stdin
      stdInputBackup <- liftIO $ dup stdInput
      _ <- dupTo stdInputRd stdInput
      closeFd stdInputRd

      -- Convert the write end to a handle and return
      stdInputWr' <- fdToHandle stdInputWr WriteMode
      return (stdInputWr', stdInputBackup)

#if PTY_SUPPORT

runPtyMaster :: (FileDescriptor, FileDescriptor) -> (Pid, Socket, Socket, FilePath) -> IO ()
runPtyMaster (masterFd, slaveFd) (processId, stdin, stdout, errorLog) = do
  -- Since we're in the master process, close the slave FD.
  closeFd slaveFd

  let readOutput :: RpcConversation -> IO RunResult
      readOutput conv = fix $ \loop -> do
        bs <- Posix.readChunk masterFd `Ex.catch` \ex ->
          -- Ignore HardwareFaults as they seem to always happen when
          -- process exits..
          if ioe_type ex == HardwareFault
            then return BSS.empty
            else Ex.throwIO ex
        if BSS.null bs
          then return RunOk
          else do
            put conv (GhcRunOutp bs)
            loop
      handleRequests :: RpcConversation -> IO ()
      handleRequests conv = forever $ do
        request <- get conv
        case request of
          GhcRunInput bs -> Posix.write masterFd bs
          -- Fork a new thread because this could throw exceptions.
          GhcRunInterrupt -> void $ forkIO $ sigKillProcess processId
      -- Turn a GHC exception into a RunResult
      ghcException :: GhcException -> IO RunResult
      ghcException = return . RunGhcException . show


  void $ forkIO $
    concurrentConversation stdin stdout errorLog $ \_ conv -> do
      result <- Ex.handle ghcException $
        withAsync (handleRequests conv) $ \_ ->
        readOutput conv
      put conv (GhcRunDone result)

ghcHandleRunPtySlave :: (FileDescriptor, FileDescriptor) -> RunCmd -> Ghc ()
ghcHandleRunPtySlave (masterFd, slaveFd) runCmd = do
  liftIO $ do
    -- Since we're in the slave process, close the master FD.
    closeFd masterFd
    -- Create a new session with a controlling terminal.
    void createSession
    Posix.setControllingTerminal slaveFd
    -- Redirect standard IO to the terminal FD.
    void $ dupTo slaveFd stdInput
    void $ dupTo slaveFd stdOutput
    void $ dupTo slaveFd stdError
    closeFd slaveFd
    -- Set TERM env variable
    setEnv "TERM" "xterm-256color"
  --FIXME: Properly pass the run result to the client as a GhcRunDone
  --value. Instead, we write it to standard output, which gets sent to
  --the terminal.
  result <- runInGhc runCmd
  case result of
    -- A successful result will be sent by runPtyMaster - only send
    -- failures.
    RunOk -> return ()
    _ -> liftIO $ putStrLn $ "\r\nProcess done: " ++ show result ++ "\r\n"

#endif

startConcurrentConversation
  :: (Socket -> Socket -> FilePath -> Ghc ())
  -> Ghc (Pid, Socket, Socket, FilePath)
startConcurrentConversation inner = do
  -- Ideally, we'd have the child process create the temp directory and
  -- communicate the name back to us, so that the child process can remove the
  -- directories again when it's done with it. However, this means we need some
  -- interprocess communication, which is awkward. So we create the temp
  -- directory here; I suppose we could still delegate the responsibility of
  -- deleting the directory to the child, but instead we'll just remove the
  -- directory along with the rest of the session temp dirs on session exit.
  (stdin, stdout, errorLog) <- liftIO $ do
    stdin <- makeSocket
    stdout <- makeSocket

    tmpDir <- Dir.getTemporaryDirectory
    (errorLogPath, errorLogHandle) <- openTempFile tmpDir "rpc-snippet-.log"
    hClose errorLogHandle

    return (stdin, stdout, errorLogPath)

  -- Start the concurrent conversion. We use forkGhcProcess rather than forkGhc
  -- because we need to change global state in the child process; in particular,
  -- we need to redirect stdin, stdout, and stderr (as well as some other global
  -- state, including withArgs).
  liftIO performGC
  processId <- forkGhcProcess $ inner stdin stdout errorLog

  -- We wait for the process to finish in a separate thread so that we do not
  -- accumulate zombies
  --
  -- FIXME(mgs): I didn't write this, and I'm not sure I see the point
  -- of doing this.
  liftIO $ void $ forkIO $
    void $ getProcessStatus True False processId

  return (processId, stdin, stdout, errorLog)
#endif