nixpkgs-update-0.2.0: src/Check.hs

{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module Check
  ( result
  ) where

import Control.Applicative (many)
import Control.Monad (forM)
import Data.Char (isSpace)
import Data.Maybe (isJust)
import Data.Semigroup ((<>))
import qualified Data.Text as T
import Data.Text (Text)
import Prelude hiding (FilePath)
import Shelly
import qualified Text.Regex.Applicative as RE
import Text.Regex.Applicative (RE, (=~))
import Utils (Options(..), UpdateEnv (..), Version, canFail, succeded)

default (T.Text)

data BinaryCheck = BinaryCheck
  { filePath :: FilePath
  , zeroExitCode :: Bool
  , versionPresent :: Bool
  }

-- | Construct regex: [^\.]*${version}\.*\s*
versionRegex :: Text -> RE Char ()
versionRegex version =
  (\_ _ _ _ -> ()) <$> many (RE.psym (/= '.')) <*> RE.string (T.unpack version) <*>
  many (RE.sym '.') <*>
  many (RE.psym isSpace)

-- | Run a program with provided argument and report whether the output
-- mentions the expected version
checkBinary :: Text -> Version -> FilePath -> Sh BinaryCheck
checkBinary argument expectedVersion program =
  catchany_sh
  (do
      stdout <- canFail $ cmd "timeout" "-k" "2" "1" program argument
      code <- lastExitCode
      stderr <- lastStderr
      let hasVersion =
            isJust $ (T.unpack . T.unwords . T.lines $ stdout <> "\n" <> stderr) =~
            versionRegex expectedVersion
      return $ BinaryCheck program (code == 0) hasVersion)
  (\ _ -> return $ BinaryCheck program False False)

checks :: [Version -> FilePath -> Sh BinaryCheck]
checks =
  [ checkBinary ""
  , checkBinary "-V"
  , checkBinary "-v"
  , checkBinary "--version"
  , checkBinary "version"
  , checkBinary "-h"
  , checkBinary "--help"
  , checkBinary "help"
  ]

someChecks :: BinaryCheck -> [Sh BinaryCheck] -> Sh 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 -> Sh BinaryCheck
runChecks expectedVersion program =
  someChecks (BinaryCheck program False False) checks'
  where
    checks' = map (\c -> c expectedVersion program) checks

checkReport :: BinaryCheck -> Text
checkReport (BinaryCheck p False False) = "- Warning: no invocation of " <> toTextIgnore p <> " had a zero exit code or showed the expected version"
checkReport (BinaryCheck p _ _) = "- " <> toTextIgnore p <> " passed the binary check."

successfullCheck :: BinaryCheck -> Bool
successfullCheck (BinaryCheck _ False False) = False
successfullCheck _ = True

result :: UpdateEnv -> FilePath  -> Sh Text
result updateEnv resultPath = do
  let expectedVersion = newVersion updateEnv
  home <- get_env_text "HOME"
  let logFile = workingDir (options updateEnv) </> "check-result-log.tmp"
  setenv "EDITOR" "echo"
  setenv "HOME" "/homeless-shelter"
  let addToReport input = appendfile logFile (input <> "\n")
  tempdir <- fromText . T.strip <$> cmd "mktemp" "-d"
  chdir tempdir $ do
    rm_f logFile
    let binaryDir = resultPath </> "bin"
    binExists <- test_d binaryDir
    binaries <-
      if binExists
        then findWhen test_f (resultPath </> "bin")
        else return []
    checks <- forM binaries $ \binary -> runChecks expectedVersion binary
    addToReport (T.intercalate "\n" (map checkReport checks))
    let passedZeroExitCode = (T.pack . show)
          (foldl
           (\sum c -> if zeroExitCode c then sum + 1 else sum) 0 checks :: Int)
        passedVersionPresent = (T.pack . show)
          (foldl
           (\sum c -> if versionPresent c then sum + 1 else sum) 0 checks :: Int)
        numBinaries = (T.pack . show) (length binaries)

    addToReport ("- " <> passedZeroExitCode <> " of " <> numBinaries <> " passed binary check by having a zero exit code.")
    addToReport ("- " <> passedVersionPresent <> " of " <> numBinaries <> " passed binary check by having the new version present in output.")
    canFail $ cmd "grep" "-r" expectedVersion resultPath
    whenM ((== 0) <$> lastExitCode) $
      addToReport $
        "- found " <> expectedVersion <> " with grep in " <>
        toTextIgnore resultPath
    whenM
      (null <$>
       findWhen
         (\path ->
            ((expectedVersion `T.isInfixOf` toTextIgnore path) &&) <$>
            test_f path)
         resultPath) $
      addToReport $
        "- found " <> expectedVersion <> " in filename of file in " <>
        toTextIgnore resultPath
    setenv "HOME" home
    gist1 <- cmd "tree" resultPath -|- cmd "gist"
    unless (T.null gist1) $ addToReport $ "- directory tree listing: " <> T.strip gist1
    gist2 <- cmd "du" "-h" resultPath -|- cmd "gist"
    unless (T.null gist2) $ addToReport $ "- du listing: " <> T.strip gist2
  canFail $ readfile logFile