Add Haskell script trying to reproduce the build
We add a Haskell script in charge of reproducing the build.
This commit is contained in:
parent
4ce91a2379
commit
39b98f330a
|
@ -0,0 +1,112 @@
|
||||||
|
#!/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 Data.Text hiding (foldl')
|
||||||
|
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"
|
||||||
|
$ 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 (unpack cmd) (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"
|
11
default.nix
11
default.nix
|
@ -2,12 +2,5 @@
|
||||||
hs-pkg-name ? "wcwidth",
|
hs-pkg-name ? "wcwidth",
|
||||||
ghcSrc ? /home/ninjatrappeur/Code/perso/haskell/ghc
|
ghcSrc ? /home/ninjatrappeur/Code/perso/haskell/ghc
|
||||||
}:
|
}:
|
||||||
let
|
|
||||||
ghcOverlay =
|
import ./repro.nix { inherit hs-pkg-name ghcSrc; }
|
||||||
import ./overlays/ghc.nix {
|
|
||||||
inherit ghcSrc pkgs;
|
|
||||||
};
|
|
||||||
nixpkgsConfig = { overlays = [ ghcOverlay ]; };
|
|
||||||
nixpkgsSrc = (import ./nix/sources.nix).nixpkgs;
|
|
||||||
pkgs = import nixpkgsSrc nixpkgsConfig;
|
|
||||||
in pkgs.customGhcHEAD."${hs-pkg-name}"
|
|
||||||
|
|
|
@ -0,0 +1,7 @@
|
||||||
|
let
|
||||||
|
pkgs = import (import ../nix/sources.nix).nixpkgs {};
|
||||||
|
in pkgs.fetchgit {
|
||||||
|
url = "https://gitlab.haskell.org/ghc/ghc.git/";
|
||||||
|
rev = "40c71c2cf38b4e134d81b7184a4d5e02949ae70c";
|
||||||
|
sha256 = "04h9rcyzm9w3an1z00hjs062dp7dl19b8pkyxjsypr7a2i9dmvkb";
|
||||||
|
}
|
|
@ -0,0 +1,14 @@
|
||||||
|
{
|
||||||
|
hs-pkg-name ? "wcwidth",
|
||||||
|
ghcSrcDrv ? ./examples/ghc.nix
|
||||||
|
}:
|
||||||
|
let
|
||||||
|
ghcSrc = import ghcSrcDrv;
|
||||||
|
ghcOverlay =
|
||||||
|
import ./overlays/ghc.nix {
|
||||||
|
inherit ghcSrc pkgs;
|
||||||
|
};
|
||||||
|
nixpkgsConfig = { overlays = [ ghcOverlay ]; };
|
||||||
|
nixpkgsSrc = (import ./nix/sources.nix).nixpkgs;
|
||||||
|
pkgs = import nixpkgsSrc nixpkgsConfig;
|
||||||
|
in pkgs.haskellPackages."${hs-pkg-name}"
|
Loading…
Reference in New Issue