{-# LANGUAGE ScopedTypeVariables #-}
module Hedgehog.Extras.Test.Network
( doesFileExists
, isPortOpen
, doesSocketExist
, assertPortOpen
, assertSocketExists
, doesSprocketExist
, downloadToFile
, downloadAndExtractGithubCommitToTemp
) where
import Control.Exception (IOException, try)
import Control.Monad
import Control.Monad.IO.Class (MonadIO)
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
doesFileExists :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m Bool
doesFileExists :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
FilePath -> m Bool
doesFileExists = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Bool
IO.doesFileExist
isPortOpen :: (MonadTest m, MonadIO m, HasCallStack) => Int -> m Bool
isPortOpen :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
Int -> m Bool
isPortOpen Int
port = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ forall a b. (a -> b) -> a -> b
$ FilePath
"Port: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Int
port
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ Int -> IO Bool
IO.isPortOpen Int
port
doesSocketExist :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m Bool
doesSocketExist :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
FilePath -> m Bool
doesSocketExist = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Bool
IO.doesSocketExist
assertPortOpen :: (MonadTest m, MonadIO m, HasCallStack) => Int -> m ()
assertPortOpen :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
Int -> m ()
assertPortOpen = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). (MonadTest m, HasCallStack) => m Bool -> m ()
H.assertM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
Int -> m Bool
isPortOpen
assertSocketExists :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m ()
assertSocketExists :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
FilePath -> m ()
assertSocketExists = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). (MonadTest m, HasCallStack) => m Bool -> m ()
H.assertM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
FilePath -> m Bool
doesSocketExist
doesSprocketExist :: (MonadTest m, MonadIO m, HasCallStack) => Sprocket -> m Bool
doesSprocketExist :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
Sprocket -> m Bool
doesSprocketExist Sprocket
socket = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
Either IOException Bool
waitResult <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ if Bool
OS.isWin32
then FilePath -> IO Bool
IO.doesNamedPipeExist (Sprocket -> FilePath
sprocketSystemName Sprocket
socket)
else FilePath -> IO Bool
IO.doesSocketExist (Sprocket -> FilePath
sprocketSystemName Sprocket
socket)
case Either IOException Bool
waitResult of
Right Bool
result -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
result
Left (IOException
e :: IOException) -> do
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.annotate forall a b. (a -> b) -> a -> b
$ FilePath
"Error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show IOException
e
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
downloadToFile :: (MonadTest m, MonadIO m, HasCallStack) => String -> FilePath -> m ()
downloadToFile :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
FilePath -> FilePath -> m ()
downloadToFile FilePath
url FilePath
path = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ forall a b. (a -> b) -> a -> b
$ FilePath
"Downloading " forall a. Semigroup a => a -> a -> a
<> FilePath
url forall a. Semigroup a => a -> a -> a
<> FilePath
" to " forall a. Semigroup a => a -> a -> a
<> FilePath
path
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
HTTP.simpleHttp FilePath
url forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
path
tarErrors :: TAR.Entries (Either TAR.FormatError TAR.TarBombError) -> [Either TAR.FormatError TAR.TarBombError]
tarErrors :: Entries (Either FormatError TarBombError)
-> [Either FormatError TarBombError]
tarErrors Entries (Either FormatError TarBombError)
entries = forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
TAR.foldEntries (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. a -> b -> a
const) forall a. a -> a
id (:) Entries (Either FormatError TarBombError)
entries []
downloadAndExtractGithubCommitToTemp :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> String -> String -> m FilePath
downloadAndExtractGithubCommitToTemp :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
FilePath -> FilePath -> FilePath -> m FilePath
downloadAndExtractGithubCommitToTemp FilePath
dir FilePath
repository FilePath
commit = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
let url :: FilePath
url = FilePath
"https://github.com/" forall a. Semigroup a => a -> a -> a
<> FilePath
repository forall a. Semigroup a => a -> a -> a
<> FilePath
"/archive/" forall a. Semigroup a => a -> a -> a
<> FilePath
commit forall a. Semigroup a => a -> a -> a
<> FilePath
".tar.gz"
let topDir :: FilePath
topDir = FilePath -> FilePath
FP.takeFileName FilePath
repository forall a. Semigroup a => a -> a -> a
<> FilePath
"-" forall a. Semigroup a => a -> a -> a
<> FilePath
commit
let tarPath :: FilePath
tarPath = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
topDir forall a. Semigroup a => a -> a -> a
<> FilePath
".tar.gz"
let dest :: FilePath
dest = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
topDir
Bool
tarFileExists <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
IO.doesFileExist FilePath
tarPath
if Bool
tarFileExists
then forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ forall a b. (a -> b) -> a -> b
$ FilePath
"Already downloaded " forall a. Semigroup a => a -> a -> a
<> FilePath
url forall a. Semigroup a => a -> a -> a
<> FilePath
" to " forall a. Semigroup a => a -> a -> a
<> FilePath
tarPath
else do
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ forall a b. (a -> b) -> a -> b
$ FilePath
"Downloading " forall a. Semigroup a => a -> a -> a
<> FilePath
url forall a. Semigroup a => a -> a -> a
<> FilePath
" to " forall a. Semigroup a => a -> a -> a
<> FilePath
tarPath
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
HTTP.simpleHttp FilePath
url forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
tarPath
Bool
destExists <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
IO.doesDirectoryExist FilePath
dest
if Bool
destExists
then forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ forall a b. (a -> b) -> a -> b
$ FilePath
"Already extracted " forall a. Semigroup a => a -> a -> a
<> FilePath
tarPath forall a. Semigroup a => a -> a -> a
<> FilePath
" to " forall a. Semigroup a => a -> a -> a
<> FilePath
dest
else do
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ forall a b. (a -> b) -> a -> b
$ FilePath
"Extracting " forall a. Semigroup a => a -> a -> a
<> FilePath
tarPath forall a. Semigroup a => a -> a -> a
<> FilePath
" to " forall a. Semigroup a => a -> a -> a
<> FilePath
dest
[Either FormatError TarBombError]
errors <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ Entries (Either FormatError TarBombError)
-> [Either FormatError TarBombError]
tarErrors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. FilePath -> Entries e -> Entries (Either e TarBombError)
TAR.checkTarbomb FilePath
topDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
TAR.read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZ.decompress forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
LBS.readFile FilePath
tarPath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [Either FormatError TarBombError]
errors) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.annotate forall a b. (a -> b) -> a -> b
$ FilePath
"Errors: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show [Either FormatError TarBombError]
errors
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ forall e. Exception e => FilePath -> Entries e -> IO ()
TAR.unpack FilePath
dir forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
TAR.read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZ.decompress forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO ByteString
LBS.readFile FilePath
tarPath
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
IO Bool -> m ()
H.assertIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
H.doesDirectoryExist FilePath
dest
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m FilePath
H.note FilePath
dest