diff --git a/core/HaskellWorks/IO/Network.hs b/core/HaskellWorks/IO/Network.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/IO/Network.hs @@ -0,0 +1,9 @@ +module HaskellWorks.IO.Network + ( doesNamedPipeExist, + randomPort, + reserveRandomPort, + portInUse, + ) where + +import HaskellWorks.IO.Network.NamedPipe +import HaskellWorks.IO.Network.Port diff --git a/core/HaskellWorks/IO/Network/NamedPipe.hs b/core/HaskellWorks/IO/Network/NamedPipe.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/IO/Network/NamedPipe.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +module HaskellWorks.IO.Network.NamedPipe + ( doesNamedPipeExist + ) where + +import Data.Bool +import Prelude (error) +import System.IO (FilePath, IO) + +#ifdef mingw32_HOST_OS +import qualified Hedgehog.Extras.Internal.Win32.NamedPipes as W32 +#endif + +doesNamedPipeExist :: FilePath -> IO Bool +doesNamedPipeExist path = +#ifdef mingw32_HOST_OS + W32.waitNamedPipe path 1 +#else + error "doesNamedPipeExist may only be called on Windows" +#endif diff --git a/core/HaskellWorks/IO/Network/Port.hs b/core/HaskellWorks/IO/Network/Port.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/IO/Network/Port.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TypeApplications #-} + +module HaskellWorks.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 + -- Allow the port to be reused immediately after the socket is closed + liftIO $ setSocketOption sock ReuseAddr 1 + 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 $ setSocketOption sock ReuseAddr 1 + 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 + liftIO $ setSocketOption sock ReuseAddr 1 + result <- liftIO $ try @SomeException $ bind sock (SockAddrInet pn hostAddress) + liftIO $ close sock + return $ either (const False) (const True) result diff --git a/core/HaskellWorks/IO/Network/Socket.hs b/core/HaskellWorks/IO/Network/Socket.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/IO/Network/Socket.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module HaskellWorks.IO.Network.Socket + ( doesSocketExist + , isPortOpen + , canConnect + , listenOn + , allocateRandomPorts + ) where + +import Control.Exception (IOException, handle) +import Control.Monad +import Data.Bool +import Data.Function +import Data.Functor +import Data.Int +import Data.Maybe +import Network.Socket (Family (AF_INET), SockAddr (..), Socket, + SocketType (Stream)) +import Prelude (fromIntegral) +import System.IO (FilePath, IO) +import Text.Show (show) + +import qualified Network.Socket as IO +import qualified System.Directory as IO +import qualified UnliftIO.Exception as IO + +-- | Check if a TCP port is open +isPortOpen :: Int -> IO Bool +isPortOpen port = do + socketAddressInfos <- IO.getAddrInfo Nothing (Just "127.0.0.1") (Just (show port)) + case socketAddressInfos of + socketAddressInfo:_ -> + handle (return . const @Bool @IOException False) $ + canConnect (IO.addrAddress socketAddressInfo) $> True + [] -> return False + +-- | Check if it is possible to connect to a socket address +canConnect :: SockAddr -> IO () +canConnect sockAddr = IO.bracket (IO.socket AF_INET Stream 6) IO.close' $ \sock -> do + IO.connect sock sockAddr + +-- | Open a socket at the specified port for listening +listenOn :: Int -> IO Socket +listenOn n = do + sock <- IO.socket AF_INET Stream 0 + sockAddrInfo:_ <- IO.getAddrInfo Nothing (Just "127.0.0.1") (Just (show n)) + IO.setSocketOption sock IO.ReuseAddr 1 + IO.bind sock (IO.addrAddress sockAddrInfo) + IO.listen sock 2 + return sock + +doesSocketExist :: FilePath -> IO Bool +doesSocketExist = IO.doesFileExist +{-# INLINE doesSocketExist #-} + +-- | Allocate the specified number of random ports +allocateRandomPorts :: Int -> IO [Int] +allocateRandomPorts n = do + let hints = IO.defaultHints + { IO.addrFlags = [IO.AI_PASSIVE] + , IO.addrSocketType = IO.Stream + } + + -- Create n sockets with randomly bound ports, grab the port numbers and close those ports + addr:_ <- IO.getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0") + socks <- forM [1..n] $ \_ -> IO.socket (IO.addrFamily addr) (IO.addrSocketType addr) (IO.addrProtocol addr) + forM_ socks $ \sock -> IO.bind sock (IO.addrAddress addr) + ports <- forM socks IO.socketPort + forM_ socks IO.close + + return $ fmap fromIntegral ports diff --git a/core/HaskellWorks/IO/Process.hs b/core/HaskellWorks/IO/Process.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/IO/Process.hs @@ -0,0 +1,24 @@ +module HaskellWorks.IO.Process + ( maybeWaitForProcess + ) where + +import qualified Control.Concurrent as IO +import Control.Concurrent.Async +import qualified Control.Concurrent.Async as IO +import qualified Control.Exception as IO +import Data.Maybe +import System.Exit +import System.IO +import qualified System.Process as IO + +import Control.Applicative +import Data.Function +import Data.Functor +import GHC.Stack (HasCallStack, withFrozenCallStack) +import System.Process + +maybeWaitForProcess :: () + => ProcessHandle + -> IO (Maybe ExitCode) +maybeWaitForProcess hProcess = + IO.catch (fmap Just (IO.waitForProcess hProcess)) $ \(_ :: AsyncCancelled) -> pure Nothing diff --git a/core/HaskellWorks/IO/Win32/NamedPipe.hsc b/core/HaskellWorks/IO/Win32/NamedPipe.hsc new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/IO/Win32/NamedPipe.hsc @@ -0,0 +1,71 @@ +#include +#include + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +-- | For full details on the Windows named pipes API see +-- +-- +module HaskellWorks.IO.Win32.NamedPipe + ( -- ** waiting for named pipe instances + waitNamedPipe, + + TimeOut, + nMPWAIT_USE_DEFAULT_WAIT, + nMPWAIT_WAIT_FOREVER, + ) where + +import Control.Applicative (pure) +import Data.Bool (Bool (..), otherwise) +import Data.Eq ((==)) +import Data.Function (($)) +import Data.String (String) +import Foreign.C.String (withCString) +import System.IO (IO) +import System.Win32.File +import System.Win32.Types hiding (try) + +-- | Timeout in milliseconds. +-- +-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to +-- 'createNamedPipe' should be used. +-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named +-- pipe instance is available. +-- +type TimeOut = DWORD +#{enum TimeOut, + , nMPWAIT_USE_DEFAULT_WAIT = NMPWAIT_USE_DEFAULT_WAIT + , nMPWAIT_WAIT_FOREVER = NMPWAIT_WAIT_FOREVER + } + +-- | Wait until a named pipe instance is available. If there is no instance at +-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e. +-- @invalid argument (The semaphore timeout period has expired)@ +-- +-- It returns 'True' if there is an available instance, subsequent 'createFile' +-- might still fail, if another thread will take turn and connect before, or if +-- the other end shuts down the name pipe. +-- +-- It returns 'False' if timeout fired. +-- +waitNamedPipe :: String -- ^ pipe name + -> TimeOut -- ^ nTimeOut + -> IO Bool +waitNamedPipe name timeout = + withCString name $ \ c_name -> do + r <- c_WaitNamedPipe c_name timeout + e <- getLastError + if | r -> pure r + | e == eRROR_SEM_TIMEOUT -> pure False + | otherwise -> failWith "waitNamedPipe" e + + +-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import. +foreign import ccall safe "windows.h WaitNamedPipeA" + c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName + -> DWORD -- nTimeOut + -> IO BOOL + +eRROR_SEM_TIMEOUT :: ErrCode +eRROR_SEM_TIMEOUT = #const ERROR_SEM_TIMEOUT diff --git a/core/HaskellWorks/Polysemy/Cabal.hs b/core/HaskellWorks/Polysemy/Cabal.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/Polysemy/Cabal.hs @@ -0,0 +1,85 @@ +module HaskellWorks.Polysemy.Cabal + ( findDefaultPlanJsonFile + , getPlanJsonFile + , binDist + ) where + +import HaskellWorks.Polysemy.Cabal.Types +import qualified HaskellWorks.Polysemy.Data.ByteString.Lazy as LBS +import HaskellWorks.Polysemy.Error.Types +import HaskellWorks.Polysemy.Prelude +import HaskellWorks.Polysemy.System.Directory +import HaskellWorks.Polysemy.System.Environment +import System.FilePath (takeDirectory) + +import Data.Aeson +import qualified Data.List as L +import qualified HaskellWorks.Polysemy.Data.Text as T +import HaskellWorks.Polysemy.FilePath +import Polysemy +import Polysemy.Error +import Polysemy.Log + +-- | Find the nearest plan.json going upwards from the current directory. +findDefaultPlanJsonFile :: () + => Member (Embed IO) r + => Member (Error IOException) r + => Member Log r + => Sem r FilePath +findDefaultPlanJsonFile = getCurrentDirectory >>= go + where go :: () + => Member (Embed IO) r + => Member (Error IOException) r + => Member Log r + => FilePath + -> Sem r FilePath + go d = do + let file = d "dist-newstyle/cache/plan.json" + exists <- doesFileExist file + if exists + then return file + else do + let parent = takeDirectory d + if parent == d + then return "dist-newstyle/cache/plan.json" + else go parent + + +getPlanJsonFile :: () + => Member (Embed IO) r + => Member (Error IOException) r + => Member Log r + => Sem r String +getPlanJsonFile = do + maybeBuildDir <- lookupEnv "CABAL_BUILDDIR" + case maybeBuildDir of + Just buildDir -> return $ ".." buildDir "cache/plan.json" + Nothing -> findDefaultPlanJsonFile + +-- | Consult the "plan.json" generated by cabal to get the path to the executable corresponding. +-- to a haskell package. It is assumed that the project has already been configured and the +-- executable has been built. +binDist:: () + => Member (Embed IO) r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => String + -- ^ Package name + -> Sem r FilePath + -- ^ Path to executable +binDist pkg = do + planJsonFile <- getPlanJsonFile + contents <- LBS.readFile planJsonFile + + case eitherDecode contents of + Right plan -> case L.filter matching (plan & installPlan) of + (component:_) -> case component & binFile of + Just bin -> return $ addExeSuffix (T.unpack bin) + Nothing -> throw $ GenericError $ "Missing bin-file in " <> tshow component + [] -> throw $ GenericError $ "Cannot find exe " <> tshow pkg <> " in plan" + Left message -> throw $ GenericError $ "Cannot decode plan: " <> T.pack message + where matching :: Component -> Bool + matching component = case componentName component of + Just name -> name == "exe:" <> T.pack pkg + Nothing -> False diff --git a/core/HaskellWorks/Polysemy/Cabal/Types.hs b/core/HaskellWorks/Polysemy/Cabal/Types.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/Polysemy/Cabal/Types.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Polysemy.Cabal.Types + ( Plan(..) + , Component(..) + ) where + +import Control.Applicative +import Data.Aeson +import Data.Eq +import Data.Function +import Data.Maybe +import Data.Text (Text) +import GHC.Generics +import Text.Show + +data Component = Component + { componentName :: Maybe Text + , binFile :: Maybe Text + } + deriving (Generic, Eq, Show) + +newtype Plan = Plan + { installPlan :: [Component] + } + deriving (Generic, Eq, Show) + +instance FromJSON Plan where + parseJSON = withObject "Plan" $ \v -> Plan + <$> v .: "install-plan" + +instance FromJSON Component where + parseJSON = withObject "Plan" $ \v -> Component + <$> v .:? "component-name" + <*> v .:? "bin-file" diff --git a/core/HaskellWorks/Polysemy/Error/Types.hs b/core/HaskellWorks/Polysemy/Error/Types.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/Polysemy/Error/Types.hs @@ -0,0 +1,14 @@ +module HaskellWorks.Polysemy.Error.Types + ( GenericError(..) + , TimedOut(..) + ) where + +import HaskellWorks.Polysemy.Prelude + +newtype GenericError = GenericError + { message :: Text + } + deriving (Eq, Show) + +data TimedOut = TimedOut + deriving (Generic, Eq, Show) diff --git a/core/HaskellWorks/Polysemy/File.hs b/core/HaskellWorks/Polysemy/File.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/Polysemy/File.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module HaskellWorks.Polysemy.File + ( JsonDecodeError(..) + , YamlDecodeError(..) + , readJsonFile + , readYamlFile + ) where + +import Data.Aeson +import qualified Data.Aeson as J +import qualified Data.Yaml as Y +import GHC.Generics +import qualified HaskellWorks.Polysemy.Data.ByteString.Lazy as LBS +import qualified HaskellWorks.Polysemy.Data.Text as T +import HaskellWorks.Polysemy.Error +import HaskellWorks.Polysemy.Prelude +import Polysemy +import Polysemy.Error +import Polysemy.Log + +newtype JsonDecodeError = JsonDecodeError { message :: String } + deriving (Eq, Generic, Show) + +newtype YamlDecodeError = YamlDecodeError { message :: String } + deriving (Eq, Generic, Show) + +-- | Read the 'filePath' file as JSON. Use @readJsonFile \@'Value'@ to decode into 'Value'. +readJsonFile :: forall a r. () + => FromJSON a + => HasCallStack + => Member (Error IOException) r + => Member (Error JsonDecodeError) r + => Member (Embed IO) r + => Member Log r + => FilePath + -> Sem r a +readJsonFile filePath = withFrozenCallStack $ do + info $ "Reading JSON file: " <> T.pack filePath + contents <- LBS.readFile filePath + J.eitherDecode contents + & onLeft (throw . JsonDecodeError) + + +-- | Read the 'filePath' file as YAML. +readYamlFile :: forall a r. () + => FromJSON a + => HasCallStack + => Member (Error IOException) r + => Member (Error JsonDecodeError) r + => Member (Error YamlDecodeError) r + => Member (Embed IO) r + => Member Log r + => FilePath + -> Sem r a +readYamlFile filePath = withFrozenCallStack $ do + info $ "Reading YAML file: " <> T.pack filePath + contents <- LBS.toStrict <$> LBS.readFile filePath + Y.decodeEither' contents + & onLeft (throw . YamlDecodeError . Y.prettyPrintParseException) diff --git a/core/HaskellWorks/Polysemy/FilePath.hs b/core/HaskellWorks/Polysemy/FilePath.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/Polysemy/FilePath.hs @@ -0,0 +1,17 @@ +module HaskellWorks.Polysemy.FilePath + ( exeSuffix + , addExeSuffix + ) where + +import qualified HaskellWorks.Polysemy.OS as OS + +import qualified Data.List as L +import HaskellWorks.Polysemy.Prelude + +exeSuffix :: String +exeSuffix = if OS.isWin32 then ".exe" else "" + +addExeSuffix :: String -> String +addExeSuffix s = if ".exe" `L.isSuffixOf` s + then s + else s <> exeSuffix diff --git a/core/HaskellWorks/Polysemy/OS.hs b/core/HaskellWorks/Polysemy/OS.hs new file mode 100644 --- /dev/null +++ b/core/HaskellWorks/Polysemy/OS.hs @@ -0,0 +1,12 @@ +module HaskellWorks.Polysemy.OS + ( isWin32 + ) where + +import Data.Bool +import Data.Eq +import System.Info + +-- | Determine if the operating system is Windows. +isWin32 :: Bool +isWin32 = os == "mingw32" +{-# INLINE isWin32 #-} diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Assert.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Assert.hs --- a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Assert.hs +++ b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Assert.hs @@ -2,22 +2,46 @@ ( Hedgehog, leftFail, leftFailM, + nothingFail, + nothingFailM, requireHead, catchFail, + trapFail, evalIO, failure, failMessage, (===), + assertPidOk, + assertIsJsonFile_, + assertIsYamlFile, + assertFileExists, + assertFilesExist, + assertFileMissing, + assertFilesMissing, + assertFileOccurences, + assertFileLines, + assertEndsWithSingleNewline, + assertDirectoryExists, + assertDirectoryMissing, ) where +import Control.Lens ((^.)) +import Data.Aeson (Value) +import Data.Generics.Product.Any +import qualified Data.List as L import qualified GHC.Stack as GHC +import HaskellWorks.Polysemy.File import HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog import HaskellWorks.Polysemy.Prelude +import HaskellWorks.Polysemy.System.Directory +import HaskellWorks.Polysemy.System.IO as IO +import HaskellWorks.Polysemy.System.Process import Polysemy import Polysemy.Error +import Polysemy.Log (===) :: () => Member Hedgehog r @@ -30,7 +54,7 @@ (===) a b = withFrozenCallStack $ assertEquals a b -- | Fail when the result is Left. -leftFail :: forall e r a. () +leftFail :: () => Member Hedgehog r => Show e => HasCallStack @@ -40,6 +64,15 @@ Right a -> pure a Left e -> failMessage GHC.callStack ("Expected Right: " <> show e) +nothingFail :: () + => Member Hedgehog r + => HasCallStack + => Maybe a + -> Sem r a +nothingFail r = withFrozenCallStack $ case r of + Just a -> return a + Nothing -> failMessage GHC.callStack "Expected Just" + failure :: () => Member Hedgehog r => HasCallStack @@ -65,6 +98,14 @@ leftFailM f = withFrozenCallStack $ f >>= leftFail +nothingFailM :: forall r a. () + => Member Hedgehog r + => HasCallStack + => Sem r (Maybe a) + -> Sem r a +nothingFailM f = + withFrozenCallStack $ f >>= nothingFail + catchFail :: forall e r a.() => Member Hedgehog r => HasCallStack @@ -73,7 +114,17 @@ -> Sem r a catchFail f = withFrozenCallStack $ f & runError & leftFailM +{-# DEPRECATED catchFail "Use trapFail instead" #-} +trapFail :: forall e r a.() + => Member Hedgehog r + => HasCallStack + => Show e + => Sem (Error e ': r) a + -> Sem r a +trapFail f = + withFrozenCallStack $ f & runError & leftFailM + requireHead :: () => Member Hedgehog r => HasCallStack @@ -83,3 +134,175 @@ \case [] -> failMessage GHC.callStack "Cannot take head of empty list" (x:_) -> pure x + +assertPidOk :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member (Error IOException) r + => ProcessHandle + -> Sem r Pid +assertPidOk hProcess = withFrozenCallStack $ + nothingFailM $ getPid hProcess + +trap :: forall e r a. () + => (e -> Sem r a) + -> Sem (Error e ': r) a + -> Sem r a +trap h f = + runError f >>= \case + Left e -> h e + Right a -> pure a + +-- | Assert the 'filePath' can be parsed as JSON. +assertIsJsonFile_ :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member Log r + => FilePath + -> Sem r () +assertIsJsonFile_ fp = withFrozenCallStack $ do + void (readJsonFile @Value fp) + & trap @IOException (failMessage GHC.callStack . show) + & trap @JsonDecodeError (\e -> failMessage GHC.callStack (e ^. the @"message")) + +-- | Assert the 'filePath' can be parsed as YAML. +assertIsYamlFile :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member Log r + => FilePath + -> Sem r () +assertIsYamlFile fp = withFrozenCallStack $ do + void (readYamlFile @Value fp) + & trap @IOException (failMessage GHC.callStack . show) + & trap @JsonDecodeError (\e -> failMessage GHC.callStack (e ^. the @"message")) + & trap @YamlDecodeError (\e -> failMessage GHC.callStack (e ^. the @"message")) + +-- | Asserts that the given file exists. +assertFileExists :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member Log r + => FilePath + -> Sem r () +assertFileExists file = withFrozenCallStack $ do + exists <- doesFileExist file + & trap @IOException (const (pure False)) + unless exists $ failWithCustom GHC.callStack Nothing (file <> " has not been successfully created.") + +-- | Asserts that all of the given files exist. +assertFilesExist :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member Log r + => [FilePath] + -> Sem r () +assertFilesExist files = + withFrozenCallStack $ for_ files assertFileExists + +-- | Asserts that the given file is missing. +assertFileMissing :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member Log r + => FilePath + -> Sem r () +assertFileMissing file = withFrozenCallStack $ do + exists <- doesFileExist file + & trap @IOException (const (pure False)) + when exists $ failWithCustom GHC.callStack Nothing (file <> " should not have been created.") + +-- | Asserts that all of the given files are missing. +assertFilesMissing :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member Log r + => [FilePath] + -> Sem r () +assertFilesMissing files = + withFrozenCallStack $ for_ files assertFileMissing + +-- | Assert the file contains the given number of occurrences of the given string +assertFileOccurences :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member Log r + => Int -> String -> FilePath -> Sem r () +assertFileOccurences n s fp = withFrozenCallStack $ do + contents <- readFile fp + & trap @IOException (failMessage GHC.callStack . show) + + L.length (L.filter (s `L.isInfixOf`) (L.lines contents)) === n + +-- | Assert the file contains the given number of occurrences of the given string +assertFileLines :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member Log r + => (Int -> Bool) + -> FilePath + -> Sem r () +assertFileLines p fp = withFrozenCallStack $ do + contents <- readFile fp + & trap @IOException (failMessage GHC.callStack . show) + + let lines = L.lines contents + + let len = case L.reverse lines of + "":xs -> L.length xs + xs -> L.length xs + + unless (p len) $ do + failWithCustom GHC.callStack Nothing (fp <> " has an unexpected number of lines") + +-- | Assert the file contains the given number of occurrences of the given string +assertEndsWithSingleNewline :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member Log r + => FilePath + -> Sem r () +assertEndsWithSingleNewline fp = withFrozenCallStack $ do + contents <- readFile fp + & trap @IOException (failMessage GHC.callStack . show) + + case L.reverse contents of + '\n':'\n':_ -> failWithCustom GHC.callStack Nothing (fp <> " ends with too many newlines.") + '\n':_ -> return () + _ -> failWithCustom GHC.callStack Nothing (fp <> " must end with newline.") + +-- | Asserts that the given directory exists. +assertDirectoryExists :: () + => HasCallStack + => Member Hedgehog r + => Member (Embed IO) r + => Member Log r + => FilePath + -> Sem r () +assertDirectoryExists dir = withFrozenCallStack $ do + exists <- doesDirectoryExist dir + & trap @IOException (const (pure False)) + unless exists $ failWithCustom GHC.callStack Nothing ("Directory '" <> dir <> "' does not exist on the file system.") + +-- | Asserts that the given directory is missing. +assertDirectoryMissing :: () + => HasCallStack + => Member Hedgehog r + => Member Log r + => Member (Embed IO) r + => FilePath + -> Sem r () +assertDirectoryMissing dir = withFrozenCallStack $ do + exists <- doesDirectoryExist dir + & trap @IOException (const (pure False)) + when exists $ failWithCustom GHC.callStack Nothing ("Directory '" <> dir <> "' does exist on the file system.") diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Process.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Process.hs new file mode 100644 --- /dev/null +++ b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Process.hs @@ -0,0 +1,266 @@ +module HaskellWorks.Polysemy.Hedgehog.Process + ( defaultExecConfig + , execFlex + , execFlexOk + , execFlexOk' + , execOk + , execOk_ + , exec + , procFlex + , procFlex' + , binFlex + + , waitSecondsForProcess + , waitSecondsForProcessOk + + ) where + +import qualified Control.Concurrent as IO +import qualified Control.Concurrent.Async as IO +import Data.Monoid (Last (..)) +import GHC.Stack (callStack) +import qualified HaskellWorks.IO.Process as IO +import HaskellWorks.Polysemy.Cabal +import HaskellWorks.Polysemy.Error.Types +import HaskellWorks.Polysemy.Hedgehog.Assert +import HaskellWorks.Polysemy.Hedgehog.Jot +import HaskellWorks.Polysemy.Hedgehog.Process.Internal +import HaskellWorks.Polysemy.Prelude +import HaskellWorks.Polysemy.System.Environment +import HaskellWorks.Polysemy.System.Process + +import qualified Data.List as L +import Polysemy +import Polysemy.Error +import Polysemy.Log + +-- | Configuration for starting a new process. This is a subset of 'IO.CreateProcess'. +data ExecConfig = ExecConfig + { execConfigEnv :: Last [(String, String)] + , execConfigCwd :: Last FilePath + } deriving (Eq, Generic, Show) + +defaultExecConfig :: ExecConfig +defaultExecConfig = ExecConfig + { execConfigEnv = mempty + , execConfigCwd = mempty + } + +-- | Create a process returning its stdout. +-- +-- Being a 'flex' function means that the environment determines how the process is launched. +-- +-- When running in a nix environment, the 'envBin' argument describes the environment variable +-- that defines the binary to use to launch the process. +-- +-- When running outside a nix environment, the `pkgBin` describes the name of the binary +-- to launch via cabal exec. +execFlexOk :: () + => Member (Embed IO) r + => Member Hedgehog r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => String + -> String + -> [String] + -> Sem r String +execFlexOk = execFlexOk' defaultExecConfig + +execFlexOk' :: () + => Member (Embed IO) r + => Member Hedgehog r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => ExecConfig + -> String + -> String + -> [String] + -> Sem r String +execFlexOk' execConfig pkgBin envBin arguments = withFrozenCallStack $ do + (exitResult, stdout, stderr) <- execFlex execConfig pkgBin envBin arguments + case exitResult of + ExitFailure exitCode -> do + jot_ $ L.unlines $ + [ "Process exited with non-zero exit-code: " <> show @Int exitCode ] + <> (if L.null stdout then [] else ["━━━━ stdout ━━━━" , stdout]) + <> (if L.null stderr then [] else ["━━━━ stderr ━━━━" , stderr]) + failMessage callStack "Execute process failed" + ExitSuccess -> return stdout + +-- | Run a process, returning its exit code, its stdout, and its stderr. +-- Contrary to @execFlexOk'@, this function doesn't fail if the call fails. +-- So, if you want to test something negative, this is the function to use. +execFlex :: () + => Member (Embed IO) r + => Member Hedgehog r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => ExecConfig + -> String -- ^ @pkgBin@: name of the binary to launch via 'cabal exec' + -> String -- ^ @envBin@: environment variable defining the binary to launch the process, when in Nix + -> [String] + -> Sem r (ExitCode, String, String) -- ^ exit code, stdout, stderr +execFlex execConfig pkgBin envBin arguments = withFrozenCallStack $ do + cp <- procFlex' execConfig pkgBin envBin arguments + jot_ . ("━━━━ command ━━━━\n" <>) $ case cmdspec cp of + ShellCommand cmd -> cmd + RawCommand cmd args -> cmd <> " " <> L.unwords (argQuote <$> args) + + readCreateProcessWithExitCode cp "" + +-- | Execute a process, returning '()'. +execOk_ :: () + => Member (Embed IO) r + => Member Hedgehog r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => ExecConfig + -> String + -> [String] + -> Sem r () +execOk_ execConfig bin arguments = void $ execOk execConfig bin arguments + +-- | Execute a process, returning the stdout. Fail if the call returns +-- with a non-zero exit code. For a version that doesn't fail upon receiving +-- a non-zero exit code, see 'execAny'. +execOk :: () + => Member (Embed IO) r + => Member Hedgehog r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => ExecConfig + -> String + -> [String] + -> Sem r String +execOk execConfig bin arguments = withFrozenCallStack $ do + (exitResult, stdout, stderr) <- exec execConfig bin arguments + case exitResult of + ExitFailure exitCode ->failMessage callStack . L.unlines $ + [ "Process exited with non-zero exit-code: " <> show @Int exitCode ] + <> (if L.null stdout then [] else ["━━━━ stdout ━━━━" , stdout]) + <> (if L.null stderr then [] else ["━━━━ stderr ━━━━" , stderr]) + ExitSuccess -> return stdout + +-- | Execute a process, returning the error code, the stdout, and the stderr. +exec :: () + => Member (Embed IO) r + => Member Hedgehog r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => ExecConfig + -> String -- ^ The binary to launch + -> [String] -- ^ The binary's arguments + -> Sem r (ExitCode, String, String) -- ^ exit code, stdout, stderr +exec execConfig bin arguments = withFrozenCallStack $ do + let cp = (proc bin arguments) + { env = getLast $ execConfigEnv execConfig + , cwd = getLast $ execConfigCwd execConfig + } + jot_ . ( "━━━━ command ━━━━\n" <>) $ bin <> " " <> L.unwords (argQuote <$> arguments) + readCreateProcessWithExitCode cp "" + +waitSecondsForProcess :: () + => Member (Embed IO) r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => Int + -> ProcessHandle + -> Sem r (Either TimedOut (Maybe ExitCode)) +waitSecondsForProcess seconds hProcess = embed $ + IO.race + (IO.threadDelay (seconds * 1000000) >> return TimedOut) + (IO.maybeWaitForProcess hProcess) + +-- | Wait a maximum of 'seconds' secons for process to exit. +waitSecondsForProcessOk :: () + => Member Hedgehog r + => Member (Embed IO) r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => Int + -> ProcessHandle + -> Sem r (Either TimedOut ExitCode) +waitSecondsForProcessOk seconds hProcess = withFrozenCallStack $ do + result <- waitSecondsForProcess seconds hProcess + case result of + Left TimedOut -> do + jot_ "Timed out waiting for process to exit" + return (Left TimedOut) + Right maybeExitCode -> do + case maybeExitCode of + Nothing -> failMessage callStack "No exit code for process" + Just exitCode -> do + jot_ $ "Process exited " <> show exitCode + return (Right exitCode) + +-- | Compute the path to the binary given a package name or an environment variable override. +binFlex :: () + => Member (Embed IO) r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => String + -- ^ Package name + -> String + -- ^ Environment variable pointing to the binary to run + -> Sem r FilePath + -- ^ Path to executable +binFlex pkg binaryEnv = do + maybeEnvBin <- lookupEnv binaryEnv + case maybeEnvBin of + Just envBin -> return envBin + Nothing -> binDist pkg + +-- | Create a 'CreateProcess' describing how to start a process given the Cabal package name +-- corresponding to the executable, an environment variable pointing to the executable, +-- and an argument list. +-- +-- The actual executable used will the one specified by the environment variable, but if +-- the environment variable is not defined, it will be found instead by consulting the +-- "plan.json" generated by cabal. It is assumed that the project has already been +-- configured and the executable has been built. +procFlex :: () + => Member (Embed IO) r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => String + -- ^ Cabal package name corresponding to the executable + -> String + -- ^ Environment variable pointing to the binary to run + -> [String] + -- ^ Arguments to the CLI command + -> Sem r CreateProcess + -- ^ Captured stdout +procFlex = procFlex' defaultExecConfig + +procFlex' :: () + => Member (Embed IO) r + => Member (Error GenericError) r + => Member (Error IOException) r + => Member Log r + => ExecConfig + -> String + -- ^ Cabal package name corresponding to the executable + -> String + -- ^ Environment variable pointing to the binary to run + -> [String] + -- ^ Arguments to the CLI command + -> Sem r CreateProcess + -- ^ Captured stdout +procFlex' execConfig pkg binaryEnv arguments = withFrozenCallStack $ do + bin <- binFlex pkg binaryEnv + return (proc bin arguments) + { env = getLast $ execConfigEnv execConfig + , cwd = getLast $ execConfigCwd execConfig + -- this allows sending signals to the created processes, without killing the test-suite process + , create_group = True + } diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Process/Internal.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Process/Internal.hs new file mode 100644 --- /dev/null +++ b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Process/Internal.hs @@ -0,0 +1,28 @@ +module HaskellWorks.Polysemy.Hedgehog.Process.Internal + ( argQuote + ) where + +import Data.Bool +import Data.Semigroup +import Data.String + +import qualified Data.List as L + +-- | Format argument for a shell CLI command. +-- +-- This includes automatically embedding string in double quotes if necessary, including any necessary escaping. +-- +-- Note, this function does not cover all the edge cases for shell processing, so avoid use in production code. +argQuote :: String -> String +argQuote arg = if ' ' `L.elem` arg || '"' `L.elem` arg || '$' `L.elem` arg + then "\"" <> escape arg <> "\"" + else arg + where escape :: String -> String + escape ('"':xs) = '\\':'"':escape xs + escape ('\\':xs) = '\\':'\\':escape xs + escape ('\n':xs) = '\\':'n':escape xs + escape ('\r':xs) = '\\':'r':escape xs + escape ('\t':xs) = '\\':'t':escape xs + escape ('$':xs) = '\\':'$':escape xs + escape (x:xs) = x:escape xs + escape "" = "" diff --git a/hw-polysemy.cabal b/hw-polysemy.cabal --- a/hw-polysemy.cabal +++ b/hw-polysemy.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: hw-polysemy -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Opinionated polysemy library description: Opinionated polysemy library. license: Apache-2.0 @@ -19,23 +19,31 @@ common base { build-depends: base >= 4.18 && < 5 } +common aeson { build-depends: aeson < 2.3 } +common async { build-depends: async < 2.3 } common bytestring { build-depends: bytestring < 0.13 } common contravariant { build-depends: contravariant < 1.6 } common Diff { build-depends: Diff < 0.6 } common directory { build-depends: directory < 1.4 } common filepath { build-depends: filepath < 1.6 } +common generic-lens { build-depends: generic-lens < 2.3 } common ghc-prim { build-depends: ghc-prim < 0.12 } common hedgehog { build-depends: hedgehog < 1.5 } +common network { build-depends: network < 3.3 } +common lens { build-depends: lens < 5.4 } common polysemy { build-depends: polysemy < 2 } common polysemy-log { build-depends: polysemy-log < 0.11 } common polysemy-plugin { build-depends: polysemy-plugin < 0.5 } common polysemy-time { build-depends: polysemy-time < 0.7 } common process { build-depends: process < 1.7 } +common resourcet { build-depends: resourcet < 1.4 } common stm { build-depends: stm < 2.6 } common tasty { build-depends: tasty < 1.6 } common tasty-hedgehog { build-depends: tasty-hedgehog < 1.5 } common text { build-depends: text < 3 } common time { build-depends: time < 2 } +common unliftio { build-depends: unliftio < 0.3 } +common yaml { build-depends: yaml < 0.12 } common hw-polysemy { build-depends: hw-polysemy } common hw-polysemy-core { build-depends: hw-polysemy:core } @@ -57,21 +65,40 @@ library core import: base, project-config, + aeson, + async, bytestring, contravariant, directory, filepath, + generic-lens, ghc-prim, hedgehog, + lens, + network, polysemy, polysemy-log, polysemy-time, process, + resourcet, stm, text, time, + unliftio, + yaml, visibility: public - exposed-modules: HaskellWorks.Polysemy + + if os(windows) + exposed-modules: HaskellWorks.IO.Win32.NamedPipe + + exposed-modules: HaskellWorks.IO.Network + HaskellWorks.IO.Network.NamedPipe + HaskellWorks.IO.Network.Port + HaskellWorks.IO.Network.Socket + HaskellWorks.IO.Process + HaskellWorks.Polysemy + HaskellWorks.Polysemy.Cabal + HaskellWorks.Polysemy.Cabal.Types HaskellWorks.Polysemy.Control.Concurrent HaskellWorks.Polysemy.Control.Concurrent.QSem HaskellWorks.Polysemy.Control.Concurrent.STM @@ -84,6 +111,10 @@ HaskellWorks.Polysemy.Data.Text.Lazy HaskellWorks.Polysemy.Data.Text.Strict HaskellWorks.Polysemy.Error + HaskellWorks.Polysemy.Error.Types + HaskellWorks.Polysemy.File + HaskellWorks.Polysemy.FilePath + HaskellWorks.Polysemy.OS HaskellWorks.Polysemy.Prelude HaskellWorks.Polysemy.String HaskellWorks.Polysemy.System.Directory @@ -95,16 +126,21 @@ library hedgehog import: base, project-config, + aeson, + async, bytestring, contravariant, Diff, filepath, + generic-lens, ghc-prim, hedgehog, hw-polysemy-core, - polysemy, + lens, polysemy-log, polysemy-time, + polysemy, + process, text, visibility: public exposed-modules: HaskellWorks.Polysemy.Hedgehog @@ -115,6 +151,8 @@ HaskellWorks.Polysemy.Hedgehog.Eval HaskellWorks.Polysemy.Hedgehog.Golden HaskellWorks.Polysemy.Hedgehog.Jot + HaskellWorks.Polysemy.Hedgehog.Process + HaskellWorks.Polysemy.Hedgehog.Process.Internal HaskellWorks.Polysemy.Hedgehog.Property hs-source-dirs: hedgehog default-language: GHC2021 @@ -123,7 +161,12 @@ import: base, project-config, hw-polysemy-core, hw-polysemy-hedgehog, - reexported-modules: HaskellWorks.Polysemy, + reexported-modules: HaskellWorks.IO.Network, + HaskellWorks.IO.Network.NamedPipe, + HaskellWorks.IO.Network.Port, + HaskellWorks.Polysemy, + HaskellWorks.Polysemy.Cabal, + HaskellWorks.Polysemy.Cabal.Types, HaskellWorks.Polysemy.Control.Concurrent, HaskellWorks.Polysemy.Control.Concurrent.QSem, HaskellWorks.Polysemy.Control.Concurrent.STM, @@ -136,6 +179,9 @@ HaskellWorks.Polysemy.Data.Text.Lazy, HaskellWorks.Polysemy.Data.Text.Strict, HaskellWorks.Polysemy.Error, + HaskellWorks.Polysemy.Error.Types, + HaskellWorks.Polysemy.FilePath, + HaskellWorks.Polysemy.OS, HaskellWorks.Polysemy.Hedgehog, HaskellWorks.Polysemy.Hedgehog.Assert, HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog, @@ -144,6 +190,8 @@ HaskellWorks.Polysemy.Hedgehog.Eval, HaskellWorks.Polysemy.Hedgehog.Golden, HaskellWorks.Polysemy.Hedgehog.Jot, + HaskellWorks.Polysemy.Hedgehog.Process, + HaskellWorks.Polysemy.Hedgehog.Process.Internal, HaskellWorks.Polysemy.Hedgehog.Property, HaskellWorks.Polysemy.Prelude, HaskellWorks.Polysemy.String, diff --git a/test/HaskellWorks/Polysemy/HedgehogSpec.hs b/test/HaskellWorks/Polysemy/HedgehogSpec.hs --- a/test/HaskellWorks/Polysemy/HedgehogSpec.hs +++ b/test/HaskellWorks/Polysemy/HedgehogSpec.hs @@ -20,7 +20,7 @@ let projectRoot = "." contents <- T.readFile (projectRoot "LICENSE") - & catchFail @IOException + & trapFail @IOException line1 <- T.lines contents & L.dropWhile T.null