Fix mainInParentDirectory failing when initdb is not on PATH

dev/Paths_ihp_ide.hs

@@ -3,7 +3,38 @@ module Paths_ihp_ide where
 
 import Data.Version
 import Prelude
+import System.Directory (doesPathExist)
+import System.Environment (lookupEnv)
+import System.FilePath ((</>), takeDirectory)
 
 version = Version { versionBranch = [1, 3, 0], versionTags = [] }
 
-getDataFileName path = pure path
+getDataFileName path = do
+    let directCandidate = path
+    directExists <- doesPathExist directCandidate
+    if directExists
+        then pure directCandidate
+        else do
+            envCandidates <- ihpLibCandidates path
+            firstExistingPath envCandidates directCandidate
+
+ihpLibCandidates :: FilePath -> IO [FilePath]
+ihpLibCandidates path = do
+    ihpLib <- lookupEnv "IHP_LIB"
+    pure case ihpLib of
+        Nothing -> []
+        Just ihpLibPath ->
+            let ihpIdePath = takeDirectory (takeDirectory ihpLibPath)
+             in
+                [ ihpIdePath </> path
+                , ihpIdePath </> "data" </> path
+                ]
+
+
+firstExistingPath :: [FilePath] -> FilePath -> IO FilePath
+firstExistingPath [] defaultPath = pure defaultPath
+firstExistingPath (candidate : rest) defaultPath = do
+    exists <- doesPathExist candidate
+    if exists
+        then pure candidate
+        else firstExistingPath rest defaultPath

ihp-ide/IHP/IDE/Postgres.hs

@@ -15,7 +15,7 @@ import qualified Control.Exception.Safe as Exception
 import qualified IHP.Log as Log
 import qualified IHP.EnvVar as EnvVar
 import Paths_ihp_ide (getDataFileName)
-import System.OsPath (decodeUtf)
+import System.OsPath (OsPath, decodeUtf)
 
 withPostgres :: (?context :: Context) => (MVar () -> IORef ByteString.Builder -> IORef ByteString.Builder -> IO a) -> IO a
 withPostgres callback = do
@@ -80,7 +80,7 @@ redirectHandleToVariable !ref !handle !onLine = do
         onLine line
         modifyIORef ref (\log -> log <> "\n" <> ByteString.byteString line)
 
-ensureNoOtherPostgresIsRunning :: IO ()
+ensureNoOtherPostgresIsRunning :: (?context :: Context) => IO ()
 ensureNoOtherPostgresIsRunning = do
     pidFileExists <- Directory.doesFileExist "build/db/state/postmaster.pid"
     let stopFailedHandler (exception :: SomeException) = do
@@ -89,35 +89,37 @@ ensureNoOtherPostgresIsRunning = do
                 then Directory.removeFile "build/db/state/postmaster.pid"
                 else putStrLn "Found postgres lockfile at 'build/db/state/postmaster.pid'. Could not bring the other postgres instance to halt. Please stop the running postgres manually and then restart this dev server"
     when pidFileExists do
-        (Process.callProcess "pg_ctl" ["stop", "-D", "build/db/state"]) `catch` stopFailedHandler
+        (callProcessDirenvAware "pg_ctl" ["stop", "-D", "build/db/state"]) `catch` stopFailedHandler
 
 needsDatabaseInit :: IO Bool
 needsDatabaseInit = not <$> Directory.doesDirectoryExist "build/db/state"
 
-initDatabase :: IO ()
+initDatabase :: (?context :: Context) => IO ()
 initDatabase = do
     currentDir <- Directory.getCurrentDirectory
     currentDirStr <- decodeUtf currentDir
     Directory.createDirectoryIfMissing True "build/db"
 
-    Process.callProcess "initdb" [
+    callProcessDirenvAware "initdb" [
                 "build/db/state"
                 , "--no-locale" -- Avoid issues with impure host system locale in dev mode
                 , "--encoding"
                 , "UTF8"
             ]
 
-    let params = (Process.proc "postgres" ["-D", "build/db/state", "-k", currentDirStr <> "/build/db", "-c", "listen_addresses="])
-                { Process.std_in = Process.CreatePipe
-                , Process.std_out = Process.CreatePipe
-                , Process.std_err = Process.CreatePipe
-                }
+    baseProcess <- procDirenvAware "postgres" ["-D", "build/db/state", "-k", currentDirStr <> "/build/db", "-c", "listen_addresses="]
+    let params = baseProcess
+            { Process.std_in = Process.CreatePipe
+            , Process.std_out = Process.CreatePipe
+            , Process.std_err = Process.CreatePipe
+            , Process.create_group = True
+            }
 
     Process.withCreateProcess params \(Just inputHandle) (Just outputHandle) (Just errorHandle) processHandle -> do
         waitUntilReady errorHandle do
-            Process.callProcess "createdb" ["app", "-h", currentDirStr <> "/build/db"]
+            callProcessDirenvAware "createdb" ["app", "-h", currentDirStr <> "/build/db"]
 
-            let importSql file = Process.callCommand ("psql -h '" <> currentDirStr <> "/build/db' -d app < " <> file)
+            let importSql file = callProcessDirenvAware "psql" ["-h", currentDirStr <> "/build/db", "-d", "app", "-f", file]
             ihpSchemaSql <- getDataFileName "IHPSchema.sql"
             importSql ihpSchemaSql
             importSql "Application/Schema.sql"
@@ -133,6 +135,13 @@ waitUntilReady handle callback = do
         then callback
         else waitUntilReady handle callback
 
+callProcessDirenvAware :: (?context :: Context) => OsPath -> [String] -> IO ()
+callProcessDirenvAware command args = do
+    commandStr <- decodeUtf command
+    if ?context.wrapWithDirenv
+        then Process.callProcess "direnv" (["exec", ".", commandStr] <> args)
+        else Process.callProcess commandStr args
+
 waitPostgres :: (?context :: Context) => IO ()
 waitPostgres = do
     let isDebugMode = ?context.isDebugMode
@@ -168,4 +177,4 @@ withBuiltinOrDevenvPostgres callback = do
 
         callback databaseIsReady standardOutput errorOutput
     else do
-        withPostgres callback
+        withPostgres callback

ihp-ide/Test/IDE/PostgresSpec.hs

@@ -0,0 +1,179 @@
+module Test.IDE.PostgresSpec where
+
+import IHP.Prelude
+import Test.Hspec
+import IHP.IDE.Postgres (withBuiltinOrDevenvPostgres)
+import IHP.IDE.Types (Context (..))
+import IHP.IDE.PortConfig (PortConfig (..))
+import qualified IHP.Log as Log
+import Control.Concurrent.MVar (takeMVar)
+import qualified Control.Concurrent.Chan.Unagi as Queue
+import qualified Control.Exception.Safe as Exception
+import qualified Data.Map as Map
+import Data.Default (def)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as TextIO
+import qualified Network.Socket as Socket
+import qualified System.Directory as Directory
+import qualified System.Environment as Env
+import qualified System.Process as Process
+import qualified System.Timeout as Timeout
+
+tests :: Spec
+tests = describe "IHP.IDE.Postgres" do
+    it "runs postgres setup through direnv in wrapped mode" do
+        withTemporaryTestDirectory \testDir -> do
+            let scriptsDir = testDir <> "/bin"
+            let commandLog = testDir <> "/commands.log"
+            path <- fromMaybe "" <$> Env.lookupEnv "PATH"
+
+            writeExecutable (scriptsDir <> "/direnv") direnvScript
+            writeExecutable (scriptsDir <> "/initdb") initdbScript
+            writeExecutable (scriptsDir <> "/createdb") createdbScript
+            writeExecutable (scriptsDir <> "/psql") psqlScript
+            writeExecutable (scriptsDir <> "/postgres") postgresScript
+
+            withEnvVar "PATH" (scriptsDir <> ":" <> path) do
+                withEnvVar "IHP_DEVENV" "0" do
+                    withEnvVar "IHP_TEST_COMMAND_LOG" commandLog do
+                        withEnvVar "IHP_LIB" (testDir <> "/IHP/ihp-ide/lib/IHP") do
+                            withTestContext True do
+                                withCurrentDirectory testDir do
+                                    withBuiltinOrDevenvPostgres \databaseIsReady _ _ -> do
+                                        ready <- Timeout.timeout (2 * 1000 * 1000) (takeMVar databaseIsReady)
+                                        ready `shouldBe` Just ()
+
+            commandLogContent <- TextIO.readFile commandLog
+            let commandLines = Text.lines commandLogContent
+            commandLines `shouldSatisfy` any ("exec . initdb " `Text.isPrefixOf`)
+            commandLines `shouldSatisfy` any ("exec . createdb " `Text.isPrefixOf`)
+            commandLines `shouldSatisfy` any ("exec . psql " `Text.isPrefixOf`)
+            commandLines `shouldSatisfy` any (\line -> "-f " `Text.isInfixOf` line && "IHPSchema.sql" `Text.isInfixOf` line)
+            commandLines `shouldSatisfy` any ("-f Application/Schema.sql" `Text.isInfixOf`)
+            commandLines `shouldSatisfy` any ("-f Application/Fixtures.sql" `Text.isInfixOf`)
+            length (filter ("exec . postgres " `Text.isPrefixOf`) commandLines) `shouldSatisfy` (>= 2)
+
+withEnvVar :: String -> String -> IO a -> IO a
+withEnvVar key value action = do
+    oldValue <- Env.lookupEnv key
+    Exception.bracket_
+        (Env.setEnv key value)
+        (restoreEnvVar oldValue)
+        action
+    where
+        restoreEnvVar (Just oldValue) = Env.setEnv key oldValue
+        restoreEnvVar Nothing = Env.unsetEnv key
+
+withTemporaryTestDirectory :: (FilePath -> IO a) -> IO a
+withTemporaryTestDirectory callback = do
+    currentDirectory <- Directory.getCurrentDirectory
+    let testDir = currentDirectory <> "/build/test-postgres-direnv"
+    ignoreIOError (Directory.removePathForcibly testDir)
+    Directory.createDirectoryIfMissing True (testDir <> "/Application")
+    Directory.createDirectoryIfMissing True (testDir <> "/bin")
+    Directory.createDirectoryIfMissing True (testDir <> "/IHP/ihp-ide")
+    TextIO.writeFile (testDir <> "/Application/Schema.sql") "CREATE TABLE test_table (id UUID PRIMARY KEY);\n"
+    TextIO.writeFile (testDir <> "/Application/Fixtures.sql") ""
+    TextIO.writeFile (testDir <> "/IHP/ihp-ide/IHPSchema.sql") "CREATE EXTENSION IF NOT EXISTS pgcrypto;\n"
+    Exception.finally
+        (callback testDir)
+        (ignoreIOError (Directory.removePathForcibly testDir))
+
+withCurrentDirectory :: FilePath -> IO a -> IO a
+withCurrentDirectory workingDirectory callback = do
+    oldDirectory <- Directory.getCurrentDirectory
+    Exception.bracket_
+        (Directory.setCurrentDirectory workingDirectory)
+        (Directory.setCurrentDirectory oldDirectory)
+        callback
+
+ignoreIOError :: IO () -> IO ()
+ignoreIOError io = io `Exception.catchAny` \_ -> pure ()
+
+withTestContext :: Bool -> ((?context :: Context) => IO a) -> IO a
+withTestContext wrapWithDirenv callback = Exception.bracket createContext cleanupContext runCallback
+    where
+        createContext = do
+            logger <- Log.newLogger def
+            (ghciInChan, ghciOutChan) <- Queue.newChan
+            liveReloadClients <- newIORef Map.empty
+            lastSchemaCompilerError <- newIORef Nothing
+            (appSocket, helperSocket) <- Socket.socketPair Socket.AF_UNIX Socket.Stream Socket.defaultProtocol
+            Socket.close helperSocket
+            let portConfig = PortConfig { appPort = 8000, toolServerPort = 8001 }
+            let isDebugMode = False
+            let context = Context { portConfig, isDebugMode, logger, ghciInChan, ghciOutChan, wrapWithDirenv, liveReloadClients, lastSchemaCompilerError, appSocket }
+            pure context
+
+        cleanupContext context = do
+            Socket.close context.appSocket
+            context.logger.cleanup
+
+        runCallback context = do
+            let ?context = context
+            callback
+
+writeExecutable :: FilePath -> Text -> IO ()
+writeExecutable filePath content = do
+    TextIO.writeFile filePath content
+    Process.callProcess "chmod" ["+x", filePath]
+
+direnvScript :: Text
+direnvScript = Text.unlines
+    [ "#!/bin/sh"
+    , "set -eu"
+    , "if [ \"${1:-}\" != \"exec\" ] || [ \"${2:-}\" != \".\" ]; then"
+    , "  echo \"unexpected direnv invocation: $*\" >&2"
+    , "  exit 1"
+    , "fi"
+    , "echo \"$*\" >> \"$IHP_TEST_COMMAND_LOG\""
+    , "shift 2"
+    , "export IHP_TEST_CALLED_VIA_DIRENV=1"
+    , "exec \"$@\""
+    ]
+
+initdbScript :: Text
+initdbScript = Text.unlines
+    [ "#!/bin/sh"
+    , "set -eu"
+    , "if [ \"${IHP_TEST_CALLED_VIA_DIRENV:-0}\" != \"1\" ]; then"
+    , "  echo \"initdb called without direnv\" >&2"
+    , "  exit 1"
+    , "fi"
+    , "mkdir -p \"$1\""
+    ]
+
+createdbScript :: Text
+createdbScript = Text.unlines
+    [ "#!/bin/sh"
+    , "set -eu"
+    , "if [ \"${IHP_TEST_CALLED_VIA_DIRENV:-0}\" != \"1\" ]; then"
+    , "  echo \"createdb called without direnv\" >&2"
+    , "  exit 1"
+    , "fi"
+    ]
+
+psqlScript :: Text
+psqlScript = Text.unlines
+    [ "#!/bin/sh"
+    , "set -eu"
+    , "if [ \"${IHP_TEST_CALLED_VIA_DIRENV:-0}\" != \"1\" ]; then"
+    , "  echo \"psql called without direnv\" >&2"
+    , "  exit 1"
+    , "fi"
+    ]
+
+postgresScript :: Text
+postgresScript = Text.unlines
+    [ "#!/bin/sh"
+    , "set -eu"
+    , "if [ \"${IHP_TEST_CALLED_VIA_DIRENV:-0}\" != \"1\" ]; then"
+    , "  echo \"postgres called without direnv\" >&2"
+    , "  exit 1"
+    , "fi"
+    , "echo \"database system is ready to accept connections\" >&2"
+    , "trap 'exit 0' INT TERM"
+    , "while true; do"
+    , "  sleep 0.1"
+    , "done"
+    ]

ihp-ide/Test/Main.hs

@@ -16,6 +16,7 @@ import qualified Test.IDE.CodeGeneration.JobGenerator
 import qualified Test.IDE.CodeGeneration.MigrationGenerator
 import qualified Test.SchemaCompilerSpec
 import qualified Test.IDE.ToolServer.MiddlewareSpec
+import qualified Test.IDE.PostgresSpec
 import qualified Test.ServerSpec
 
 main :: IO ()
@@ -33,4 +34,5 @@ main = hspec do
     Test.IDE.CodeGeneration.MigrationGenerator.tests
     Test.SchemaCompilerSpec.tests
     Test.IDE.ToolServer.MiddlewareSpec.tests
+    Test.IDE.PostgresSpec.tests
     Test.ServerSpec.tests

ihp-ide/ihp-ide.cabal

@@ -343,4 +343,5 @@ test-suite tests
         Test.IDE.SchemaDesigner.SchemaOperationsSpec
         Test.IDE.CodeGeneration.MigrationGenerator
         Test.SchemaCompilerSpec
+        Test.IDE.PostgresSpec
         Test.ServerSpec