2020-05-25 13:19:21 +02:00
#!/ 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 "
2021-02-01 16:14:40 +01:00
$ T . unpack <$> [ " --html-dir " , diffOutDir c ] <> rp
2020-05-25 13:19:21 +02:00
-- 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
2021-02-01 16:14:40 +01:00
p = ( proc ( T . unpack cmd ) ( T . unpack <$> args ) ) { std_out = CreatePipe , std_err = CreatePipe }
2020-05-25 13:19:21 +02:00
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 "