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.6.1.0 +version: 0.6.2.0 synopsis: Supplemental library for hedgehog description: Supplemental library for hedgehog. category: Test @@ -27,17 +27,21 @@ common exceptions { build-depends: exceptions } common filepath { build-depends: filepath } common hedgehog { build-depends: hedgehog } +common hedgehog-quickcheck { build-depends: hedgehog-quickcheck } common http-conduit { build-depends: http-conduit } common lifted-async { build-depends: lifted-async } common lifted-base { build-depends: lifted-base } -common monad-control { build-depends: monad-control } common mmorph { build-depends: mmorph } +common monad-control { build-depends: monad-control } common mtl { build-depends: mtl } common network { build-depends: network } common process { build-depends: process } common resourcet { build-depends: resourcet } common stm { build-depends: stm } common tar { build-depends: tar < 0.6 } +common tasty { build-depends: tasty } +common tasty-hedgehog { build-depends: tasty-hedgehog } +common tasty-quickcheck { build-depends: tasty-quickcheck } common temporary { build-depends: temporary } common text { build-depends: text } common time { build-depends: time >= 1.9.1 } @@ -47,6 +51,8 @@ common yaml { build-depends: yaml } common zlib { build-depends: zlib } +common hedgehog-extras { build-depends: hedgehog-extras } + common Win32 if os(windows) build-depends: Win32 >= 2.5.4.1 @@ -109,6 +115,7 @@ Hedgehog.Extras.Stock.CallStack Hedgehog.Extras.Stock.IO.File Hedgehog.Extras.Stock.IO.Network.NamedPipe + Hedgehog.Extras.Stock.IO.Network.Port Hedgehog.Extras.Stock.IO.Network.Socket Hedgehog.Extras.Stock.IO.Network.Sprocket Hedgehog.Extras.Stock.IO.Process @@ -124,3 +131,18 @@ Hedgehog.Extras.Test.MonadAssertion Hedgehog.Extras.Test.Network Hedgehog.Extras.Test.Process + +test-suite hedgehog-extras-test + import: base, project-config, + hedgehog, + hedgehog-extras, + network, + tasty, + tasty-hedgehog, + hs-source-dirs: test + main-is: hedgehog-extras-test.hs + type: exitcode-stdio-1.0 + + other-modules: Hedgehog.Extras.Stock.IO.Network.PortSpec + + build-tool-depends: tasty-discover:tasty-discover diff --git a/src/Hedgehog/Extras/Stock/IO/Network/Port.hs b/src/Hedgehog/Extras/Stock/IO/Network/Port.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Stock/IO/Network/Port.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TypeApplications #-} + +module Hedgehog.Extras.Stock.IO.Network.Port + ( randomPort + , reserveRandomPort + , portInUse + ) where + +import Control.Exception +import Control.Monad (Monad (..), MonadFail (..)) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Bool +import Data.Either +import Data.Function +import Network.Socket + +-- | Return a random available port on a specified host address +randomPort :: () + => MonadIO m + => MonadFail m + => HostAddress + -> m PortNumber +randomPort hostAddress = do + sock <- liftIO $ socket AF_INET Stream defaultProtocol + liftIO $ bind sock $ SockAddrInet defaultPort hostAddress + SockAddrInet port _ <- liftIO $ getSocketName sock + liftIO $ close sock + return port + +reserveRandomPort :: () + => MonadFail m + => MonadResource m + => HostAddress + -> m (ReleaseKey, PortNumber) +reserveRandomPort hostAddress = do + sock <- liftIO $ socket AF_INET Stream defaultProtocol + liftIO $ bind sock $ SockAddrInet defaultPort hostAddress + SockAddrInet port _ <- liftIO $ getSocketName sock + releaseKey <- register $ close sock + return (releaseKey, port) + +-- | Check if a port is in use on a specified host address +portInUse :: () + => MonadIO m + => HostAddress + -> PortNumber + -> m Bool +portInUse hostAddress pn = do + sock <- liftIO $ socket AF_INET Stream defaultProtocol + result <- liftIO $ try @SomeException $ bind sock (SockAddrInet pn hostAddress) + liftIO $ close sock + return $ either (const False) (const True) result 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 @@ -47,6 +47,7 @@ , assertEndsWithSingleNewline , appendFileTimeDelta + , assertDirectoryMissing ) where import Control.Applicative (Applicative (..)) @@ -336,3 +337,15 @@ baseTime <- H.noteShowIO DTC.getCurrentTime let delay = DTC.diffUTCTime baseTime offsetTime appendFile filePath $ show @DTC.NominalDiffTime delay <> "\n" + +-- | Asserts that the given directory exists. +assertDirectoryExists :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m () +assertDirectoryExists dir = GHC.withFrozenCallStack $ do + exists <- H.evalIO $ IO.doesDirectoryExist dir + unless exists $ H.failWithCustom GHC.callStack Nothing ("Directory '" <> dir <> "' does not exist on the file system.") + +-- | Asserts that the given directory is missing. +assertDirectoryMissing :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m () +assertDirectoryMissing dir = GHC.withFrozenCallStack $ do + exists <- H.evalIO $ IO.doesDirectoryExist dir + when exists $ H.failWithCustom GHC.callStack Nothing ("Directory '" <> dir <> "' does exist on the file system.") diff --git a/test/Hedgehog/Extras/Stock/IO/Network/PortSpec.hs b/test/Hedgehog/Extras/Stock/IO/Network/PortSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hedgehog/Extras/Stock/IO/Network/PortSpec.hs @@ -0,0 +1,26 @@ +module Hedgehog.Extras.Stock.IO.Network.PortSpec + ( hprop_randomPort + ) where + +import Data.Function +import Data.Semigroup +import Hedgehog (Property) +import qualified Hedgehog as H +import qualified Hedgehog.Extras as H +import qualified Hedgehog.Extras.Stock.IO.Network.Port as IO +import qualified Network.Socket as N +import Text.Show + +hprop_randomPort :: Property +hprop_randomPort = + H.propertyOnce $ do + let hostAddress = N.tupleToHostAddress (0, 0, 0, 0) + + pn <- H.evalIO $ IO.randomPort hostAddress + + H.note_ $ "Allocated port: " <> show pn + + -- Check that the port is available and can be bound to a socket. + sock <- H.evalIO $ N.socket N.AF_INET N.Stream N.defaultProtocol + H.evalIO $ N.bind sock $ N.SockAddrInet pn hostAddress + H.evalIO $ N.close sock diff --git a/test/hedgehog-extras-test.hs b/test/hedgehog-extras-test.hs new file mode 100644 --- /dev/null +++ b/test/hedgehog-extras-test.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --hide-successes #-}