sandwich-contexts: find shorter Unix socket paths when necessary

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
 

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

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