New randomPort, reserveRandomPort and portInUse functions

Author: newhoggy

hedgehog-extras.cabal

@@ -27,17 +27,21 @@ common directory                    { build-depends: directory
 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 unliftio                     { build-depends: unliftio
 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 @@ library
                         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 @@ library
                         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

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

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

test/hedgehog-extras-test.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --hide-successes #-}