diff --git a/hedgehog-extras.cabal b/hedgehog-extras.cabal --- a/hedgehog-extras.cabal +++ b/hedgehog-extras.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: hedgehog-extras -version: 0.4.4.1 +version: 0.4.5.1 synopsis: Supplemental library for hedgehog description: Supplemental library for hedgehog. category: Test @@ -27,6 +27,7 @@ common exceptions { build-depends: exceptions } common filepath { build-depends: filepath } common hedgehog { build-depends: hedgehog } +common http-conduit { build-depends: http-conduit } common hw-aeson { build-depends: hw-aeson >= 0.1.8.0 } common mmorph { build-depends: mmorph } common mtl { build-depends: mtl } @@ -34,6 +35,7 @@ common process { build-depends: process } common resourcet { build-depends: resourcet } common stm { build-depends: stm } +common tar { build-depends: tar } common temporary { build-depends: temporary } common text { build-depends: text } common time { build-depends: time >= 1.9.1 } @@ -41,6 +43,7 @@ common unliftio { build-depends: unliftio } common unordered-containers { build-depends: unordered-containers } common yaml { build-depends: yaml } +common zlib { build-depends: zlib } common Win32 if os(windows) @@ -69,6 +72,7 @@ exceptions, filepath, hedgehog, + http-conduit, hw-aeson, mmorph, mtl, @@ -76,6 +80,7 @@ process, resourcet, stm, + tar, temporary, text, time, @@ -84,6 +89,7 @@ unordered-containers, Win32, yaml, + zlib, hs-source-dirs: src diff --git a/src/Hedgehog/Extras/Test/File.hs b/src/Hedgehog/Extras/Test/File.hs --- a/src/Hedgehog/Extras/Test/File.hs +++ b/src/Hedgehog/Extras/Test/File.hs @@ -128,7 +128,7 @@ -- | Rename the 'src' file to 'dst'. renameFile :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> FilePath -> m () renameFile src dst = GHC.withFrozenCallStack $ do - H.annotate $ "Copying from " <> show src <> " to " <> show dst + H.annotate $ "Renaming from " <> show src <> " to " <> show dst H.evalIO $ IO.renameFile src dst -- | Create a symbolic link from 'dst' to 'src'. diff --git a/src/Hedgehog/Extras/Test/Golden.hs b/src/Hedgehog/Extras/Test/Golden.hs --- a/src/Hedgehog/Extras/Test/Golden.hs +++ b/src/Hedgehog/Extras/Test/Golden.hs @@ -60,6 +60,7 @@ referenceLines <- List.lines <$> H.readFile referenceFile let difference = getGroupedDiff actualLines referenceLines case difference of + [] -> pure () [Both{}] -> pure () _ -> failMessage callStack $ ppDiff difference else if createFiles diff --git a/src/Hedgehog/Extras/Test/Network.hs b/src/Hedgehog/Extras/Test/Network.hs --- a/src/Hedgehog/Extras/Test/Network.hs +++ b/src/Hedgehog/Extras/Test/Network.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} +{- HLINT ignore "Redundant flip" -} + module Hedgehog.Extras.Test.Network ( doesFileExists , isPortOpen @@ -7,6 +9,8 @@ , assertPortOpen , assertSocketExists , doesSprocketExist + , downloadToFile + , downloadAndExtractGithubCommitToTemp ) where import Control.Exception (IOException, try) @@ -15,21 +19,32 @@ import Data.Bool import Data.Either import Data.Function +import Data.Functor import Data.Int import Data.Semigroup import GHC.Stack (HasCallStack) import Hedgehog (MonadTest) import Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket, sprocketSystemName) +import Prelude (String) +import System.FilePath (()) import System.IO (FilePath) import Text.Show +import qualified Codec.Archive.Tar as TAR +import qualified Codec.Archive.Tar.Check as TAR +import qualified Codec.Compression.GZip as GZ +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List as List import qualified GHC.Stack as GHC import qualified Hedgehog as H import qualified Hedgehog.Extras.Stock.IO.Network.NamedPipe as IO import qualified Hedgehog.Extras.Stock.IO.Network.Socket as IO import qualified Hedgehog.Extras.Stock.OS as OS import qualified Hedgehog.Extras.Test.Base as H +import qualified Network.HTTP.Conduit as HTTP +import qualified System.Directory as H import qualified System.Directory as IO +import qualified System.FilePath as FP -- | Test if a file exists doesFileExists :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m Bool @@ -64,3 +79,47 @@ Left (e :: IOException) -> do H.annotate $ "Error: " <> show e return False + +-- | Download from a URl to a file +downloadToFile :: (MonadTest m, MonadIO m, HasCallStack) => String -> FilePath -> m () +downloadToFile url path = GHC.withFrozenCallStack $ do + H.note_ $ "Downloading " <> url <> " to " <> path + H.evalIO $ HTTP.simpleHttp url >>= LBS.writeFile path + +tarErrors :: TAR.Entries (Either TAR.FormatError TAR.TarBombError) -> [Either TAR.FormatError TAR.TarBombError] +tarErrors entries = TAR.foldEntries (flip const) id (:) entries [] + +-- | Download a github commit to a temporary directory, extract it and return the path to the extracted directory. +-- +-- If the file is already downloaded, it will not be downloaded again. +-- If the file is already extracted, it will not be extracted again. +downloadAndExtractGithubCommitToTemp :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> String -> String -> m FilePath +downloadAndExtractGithubCommitToTemp dir repository commit = GHC.withFrozenCallStack $ do + let url = "https://github.com/" <> repository <> "/archive/" <> commit <> ".tar.gz" + let topDir = FP.takeFileName repository <> "-" <> commit + let tarPath = dir topDir <> ".tar.gz" + let dest = dir topDir + + tarFileExists <- H.evalIO $ IO.doesFileExist tarPath + if tarFileExists + then H.note_ $ "Already downloaded " <> url <> " to " <> tarPath + else do + H.note_ $ "Downloading " <> url <> " to " <> tarPath + H.evalIO $ HTTP.simpleHttp url >>= LBS.writeFile tarPath + + destExists <- H.evalIO $ IO.doesDirectoryExist dest + if destExists + then H.note_ $ "Already extracted " <> tarPath <> " to " <> dest + else do + H.note_ $ "Extracting " <> tarPath <> " to " <> dest + errors <- H.evalIO $ tarErrors . TAR.checkTarbomb topDir . TAR.read . GZ.decompress <$> LBS.readFile tarPath + + unless (List.null errors) $ do + H.annotate $ "Errors: " <> show errors + H.failure + + H.evalIO $ TAR.unpack dir . TAR.read . GZ.decompress =<< LBS.readFile tarPath + + void . H.assertIO $ H.doesDirectoryExist dest + + H.note dest