cabal-testsuite/src/Test/Cabal/Server.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE NondecreasingIndentation #-}
   5 -- | A GHC run-server, which supports running multiple GHC scripts
   6 -- without having to restart from scratch.
   7 module Test.Cabal.Server (
   8     Server,
   9     serverProcessId,
  10     ServerLogMsg(..),
  11     ServerLogMsgType(..),
  12     ServerResult(..),
  13     withNewServer,
  14     runOnServer,
  15     runMain,
  16 ) where
  17
  18 import Test.Cabal.Script
  19 import Test.Cabal.TestCode
  20
  21 import Prelude hiding (log)
  22 import Control.Concurrent.MVar
  23 import Control.Concurrent
  24 import Control.Concurrent.Async
  25 import System.Process
  26 import System.IO
  27 import System.Exit
  28 import Data.List (intercalate, isPrefixOf)
  29 import Distribution.Simple.Program.Db
  30 import Distribution.Simple.Program
  31 import Control.Exception
  32 import qualified Control.Exception as E
  33 import Control.Monad
  34 import Data.IORef
  35 import Data.Maybe
  36 import Text.Read (readMaybe)
  37 import Foreign.C.Error (Errno (..), ePIPE)
  38
  39 import qualified GHC.IO.Exception as GHC
  40
  41 import Distribution.Verbosity
  42
  43 import System.Process.Internals
  44   ( ProcessHandle__( OpenHandle )
  45   , withProcessHandle
  46   )
  47 #if mingw32_HOST_OS
  48 import qualified System.Win32.Process as Win32
  49 #endif
  50
  51 -- TODO: Compare this implementation with
  52 -- https://github.com/ndmitchell/ghcid/blob/master/src/Language/Haskell/Ghcid.hs
  53 -- which does something similar
  54
  55 -- ----------------------------------------------------------------- --
  56 -- Public API
  57 -- ----------------------------------------------------------------- --
  58
  59 -- | A GHCi server session, which we can ask to run scripts.
  60 -- It operates in a *fixed* runner environment as specified
  61 -- by 'serverScriptEnv'.
  62 data Server = Server {
  63         serverStdin         :: Handle,
  64         serverStdout        :: Handle,
  65         serverStderr        :: Handle,
  66         serverProcessHandle :: ProcessHandle,
  67         serverProcessId     :: ProcessId,
  68         serverScriptEnv     :: ScriptEnv,
  69         -- | Accumulators which we use to keep tracking
  70         -- of stdout/stderr we've incrementally read out.  In the event
  71         -- of an error we'll use this to give diagnostic information.
  72         serverStdoutAccum   :: MVar [String],
  73         serverStderrAccum   :: MVar [String],
  74         serverLogChan       :: Chan ServerLogMsg
  75     }
  76
  77 -- | Portable representation of process ID; just a string rendered
  78 -- number.
  79 type ProcessId = String
  80
  81 data ServerLogMsg = ServerLogMsg ServerLogMsgType String
  82                   | ServerLogEnd
  83 data ServerLogMsgType = ServerOut  ProcessId
  84                       | ServerErr  ProcessId
  85                       | ServerIn   ProcessId
  86                       | ServerMeta ProcessId
  87                       | AllServers
  88
  89 data ServerResult = ServerResult
  90     { serverResultTestCode :: TestCode
  91     , serverResultCommand  :: String
  92     , serverResultStdout   :: String
  93     , serverResultStderr   :: String
  94     }
  95
  96 -- | With 'ScriptEnv', create a new GHCi 'Server' session.
  97 -- When @f@ returns, the server is terminated and no longer
  98 -- valid.
  99 withNewServer :: Chan ServerLogMsg -> ScriptEnv -> (Server -> IO a) -> IO a
 100 withNewServer chan senv f =
 101     bracketWithInit (startServer chan senv) initServer stopServer f
 102
 103 -- | Like 'bracket', but with an initialization function on the resource
 104 -- which will be called, unmasked, on the resource to transform it
 105 -- in some way.  If the initialization function throws an exception, the cleanup
 106 -- handler will get invoked with the original resource; if it succeeds, the
 107 -- cleanup handler will get invoked with the transformed resource.
 108 -- The cleanup handler must be able to handle both cases.
 109 --
 110 -- This can help avoid race conditions in certain situations: with
 111 -- normal use of 'bracket', the resource acquisition function
 112 -- MUST return immediately after the resource is acquired.  If it
 113 -- performs any interruptible actions afterwards, it could be
 114 -- interrupted and the exception handler not called.
 115 bracketWithInit :: IO a -> (a -> IO a) -> (a -> IO b) -> (a -> IO c) -> IO c
 116 bracketWithInit before initialize after thing =
 117   mask $ \restore -> do
 118     a0 <- before
 119     a <- restore (initialize a0) `onException` uninterruptibleMask_  (after a0)
 120     r <- restore (thing a) `onException` uninterruptibleMask_  (after a)
 121     _ <- uninterruptibleMask_ (after a)
 122     return r
 123
 124 -- | Run an hs script on the GHCi server, returning the 'ServerResult' of
 125 -- executing the command.
 126 --
 127 --      * The script MUST have an @hs@ or @lhs@ filename; GHCi
 128 --        will reject non-Haskell filenames.
 129 --
 130 --      * If the script is not well-typed, the returned output
 131 --        will be of GHC's compile errors.
 132 --
 133 --      * Inside your script, do not rely on 'getProgName' having
 134 --        a sensible value.
 135 --
 136 --      * Current working directory and environment overrides
 137 --        are currently not implemented.
 138 --
 139 runOnServer :: Server -> Maybe FilePath -> [(String, Maybe String)]
 140             -> FilePath -> [String] -> IO ServerResult
 141 runOnServer s mb_cwd env_overrides script_path args = do
 142     -- TODO: cwd not implemented
 143     when (isJust mb_cwd)        $ error "runOnServer change directory not implemented"
 144     -- TODO: env_overrides not implemented
 145     unless (null env_overrides) $ error "runOnServer set environment not implemented"
 146
 147     -- Set arguments returned by System.getArgs
 148     write s $ ":set args " ++ show args
 149     -- Output start sigil (do it here so we pick up compilation
 150     -- failures)
 151     write s $ "System.IO.hPutStrLn System.IO.stdout " ++ show start_sigil
 152     write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show start_sigil
 153     _ <- readUntilSigil s start_sigil IsOut
 154     _ <- readUntilSigil s start_sigil IsErr
 155     -- Drain the output produced by the script as we are running so that
 156     -- we do not deadlock over a full pipe.
 157     withAsync (readUntilEnd s IsOut) $ \a_exit_out -> do
 158     withAsync (readUntilSigil s end_sigil IsErr) $ \a_err -> do
 159     -- NB: No :set prog; don't rely on this value in test scripts,
 160     -- we pass it in via the arguments
 161     -- NB: load drops all bindings, which is GOOD.  Avoid holding onto
 162     -- garbage.
 163     write s $ ":load " ++ script_path
 164     -- Create a ref which will record the exit status of the command
 165     -- NB: do this after :load so it doesn't get dropped
 166     write s $ "ref <- Data.IORef.newIORef Test.Cabal.TestCode.TestCodeFail"
 167     -- TODO: What if an async exception gets raised here?  At the
 168     -- moment, there is no way to recover until we get to the top-level
 169     -- bracket; then stopServer which correctly handles this case.
 170     -- If you do want to be able to abort this computation but KEEP
 171     -- USING THE SERVER SESSION, you will need to have a lot more
 172     -- sophisticated logic.
 173     write s $ "Test.Cabal.Server.runMain ref Main.main"
 174     -- Output end sigil.
 175     -- NB: We're line-oriented, so we MUST add an extra newline
 176     -- to ensure that we see the end sigil.
 177     write s $ "System.IO.hPutStrLn System.IO.stdout " ++ show ""
 178     write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show ""
 179     write s $ "Data.IORef.readIORef ref >>= \\e -> " ++
 180               " System.IO.hPutStrLn System.IO.stdout (" ++ show end_sigil ++ " ++ \" \" ++ show e)"
 181     write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show end_sigil
 182     (code, out) <- wait a_exit_out
 183     err <- wait a_err
 184
 185     -- Give the user some indication about how they could run the
 186     -- command by hand.
 187     (real_path, real_args) <- runnerCommand (serverScriptEnv s) mb_cwd env_overrides script_path args
 188     return $
 189       ServerResult {
 190               serverResultTestCode = code,
 191               serverResultCommand = showCommandForUser real_path real_args,
 192               serverResultStdout = out,
 193               serverResultStderr = err
 194           }
 195
 196 -- | Helper function which we use in the GHCi session to communicate
 197 -- the exit code of the process.
 198 runMain :: IORef TestCode -> IO () -> IO ()
 199 runMain ref m = do
 200     E.catch (m >> writeIORef ref TestCodeOk) serverHandler
 201   where
 202     serverHandler :: SomeException -> IO ()
 203     serverHandler e = do
 204         -- TODO: Probably a few more cases you could handle;
 205         -- e.g., StackOverflow should return ExitCode 2; also signals.
 206         writeIORef ref $ case fromException e of
 207             Just test_code -> test_code
 208             _              -> TestCodeFail
 209
 210         -- Only rethrow for non ExitFailure exceptions
 211         case fromException e :: Maybe TestCode of
 212           Just _ -> return ()
 213           _      -> throwIO e
 214
 215 -- ----------------------------------------------------------------- --
 216 -- Initialize/tear down
 217 -- ----------------------------------------------------------------- --
 218
 219 -- | Start a new GHCi session.
 220 startServer :: Chan ServerLogMsg -> ScriptEnv -> IO Server
 221 startServer chan senv = do
 222     (prog, _) <- requireProgram verbosity ghcProgram (runnerProgramDb senv)
 223     let ghc_args = runnerGhcArgs senv Nothing ++ ["--interactive", "-v0", "-ignore-dot-ghci"]
 224         proc_spec = (proc (programPath prog) ghc_args) {
 225                         create_group = True,
 226                         -- Closing fds is VERY important to avoid
 227                         -- deadlock; we won't see the end of a
 228                         -- stream until everyone gives up.
 229                         close_fds = True,
 230                         std_in  = CreatePipe,
 231                         std_out = CreatePipe,
 232                         std_err = CreatePipe
 233                     }
 234     when (verbosity >= verbose) $
 235         writeChan chan (ServerLogMsg AllServers (showCommandForUser (programPath prog) ghc_args))
 236     (Just hin, Just hout, Just herr, proch) <- createProcess proc_spec
 237     out_acc <- newMVar []
 238     err_acc <- newMVar []
 239     tid <- myThreadId
 240     return Server {
 241                 serverStdin     = hin,
 242                 serverStdout    = hout,
 243                 serverStderr    = herr,
 244                 serverProcessHandle = proch,
 245                 serverProcessId = show tid,
 246                 serverLogChan   = chan,
 247                 serverStdoutAccum = out_acc,
 248                 serverStderrAccum = err_acc,
 249                 serverScriptEnv = senv
 250               }
 251   where
 252     verbosity = runnerVerbosity senv
 253
 254 -- | Unmasked initialization for the server
 255 initServer :: Server -> IO Server
 256 initServer s0 = do
 257     -- NB: withProcessHandle reads an MVar and is interruptible
 258
 259     pid <- withProcessHandle (serverProcessHandle s0) $ \ph ->
 260               case ph of
 261 #if mingw32_HOST_OS
 262                   OpenHandle x   -> fmap show (Win32.getProcessId x)
 263 #else
 264                   OpenHandle x   -> return (show x)
 265 #endif
 266                   -- TODO: handle OpenExtHandle?
 267                   _              -> return (serverProcessId s0)
 268
 269     let s = s0 { serverProcessId = pid }
 270     -- We will read/write a line at a time, including for
 271     -- output; our demarcation tokens are an entire line.
 272     forM_ [serverStdin, serverStdout, serverStderr] $ \f -> do
 273         hSetBuffering (f s) LineBuffering
 274         hSetEncoding (f s) utf8
 275     write s ":set prompt \"\""
 276     write s "System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering"
 277     return s
 278
 279 -- | Stop a GHCi session.
 280 stopServer :: Server -> IO ()
 281 stopServer s = do
 282     -- This is quite a bit of funny business.
 283     -- On Linux, terminateProcess will send a SIGINT, which
 284     -- GHCi will swallow and actually only use to terminate
 285     -- whatever computation is going on at that time.  So we
 286     -- have to follow up with an actual :quit command to
 287     -- finish it up (if you delete it, the processes will
 288     -- hang around).  On Windows, this will just actually kill
 289     -- the process so the rest should be unnecessary.
 290     mb_exit <- getProcessExitCode (serverProcessHandle s)
 291
 292     let hardKiller = do
 293             threadDelay 2000000 -- 2sec
 294             log ServerMeta s $ "Terminating..."
 295             terminateProcess (serverProcessHandle s)
 296         softKiller = do
 297             -- Ask to quit.  If we're in the middle of a computation,
 298             -- this will buffer up (unless the program is intercepting
 299             -- stdin, but that should NOT happen.)
 300             ignore $ write s ":quit"
 301
 302             -- NB: it's important that we used create_group.  We
 303             -- run this AFTER write s ":quit" because if we C^C
 304             -- sufficiently early in GHCi startup process, GHCi
 305             -- will actually die, and then hClose will fail because
 306             -- the ":quit" command was buffered up but never got
 307             -- flushed.
 308             interruptProcessGroupOf (serverProcessHandle s)
 309
 310             log ServerMeta s $ "Waiting..."
 311             -- Close input BEFORE waiting, close output AFTER waiting.
 312             -- If you get either order wrong, deadlock!
 313             ignoreSigPipe $ hClose (serverStdin s)
 314             -- waitForProcess has race condition
 315             -- https://github.com/haskell/process/issues/46
 316             waitForProcess $ serverProcessHandle s
 317
 318     let drain f = do
 319             r <- hGetContents (f s)
 320             _ <- evaluate (length r)
 321             hClose (f s)
 322             return r
 323
 324     withAsync (drain serverStdout) $ \a_out -> do
 325     withAsync (drain serverStderr) $ \a_err -> do
 326
 327     r <- case mb_exit of
 328         Nothing -> do
 329             log ServerMeta s $ "Terminating GHCi"
 330             race hardKiller softKiller
 331         Just exit -> do
 332             log ServerMeta s $ "GHCi died unexpectedly"
 333             return (Right exit)
 334
 335     -- Drain the output buffers
 336     rest_out <- wait a_out
 337     rest_err <- wait a_err
 338     if r /= Right ExitSuccess &&
 339        r /= Right (ExitFailure (-2)) -- SIGINT; happens frequently for some reason
 340         then do withMVar (serverStdoutAccum s) $ \acc ->
 341                     mapM_ (info ServerOut s) (reverse acc)
 342                 info ServerOut  s rest_out
 343                 withMVar (serverStderrAccum s) $ \acc ->
 344                     mapM_ (info ServerErr s) (reverse acc)
 345                 info ServerErr  s rest_err
 346                 info ServerMeta s $
 347                     (case r of
 348                         Left () -> "GHCi was forcibly terminated"
 349                         Right exit -> "GHCi exited with " ++ show exit) ++
 350                     if verbosity < verbose
 351                         then " (use -v for more information)"
 352                         else ""
 353         else log ServerOut s rest_out
 354
 355     log ServerMeta s $ "Done"
 356     return ()
 357   where
 358     verbosity = runnerVerbosity (serverScriptEnv s)
 359
 360     ignoreSigPipe :: IO () -> IO ()
 361     ignoreSigPipe = E.handle $ \e -> case e of
 362         GHC.IOError { GHC.ioe_type  = GHC.ResourceVanished, GHC.ioe_errno = Just ioe }
 363             | Errno ioe == ePIPE -> return ()
 364         _ -> throwIO e
 365
 366 -- Using the procedure from
 367 -- https://www.schoolofhaskell.com/user/snoyberg/general-haskell/exceptions/catching-all-exceptions
 368 ignore :: IO () -> IO ()
 369 ignore m = withAsync m $ \a -> void (waitCatch a)
 370
 371 -- ----------------------------------------------------------------- --
 372 -- Utility functions
 373 -- ----------------------------------------------------------------- --
 374
 375 log :: (ProcessId -> ServerLogMsgType) -> Server -> String -> IO ()
 376 log ctor s msg =
 377     when (verbosity >= verbose) $ info ctor s msg
 378   where
 379     verbosity = runnerVerbosity (serverScriptEnv s)
 380
 381 info :: (ProcessId -> ServerLogMsgType) -> Server -> String -> IO ()
 382 info ctor s msg =
 383     writeChan chan (ServerLogMsg (ctor (serverProcessId s)) msg)
 384   where
 385     chan = serverLogChan s
 386
 387 -- | Write a string to the prompt of the GHCi server.
 388 write :: Server -> String -> IO ()
 389 write s msg = do
 390     log ServerIn s $ msg
 391     hPutStrLn (serverStdin s) msg
 392     hFlush (serverStdin s) -- line buffering should get it, but just for good luck
 393
 394 accumulate :: MVar [String] -> String -> IO ()
 395 accumulate acc msg =
 396     modifyMVar_ acc (\msgs -> return (msg:msgs))
 397
 398 flush :: MVar [String] -> IO [String]
 399 flush acc = modifyMVar acc (\msgs -> return ([], reverse msgs))
 400
 401 data OutOrErr = IsOut | IsErr
 402
 403 serverHandle :: Server -> OutOrErr -> Handle
 404 serverHandle s IsOut = serverStdout s
 405 serverHandle s IsErr = serverStderr s
 406
 407 serverAccum :: Server -> OutOrErr -> MVar [String]
 408 serverAccum s IsOut = serverStdoutAccum s
 409 serverAccum s IsErr = serverStderrAccum s
 410
 411 outOrErrMsgType :: OutOrErr -> (ProcessId -> ServerLogMsgType)
 412 outOrErrMsgType IsOut = ServerOut
 413 outOrErrMsgType IsErr = ServerErr
 414
 415 -- | Consume output from the GHCi server until we hit a "start
 416 -- sigil" (indicating that the subsequent output is for the
 417 -- command we want.)  Call this only immediately after you
 418 -- send a command to GHCi to emit the start sigil.
 419 readUntilSigil :: Server -> String -> OutOrErr -> IO String
 420 readUntilSigil s sigil outerr = do
 421     l <- hGetLine (serverHandle s outerr)
 422     log (outOrErrMsgType outerr) s l
 423     if sigil `isPrefixOf` l -- NB: on Windows there might be extra goo at end
 424         then intercalate "\n" `fmap` flush (serverAccum s outerr)
 425         else do accumulate (serverAccum s outerr) l
 426                 readUntilSigil s sigil outerr
 427
 428 -- | Consume output from the GHCi server until we hit the
 429 -- end sigil.  Return the consumed output as well as the
 430 -- exit code (which is at the end of the sigil).
 431 readUntilEnd :: Server -> OutOrErr -> IO (TestCode, String)
 432 readUntilEnd s outerr = go []
 433   where
 434     go rs = do
 435         l <- hGetLine (serverHandle s outerr)
 436         log (outOrErrMsgType outerr) s l
 437         if end_sigil `isPrefixOf` l
 438             -- NB: NOT unlines, we don't want the trailing newline!
 439             then do exit <- evaluate (parseExit l)
 440                     _ <- flush (serverAccum s outerr) -- TODO: don't toss this out
 441                     return (exit, intercalate "\n" (reverse rs))
 442             else do accumulate (serverAccum s outerr) l
 443                     go (l:rs)
 444     parseExit l = case readMaybe (drop (length end_sigil) l) of
 445         Nothing -> error $ "Cannot parse TestCode at the end of: " ++ l
 446         Just tc -> tc
 447
 448 -- | The start and end sigils.  This should be chosen to be
 449 -- reasonably unique, so that test scripts don't accidentally
 450 -- generate them.  If these get spuriously generated, we will
 451 -- probably deadlock.
 452 start_sigil, end_sigil :: String
 453 start_sigil = "BEGIN Test.Cabal.Server"
 454 end_sigil   = "END Test.Cabal.Server"