You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 

111 lines
4.2 KiB

#!/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"