From eb12946d716a77574749de7a820c4c8e06b52107 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Sat, 9 Nov 2024 19:19:21 -0800 Subject: [PATCH] sandwich-contexts: find shorter Unix socket paths when necessary --- .../lib/Test/Sandwich/Contexts/PostgreSQL.hs | 120 +++++++++--------- .../Test/Sandwich/Contexts/UnixSocketPath.hs | 63 +++++++++ sandwich-contexts/sandwich-contexts.cabal | 1 + 3 files changed, 125 insertions(+), 59 deletions(-) create mode 100644 sandwich-contexts/lib/Test/Sandwich/Contexts/UnixSocketPath.hs diff --git a/sandwich-contexts/lib/Test/Sandwich/Contexts/PostgreSQL.hs b/sandwich-contexts/lib/Test/Sandwich/Contexts/PostgreSQL.hs index ec4ba461..1db6a98b 100644 --- a/sandwich-contexts/lib/Test/Sandwich/Contexts/PostgreSQL.hs +++ b/sandwich-contexts/lib/Test/Sandwich/Contexts/PostgreSQL.hs @@ -68,7 +68,8 @@ import Test.Sandwich.Contexts.Container 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 @@ withPostgresUnixSocket postgresBinDir username password database action = do 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=''|] - - -- 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 }) + withUnixSocketDirectory "postgres-sock" 20 $ \unixSockDir -> bracket + (do + info [i|Unix sock dir: #{unixSockDir}|] + + -- 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) - - - 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) + -- 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) + + -- 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 diff --git a/sandwich-contexts/lib/Test/Sandwich/Contexts/UnixSocketPath.hs b/sandwich-contexts/lib/Test/Sandwich/Contexts/UnixSocketPath.hs new file mode 100644 index 00000000..e3a242df --- /dev/null +++ b/sandwich-contexts/lib/Test/Sandwich/Contexts/UnixSocketPath.hs @@ -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 = Infinity +#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 diff --git a/sandwich-contexts/sandwich-contexts.cabal b/sandwich-contexts/sandwich-contexts.cabal index 2be13a39..dc7ce490 100644 --- a/sandwich-contexts/sandwich-contexts.cabal +++ b/sandwich-contexts/sandwich-contexts.cabal @@ -29,6 +29,7 @@ library 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.UUID