IntegrationSpec.hs

{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}

import           Conduit
                   ( (.|), connect, filterC, filterMC, foldMapC, mapM_C
                   , runConduit, runConduitRes, runResourceT, sourceDirectory
                   , sourceDirectoryDeep, stderrC, withSourceFile
                   )
import           Data.List ( stripPrefix )
import           Options.Generic
                   ( ParseField, ParseRecord (..), defaultModifiers
                   , fieldNameModifier, firstLetter, getRecord
                   , parseRecordWithModifiers, shortNameModifier
                   )
import           RIO
import           RIO.Char ( toLower )
import           RIO.Directory
                   ( canonicalizePath, copyFile, createDirectoryIfMissing
                   , doesFileExist, getAppUserDataDirectory
                   )
import           RIO.FilePath
                   ( (</>), (<.>), isPathSeparator, takeDirectory
                   , takeExtensions, takeFileName
                   )
import           RIO.List ( isInfixOf, partition )
import qualified RIO.Map as Map
import           RIO.Process
                   ( HasProcessContext (..), closed, findExecutable, proc
                   , runProcess, runProcess_, setStderr, setStdin, setStdout
                   , useHandleOpen, withModifyEnvVars, withWorkingDir
                   )
import qualified RIO.Set as Set
import qualified RIO.Text as T
import           RIO.Time ( defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime )
import           System.Environment ( getExecutablePath, lookupEnv )
import           System.Info ( os )
import           System.PosixCompat.Files ( createSymbolicLink )

-- This code does not use a test framework so that we get direct
-- control of how the output is displayed.

main :: IO ()
main = runSimpleApp $ do
  logInfo "Initiating Stack integration test running"

  options <- getRecord "Stack integration tests"
  startTime <- getCurrentTime
  results <- runApp options $ do
    logInfo "Running with the following environment"
    proc "env" [] runProcess_
    tests <- asks appTestDirs
    let count = Set.size tests
        loop !idx rest !accum =
          case rest of
            [] -> pure accum
            next:rest' -> do
              logInfo $ "Running integration test "
                     <> display idx
                     <> "/"
                     <> display count
                     <> ": "
                     <> fromString (takeFileName next)
              res <- test next
              loop (idx + 1) rest' (res <> accum)

    loop (1 :: Int) (Set.toList tests) mempty
  finalTime <- getCurrentTime
  let (successes, failures) = partition ((== ExitSuccess) . snd)
                            $ Map.toList results
  let timeDiff = diffUTCTime finalTime startTime
  let timeDiffStr = formatTime defaultTimeLocale "%H:%M:%S - total %s seconds" timeDiff
  logInfo $ "Integration tests ran in : " <> fromString timeDiffStr
  unless (null successes) $ do
    logInfo "Successful tests:"
    for_ successes $ \(x, _) -> logInfo $ "- " <> display x
    logInfo ""

  if null failures
    then logInfo "No failures!"
    else do
      logInfo "Failed tests:"
      for_ failures $ \(x, ec) -> logInfo $ "- " <> display x <> " - " <> displayShow ec
      exitFailure


data Options = Options
  { optSpeed :: Maybe Speed
  , optMatch :: Maybe String
  , optNot :: [String]
  }
  deriving Generic

instance ParseRecord Options where
  parseRecord = parseRecordWithModifiers modifiers
    where
      optName = map toLower . drop 3
      modifiers = defaultModifiers { fieldNameModifier = optName
                                   , shortNameModifier = firstLetter . optName
                                   }

data Speed = Fast | Normal | Superslow
  deriving (Read, Generic)

instance ParseField Speed

exeExt :: String
exeExt = if isWindows then ".exe" else ""

isWindows :: Bool
isWindows = os == "mingw32"

isLinux :: Bool
isLinux = os == "linux"

runApp :: Options -> RIO App a -> RIO SimpleApp a
runApp options inner = do
  let speed = fromMaybe Normal $ optSpeed options
  simpleApp <- ask
  runghc <- findExecutable "runghc" >>= either throwIO pure
  srcDir <- canonicalizePath ""
  testsRoot <- canonicalizePath $ srcDir </> "tests/integration"
  libdir <- canonicalizePath $ testsRoot </> "lib"
  myPath <- liftIO getExecutablePath

  stack <- canonicalizePath $ takeDirectory myPath </> "stack" ++ exeExt
  logInfo $ "Using Stack located at " <> fromString stack
  proc stack ["--version"] runProcess_
  logInfo $ "Using runghc located at " <> fromString runghc
  proc runghc ["--version"] runProcess_

  let matchTest = case (optMatch options, optNot options) of
        (Just str, _) -> (str `isInfixOf`)
        (_, []) -> const True
        (_, nl) -> \a -> all (\b -> not $ b `isInfixOf` a) nl
  testDirs
    <- runConduitRes
     $ sourceDirectory (testsRoot </> "tests")
    .| filterMC (liftIO . hasTest)
    .| filterC matchTest
    .| foldMapC Set.singleton

  let modifyEnvCommon
        = Map.insert "SRC_DIR" (fromString srcDir)
        . Map.insert "STACK_EXE" (fromString stack)
        . Map.delete "GHC_PACKAGE_PATH"
        . Map.insert "STACK_TEST_SPEED"
            (case speed of
              Superslow -> "SUPERSLOW"
              _ -> "NORMAL")
        . Map.fromList
        . map (first T.toUpper)
        . Map.toList

  case speed of
    Fast -> do
      let app = App
            { appSimpleApp = simpleApp
            , appRunghc = runghc
            , appLibDir = libdir
            , appSetupHome = id
            , appTestDirs = testDirs
            }
      runRIO app $ withModifyEnvVars modifyEnvCommon inner
    _ -> do
      origStackRoot <- liftIO (lookupEnv "STACK_ROOT") >>= \case
        Nothing -> getAppUserDataDirectory "stack"
        Just x -> pure x

      logInfo "Initializing/updating the original Pantry store"
      proc stack ["update"] runProcess_

      pantryRoot <- canonicalizePath $ origStackRoot </> "pantry"
      let modifyEnv
               = Map.insert "PANTRY_ROOT" (fromString pantryRoot)
               . modifyEnvCommon

          app = App
            { appSimpleApp = simpleApp
            , appRunghc = runghc
            , appLibDir = libdir
            , appSetupHome = \inner' -> withSystemTempDirectory "home" $ \newHome -> do
                let newStackRoot = newHome </> ".stack"
                createDirectoryIfMissing True newStackRoot
                let modifyEnv'
                      = Map.insert "HOME" (fromString newHome)
                      . Map.insert "APPDATA" (fromString newHome)
                      . Map.insert "STACK_ROOT" (fromString newStackRoot)
                writeFileBinary (newStackRoot </> "config.yaml") "system-ghc: true\ninstall-ghc: false\n"
                withModifyEnvVars modifyEnv' inner'
            , appTestDirs = testDirs
            }

      runRIO app $ withModifyEnvVars modifyEnv inner


hasTest :: FilePath -> IO Bool
hasTest dir = doesFileExist $ dir </> "Main.hs"

data App = App
  { appRunghc :: !FilePath
  , appLibDir :: !FilePath
  , appSetupHome :: !(forall a. RIO App a -> RIO App a)
  , appSimpleApp :: !SimpleApp
  , appTestDirs :: !(Set FilePath)
  }
simpleAppL :: Lens' App SimpleApp
simpleAppL = lens appSimpleApp (\x y -> x { appSimpleApp = y })
instance HasLogFunc App where
  logFuncL = simpleAppL.logFuncL
instance HasProcessContext App where
  processContextL = simpleAppL.processContextL

-- | Call 'appSetupHome' on the inner action
withHome :: RIO App a -> RIO App a
withHome inner = do
  app <- ask
  appSetupHome app inner

test :: FilePath -- ^ test dir
     -> RIO App (Map Text ExitCode)
test testDir = withDir $ \dir -> withHome $ do
    runghc <- asks appRunghc
    libDir <- asks appLibDir
    let mainFile = testDir </> "Main.hs"

    copyTree (testDir </> "files") dir

    withSystemTempFile (name <.> "log") $ \logfp logh -> do
      let args =
            [ "-clear-package-db"
            , "-global-package-db"
            , "-i" ++ libDir
            , mainFile
            ]
          args' = if isLinux
            then
              -- We seek to use lld as the linker on Linux, as it is much faster
              -- than the default linker. The executable assumes lld is on the
              -- PATH.
              "--" : "-optl-fuse-ld=lld" : args
            else
              args
      ec <- withWorkingDir dir $
              withModifyEnvVars (Map.insert "TEST_DIR" $ fromString testDir) $
                proc runghc args' $
                    runProcess
                  . setStdin closed
                  . setStdout (useHandleOpen logh)
                  . setStderr (useHandleOpen logh)
      hClose logh

      case ec of
        ExitSuccess -> logInfo "Success!"
        _ -> do
          logError "Failure, dumping log\n\n"
          withSourceFile logfp $ \src ->
            runConduit $ src .| stderrC
          logError $ "\n\nEnd of log for " <> fromString name
      pure $ Map.singleton (fromString name) ec
  where
    name = takeFileName testDir
    withDir = withSystemTempDirectory ("stack-integration-" ++ name)

copyTree :: MonadIO m => FilePath -> FilePath -> m ()
copyTree src dst =
    liftIO $
    runResourceT (sourceDirectoryDeep False src `connect` mapM_C go)
        `catch` \(_ :: IOException) -> pure ()
  where
    go srcfp = liftIO $ do
        Just suffix <- pure $ stripPrefix src srcfp
        let dstfp = dst </> stripHeadSeparator suffix
        createDirectoryIfMissing True $ takeDirectory dstfp
        -- copying yaml files so lock files won't get created in
        -- the source directory
        if takeFileName srcfp /= "package.yaml" &&
           (takeExtensions srcfp == ".yaml" || takeExtensions srcfp == ".yml")
          then
            copyFile srcfp dstfp
          else
            createSymbolicLink srcfp dstfp `catch` \(_ :: IOException) ->
                copyFile srcfp dstfp -- for Windows

    stripHeadSeparator :: FilePath -> FilePath
    stripHeadSeparator [] = []
    stripHeadSeparator fp@(x:xs) = if isPathSeparator x
                                   then xs
                                   else fp