ghc_binary_repro_test/ReproTest.hs

#!/usr/bin/env nix-shell
#!nix-shell -i runhaskell -p "haskellPackages.ghcWithPackages(p: with p; [ relude optparse-applicative process ])" -p nix -p diffoscope
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

import Relude

import Data.Maybe
import GHC.IO.Handle
import Control.Monad.Except
import Control.DeepSeq
import Options.Applicative
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified System.Exit as E
import System.Process


data Config = Config
  { pkgName     :: Text,
    ghcPath     :: Text,
    diffOutDir  :: Text,
    nbRepro     :: Int
  }
data ReproStatus = ReproStatus IsReproducible ReproPaths

type IsReproducible = Bool
type ReproPaths = [Text]
type StorePath  = Text
type NixError   = Text

main :: IO ()
main = do
  c <- execParser opts
  rs <- runExceptT $ repro c
  case rs of
    Left err -> T.putStrLn err >> exitFailure
    Right (ReproStatus True xs)  -> T.putStrLn "The build seems to be reproducible" >> exitSuccess
    Right (ReproStatus False xs) -> do
      runDiffoscope c xs
      T.putStrLn $ "Cannot Reproduce build.\n" <> unwords xs
      T.putStrLn $ "See diffoscope report for more details: " <> diffOutDir c
  where
    opts = info (configParser <**> helper)
       ( fullDesc
       <> header "ReproTest.hs - Test the GHC binary reproducibility for a hackage package"
       )

configParser :: Parser Config
configParser = Config
  <$> strOption (long "package-name" <> short 'p' <> help "Hackage package to test.")
  <*> strOption (long "ghc-nixexpr-path" <> short 'e' <> help "Path to the nix derivation retrieving the custom GHC checkpout you want to use.")
  <*> strOption (long "report-dir" <> short 'o' <> help "Directory in which you want to store the diff output in case of a failing test." <> showDefault <> value "./diff-out")
  <*> option auto (long "nb-repro" <> short 'n' <> help "How much reproduction iterations we want to perform." <> showDefault <> value 3)

repro :: (MonadIO m) => Config -> ExceptT NixError m ReproStatus
repro c = do
  -- 1. Nix instantiate derivation
  (eci, drvPath) <- streamRunCmd "nix-instantiate"
    [
      "--arg", "hs-pkg-name", "\"" <> pkgName c <> "\"",
      "--arg", "ghcSrcDrv", ghcPath c,
      "./repro.nix"
    ] True
  -- 2. nix-store --realize /nix/store/xxx.drv
  (_, p1) <- streamRunCmd "nix-store"
    ["--realise", "--quiet", drvPath] True
  -- 3. nix-store --realize --check /nix/store/xxx.drv
  (ecr2, p2) <- repeatRepro c drvPath
  -- 4. If exit code > 1 => Just two repro paths
  pure $ ReproStatus (ecr2 == E.ExitSuccess) [p1, p2]

repeatRepro :: (MonadIO m) => Config -> Text -> ExceptT NixError m (E.ExitCode, StorePath)
repeatRepro c drv = go $ nbRepro c
  where
    go (!i) = do
      (ecr2, p2) <- streamRunCmd "nix-store"
          ["--realise", "--quiet", "-K", "--check", drv] False
      if ecr2 /= E.ExitSuccess || i < 1
        then pure (ecr2, p2)
        else go $ i - 1

runDiffoscope :: Config -> ReproPaths -> IO ()
runDiffoscope c rp = callProcess "diffoscope"
                       $ T.unpack <$> [ "--html-dir", diffOutDir c ] <> rp

-- Partially vendored from Shask
-- TODO:
-- - Handle custom Exp stacks in Shask.
-- - Determine whether the out parsing should be part of the Shask API or not.
-- - Release Shask.
streamRunCmd :: (MonadIO m) => Text -> [Text] -> Bool -> ExceptT NixError m (E.ExitCode, StorePath)
streamRunCmd cmd args fail = do
    liftIO . T.putStr $ "[+] " <> cmd <> " " <> unwords args <> "\n\n"
    (ec, out) <- liftIO $ withCreateProcess p progressFn
    when (ec /= E.ExitSuccess && fail) . throwError $ "Failed to run " <> cmd <> " " <> unwords args
    liftIO $ T.putStr $ "    " <> "DONE\n\n"
    return (force ec, force . T.filter (/= '\n') $ out)
  where
      p = (proc (T.unpack cmd) (T.unpack <$> args)) { std_out = CreatePipe, std_err = CreatePipe }
      progressFn _ (Just hout) (Just herr) ph = go
        where
          go = do
            eof <- hIsEOF herr
            unless eof $ T.hGetLine herr >>= T.putStrLn
            mec <- getProcessExitCode ph
            case mec of
              (Just ec) -> T.hGetContents hout >>= \out -> pure (ec, out)
              Nothing   -> go
      progressFn _ _ _ ph = error "Cannot open subprocess IO handles"