{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Check
( result,
-- exposed for testing:
hasVersion
)
where
import Control.Applicative (many)
import Data.Char (isDigit, isLetter)
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Language.Haskell.TH.Env (envQ)
import OurPrelude
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
import System.Exit
import System.IO.Temp (withSystemTempDirectory)
import Text.Regex.Applicative.Text (RE', (=~))
import qualified Text.Regex.Applicative.Text as RE
import Utils (UpdateEnv (..), Version, nixBuildOptions)
default (T.Text)
treeBin :: String
treeBin = fromJust ($$(envQ "TREE") :: Maybe String) <> "/bin/tree"
procTree :: [String] -> ProcessConfig () () ()
procTree = proc treeBin
gistBin :: String
gistBin = fromJust ($$(envQ "GIST") :: Maybe String) <> "/bin/gist"
procGist :: [String] -> ProcessConfig () () ()
procGist = proc gistBin
timeoutBin :: String
timeoutBin = fromJust ($$(envQ "TIMEOUT") :: Maybe String) <> "/bin/timeout"
data BinaryCheck = BinaryCheck
{ filePath :: FilePath,
zeroExitCode :: Bool,
versionPresent :: Bool
}
isWordCharacter :: Char -> Bool
isWordCharacter c = (isDigit c) || (isLetter c)
isNonWordCharacter :: Char -> Bool
isNonWordCharacter c = not (isWordCharacter c)
-- | Construct regex: /.*\b${version}\b.*/s
versionRegex :: Text -> RE' ()
versionRegex version =
(\_ -> ()) <$> (
(((many RE.anySym) <* (RE.psym isNonWordCharacter)) <|> (RE.pure ""))
*> (RE.string version) <*
((RE.pure "") <|> ((RE.psym isNonWordCharacter) *> (many RE.anySym)))
)
hasVersion :: Text -> Text -> Bool
hasVersion contents expectedVersion =
isJust $ contents =~ versionRegex expectedVersion
checkTestsBuild :: Text -> IO Bool
checkTestsBuild attrPath =
let args =
nixBuildOptions
++ [ "-E",
"{ config }: (import ./. { inherit config; })."
++ (T.unpack attrPath)
++ ".tests or {}"
]
in do
r <- runExceptT $ ourReadProcessInterleaved $ proc "nix-build" args
case r of
Right (ExitSuccess, _) -> return True
_ -> return False
-- | Run a program with provided argument and report whether the output
-- mentions the expected version
checkBinary :: Text -> Version -> FilePath -> IO BinaryCheck
checkBinary argument expectedVersion program = do
eResult <-
runExceptT $
withSystemTempDirectory
"nixpkgs-update"
( ourLockedDownReadProcessInterleaved $
shell (timeoutBin <> " -k 2 1 " <> program <> " " <> T.unpack argument)
)
case eResult of
Left (_ :: Text) -> return $ BinaryCheck program False False
Right (exitCode, contents) ->
return $ BinaryCheck program (exitCode == ExitSuccess) (hasVersion contents expectedVersion)
checks :: [Version -> FilePath -> IO BinaryCheck]
checks =
[ checkBinary "",
checkBinary "-V",
checkBinary "-v",
checkBinary "--version",
checkBinary "version",
checkBinary "-h",
checkBinary "--help",
checkBinary "help"
]
someChecks :: BinaryCheck -> [IO BinaryCheck] -> IO BinaryCheck
someChecks best [] = return best
someChecks best (c : rest) = do
current <- c
let nb = newBest current
case nb of
BinaryCheck _ True True -> return nb
_ -> someChecks nb rest
where
newBest :: BinaryCheck -> BinaryCheck
newBest (BinaryCheck _ currentExit currentVersionPresent) =
BinaryCheck
(filePath best)
(zeroExitCode best || currentExit)
(versionPresent best || currentVersionPresent)
-- | Run a program with various version or help flags and report
-- when they succeded
runChecks :: Version -> FilePath -> IO BinaryCheck
runChecks expectedVersion program =
someChecks (BinaryCheck program False False) checks'
where
checks' = map (\c -> c expectedVersion program) checks
checkTestsBuildReport :: Bool -> Text
checkTestsBuildReport False =
"- Warning: a test defined in `passthru.tests` did not pass"
checkTestsBuildReport True =
"- The tests defined in `passthru.tests`, if any, passed"
checkReport :: BinaryCheck -> Text
checkReport (BinaryCheck p False False) =
"- Warning: no invocation of "
<> T.pack p
<> " had a zero exit code or showed the expected version"
checkReport (BinaryCheck p _ _) =
"- " <> T.pack p <> " passed the binary check."
ourLockedDownReadProcessInterleaved ::
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored ->
FilePath ->
ExceptT Text m (ExitCode, Text)
ourLockedDownReadProcessInterleaved processConfig tempDir =
processConfig & setWorkingDir tempDir
& setEnv [("EDITOR", "echo"), ("HOME", "/we-dont-write-to-home")]
& ourReadProcessInterleaved
foundVersionInOutputs :: Text -> String -> IO (Maybe Text)
foundVersionInOutputs expectedVersion resultPath =
hush
<$> runExceptT
( do
(exitCode, _) <-
proc "grep" ["-r", T.unpack expectedVersion, resultPath]
& ourReadProcessInterleaved
case exitCode of
ExitSuccess ->
return $
"- found "
<> expectedVersion
<> " with grep in "
<> T.pack resultPath
<> "\n"
_ -> throwE "grep did not find version in file names"
)
foundVersionInFileNames :: Text -> String -> IO (Maybe Text)
foundVersionInFileNames expectedVersion resultPath =
hush
<$> runExceptT
( do
(_, contents) <-
shell ("find " <> resultPath) & ourReadProcessInterleaved
(contents =~ versionRegex expectedVersion) & hoistMaybe
& noteT (T.pack "Expected version not found")
return $
"- found "
<> expectedVersion
<> " in filename of file in "
<> T.pack resultPath
<> "\n"
)
treeGist :: String -> IO (Maybe Text)
treeGist resultPath =
hush
<$> runExceptT
( do
contents <- procTree [resultPath] & ourReadProcessInterleavedBS_
g <-
shell gistBin & setStdin (byteStringInput contents)
& ourReadProcessInterleaved_
return $ "- directory tree listing: " <> g <> "\n"
)
duGist :: String -> IO (Maybe Text)
duGist resultPath =
hush
<$> runExceptT
( do
contents <- proc "du" [resultPath] & ourReadProcessInterleavedBS_
g <-
shell gistBin & setStdin (byteStringInput contents)
& ourReadProcessInterleaved_
return $ "- du listing: " <> g <> "\n"
)
result :: MonadIO m => UpdateEnv -> String -> m Text
result updateEnv resultPath =
liftIO $ do
let expectedVersion = newVersion updateEnv
binaryDir = resultPath <> "/bin"
testsBuild <- checkTestsBuild (packageName updateEnv)
binExists <- doesDirectoryExist binaryDir
binaries <-
if binExists
then
( do
fs <- listDirectory binaryDir
filterM doesFileExist (map (\f -> binaryDir ++ "/" ++ f) fs)
)
else return []
checks' <- forM binaries $ \binary -> runChecks expectedVersion binary
let passedZeroExitCode =
(T.pack . show)
( foldl
( \acc c ->
if zeroExitCode c
then acc + 1
else acc
)
0
checks' ::
Int
)
passedVersionPresent =
(T.pack . show)
( foldl
( \acc c ->
if versionPresent c
then acc + 1
else acc
)
0
checks' ::
Int
)
numBinaries = (T.pack . show) (length binaries)
someReports <-
fromMaybe ""
<$> foundVersionInOutputs expectedVersion resultPath
<> foundVersionInFileNames expectedVersion resultPath
<> treeGist resultPath
<> duGist resultPath
return $
let testsBuildSummary = checkTestsBuildReport testsBuild
c = T.intercalate "\n" (map checkReport checks')
binaryCheckSummary =
"- "
<> passedZeroExitCode
<> " of "
<> numBinaries
<> " passed binary check by having a zero exit code."
versionPresentSummary =
"- "
<> passedVersionPresent
<> " of "
<> numBinaries
<> " passed binary check by having the new version present in output."
in [interpolate|
$testsBuildSummary
$c
$binaryCheckSummary
$versionPresentSummary
$someReports
|]