{-# LANGUAGE ScopedTypeVariables #-}

{- HLINT ignore "Redundant flip" -}

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

-- | Test if a file exists
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

-- | Test if a port is open
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

-- | Test if a socket file exists
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

-- | Assert that a port is open
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

-- | Assert that a socket file exists is open
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

-- | Test if the sprocket exists
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

-- | Download from a URl to a file
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 []

-- | 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 :: 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