module IHP.IDE.Postgres (startPostgres, stopPostgres, waitPostgres) where
import IHP.IDE.Types
import IHP.Prelude
import qualified System.Process as Process
import qualified System.Directory as Directory
import qualified Data.ByteString.Char8 as ByteString
import qualified Data.ByteString.Builder as ByteString
import Control.Concurrent (threadDelay)
import GHC.IO.Handle
import qualified IHP.Log as Log
import qualified IHP.LibDir as LibDir
startPostgres :: (?context :: Context) => IO ManagedProcess
startPostgres :: (?context::Context) => IO ManagedProcess
startPostgres = do
String
currentDir <- IO String
Directory.getCurrentDirectory
IO ()
ensureNoOtherPostgresIsRunning
Bool
shouldInit <- IO Bool
needsDatabaseInit
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldInit IO ()
initDatabase
let args :: [String]
args = [String
"-D", String
"build/db/state", String
"-k", String
currentDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/build/db", String
"-c", String
"listen_addresses="]
let params :: CreateProcess
params = (String -> [String] -> CreateProcess
Process.proc String
"postgres" [String]
args)
{ std_in :: StdStream
Process.std_in = StdStream
Process.CreatePipe
, std_out :: StdStream
Process.std_out = StdStream
Process.CreatePipe
, std_err :: StdStream
Process.std_err = StdStream
Process.CreatePipe
}
ManagedProcess
process <- CreateProcess -> IO ManagedProcess
createManagedProcess CreateProcess
params
let ManagedProcess { Handle
outputHandle :: Handle
$sel:outputHandle:ManagedProcess :: ManagedProcess -> Handle
outputHandle, Handle
errorHandle :: Handle
$sel:errorHandle:ManagedProcess :: ManagedProcess -> Handle
errorHandle } = ManagedProcess
process
let isDebugMode :: Bool
isDebugMode = ?context::Context
Context
?context.isDebugMode
let handleOutdatedDatabase :: ByteString -> IO ()
handleOutdatedDatabase ByteString
line =
if ByteString
"FATAL" ByteString -> ByteString -> Bool
`ByteString.isInfixOf` ByteString
line
then if ByteString
"database files are incompatible with server" ByteString -> ByteString -> Bool
`ByteString.isInfixOf` ByteString
line
then Text -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.error (Text
"The current database state has been created with a different postgres server. Likely you just upgraded the IHP version. Delete your local dev database with 'rm -rf build/db'. You can use 'make dumpdb' to save your database state to Fixtures.sql, otherwise all changes in your local db will be lost. After that run 'devenv up' again." :: Text)
else ByteString -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.error ByteString
line
else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isDebugMode (ByteString -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.debug ByteString
line)
let handleDatabaseReady :: f () -> ByteString -> f ()
handleDatabaseReady f ()
onReady ByteString
line = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
"database system is ready to accept connections" ByteString -> ByteString -> Bool
`ByteString.isInfixOf` ByteString
line) f ()
onReady
IORef Builder
standardOutput <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
IORef Builder
errorOutput <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
let databaseIsReady :: IO ()
databaseIsReady = (?context::Context) => Action -> IO ()
Action -> IO ()
dispatch (PostgresState -> Action
UpdatePostgresState (PostgresStarted { IORef Builder
ManagedProcess
process :: ManagedProcess
standardOutput :: IORef Builder
errorOutput :: IORef Builder
$sel:process:PostgresNotStarted :: ManagedProcess
$sel:standardOutput:PostgresNotStarted :: IORef Builder
$sel:errorOutput:PostgresNotStarted :: IORef Builder
.. }))
IORef Builder -> Handle -> (ByteString -> IO ()) -> IO (Async ())
redirectHandleToVariable IORef Builder
standardOutput Handle
outputHandle ByteString -> IO ()
handleOutdatedDatabase
IORef Builder -> Handle -> (ByteString -> IO ()) -> IO (Async ())
redirectHandleToVariable IORef Builder
errorOutput Handle
errorHandle (ByteString -> IO ()
handleOutdatedDatabase (ByteString -> IO ())
-> (ByteString -> IO ()) -> ByteString -> IO ()
forall a b.
(ByteString -> a) -> (ByteString -> b) -> ByteString -> b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> ByteString -> IO ()
forall {f :: * -> *}. Applicative f => f () -> ByteString -> f ()
handleDatabaseReady IO ()
databaseIsReady)
ManagedProcess -> IO ManagedProcess
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ManagedProcess
process
stopPostgres :: PostgresState -> IO ()
stopPostgres :: PostgresState -> IO ()
stopPostgres PostgresStarted { IORef Builder
ManagedProcess
$sel:process:PostgresNotStarted :: PostgresState -> ManagedProcess
$sel:standardOutput:PostgresNotStarted :: PostgresState -> IORef Builder
$sel:errorOutput:PostgresNotStarted :: PostgresState -> IORef Builder
process :: ManagedProcess
standardOutput :: IORef Builder
errorOutput :: IORef Builder
.. } = ManagedProcess -> IO ()
cleanupManagedProcess ManagedProcess
process
stopPostgres PostgresState
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
redirectHandleToVariable :: IORef ByteString.Builder -> Handle -> (ByteString -> IO ()) -> IO (Async ())
redirectHandleToVariable :: IORef Builder -> Handle -> (ByteString -> IO ()) -> IO (Async ())
redirectHandleToVariable !IORef Builder
ref !Handle
handle !ByteString -> IO ()
onLine = do
IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString
line <- Handle -> IO ByteString
ByteString.hGetLine Handle
handle
ByteString -> IO ()
onLine ByteString
line
IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Builder
ref (\Builder
log -> Builder
log Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
ByteString.byteString ByteString
line)
ensureNoOtherPostgresIsRunning :: IO ()
ensureNoOtherPostgresIsRunning :: IO ()
ensureNoOtherPostgresIsRunning = do
Bool
pidFileExists <- String -> IO Bool
Directory.doesPathExist String
"build/db/state/postmaster.pid"
let stopFailedHandler :: SomeException -> IO ()
stopFailedHandler (SomeException
exception :: SomeException) = do
if (Text
"No such process" Text -> Text -> Bool
`isInfixOf` (SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
exception))
then String -> IO ()
Directory.removeFile String
"build/db/state/postmaster.pid"
else Text -> IO ()
putStrLn Text
"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"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pidFileExists do
(String -> [String] -> IO ()
Process.callProcess String
"pg_ctl" [String
"stop", String
"-D", String
"build/db/state"]) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO ()
stopFailedHandler
needsDatabaseInit :: IO Bool
needsDatabaseInit :: IO Bool
needsDatabaseInit = Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
Directory.doesDirectoryExist String
"build/db/state"
initDatabase :: IO ()
initDatabase :: IO ()
initDatabase = do
String
currentDir <- IO String
Directory.getCurrentDirectory
Bool -> String -> IO ()
Directory.createDirectoryIfMissing Bool
True String
"build/db"
String -> [String] -> IO ()
Process.callProcess String
"initdb" [
String
"build/db/state"
, String
"--no-locale"
, String
"--encoding"
, String
"UTF8"
]
ManagedProcess
process <- CreateProcess -> IO ManagedProcess
createManagedProcess (String -> [String] -> CreateProcess
Process.proc String
"postgres" [String
"-D", String
"build/db/state", String
"-k", String
currentDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/build/db", String
"-c", String
"listen_addresses="])
{ std_in :: StdStream
Process.std_in = StdStream
Process.CreatePipe
, std_out :: StdStream
Process.std_out = StdStream
Process.CreatePipe
, std_err :: StdStream
Process.std_err = StdStream
Process.CreatePipe
}
ManagedProcess -> IO () -> IO ()
forall {b}. ManagedProcess -> IO b -> IO b
waitUntilReady ManagedProcess
process do
String -> [String] -> IO ()
Process.callProcess String
"createdb" [String
"app", String
"-h", String
currentDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/build/db"]
Text
ihpLib <- IO Text
LibDir.findLibDirectory
let importSql :: String -> IO ()
importSql String
file = String -> IO ()
Process.callCommand (String
"psql -h '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
currentDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/build/db' -d app < " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
file)
String -> IO ()
importSql (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
ihpLib String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/IHPSchema.sql")
String -> IO ()
importSql String
"Application/Schema.sql"
String -> IO ()
importSql String
"Application/Fixtures.sql"
let ManagedProcess { ProcessHandle
processHandle :: ProcessHandle
$sel:processHandle:ManagedProcess :: ManagedProcess -> ProcessHandle
processHandle } = ManagedProcess
process
ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
processHandle
ExitCode
_ <- ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
processHandle
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
waitUntilReady :: ManagedProcess -> IO b -> IO b
waitUntilReady ManagedProcess
process IO b
callback = do
let ManagedProcess { Handle
$sel:errorHandle:ManagedProcess :: ManagedProcess -> Handle
errorHandle :: Handle
errorHandle } = ManagedProcess
process
ByteString
line <- Handle -> IO ByteString
ByteString.hGetLine Handle
errorHandle
if ByteString
"database system is ready to accept connections" ByteString -> ByteString -> Bool
`ByteString.isInfixOf` ByteString
line
then IO b
callback
else ManagedProcess -> IO b -> IO b
waitUntilReady ManagedProcess
process IO b
callback
waitPostgres :: (?context :: Context) => IO ()
waitPostgres :: (?context::Context) => IO ()
waitPostgres = do
let isDebugMode :: Bool
isDebugMode = ?context::Context
Context
?context.isDebugMode
Int -> IO ()
threadDelay Int
1000000
(ExitCode
_, String
stdout, String
_) <- String -> [String] -> String -> IO (ExitCode, String, String)
Process.readProcessWithExitCode String
"pg_ctl" [String
"status"] String
""
if Text
"server is running" Text -> Text -> Bool
`isInfixOf` (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
stdout)
then (?context::Context) => Action -> IO ()
Action -> IO ()
dispatch (PostgresState -> Action
UpdatePostgresState PostgresState
PostgresReady)
else do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isDebugMode (Text -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.debug (Text
"Waiting for postgres to start" :: Text))
IO ()
(?context::Context) => IO ()
waitPostgres