diff --git a/dev/Paths_ihp_ide.hs b/dev/Paths_ihp_ide.hs index 64de7de0e..7390dda10 100644 --- a/dev/Paths_ihp_ide.hs +++ b/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 \ No newline at end of file +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 diff --git a/ihp-ide/IHP/IDE/Postgres.hs b/ihp-ide/IHP/IDE/Postgres.hs index 3ff0e773d..c42577133 100644 --- a/ihp-ide/IHP/IDE/Postgres.hs +++ b/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,16 @@ waitUntilReady handle callback = do then callback else waitUntilReady handle callback +callProcessDirenvAware :: (?context :: Context) => OsPath -> [String] -> IO () +callProcessDirenvAware command args = do + baseProcess <- procDirenvAware command args + (_, _, _, processHandle) <- Process.createProcess baseProcess + exitCode <- Process.waitForProcess processHandle + commandStr <- decodeUtf command + case exitCode of + ExitSuccess -> pure () + ExitFailure c -> error ("Process " <> cs commandStr <> " exited with " <> show c) + waitPostgres :: (?context :: Context) => IO () waitPostgres = do let isDebugMode = ?context.isDebugMode @@ -168,4 +180,4 @@ withBuiltinOrDevenvPostgres callback = do callback databaseIsReady standardOutput errorOutput else do - withPostgres callback \ No newline at end of file + withPostgres callback diff --git a/ihp-ide/Test/IDE/PostgresSpec.hs b/ihp-ide/Test/IDE/PostgresSpec.hs new file mode 100644 index 000000000..dd4807b5e --- /dev/null +++ b/ihp-ide/Test/IDE/PostgresSpec.hs @@ -0,0 +1,184 @@ +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.IO.Temp as Temp +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`) + -- The exact path depends on the environment (dev uses IHP_LIB, + -- Nix uses Cabal's data-dir). The psql stub validates the file exists; + -- here we just verify an absolute path to IHPSchema.sql is used. + 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 + Temp.withSystemTempDirectory "ihp-test-postgres" \testDir -> do + Directory.createDirectoryIfMissing True (testDir <> "/Application") + Directory.createDirectoryIfMissing True (testDir <> "/bin") + Directory.createDirectoryIfMissing True (testDir <> "/IHP/ihp-ide/data") + 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/data/IHPSchema.sql") "CREATE EXTENSION IF NOT EXISTS pgcrypto;\n" + callback testDir + +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory workingDirectory callback = do + oldDirectory <- Directory.getCurrentDirectory + Exception.bracket_ + (Directory.setCurrentDirectory workingDirectory) + (Directory.setCurrentDirectory oldDirectory) + callback + + +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" + , "# Verify that -f file targets exist" + , "while [ $# -gt 0 ]; do" + , " case \"$1\" in" + , " -f) shift; if [ ! -f \"$1\" ]; then echo \"psql: file not found: $1\" >&2; exit 1; fi;;" + , " esac" + , " shift" + , "done" + ] + +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" + ] diff --git a/ihp-ide/Test/Main.hs b/ihp-ide/Test/Main.hs index d68cc3c5e..afed29a44 100644 --- a/ihp-ide/Test/Main.hs +++ b/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 diff --git a/ihp-ide/ihp-ide.cabal b/ihp-ide/ihp-ide.cabal index 9f43dedc6..a07b21c6c 100644 --- a/ihp-ide/ihp-ide.cabal +++ b/ihp-ide/ihp-ide.cabal @@ -329,7 +329,7 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Test/Main.hs hs-source-dirs: . - build-depends: ihp, ihp-log, ihp-modal, ihp-schema-compiler, hspec, wai-request-params, wai-asset-path + build-depends: ihp, ihp-log, ihp-modal, ihp-schema-compiler, hspec, wai-request-params, wai-asset-path, temporary other-modules: Test.IDE.SchemaDesigner.CompilerSpec Test.IDE.SchemaDesigner.ParserSpec @@ -343,4 +343,5 @@ test-suite tests Test.IDE.SchemaDesigner.SchemaOperationsSpec Test.IDE.CodeGeneration.MigrationGenerator Test.SchemaCompilerSpec + Test.IDE.PostgresSpec Test.ServerSpec