diff --git a/core/HaskellWorks/Control/Monad.hs b/core/HaskellWorks/Control/Monad.hs deleted file mode 100644 --- a/core/HaskellWorks/Control/Monad.hs +++ /dev/null @@ -1,32 +0,0 @@ -module HaskellWorks.Control.Monad - ( repeatNUntilM_, - repeatNWhileM_, - ) where - -import HaskellWorks.Prelude - --- | Repeat an action n times until the action returns True. -repeatNUntilM_ :: () - => Monad m - => Int - -> (Int -> m Bool) - -> m () -repeatNUntilM_ n action = go 0 - where - go i = - when (i < n) $ do - shouldTerminate <- action i - unless shouldTerminate $ go (i + 1) - --- | Repeat an action n times while the action returns True. -repeatNWhileM_ :: () - => Monad m - => Int - -> (Int -> m Bool) - -> m () -repeatNWhileM_ n action = go 0 - where - go i = - when (i < n) $ do - shouldContinue <- action i - when shouldContinue $ go (i + 1) diff --git a/core/HaskellWorks/Data/String.hs b/core/HaskellWorks/Data/String.hs deleted file mode 100644 --- a/core/HaskellWorks/Data/String.hs +++ /dev/null @@ -1,8 +0,0 @@ -module HaskellWorks.Data.String - ( unlines - , unwords - , words - , lines - ) where - -import Data.String diff --git a/core/HaskellWorks/Error.hs b/core/HaskellWorks/Error.hs deleted file mode 100644 --- a/core/HaskellWorks/Error.hs +++ /dev/null @@ -1,28 +0,0 @@ -module HaskellWorks.Error - ( onLeft, - onNothing, - onLeftM, - onNothingM, - ) where - -import HaskellWorks.Polysemy.Prelude - -onLeft :: forall e a m. () - => Monad m - => (e -> m a) -> Either e a -> m a -onLeft f = either f pure - -onNothing :: forall a m. () - => Monad m - => m a -> Maybe a -> m a -onNothing h = maybe h return - -onLeftM :: forall e a m. () - => Monad m - => (e -> m a) -> m (Either e a) -> m a -onLeftM f action = onLeft f =<< action - -onNothingM :: forall a m. () - => Monad m - => m a -> m (Maybe a) -> m a -onNothingM h f = onNothing h =<< f diff --git a/core/HaskellWorks/Error/Types.hs b/core/HaskellWorks/Error/Types.hs deleted file mode 100644 --- a/core/HaskellWorks/Error/Types.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module HaskellWorks.Error.Types - ( GenericError(..), - TimedOut(..), - ) where - -import HaskellWorks.Polysemy.Prelude - -newtype GenericError = GenericError - { message :: Text - } - deriving (Generic, Eq, Show) - -newtype TimedOut = TimedOut - { message :: Text - } - deriving (Generic, Eq, Show) diff --git a/core/HaskellWorks/IO/Network.hs b/core/HaskellWorks/IO/Network.hs deleted file mode 100644 --- a/core/HaskellWorks/IO/Network.hs +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 --- a/core/HaskellWorks/IO/Network/NamedPipe.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# 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 HaskellWorks.IO.Win32.NamedPipe 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 deleted file mode 100644 --- a/core/HaskellWorks/IO/Network/Port.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/core/HaskellWorks/IO/Network/Socket.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/core/HaskellWorks/IO/Process.hs +++ /dev/null @@ -1,34 +0,0 @@ -module HaskellWorks.IO.Process - ( maybeWaitForProcess, - waitSecondsForProcess, - ) where - -import Control.Concurrent as IO -import Control.Concurrent.Async as IO -import qualified Control.Exception as IO -import Data.Maybe -import System.Exit -import System.IO - -import Control.Applicative -import Data.Function -import Data.Functor -import HaskellWorks.Error.Types -import HaskellWorks.Prelude -import qualified System.Process as IO -import System.Process - -maybeWaitForProcess :: () - => ProcessHandle - -> IO (Maybe ExitCode) -maybeWaitForProcess hProcess = - IO.catch (fmap Just (IO.waitForProcess hProcess)) $ \(_ :: AsyncCancelled) -> pure Nothing - -waitSecondsForProcess :: () - => Int - -> ProcessHandle - -> IO (Either TimedOut (Maybe ExitCode)) -waitSecondsForProcess seconds hProcess = - IO.race - (IO.threadDelay (seconds * 1000000) >> pure (TimedOut "Timed out waiting for process")) - (maybeWaitForProcess hProcess) diff --git a/core/HaskellWorks/IO/Win32/NamedPipe.hsc b/core/HaskellWorks/IO/Win32/NamedPipe.hsc deleted file mode 100644 --- a/core/HaskellWorks/IO/Win32/NamedPipe.hsc +++ /dev/null @@ -1,71 +0,0 @@ -#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/Prelude.hs b/core/HaskellWorks/Prelude.hs deleted file mode 100644 --- a/core/HaskellWorks/Prelude.hs +++ /dev/null @@ -1,205 +0,0 @@ -module HaskellWorks.Prelude - ( Bool(..), - Char(..), - Maybe(..), - Either(..), - - String, - Text, - ByteString, - Int, - Int8, - Int16, - Int32, - Int64, - Integer, - Word, - Word8, - Word16, - Word32, - Word64, - Float, - Double, - FilePath, - Void, - - Eq(..), - Ord(..), - Num(..), - Show(..), - IsString(..), - tshow, - - bool, - const, - - absurd, - vacuous, - - either, - lefts, - rights, - isLeft, - isRight, - fromLeft, - fromRight, - - maybe, - isJust, - isNothing, - fromMaybe, - listToMaybe, - maybeToList, - catMaybes, - mapMaybe, - - fst, - flip, - snd, - id, - seq, - curry, - uncurry, - ($!), - ($), - (&), - not, - otherwise, - (&&), - (||), - (.), - (), - - void, - mapM_, - forM, - forM_, - sequence_, - (=<<), - (>=>), - (<=<), - forever, - join, - msum, - mfilter, - filterM, - foldM, - foldM_, - replicateM, - replicateM_, - guard, - when, - unless, - liftM, - liftM2, - liftM3, - liftM4, - liftM5, - ap, - (<$!>), - - (<$>), - - (<**>), - liftA, - liftA3, - optional, - asum, - - for_, - - zip, - zip3, - zipWith, - zipWith3, - unzip, - unzip3, - - Fractional(..), - Floating(..), - Integral(..), - Read(..), - Real(..), - RealFrac(..), - RealFloat(..), - Ratio(..), - Rational, - fromIntegral, - realToFrac, - even, - odd, - numericEnumFrom, - numericEnumFromThen, - numericEnumFromTo, - numericEnumFromThenTo, - integralEnumFrom, - integralEnumFromThen, - integralEnumFromTo, - integralEnumFromThenTo, - numerator, - denominator, - (%), - - Monad(..), - MonadFail(..), - MonadPlus(..), - Applicative(..), - Alternative(..), - Contravariant(..), - Divisible(..), - Functor(..), - Bifunctor(..), - Semigroup(..), - Monoid(..), - Foldable(..), - Traversable(..), - - IO, - - CallStack, - HasCallStack, - withFrozenCallStack, - - Generic, - - IOException, - IOError, - SomeException(..), - ) where - -import Control.Applicative -import Control.Exception -import Control.Monad -import Data.Bifunctor -import Data.Bool -import Data.ByteString (ByteString) -import Data.Char -import Data.Either -import Data.Eq -import Data.Foldable -import Data.Function -import Data.Functor.Contravariant -import Data.Functor.Contravariant.Divisible -import Data.Int -import Data.Maybe -import Data.Monoid -import Data.Ord -import Data.Semigroup -import Data.String -import Data.Text (Text) -import Data.Traversable -import Data.Tuple -import Data.Void -import Data.Word -import GHC.Base -import GHC.Generics -import GHC.Num -import GHC.Real -import GHC.Stack -import Prelude -import System.FilePath - -import qualified Data.Text as T - -tshow :: Show a => a -> Text -tshow = T.pack . show diff --git a/core/HaskellWorks/Unsafe.hs b/core/HaskellWorks/Unsafe.hs deleted file mode 100644 --- a/core/HaskellWorks/Unsafe.hs +++ /dev/null @@ -1,6 +0,0 @@ -module HaskellWorks.Unsafe - ( error - , undefined - ) where - -import Prelude 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.14.12 +version: 0.3.0.0 synopsis: Opinionated polysemy library description: Opinionated polysemy library. license: Apache-2.0 @@ -35,6 +35,7 @@ common ghc-prim { build-depends: ghc-prim < 0.12 } common hedgehog { build-depends: hedgehog < 1.6 } common http-conduit { build-depends: http-conduit >= 2.3 && < 2.4 } +common hw-prelude { build-depends: hw-prelude >= 0.0.0.1 && < 0.1 } common lens { build-depends: lens < 5.4 } common mtl { build-depends: mtl < 2.4 } common network { build-depends: network < 3.3 } @@ -60,7 +61,7 @@ common Win32 if os(windows) - build-depends: Win32 >= 2.5.4.1 + build-depends: Win32 >= 2.5.4.1 && < 3 common hw-polysemy { build-depends: hw-polysemy } common hw-polysemy-amazonka { build-depends: hw-polysemy:amazonka } @@ -106,6 +107,7 @@ generic-lens, ghc-prim, hedgehog, + hw-prelude, lens, mtl, network, @@ -124,19 +126,7 @@ yaml, visibility: public - if os(windows) - exposed-modules: HaskellWorks.IO.Win32.NamedPipe - - exposed-modules: HaskellWorks.Control.Monad - HaskellWorks.Data.String - HaskellWorks.Error - HaskellWorks.Error.Types - HaskellWorks.IO.Network - HaskellWorks.IO.Network.NamedPipe - HaskellWorks.IO.Network.Port - HaskellWorks.IO.Network.Socket - HaskellWorks.IO.Process - HaskellWorks.Polysemy + exposed-modules: HaskellWorks.Polysemy HaskellWorks.Polysemy.Cabal HaskellWorks.Polysemy.Cabal.Types HaskellWorks.Polysemy.Control.Concurrent @@ -167,8 +157,6 @@ HaskellWorks.Polysemy.System.IO HaskellWorks.Polysemy.System.IO.Temp HaskellWorks.Polysemy.System.Process - HaskellWorks.Prelude - HaskellWorks.Unsafe hs-source-dirs: core default-language: Haskell2010 @@ -186,6 +174,7 @@ generic-lens, ghc-prim, hedgehog, + hw-prelude, hw-polysemy-core, lens, mtl, @@ -226,6 +215,7 @@ binary, generic-lens, hw-polysemy-core, + hw-prelude, lens, polysemy-log, polysemy-time, @@ -247,6 +237,7 @@ hw-polysemy-amazonka, hw-polysemy-core, hw-polysemy-hedgehog, + hw-prelude, lens, resourcet, resourcet, @@ -265,10 +256,7 @@ import: base, project-config, hw-polysemy-core, hw-polysemy-hedgehog, - reexported-modules: HaskellWorks.IO.Network, - HaskellWorks.IO.Network.NamedPipe, - HaskellWorks.IO.Network.Port, - HaskellWorks.Polysemy, + reexported-modules: HaskellWorks.Polysemy, HaskellWorks.Polysemy.Cabal, HaskellWorks.Polysemy.Cabal.Types, HaskellWorks.Polysemy.Control.Concurrent, @@ -317,6 +305,7 @@ hw-polysemy-core, hw-polysemy-testcontainers-localstack, hw-polysemy, + hw-prelude, lens, polysemy-log, polysemy, diff --git a/test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs b/test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs --- a/test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs +++ b/test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs @@ -20,22 +20,29 @@ import HaskellWorks.Polysemy.Hedgehog import HaskellWorks.Prelude import Polysemy +import qualified System.Info as OS import qualified TestContainers.Tasty as TC {- HLINT ignore "Use camelCase" -} +isWindows :: Bool +isWindows = OS.os == "mingw32" + tasty_local_stack :: Tasty.TestTree tasty_local_stack = - TC.withContainers (setupContainers' "localstack/localstack-pro:3.7.2") $ \getContainer -> - H.testProperty "Local stack test" $ propertyOnce $ runLocalTestEnv getContainer $ do - container <- embed getContainer - ep <- getLocalStackEndpoint container - jotYamlM_ $ inspectContainer container - jotShow_ ep - listBucketsReq <- pure AWS.newListBuckets + if isWindows + then Tasty.testGroup "LocalStackSpec skipped on Windows" [] + else + TC.withContainers (setupContainers' "localstack/localstack-pro:3.7.2") $ \getContainer -> + H.testProperty "Local stack test" $ propertyOnce $ runLocalTestEnv getContainer $ do + container <- embed getContainer + ep <- getLocalStackEndpoint container + jotYamlM_ $ inspectContainer container + jotShow_ ep + listBucketsReq <- pure AWS.newListBuckets - listBucketResp <- sendAws listBucketsReq - & jotShowDataLog @AwsLogEntry - & trapFail + listBucketResp <- sendAws listBucketsReq + & jotShowDataLog @AwsLogEntry + & trapFail - jotShow_ listBucketResp + jotShow_ listBucketResp