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 =
            -- Always log fatal errors to the output:
            -- 2021-09-04 12:18:08.888 CEST [55794] FATAL:  database files are incompatible with server
            --
            -- If we're in debug mode, log all output
            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
            -- pg_ctl: could not send stop signal (PID: 123456765432): No such process
            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" -- Avoid issues with impure host system locale in dev mode
                , 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