sandwich-contexts 0.3.0.0 → 0.3.0.1
raw patch · 6 files changed
+137/−104 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +9/−0
- lib/Test/Sandwich/Contexts/Nix.hs +3/−3
- lib/Test/Sandwich/Contexts/PostgreSQL.hs +58/−56
- lib/Test/Sandwich/Contexts/UnixSocketPath.hs +63/−0
- lib/Test/Sandwich/Contexts/Util/SocketUtil.hs +0/−43
- sandwich-contexts.cabal +4/−2
+ CHANGELOG.md view
@@ -0,0 +1,9 @@+# Changelog for sandwich-contexts++## 0.3.0.1++* Automatically find sufficiently short Unix socket paths when the system temp ones are too long++## 0.3.0.0++* Initial release.
lib/Test/Sandwich/Contexts/Nix.hs view
@@ -117,15 +117,15 @@ , nixpkgsDerivationAllowUnfree :: Bool } deriving (Show, Eq) --- | Nixpkgs release 24.05, accessed 6\/10\/2024.+-- | Nixpkgs release 24.05, accessed 11\/9\/2024. -- You can compute updated values for this release (or others) by running -- nix-prefetch-github NixOS nixpkgs --rev release-24.05 nixpkgsRelease2405 :: NixpkgsDerivation nixpkgsRelease2405 = NixpkgsDerivationFetchFromGitHub { nixpkgsDerivationOwner = "NixOS" , nixpkgsDerivationRepo = "nixpkgs"- , nixpkgsDerivationRev = "869cab745a802b693b45d193b460c9184da671f3"- , nixpkgsDerivationSha256 = "sha256-zliqz7ovpxYdKIK+GlWJZxifXsT9A1CHNQhLxV0G1Hc="+ , nixpkgsDerivationRev = "bb824c634c812feede9d398c000526401028c0e7"+ , nixpkgsDerivationSha256 = "sha256-xYnWv9kyJyF8rEZ1uJaSek2fmaIowkk/ovE6+MwcP2E=" , nixpkgsDerivationAllowUnfree = False }
lib/Test/Sandwich/Contexts/PostgreSQL.hs view
@@ -68,7 +68,8 @@ import Test.Sandwich.Contexts.Nix import Test.Sandwich.Contexts.ReverseProxy.TCP import Test.Sandwich.Contexts.Types.Network-import Test.Sandwich.Contexts.Util.UUID+import Test.Sandwich.Contexts.Util.UUID (makeUUID)+import Test.Sandwich.Contexts.UnixSocketPath import UnliftIO.Directory import UnliftIO.Environment import UnliftIO.Exception@@ -213,67 +214,68 @@ let logfileName = baseDir </> "logfile" -- The Unix socket can't live in the sandwich test tree because it has an absurdly short length- -- requirement (107 bytes on Linux). See+ -- requirement (107 bytes on Linux, 104 bytes on macOS). See -- https://unix.stackexchange.com/questions/367008/why-is-socket-path-length-limited-to-a-hundred-chars- withSystemTempDirectory "postgres-nix-unix-socks" $ \unixSockDir -> do- bracket- (do- -- Run initdb- baseEnv <- getEnvironment- let env = ("LC_ALL", "C")- : ("LC_CTYPE", "C")- : baseEnv- withTempFile baseDir "pwfile" $ \pwfile h -> do- liftIO $ T.hPutStrLn h password- hClose h- createProcessWithLogging ((proc (postgresBinDir </> "initdb") [dbDirName- , "--username", toString username- , "-A", "md5"- , "--pwfile", pwfile- ]) {- cwd = Just dir- , env = Just env- })- >>= waitForProcess >>= (`shouldBe` ExitSuccess)-- -- Turn off the TCP interface; we'll have it listen solely on a Unix socket- withFile (dir </> dbDirName </> "postgresql.conf") AppendMode $ \h -> liftIO $ do- T.hPutStr h "\n"- T.hPutStrLn h [i|listen_addresses=''|]+ withUnixSocketDirectory "postgres-sock" 20 $ \unixSockDir -> bracket+ (do+ info [i|Unix sock dir: #{unixSockDir}|] - -- Run pg_ctl to start the DB- createProcessWithLogging ((proc (postgresBinDir </> "pg_ctl") [- "-D", dbDirName- , "-l", logfileName- , "-o", [i|--unix_socket_directories='#{unixSockDir}'|]- , "start" , "--wait"- ]) { cwd = Just dir })+ -- Run initdb+ baseEnv <- getEnvironment+ let env = ("LC_ALL", "C")+ : ("LC_CTYPE", "C")+ : baseEnv+ withTempFile baseDir "pwfile" $ \pwfile h -> do+ liftIO $ T.hPutStrLn h password+ hClose h+ createProcessWithLogging ((proc (postgresBinDir </> "initdb") [dbDirName+ , "--username", toString username+ , "-A", "md5"+ , "--pwfile", pwfile+ ]) {+ cwd = Just dir+ , env = Just env+ }) >>= waitForProcess >>= (`shouldBe` ExitSuccess) - -- Create the default db- createProcessWithLogging ((proc (postgresBinDir </> "psql") [- -- "-h", unixSockDir- -- , "--username", toString postgresNixUsername- [i|postgresql://#{username}:#{password}@/?host=#{unixSockDir}|]- , "-c", [i|CREATE DATABASE #{database};|]- ]) { cwd = Just dir })- >>= waitForProcess >>= (`shouldBe` ExitSuccess)+ -- Turn off the TCP interface; we'll have it listen solely on a Unix socket+ withFile (dir </> dbDirName </> "postgresql.conf") AppendMode $ \h -> liftIO $ do+ T.hPutStr h "\n"+ T.hPutStrLn h [i|listen_addresses=''|] + -- Run pg_ctl to start the DB+ createProcessWithLogging ((proc (postgresBinDir </> "pg_ctl") [+ "-D", dbDirName+ , "-l", logfileName+ , "-o", [i|--unix_socket_directories='#{unixSockDir}'|]+ , "start" , "--wait"+ ]) { cwd = Just dir })+ >>= waitForProcess >>= (`shouldBe` ExitSuccess) - files <- listDirectory unixSockDir- filterM ((isSocket <$>) . liftIO . getFileStatus) [unixSockDir </> f | f <- files] >>= \case- [f] -> pure f- [] -> expectationFailure [i|Couldn't find Unix socket for PostgreSQL server (check output and logfile for errors).|]- xs -> expectationFailure [i|Found multiple Unix sockets for PostgreSQL server, not sure which one to use: #{xs}|]- )- (\_ -> do- void $ readCreateProcessWithLogging ((proc (postgresBinDir </> "pg_ctl") [- "-D", dbDirName- , "-l", logfileName- , "stop" , "--wait"- ]) { cwd = Just dir }) ""- )- (\socketPath -> action socketPath)+ -- Create the default db+ createProcessWithLogging ((proc (postgresBinDir </> "psql") [+ -- "-h", unixSockDir+ -- , "--username", toString postgresNixUsername+ [i|postgresql://#{username}:#{password}@/?host=#{unixSockDir}|]+ , "-c", [i|CREATE DATABASE #{database};|]+ ]) { cwd = Just dir })+ >>= waitForProcess >>= (`shouldBe` ExitSuccess)+++ files <- listDirectory unixSockDir+ filterM ((isSocket <$>) . liftIO . getFileStatus) [unixSockDir </> f | f <- files] >>= \case+ [f] -> pure f+ [] -> expectationFailure [i|Couldn't find Unix socket for PostgreSQL server (check output and logfile for errors).|]+ xs -> expectationFailure [i|Found multiple Unix sockets for PostgreSQL server, not sure which one to use: #{xs}|]+ )+ (\_ -> do+ void $ readCreateProcessWithLogging ((proc (postgresBinDir </> "pg_ctl") [+ "-D", dbDirName+ , "-l", logfileName+ , "stop" , "--wait"+ ]) { cwd = Just dir }) ""+ )+ action -- * Container
+ lib/Test/Sandwich/Contexts/UnixSocketPath.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}++module Test.Sandwich.Contexts.UnixSocketPath (+ withUnixSocketDirectory+ , maxUnixSocketLength+ ) where++import Control.Monad.IO.Unlift+import Relude+import System.IO.Error (IOError)+import Test.Sandwich.Expectations (expectationFailure)+import UnliftIO.Directory+import UnliftIO.Exception+import UnliftIO.Temporary+++-- | The longest allowed path for a Unix socket on the current system.+maxUnixSocketLength :: Int+#ifdef mingw32_HOST_OS+maxUnixSocketLength = maxBound+#elif darwin_host_os+maxUnixSocketLength = 103 -- macOS: 104 with null terminator+#else+maxUnixSocketLength = 107 -- Linux: 108 with null terminator+#endif++-- | Create a temporary directory in which a Unix socket can be safely created,+-- bearing in mind the longest allowed Unix socket path on the system.+withUnixSocketDirectory :: (MonadUnliftIO m)+ -- | Name template, as passed to 'withSystemTempDirectory'+ => String+ -- | Amount of headroom to leave for a file name in this directory,+ -- before hitting the 'maxUnixSocketLength'+ -> Int+ -- | Callback+ -> (FilePath -> m a) -> m a+withUnixSocketDirectory nameTemplate headroom action = do+ withSystemTempDirectory nameTemplate $ \dir ->+ if | length dir + headroom <= maxUnixSocketLength -> action dir+ | otherwise -> withShortTempDir nameTemplate headroom action++withShortTempDir :: (+ MonadUnliftIO m+ )+ => String+ -> Int+ -> (FilePath -> m a)+ -> m a+withShortTempDir nameTemplate headroom action = doesDirectoryExist "/tmp" >>= \case+ True -> isDirectoryWritable "/tmp" >>= \case+ True -> withTempDirectory "/tmp" nameTemplate $ \dir ->+ if | length dir + headroom <= maxUnixSocketLength -> action dir+ | otherwise -> doFail+ False -> doFail+ _ -> doFail+ where+ doFail = expectationFailure "Couldn't create a short enough Unix socket path on this system."++isDirectoryWritable :: MonadUnliftIO m => FilePath -> m Bool+isDirectoryWritable dir = do+ try (getPermissions dir) >>= \case+ Left (_ :: IOError) -> return False+ Right perms -> return $ writable perms
− lib/Test/Sandwich/Contexts/Util/SocketUtil.hs
@@ -1,43 +0,0 @@-module Test.Sandwich.Contexts.Util.SocketUtil (- isPortOpen- , simpleSockAddr- ) where---- Taken from--- https://stackoverflow.com/questions/39139787/i-want-to-check-whether-or-not-a-certain-port-is-open-haskell--- https://gist.github.com/nh2/0a1442eb71ec0405a1e3ce83a467dfde#file-socketutils-hs--import Foreign.C.Error (Errno(..), eCONNREFUSED)-import GHC.IO.Exception (IOException(..))-import Network.Socket (Family(AF_INET), PortNumber, SocketType(Stream), SockAddr(SockAddrInet), socket, connect, close', tupleToHostAddress)-import Relude-import UnliftIO.Exception---- | Checks whether @connect()@ to a given TCPv4 `SockAddr` succeeds or--- returns `eCONNREFUSED`.------ Rethrows connection exceptions in all other cases (e.g. when the host--- is unroutable).-isPortOpen :: SockAddr -> IO Bool-isPortOpen sockAddr = do- bracket (socket AF_INET Stream 6 {- TCP -}) close' $ \sock -> do- res <- try $ connect sock sockAddr- case res of- Right () -> return True- Left e ->- if (Errno <$> ioe_errno e) == Just eCONNREFUSED- then return False- else throwIO e----- | Creates a `SockAttr` from host IP and port number.------ Example:--- > simpleSockAddr (127,0,0,1) 8000-simpleSockAddr :: (Word8, Word8, Word8, Word8) -> PortNumber -> SockAddr-simpleSockAddr addr port = SockAddrInet port (tupleToHostAddress addr)----- Example usage:--- > isPortOpen (simpleSockAddr (127,0,0,1) 8000)--- True
sandwich-contexts.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sandwich-contexts-version: 0.3.0.0+version: 0.3.0.1 synopsis: Contexts for the Sandwich test library description: Please see the <https://codedownio.github.io/sandwich documentation>. author: Tom McLaughlin@@ -13,6 +13,8 @@ copyright: 2024 Tom McLaughlin license: BSD3 build-type: Simple+extra-source-files:+ CHANGELOG.md library exposed-modules:@@ -29,9 +31,9 @@ Test.Sandwich.Contexts.FakeSmtpServer.Derivation Test.Sandwich.Contexts.Files.Types Test.Sandwich.Contexts.ReverseProxy.TCP+ Test.Sandwich.Contexts.UnixSocketPath Test.Sandwich.Contexts.Util.Aeson Test.Sandwich.Contexts.Util.Nix- Test.Sandwich.Contexts.Util.SocketUtil Test.Sandwich.Contexts.Util.UUID Paths_sandwich_contexts hs-source-dirs: