@@ -52,7 +52,7 @@
primaryKey = intercalate "---" . map (cs . fromMaybe "" . (.fieldValue)) $ filter ((`elem` primaryKeyFields) . cs . (.fieldName)) fields
renderField primaryKey DynamicField { .. }
| fieldName == "id" = [hsx|
|]
- | isBoolField fieldName tableCols && not (isNothing fieldValue) = [hsx|
|]
+ | isBoolField fieldName tableCols && not (isNothing fieldValue) = [hsx|
|]
| otherwise = renderNormalField primaryKey DynamicField { .. }
renderNormalField primaryKey DynamicField { .. } = [hsx|
@@ -101,7 +101,7 @@
renderPageButton :: Int -> Html
- renderPageButton nr = [hsx|
|]
emptyState :: Html
emptyState = [hsx|
diff --git a/IHP/IDE/FileWatcher.hs b/IHP/IDE/FileWatcher.hs
--- a/IHP/IDE/FileWatcher.hs
+++ b/IHP/IDE/FileWatcher.hs
@@ -5,11 +5,14 @@
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar
import Control.Monad (filterM)
-import System.Directory (listDirectory, doesDirectoryExist)
+import qualified System.Directory.OsPath as Directory
import qualified Data.Map as Map
import qualified System.FSNotify as FS
import qualified Data.List as List
import qualified Control.Debounce as Debounce
+import System.OsPath (encodeUtf, decodeUtf)
+import qualified System.Process as Process
+import qualified System.IO as IO
data FileWatcherParams
= FileWatcherParams
@@ -81,16 +84,39 @@
listWatchableDirectories :: IO [String]
listWatchableDirectories = do
- rootDirectoryContents <- listDirectory "."
- filterM shouldWatchDirectory rootDirectoryContents
+ osEntries <- Directory.listDirectory "."
+ rootDirectoryContents <- mapM decodeUtf osEntries
+ directories <- filterM shouldWatchDirectory rootDirectoryContents
+ filterGitIgnored directories
shouldWatchDirectory :: String -> IO Bool
shouldWatchDirectory path = do
- isDirectory <- doesDirectoryExist path
- pure $ isDirectory && isDirectoryWatchable path
+ osPath <- encodeUtf path
+ Directory.doesDirectoryExist osPath
+-- | Filter out directories that are git-ignored.
+-- Falls back to the old hardcoded exclusion list if git is not available
+-- or the project is not a git repo.
+filterGitIgnored :: [String] -> IO [String]
+filterGitIgnored [] = pure []
+filterGitIgnored dirs = do
+ result <- try @SomeException $ do
+ let process = (Process.proc "git" ("check-ignore" : "--no-index" : dirs))
+ { Process.std_out = Process.CreatePipe
+ , Process.std_err = Process.CreatePipe
+ }
+ Process.withCreateProcess process \_ (Just stdout) _ processHandle -> do
+ output <- IO.hGetContents stdout
+ _ <- evaluate (length output)
+ let ignored = List.lines output
+ _ <- Process.waitForProcess processHandle
+ pure ignored
+ case result of
+ Right ignored -> pure (filter (`notElem` ignored) dirs)
+ Left _ -> pure (filter isDirectoryWatchable dirs)
+
isDirectoryWatchable :: String -> Bool
-isDirectoryWatchable path =
+isDirectoryWatchable path =
path /= ".devenv" && path /= ".direnv"
fileWatcherConfig :: FS.WatchConfig
diff --git a/IHP/IDE/LiveReloadNotificationServer.hs b/IHP/IDE/LiveReloadNotificationServer.hs
--- a/IHP/IDE/LiveReloadNotificationServer.hs
+++ b/IHP/IDE/LiveReloadNotificationServer.hs
@@ -3,7 +3,6 @@
import IHP.Prelude
import qualified Network.WebSockets as Websocket
import qualified Control.Concurrent as Concurrent
-import IHP.IDE.Types
import qualified Control.Exception as Exception
import qualified Data.UUID.V4 as UUID
import qualified Data.Map as Map
diff --git a/IHP/IDE/Logs/Controller.hs b/IHP/IDE/Logs/Controller.hs
--- a/IHP/IDE/Logs/Controller.hs
+++ b/IHP/IDE/Logs/Controller.hs
@@ -4,10 +4,10 @@
import IHP.IDE.ToolServer.Helper.Controller
import IHP.IDE.ToolServer.Types
import IHP.IDE.Logs.View.Logs
-import qualified IHP.IDE.Types as DevServer
+import IHP.IDE.Logs.ServiceLog (discoverServices, getServiceLogs)
import qualified Data.ByteString.Char8 as ByteString
-import qualified Data.ByteString.Builder as ByteString
-import qualified Control.Concurrent.MVar as MVar
+import qualified IHP.EnvVar as EnvVar
+import qualified System.Directory as Directory
instance Controller LogsController where
action AppLogsAction = do
@@ -16,13 +16,32 @@
standardOutput <- cs . ByteString.unlines . reverse <$> readIORef toolServerApp.appStandardOutput
errorOutput <- cs . ByteString.unlines . reverse <$> readIORef toolServerApp.appErrorOutput
+ services <- discoverServices
+ let activeService = "app"
+
render LogsView { .. }
action PostgresLogsAction = do
- toolServerApp <- fromContext @ToolServerApplication
+ pgdata <- EnvVar.env @String "PGDATA"
+ let logFile = pgdata <> "/log/postgresql.log"
- standardOutput <- cs . ByteString.toLazyByteString <$> readIORef toolServerApp.postgresStandardOutput
- errorOutput <- cs . ByteString.toLazyByteString <$> readIORef toolServerApp.postgresErrorOutput
+ logExists <- Directory.doesFileExist logFile
+ standardOutput <- if logExists
+ then cs <$> ByteString.readFile logFile
+ else pure ("Postgres log file not found" :: ByteString)
+ let errorOutput = "" :: ByteString
+
+ services <- discoverServices
+ let activeService = "postgres"
+
+ render LogsView { .. }
+
+ action ServiceLogsAction { serviceName } = do
+ standardOutput <- cs <$> getServiceLogs serviceName
+ let errorOutput = "" :: ByteString
+
+ services <- discoverServices
+ let activeService = serviceName
render LogsView { .. }
diff --git a/IHP/IDE/Logs/ServiceLog.hs b/IHP/IDE/Logs/ServiceLog.hs
new file mode 100644
--- /dev/null
+++ b/IHP/IDE/Logs/ServiceLog.hs
@@ -0,0 +1,157 @@
+-- | Service discovery and log reading for devenv process managers.
+--
+-- Supports process-compose (via @$PC_CONFIG_FILES@) and overmind (via Procfile).
+-- Log lines are read from the process manager's combined log file and filtered
+-- by the @"serviceName |"@ prefix each manager prepends.
+module IHP.IDE.Logs.ServiceLog
+ ( discoverServices
+ , getServiceLogs
+ -- * Pure helpers (exported for testing)
+ , extractProcessComposeNames
+ , filterServiceLines
+ , filterBuiltinServices
+ ) where
+
+import IHP.Prelude
+import qualified IHP.EnvVar as EnvVar
+import qualified System.Directory as Directory
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text.IO
+
+-- | Discover devenv services by checking process-compose config or Procfile.
+-- Returns service names excluding "ihp" and "postgres" (which have dedicated tabs).
+-- Returns @[]@ if no config is found or files are unreadable.
+discoverServices :: IO [Text]
+discoverServices = do
+ pcConfig <- EnvVar.envOrNothing "PC_CONFIG_FILES" :: IO (Maybe String)
+ case pcConfig of
+ Just configPath -> discoverFromProcessCompose configPath
+ Nothing -> do
+ procfileExists <- Directory.doesFileExist "Procfile"
+ if procfileExists
+ then discoverFromProcfile "Procfile"
+ else pure []
+
+-- | Read logs for a specific devenv service from the process manager log file.
+-- Filters lines by the @"serviceName |"@ prefix pattern and returns the last 10 000 lines.
+getServiceLogs :: Text -> IO ByteString
+getServiceLogs serviceName = do
+ logFile <- findProcessManagerLogFile
+ case logFile of
+ Just path -> do
+ exists <- Directory.doesFileExist path
+ if exists
+ then do
+ content <- Text.IO.readFile path
+ let filtered = filterServiceLines serviceName (Text.lines content)
+ let limited = takeLast 10000 filtered
+ pure (cs (Text.unlines limited))
+ else pure ("Log file not found: " <> cs path)
+ Nothing -> pure "No process manager log file found"
+
+------------------------------------------------------------------------
+-- Service discovery
+------------------------------------------------------------------------
+
+discoverFromProcessCompose :: String -> IO [Text]
+discoverFromProcessCompose configPath = do
+ -- PC_CONFIG_FILES can contain multiple paths separated by ","
+ let firstPath = takeWhile (/= ',') configPath
+ exists <- Directory.doesFileExist firstPath
+ if exists
+ then do
+ content <- Text.IO.readFile firstPath
+ pure (filterBuiltinServices (extractProcessComposeNames (Text.lines content)))
+ else pure []
+
+discoverFromProcfile :: String -> IO [Text]
+discoverFromProcfile path = do
+ content <- Text.IO.readFile path
+ let names = mapMaybe parseProcfileLine (Text.lines content)
+ pure (filterBuiltinServices names)
+ where
+ parseProcfileLine line =
+ let stripped = Text.strip line
+ in if Text.null stripped || Text.isPrefixOf "#" stripped
+ then Nothing
+ else case Text.breakOn ":" stripped of
+ (name, rest')
+ | not (Text.null rest'), not (Text.null name)
+ -> Just (Text.strip name)
+ _ -> Nothing
+
+------------------------------------------------------------------------
+-- Log file location
+------------------------------------------------------------------------
+
+findProcessManagerLogFile :: IO (Maybe String)
+findProcessManagerLogFile = do
+ devenvState <- EnvVar.envOrNothing "DEVENV_STATE" :: IO (Maybe String)
+ let baseDirs = maybe [".devenv/state"] (\s -> [s, ".devenv/state"]) devenvState
+ findFirst
+ [ dir <> suffix
+ | dir <- baseDirs
+ , suffix <- ["/process-compose/process-compose.log", "/overmind.log"]
+ ]
+ where
+ findFirst [] = pure Nothing
+ findFirst (p:ps) = do
+ exists <- Directory.doesFileExist p
+ if exists then pure (Just p) else findFirst ps
+
+------------------------------------------------------------------------
+-- Pure helpers
+------------------------------------------------------------------------
+
+-- | Extract process names from process-compose YAML.
+-- Finds the @processes:@ section and extracts direct child keys only,
+-- ignoring deeper-nested keys like @command:@ or @depends_on:@.
+extractProcessComposeNames :: [Text] -> [Text]
+extractProcessComposeNames ls = go Nothing ls
+ where
+ go _ [] = []
+ go state (l:rest)
+ | Text.stripEnd l == "processes:" = go (Just Nothing) rest
+ | Nothing <- state = go Nothing rest
+ | not (Text.null l), not (Text.isPrefixOf " " l), not (Text.isPrefixOf "\t" l) = []
+ | Just mIndent <- state
+ , Just (indent, name) <- parseIndentedKey l
+ = case mIndent of
+ Nothing -> name : go (Just (Just indent)) rest
+ Just expected
+ | indent == expected -> name : go state rest
+ | indent < expected -> []
+ | otherwise -> go state rest
+ | otherwise = go state rest
+
+ parseIndentedKey line =
+ let indent = Text.length (Text.takeWhile (== ' ') line)
+ stripped = Text.strip line
+ in if indent == 0 || Text.null stripped || Text.isPrefixOf "#" stripped
+ then Nothing
+ else case Text.breakOn ":" stripped of
+ (name, rest')
+ | not (Text.null rest'), not (Text.null name), Text.all isNameChar name
+ -> Just (indent, name)
+ _ -> Nothing
+
+ isNameChar c = c == '_' || c == '-' || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9')
+
+-- | Filter log lines belonging to a specific service.
+-- Matches the @"name |"@ or @"name |"@ prefix that process-compose and overmind prepend.
+filterServiceLines :: Text -> [Text] -> [Text]
+filterServiceLines name = mapMaybe extractLine
+ where
+ extractLine line =
+ case Text.breakOn "|" (Text.stripStart line) of
+ (prefix, rest')
+ | not (Text.null rest'), Text.strip prefix == name
+ -> Just (Text.drop 1 rest')
+ _ -> Nothing
+
+-- | Filter out services that already have dedicated tabs.
+filterBuiltinServices :: [Text] -> [Text]
+filterBuiltinServices = filter (\name -> Text.toLower name /= "ihp" && Text.toLower name /= "postgres")
+
+takeLast :: Int -> [a] -> [a]
+takeLast n xs = drop (max 0 (length xs - n)) xs
diff --git a/IHP/IDE/Logs/View/Logs.hs b/IHP/IDE/Logs/View/Logs.hs
--- a/IHP/IDE/Logs/View/Logs.hs
+++ b/IHP/IDE/Logs/View/Logs.hs
@@ -4,17 +4,40 @@
import IHP.IDE.ToolServer.Types
import IHP.IDE.ToolServer.Layout ()
-data LogsView = LogsView { standardOutput :: ByteString, errorOutput :: ByteString }
+data LogsView = LogsView
+ { standardOutput :: ByteString
+ , errorOutput :: ByteString
+ , services :: [Text]
+ , activeService :: Text
+ }
instance View LogsView where
html LogsView { .. } = [hsx|
-
-
App
-
Postgres
+
-
{standardOutput}
-
{errorOutput}
+
+
{standardOutput}
+ {renderStderr}
+
+
|]
+ where
+ renderStderr = if errorOutput /= ""
+ then [hsx|
{errorOutput}|]
+ else mempty
+
+ serviceTab :: Text -> Html
+ serviceTab name = [hsx|
+
{name}
+ |]
diff --git a/IHP/IDE/PortConfig.hs b/IHP/IDE/PortConfig.hs
--- a/IHP/IDE/PortConfig.hs
+++ b/IHP/IDE/PortConfig.hs
@@ -3,6 +3,7 @@
, defaultAppPort
, findAvailablePortConfig
, isPortAvailable
+, createListeningSocket
)
where
@@ -10,9 +11,10 @@
import qualified Network.Socket as Socket
import qualified UnliftIO.Exception as Exception
import Foreign.C.Error (Errno (..), eCONNREFUSED)
-import Control.Exception.Safe (IOException(..))
import GHC.IO.Exception (ioe_errno)
import IHP.FrameworkConfig (defaultPort)
+import qualified System.Posix.IO as Posix
+import System.Posix.Types (Fd(..))
-- | Port configuration used for starting the different app services
data PortConfig = PortConfig
@@ -76,3 +78,19 @@
then pure portConfig
else go rest
go [] = error "findAvailablePortConfig: No port configuration found"
+
+-- | Creates a listening socket bound to the given port on localhost.
+-- The socket is set up with SO_REUSEADDR and a listen backlog of 1024.
+-- This socket can be shared between the status server and the app server
+-- to ensure seamless transitions during app restarts.
+-- The CLOEXEC flag is cleared so child processes (like GHCi) can inherit the socket.
+createListeningSocket :: Socket.PortNumber -> IO Socket.Socket
+createListeningSocket port = do
+ socket <- Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol
+ Socket.setSocketOption socket Socket.ReuseAddr 1
+ Socket.bind socket (Socket.SockAddrInet port (Socket.tupleToHostAddress (127, 0, 0, 1)))
+ Socket.listen socket 1024
+ -- Clear the CLOEXEC flag so child processes (GHCi) can inherit this socket FD
+ fd <- Socket.unsafeFdSocket socket
+ Posix.setFdOption (Fd (fromIntegral fd)) Posix.CloseOnExec False
+ pure socket
diff --git a/IHP/IDE/Postgres.hs b/IHP/IDE/Postgres.hs
--- a/IHP/IDE/Postgres.hs
+++ b/IHP/IDE/Postgres.hs
@@ -1,157 +1,25 @@
-module IHP.IDE.Postgres (withPostgres, withBuiltinOrDevenvPostgres) where
+module IHP.IDE.Postgres (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 Control.Concurrent.MVar
-import GHC.IO.Handle
-import qualified Control.Exception.Safe as Exception
import qualified IHP.Log as Log
import qualified IHP.EnvVar as EnvVar
-import Paths_ihp_ide (getDataFileName)
-withPostgres :: (?context :: Context) => (MVar () -> IORef ByteString.Builder -> IORef ByteString.Builder -> IO a) -> IO a
-withPostgres callback = do
- currentDir <- Directory.getCurrentDirectory
- ensureNoOtherPostgresIsRunning
- shouldInit <- needsDatabaseInit
- when shouldInit initDatabase
-
- Process.withCreateProcess (postgresProcessParams currentDir) \(Just inputHandle) (Just outputHandle) (Just errorHandle) processHandle -> do
- let main = do
- standardOutput <- newIORef mempty
- errorOutput <- newIORef mempty
- databaseIsReady <- newEmptyMVar
-
- redirectHandleToVariable standardOutput outputHandle handleOutdatedDatabase
- redirectHandleToVariable errorOutput errorHandle (handleOutdatedDatabase >> handleDatabaseReady databaseIsReady)
-
- callback databaseIsReady standardOutput errorOutput
-
- Exception.finally main (softStopPostgres processHandle)
-
-softStopPostgres :: Process.ProcessHandle -> IO ()
-softStopPostgres processHandle = do
- let interruptAndWait = Process.interruptProcessGroupOf processHandle >> Process.waitForProcess processHandle
- let waitAndKill = threadDelay 1000000 >> pure ()
- race_
- interruptAndWait
- waitAndKill
-
-postgresProcessParams :: (?context :: Context) => FilePath -> Process.CreateProcess
-postgresProcessParams workingDirectory =
- let
- args = ["-D", "build/db/state", "-k", workingDirectory <> "/build/db", "-c", "listen_addresses="]
- in (procDirenvAware "postgres" args)
- { Process.std_in = Process.CreatePipe
- , Process.std_out = Process.CreatePipe
- , Process.std_err = Process.CreatePipe
- , Process.create_group = True
- }
-
-handleDatabaseReady :: MVar () -> ByteString -> IO ()
-handleDatabaseReady onReady line = when ("database system is ready to accept connections" `ByteString.isInfixOf` line) (putMVar onReady ())
-
-handleOutdatedDatabase :: (?context :: Context) => ByteString -> IO ()
-handleOutdatedDatabase 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 "FATAL" `ByteString.isInfixOf` line
- then if "database files are incompatible with server" `ByteString.isInfixOf` line
- then Log.error ("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 Log.error line
- else when ?context.isDebugMode (Log.debug line)
-
-redirectHandleToVariable :: IORef ByteString.Builder -> Handle -> (ByteString -> IO ()) -> IO (Async ())
-redirectHandleToVariable !ref !handle !onLine = do
- async $ forever $ do
- line <- ByteString.hGetLine handle
- onLine line
- modifyIORef ref (\log -> log <> "\n" <> ByteString.byteString line)
-
-ensureNoOtherPostgresIsRunning :: IO ()
-ensureNoOtherPostgresIsRunning = do
- pidFileExists <- Directory.doesPathExist "build/db/state/postmaster.pid"
- let stopFailedHandler (exception :: SomeException) = do
- -- pg_ctl: could not send stop signal (PID: 123456765432): No such process
- if ("No such process" `isInfixOf` (tshow exception))
- 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
-
-needsDatabaseInit :: IO Bool
-needsDatabaseInit = not <$> Directory.doesDirectoryExist "build/db/state"
-
-initDatabase :: IO ()
-initDatabase = do
- currentDir <- Directory.getCurrentDirectory
- Directory.createDirectoryIfMissing True "build/db"
-
- Process.callProcess "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", currentDir <> "/build/db", "-c", "listen_addresses="])
- { Process.std_in = Process.CreatePipe
- , Process.std_out = Process.CreatePipe
- , Process.std_err = Process.CreatePipe
- }
-
- Process.withCreateProcess params \(Just inputHandle) (Just outputHandle) (Just errorHandle) processHandle -> do
- waitUntilReady errorHandle do
- Process.callProcess "createdb" ["app", "-h", currentDir <> "/build/db"]
-
- let importSql file = Process.callCommand ("psql -h '" <> currentDir <> "/build/db' -d app < " <> file)
- ihpSchemaSql <- getDataFileName "IHPSchema.sql"
- importSql ihpSchemaSql
- importSql "Application/Schema.sql"
- importSql "Application/Fixtures.sql"
-
- Process.terminateProcess processHandle
- _ <- Process.waitForProcess processHandle
- pure ()
-
-waitUntilReady handle callback = do
- line <- ByteString.hGetLine handle
- if "database system is ready to accept connections" `ByteString.isInfixOf` line
- then callback
- else waitUntilReady handle callback
+import qualified System.Process as Process
+import System.Exit (ExitCode(..))
waitPostgres :: (?context :: Context) => IO ()
waitPostgres = do
let isDebugMode = ?context.isDebugMode
- threadDelay 1000000
- (_, stdout, _) <- Process.readProcessWithExitCode "pg_ctl" ["status"] ""
- if "server is running" `isInfixOf` (cs stdout)
- then pure ()
- else do
- when isDebugMode (Log.debug ("Waiting for postgres to start" :: Text))
- waitPostgres
-
-
-withBuiltinOrDevenvPostgres :: (?context :: Context) => (MVar () -> IORef ByteString.Builder -> IORef ByteString.Builder -> IO a) -> IO a
-withBuiltinOrDevenvPostgres callback = do
- useDevenv <- EnvVar.envOrDefault "IHP_DEVENV" False
- if useDevenv
- then do
- waitPostgres
-
- -- For devenv postgres we don't have access to the postgres logs
- standardOutput <- newIORef mempty
- errorOutput <- newIORef mempty
- databaseIsReady <- newMVar ()
+ socketDir <- EnvVar.env @String "PGHOST"
- callback databaseIsReady standardOutput errorOutput
- else do
- withPostgres callback
+ -- pg_isready returns exit code 0 when ready, non-zero otherwise
+ exitCode <- Process.rawSystem "pg_isready" ["-h", socketDir, "-q"]
+ case exitCode of
+ ExitSuccess -> pure ()
+ ExitFailure _ -> do
+ when isDebugMode (Log.debug ("Waiting for postgres to start" :: Text))
+ threadDelay 100000 -- 100ms between checks
+ waitPostgres
diff --git a/IHP/IDE/Prelude.hs b/IHP/IDE/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/IHP/IDE/Prelude.hs
@@ -0,0 +1,38 @@
+{-# OPTIONS_HADDOCK not-home, hide #-}
+-- | Minimal prelude for IDE controllers
+--
+-- This module provides a focused subset of 'IHP.ControllerPrelude' optimized
+-- for faster compilation of IDE controllers. It includes only the commonly
+-- needed imports for SchemaDesigner and other IDE controllers.
+module IHP.IDE.Prelude
+ ( module IHP.Prelude
+ , module IHP.ControllerSupport
+ , module IHP.Controller.Param
+ , module IHP.Controller.Render
+ , module IHP.Controller.Redirect
+ , module IHP.Controller.Layout
+ , module IHP.FlashMessages
+ , module IHP.Modal.Types
+ , setModal
+ , module IHP.ValidationSupport
+ ) where
+
+import IHP.Prelude
+import IHP.ControllerSupport
+import IHP.Controller.Param
+import IHP.Controller.Render
+import IHP.Controller.Redirect
+import IHP.Controller.Layout
+import IHP.FlashMessages
+import IHP.Modal.Types
+import qualified IHP.Modal.ControllerFunctions as Modal
+import IHP.ViewSupport (View)
+import qualified IHP.ViewSupport as ViewSupport
+import IHP.ValidationSupport
+
+-- | Renders a view and stores it as modal HTML in the context for later rendering.
+--
+-- > setModal MyModalView { .. }
+--
+setModal :: (?context :: ControllerContext, ?request :: Request, View view) => view -> IO ()
+setModal view = let ?view = view in Modal.setModal (ViewSupport.html view)
diff --git a/IHP/IDE/SchemaDesigner/Compiler.hs b/IHP/IDE/SchemaDesigner/Compiler.hs
--- a/IHP/IDE/SchemaDesigner/Compiler.hs
+++ b/IHP/IDE/SchemaDesigner/Compiler.hs
@@ -1,507 +1,19 @@
{-|
Module: IHP.IDE.SchemaDesigner.Compiler
-Description: Compiles AST of SQL to DDL
+Description: IHP-specific schema file utilities
Copyright: (c) digitally induced GmbH, 2020
-}
-module IHP.IDE.SchemaDesigner.Compiler (compileSql, writeSchema, compileIdentifier, compileExpression, compilePostgresType, compileIndexColumn) where
+module IHP.IDE.SchemaDesigner.Compiler
+( writeSchema
+) where
import IHP.Prelude
-import IHP.IDE.SchemaDesigner.Types
-import Data.Maybe (fromJust)
+import IHP.Postgres.Compiler (compileSql, compareStatement)
+import IHP.Postgres.Types (Statement)
import qualified Data.Text.IO as Text
-import qualified Data.Text as Text
+-- | Write statements to the IHP schema file at 'Application/Schema.sql'
writeSchema :: [Statement] -> IO ()
writeSchema !statements = do
let sortedStatements = sortBy compareStatement statements
Text.writeFile "Application/Schema.sql" (compileSql sortedStatements)
-
-compileSql :: [Statement] -> Text
-compileSql statements = statements
- |> map compileStatement
- |> unlines
-
-compileStatement :: Statement -> Text
-compileStatement (StatementCreateTable CreateTable { name, columns, primaryKeyConstraint, constraints, unlogged }) = "CREATE" <> (if unlogged then " UNLOGGED" else "") <> " TABLE " <> compileIdentifier name <> " (\n" <> intercalate ",\n" (map (\col -> " " <> compileColumn primaryKeyConstraint col) columns <> maybe [] ((:[]) . indent) (compilePrimaryKeyConstraint primaryKeyConstraint) <> map (indent . compileConstraint) constraints) <> "\n);"
-compileStatement CreateEnumType { name, values } = "CREATE TYPE " <> compileIdentifier name <> " AS ENUM (" <> intercalate ", " (values |> map TextExpression |> map compileExpression) <> ");"
-compileStatement CreateExtension { name, ifNotExists } = "CREATE EXTENSION " <> (if ifNotExists then "IF NOT EXISTS " else "") <> compileIdentifier name <> ";"
-compileStatement AddConstraint { tableName, constraint = UniqueConstraint { name = Nothing, columnNames } } = "ALTER TABLE " <> compileIdentifier tableName <> " ADD UNIQUE (" <> intercalate ", " columnNames <> ")" <> ";"
-compileStatement AddConstraint { tableName, constraint, deferrable, deferrableType } = "ALTER TABLE " <> compileIdentifier tableName <> " ADD CONSTRAINT " <> compileIdentifier (fromMaybe (error "compileStatement: Expected constraint name") (constraint.name)) <> " " <> compileConstraint constraint <> compileDeferrable deferrable deferrableType <> ";"
-compileStatement AddColumn { tableName, column } = "ALTER TABLE " <> compileIdentifier tableName <> " ADD COLUMN " <> (compileColumn (PrimaryKeyConstraint []) column) <> ";"
-compileStatement DropColumn { tableName, columnName } = "ALTER TABLE " <> compileIdentifier tableName <> " DROP COLUMN " <> compileIdentifier columnName <> ";"
-compileStatement RenameColumn { tableName, from, to } = "ALTER TABLE " <> compileIdentifier tableName <> " RENAME COLUMN " <> compileIdentifier from <> " TO " <> compileIdentifier to <> ";"
-compileStatement DropTable { tableName } = "DROP TABLE " <> compileIdentifier tableName <> ";"
-compileStatement Comment { content } = "--" <> content
-compileStatement CreateIndex { indexName, unique, tableName, columns, whereClause, indexType } = "CREATE" <> (if unique then " UNIQUE " else " ") <> "INDEX " <> compileIdentifier indexName <> " ON " <> compileIdentifier tableName <> (maybe "" (\indexType -> " USING " <> compileIndexType indexType) indexType) <> " (" <> (intercalate ", " (map compileIndexColumn columns)) <> ")" <> (case whereClause of Just expression -> " WHERE " <> compileExpression expression; Nothing -> "") <> ";"
-compileStatement CreateFunction { functionName, functionArguments, functionBody, orReplace, returns, language } = "CREATE " <> (if orReplace then "OR REPLACE " else "") <> "FUNCTION " <> functionName <> "(" <> (functionArguments |> map (\(argName, argType) -> argName ++ " " ++ compilePostgresType argType) |> intercalate ", ") <> ")" <> " RETURNS " <> compilePostgresType returns <> " AS $$" <> functionBody <> "$$ language " <> language <> ";"
-compileStatement EnableRowLevelSecurity { tableName } = "ALTER TABLE " <> compileIdentifier tableName <> " ENABLE ROW LEVEL SECURITY;"
-compileStatement CreatePolicy { name, action, tableName, using, check } = "CREATE POLICY " <> compileIdentifier name <> " ON " <> compileIdentifier tableName <> maybe "" (\action -> " FOR " <> compilePolicyAction action) action <> maybe "" (\expr -> " USING (" <> compileExpression expr <> ")") using <> maybe "" (\expr -> " WITH CHECK (" <> compileExpression expr <> ")") check <> ";"
-compileStatement CreateSequence { name } = "CREATE SEQUENCE " <> compileIdentifier name <> ";"
-compileStatement DropConstraint { tableName, constraintName } = "ALTER TABLE " <> compileIdentifier tableName <> " DROP CONSTRAINT " <> compileIdentifier constraintName <> ";"
-compileStatement DropEnumType { name } = "DROP TYPE " <> compileIdentifier name <> ";"
-compileStatement DropIndex { indexName } = "DROP INDEX " <> compileIdentifier indexName <> ";"
-compileStatement DropNotNull { tableName, columnName } = "ALTER TABLE " <> compileIdentifier tableName <> " ALTER COLUMN " <> compileIdentifier columnName <> " DROP NOT NULL;"
-compileStatement SetNotNull { tableName, columnName } = "ALTER TABLE " <> compileIdentifier tableName <> " ALTER COLUMN " <> compileIdentifier columnName <> " SET NOT NULL;"
-compileStatement RenameTable { from, to } = "ALTER TABLE " <> compileIdentifier from <> " RENAME TO " <> compileIdentifier to <> ";"
-compileStatement DropPolicy { tableName, policyName } = "DROP POLICY " <> compileIdentifier policyName <> " ON " <> compileIdentifier tableName <> ";"
-compileStatement SetDefaultValue { tableName, columnName, value } = "ALTER TABLE " <> compileIdentifier tableName <> " ALTER COLUMN " <> compileIdentifier columnName <> " SET DEFAULT " <> compileExpression value <> ";"
-compileStatement DropDefaultValue { tableName, columnName } = "ALTER TABLE " <> compileIdentifier tableName <> " ALTER COLUMN " <> compileIdentifier columnName <> " DROP DEFAULT;"
-compileStatement AddValueToEnumType { enumName, newValue } = "ALTER TYPE " <> compileIdentifier enumName <> " ADD VALUE " <> compileExpression (TextExpression newValue) <> ";"
-compileStatement CreateTrigger { name, eventWhen, event, tableName, for, whenCondition, functionName, arguments } = "CREATE TRIGGER " <> compileIdentifier name <> " " <> compileTriggerEventWhen eventWhen <> " " <> compileTriggerEvent event <> " ON " <> compileIdentifier tableName <> " " <> compileTriggerFor for <> " EXECUTE FUNCTION " <> compileExpression (CallExpression functionName arguments) <> ";"
-compileStatement Begin = "BEGIN;"
-compileStatement Commit = "COMMIT;"
-compileStatement DropFunction { functionName } = "DROP FUNCTION " <> compileIdentifier functionName <> ";"
-compileStatement UnknownStatement { raw } = raw <> ";"
-compileStatement Set { name, value } = "SET " <> compileIdentifier name <> " = " <> compileExpression value <> ";"
-compileStatement SelectStatement { query } = "SELECT " <> query <> ";"
-compileStatement DropTrigger { name, tableName } = "DROP TRIGGER " <> compileIdentifier name <> " ON " <> compileIdentifier tableName <> ";"
-compileStatement CreateEventTrigger { name, eventOn, whenCondition, functionName, arguments } = "CREATE EVENT TRIGGER " <> compileIdentifier name <> " ON " <> compileIdentifier eventOn <> " " <> (maybe "" (\expression -> "WHEN " <> compileExpression expression) whenCondition) <> " EXECUTE FUNCTION " <> compileExpression (CallExpression functionName arguments) <> ";"
-compileStatement DropEventTrigger { name } = "DROP EVENT TRIGGER " <> compileIdentifier name <> ";"
-
--- | Emit a PRIMARY KEY constraint when there are multiple primary key columns
-compilePrimaryKeyConstraint :: PrimaryKeyConstraint -> Maybe Text
-compilePrimaryKeyConstraint PrimaryKeyConstraint { primaryKeyColumnNames } =
- case primaryKeyColumnNames of
- [] -> Nothing
- [_] -> Nothing
- names -> Just $ "PRIMARY KEY(" <> intercalate ", " names <> ")"
-
-compileConstraint :: Constraint -> Text
-compileConstraint ForeignKeyConstraint { columnName, referenceTable, referenceColumn, onDelete } = "FOREIGN KEY (" <> compileIdentifier columnName <> ") REFERENCES " <> compileIdentifier referenceTable <> (if isJust referenceColumn then " (" <> fromJust referenceColumn <> ")" else "") <> " " <> compileOnDelete onDelete
-compileConstraint UniqueConstraint { columnNames } = "UNIQUE(" <> intercalate ", " columnNames <> ")"
-compileConstraint CheckConstraint { checkExpression } = "CHECK (" <> compileExpression checkExpression <> ")"
-compileConstraint ExcludeConstraint { excludeElements, predicate, indexType } = "EXCLUDE" <> compiledIndexType <> " (" <> compiledExcludeElements <> ")" <> case predicate of
- Just expression -> " WHERE (" <> compileExpression expression <> ")"
- Nothing -> ""
- where
- compiledExcludeElements = intercalate ", " $ map compileExcludeElement excludeElements
-
- compileExcludeElement ExcludeConstraintElement { element, operator } = element <> " WITH " <> operator
-
- compiledIndexType = case indexType of
- Nothing -> ""
- Just indexType -> " USING " <> compileIndexType indexType
-
-compileDeferrable :: Maybe Bool -> Maybe DeferrableType -> Text
-compileDeferrable deferrable deferrableType = Text.concat $ map ((<>) " ") $ catMaybes [compileIsDeferrable <$> deferrable, compileDeferrableType <$> deferrableType]
- where
- compileIsDeferrable True = "DEFERRABLE"
- compileIsDeferrable False = "NOT DEFERRABLE"
- compileDeferrableType InitiallyImmediate = "INITIALLY IMMEDIATE"
- compileDeferrableType InitiallyDeferred = "INITIALLY DEFERRED"
-
-compileOnDelete :: Maybe OnDelete -> Text
-compileOnDelete Nothing = ""
-compileOnDelete (Just NoAction) = "ON DELETE NO ACTION"
-compileOnDelete (Just Restrict) = "ON DELETE RESTRICT"
-compileOnDelete (Just SetNull) = "ON DELETE SET NULL"
-compileOnDelete (Just SetDefault) = "ON DELETE SET DEFAULT"
-compileOnDelete (Just Cascade) = "ON DELETE CASCADE"
-
-compileColumn :: PrimaryKeyConstraint -> Column -> Text
-compileColumn primaryKeyConstraint Column { name, columnType, defaultValue, notNull, isUnique, generator } =
- unwords (catMaybes
- [ Just (compileIdentifier name)
- , Just (compilePostgresType columnType)
- , fmap compileDefaultValue defaultValue
- , fmap compileGenerator generator
- , primaryKeyColumnConstraint
- , if notNull then Just "NOT NULL" else Nothing
- , if isUnique then Just "UNIQUE" else Nothing
- ])
- where
- -- Emit a PRIMARY KEY column constraint if this is the only primary key column
- primaryKeyColumnConstraint = case primaryKeyConstraint of
- PrimaryKeyConstraint [primaryKeyColumn]
- | name == primaryKeyColumn -> Just "PRIMARY KEY"
- | otherwise -> Nothing
- PrimaryKeyConstraint _ -> Nothing
-
-compileDefaultValue :: Expression -> Text
-compileDefaultValue value = "DEFAULT " <> compileExpression value
-
-compileExpression :: Expression -> Text
-compileExpression (TextExpression value) = "'" <> value <> "'"
-compileExpression (VarExpression name) =
- if nameContainsSpaces
- then compileIdentifier name
- else name
- where
- nameContainsSpaces = Text.any (== ' ') name
-compileExpression (CallExpression func args) = func <> "(" <> intercalate ", " (map compileExpressionWithOptionalParenthese args) <> ")"
-compileExpression (NotEqExpression a b) = compileExpression a <> " <> " <> compileExpression b
-compileExpression (EqExpression a b) = compileExpressionWithOptionalParenthese a <> " = " <> compileExpressionWithOptionalParenthese b
-compileExpression (IsExpression a (NotExpression b)) = compileExpressionWithOptionalParenthese a <> " IS NOT " <> compileExpressionWithOptionalParenthese b -- 'IS (NOT NULL)' => 'IS NOT NULL'
-compileExpression (IsExpression a b) = compileExpressionWithOptionalParenthese a <> " IS " <> compileExpressionWithOptionalParenthese b
-compileExpression (InExpression a b) = compileExpressionWithOptionalParenthese a <> " IN " <> compileExpressionWithOptionalParenthese b
-compileExpression (InArrayExpression values) = "(" <> intercalate ", " (map compileExpression values) <> ")"
-compileExpression (NotExpression a) = "NOT " <> compileExpressionWithOptionalParenthese a
-compileExpression (AndExpression a b) = compileExpressionWithOptionalParenthese a <> " AND " <> compileExpressionWithOptionalParenthese b
-compileExpression (OrExpression a b) = compileExpressionWithOptionalParenthese a <> " OR " <> compileExpressionWithOptionalParenthese b
-compileExpression (LessThanExpression a b) = compileExpressionWithOptionalParenthese a <> " < " <> compileExpressionWithOptionalParenthese b
-compileExpression (LessThanOrEqualToExpression a b) = compileExpressionWithOptionalParenthese a <> " <= " <> compileExpressionWithOptionalParenthese b
-compileExpression (GreaterThanExpression a b) = compileExpressionWithOptionalParenthese a <> " > " <> compileExpressionWithOptionalParenthese b
-compileExpression (GreaterThanOrEqualToExpression a b) = compileExpressionWithOptionalParenthese a <> " >= " <> compileExpressionWithOptionalParenthese b
-compileExpression (DoubleExpression double) = tshow double
-compileExpression (IntExpression integer) = tshow integer
-compileExpression (TypeCastExpression value type_) = compileExpression value <> "::" <> compilePostgresType type_
-compileExpression (SelectExpression Select { columns, from, whereClause }) = "SELECT " <> intercalate ", " (map compileExpression columns) <> " FROM " <> compileExpression from <> " WHERE " <> compileExpression whereClause
-compileExpression (ExistsExpression a) = "EXISTS " <> compileExpressionWithOptionalParenthese a
-compileExpression (DotExpression a b) = compileExpressionWithOptionalParenthese a <> "." <> compileIdentifier b
-compileExpression (ConcatenationExpression a b) = compileExpressionWithOptionalParenthese a <> " || " <> compileExpressionWithOptionalParenthese b
-
-compileExpressionWithOptionalParenthese :: Expression -> Text
-compileExpressionWithOptionalParenthese expr@(VarExpression {}) = compileExpression expr
-compileExpressionWithOptionalParenthese expr@(IsExpression a (NotExpression b)) = compileExpression a <> " IS " <> compileExpression (NotExpression b) -- 'IS (NOT NULL)' => 'IS NOT NULL'
-compileExpressionWithOptionalParenthese expr@(IsExpression {}) = compileExpression expr
-compileExpressionWithOptionalParenthese expr@(EqExpression {}) = compileExpression expr
-compileExpressionWithOptionalParenthese expr@(AndExpression a@(AndExpression {}) b ) = "(" <> compileExpression a <> " AND " <> compileExpressionWithOptionalParenthese b <> ")" -- '(a AND b) AND c' => 'a AND b AND C'
-compileExpressionWithOptionalParenthese expr@(AndExpression a b@(AndExpression {}) ) = "(" <> compileExpressionWithOptionalParenthese a <> " AND " <> compileExpression b <> ")" -- 'a AND (b AND c)' => 'a AND b AND C'
---compileExpressionWithOptionalParenthese expr@(OrExpression a@(IsExpression {}) b ) = compileExpressionWithOptionalParenthese a <> " OR " <> compileExpressionWithOptionalParenthese b -- '(a IS NULL) OR b' => 'A IS NULL OR b'
-compileExpressionWithOptionalParenthese expr@(CallExpression {}) = compileExpression expr
-compileExpressionWithOptionalParenthese expr@(TextExpression {}) = compileExpression expr
-compileExpressionWithOptionalParenthese expr@(IntExpression {}) = compileExpression expr
-compileExpressionWithOptionalParenthese expr@(DoubleExpression {}) = compileExpression expr
-compileExpressionWithOptionalParenthese expr@(DotExpression (VarExpression {}) b) = compileExpression expr
-compileExpressionWithOptionalParenthese expr@(ConcatenationExpression a b ) = compileExpression expr
-compileExpressionWithOptionalParenthese expr@(InArrayExpression values) = compileExpression expr
-compileExpressionWithOptionalParenthese expression = "(" <> compileExpression expression <> ")"
-
-compareStatement (CreateEnumType {}) _ = LT
-compareStatement (StatementCreateTable CreateTable {}) (AddConstraint {}) = LT
-compareStatement (AddConstraint { constraint = a }) (AddConstraint { constraint = b }) = compare (a.name) (b.name)
-compareStatement (AddConstraint {}) _ = GT
-compareStatement _ _ = EQ
-
-compilePostgresType :: PostgresType -> Text
-compilePostgresType PUUID = "UUID"
-compilePostgresType PText = "TEXT"
-compilePostgresType PInt = "INT"
-compilePostgresType PSmallInt = "SMALLINT"
-compilePostgresType PBigInt = "BIGINT"
-compilePostgresType PBoolean = "BOOLEAN"
-compilePostgresType PTimestamp = "TIMESTAMP WITHOUT TIME ZONE"
-compilePostgresType PTimestampWithTimezone = "TIMESTAMP WITH TIME ZONE"
-compilePostgresType PReal = "REAL"
-compilePostgresType PDouble = "DOUBLE PRECISION"
-compilePostgresType PPoint = "POINT"
-compilePostgresType PPolygon = "POLYGON"
-compilePostgresType PDate = "DATE"
-compilePostgresType PBinary = "BYTEA"
-compilePostgresType PTime = "TIME"
-compilePostgresType (PInterval Nothing) = "INTERVAL"
-compilePostgresType (PInterval (Just fields)) = "INTERVAL" <> " " <> fields
-compilePostgresType (PNumeric (Just precision) (Just scale)) = "NUMERIC(" <> show precision <> "," <> show scale <> ")"
-compilePostgresType (PNumeric (Just precision) Nothing) = "NUMERIC(" <> show precision <> ")"
-compilePostgresType (PNumeric Nothing _) = "NUMERIC"
-compilePostgresType (PVaryingN (Just limit)) = "CHARACTER VARYING(" <> show limit <> ")"
-compilePostgresType (PVaryingN Nothing) = "CHARACTER VARYING"
-compilePostgresType (PCharacterN length) = "CHARACTER(" <> show length <> ")"
-compilePostgresType PSingleChar = "\"char\""
-compilePostgresType PSerial = "SERIAL"
-compilePostgresType PBigserial = "BIGSERIAL"
-compilePostgresType PJSONB = "JSONB"
-compilePostgresType PInet = "INET"
-compilePostgresType PTSVector = "TSVECTOR"
-compilePostgresType (PArray type_) = compilePostgresType type_ <> "[]"
-compilePostgresType PTrigger = "TRIGGER"
-compilePostgresType PEventTrigger = "EVENT_TRIGGER"
-compilePostgresType (PCustomType theType) = theType
-
-compileIdentifier :: Text -> Text
-compileIdentifier identifier = if identifierNeedsQuoting then tshow identifier else identifier
- where
- identifierNeedsQuoting = isKeyword || containsChar ' ' || containsChar '-' || isUsingUppercase
- isKeyword = IHP.Prelude.toUpper identifier `elem` keywords
- containsChar char = Text.any (char ==) identifier
- isUsingUppercase = Text.toLower identifier /= identifier
-
- keywords = [ "ABORT"
- , "ABSOLUTE"
- , "ACCESS"
- , "ACTION"
- , "ADD"
- , "ADMIN"
- , "AFTER"
- , "AGGREGATE"
- , "ALSO"
- , "ALTER"
- , "ASSERTION"
- , "ASSIGNMENT"
- , "AT"
- , "ALL"
- , "BACKWARD"
- , "BEFORE"
- , "BEGIN"
- , "BY"
- , "CACHE"
- , "CALLED"
- , "CASCADE"
- , "CHAIN"
- , "CHARACTERISTICS"
- , "CHECKPOINT"
- , "CLASS"
- , "CLOSE"
- , "CLUSTER"
- , "COMMENT"
- , "COMMIT"
- , "COMMITTED"
- , "CONNECTION"
- , "CONSTRAINTS"
- , "CONVERSION"
- , "COPY"
- , "CREATEDB"
- , "CREATEROLE"
- , "CREATEUSER"
- , "CSV"
- , "CURSOR"
- , "CYCLE"
- , "DATABASE"
- , "DAY"
- , "DEALLOCATE"
- , "DECLARE"
- , "DEFAULTS"
- , "DEFERRED"
- , "DEFINER"
- , "DELETE"
- , "DELIMITER"
- , "DELIMITERS"
- , "DISABLE"
- , "DOMAIN"
- , "DOUBLE"
- , "DROP"
- , "EACH"
- , "ENABLE"
- , "ENCODING"
- , "ENCRYPTED"
- , "ESCAPE"
- , "EXCLUDING"
- , "EXCLUSIVE"
- , "EXECUTE"
- , "EXPLAIN"
- , "EXTERNAL"
- , "FETCH"
- , "FIRST"
- , "FORCE"
- , "FORWARD"
- , "FUNCTION"
- , "GLOBAL"
- , "GRANTED"
- , "HANDLER"
- , "HEADER"
- , "HOLD"
- , "HOUR"
- , "IMMEDIATE"
- , "IMMUTABLE"
- , "IMPLICIT"
- , "INCLUDING"
- , "INCREMENT"
- , "INDEX"
- , "INHERIT"
- , "INHERITS"
- , "INPUT"
- , "INSENSITIVE"
- , "INSERT"
- , "INSTEAD"
- , "INVOKER"
- , "ISOLATION"
- , "KEY"
- , "LANCOMPILER"
- , "LANGUAGE"
- , "LARGE"
- , "LAST"
- , "LEVEL"
- , "LISTEN"
- , "LOAD"
- , "LOCAL"
- , "LOCATION"
- , "LOCK"
- , "LOGIN"
- , "MATCH"
- , "MAXVALUE"
- , "MINUTE"
- , "MINVALUE"
- , "MODE"
- , "MONTH"
- , "MOVE"
- , "NAMES"
- , "NEXT"
- , "NO"
- , "NOCREATEDB"
- , "NOCREATEROLE"
- , "NOCREATEUSER"
- , "NOINHERIT"
- , "NOLOGIN"
- , "NOSUPERUSER"
- , "NOTHING"
- , "NOTIFY"
- , "NOWAIT"
- , "OBJECT"
- , "OF"
- , "OIDS"
- , "OPERATOR"
- , "OPTION"
- , "OWNER"
- , "PARTIAL"
- , "PASSWORD"
- , "PREPARE"
- , "PREPARED"
- , "PRESERVE"
- , "PRIOR"
- , "PRIVILEGES"
- , "PROCEDURAL"
- , "PROCEDURE"
- , "QUOTE"
- , "READ"
- , "RECHECK"
- , "REINDEX"
- , "RELATIVE"
- , "RELEASE"
- , "RENAME"
- , "REPEATABLE"
- , "REPLACE"
- , "RESET"
- , "RESTART"
- , "RESTRICT"
- , "RETURNS"
- , "REVOKE"
- , "ROLE"
- , "ROLLBACK"
- , "ROWS"
- , "RULE"
- , "SAVEPOINT"
- , "SCHEMA"
- , "SCROLL"
- , "SECOND"
- , "SECURITY"
- , "SEQUENCE"
- , "SERIALIZABLE"
- , "SESSION"
- , "SET"
- , "SHARE"
- , "tshow"
- , "SIMPLE"
- , "STABLE"
- , "START"
- , "STATEMENT"
- , "STATISTICS"
- , "STDIN"
- , "STDOUT"
- , "STORAGE"
- , "STRICT"
- , "SUPERUSER"
- , "SYSID"
- , "SYSTEM"
- , "TABLESPACE"
- , "TEMP"
- , "TEMPLATE"
- , "TEMPORARY"
- , "TOAST"
- , "TRANSACTION"
- , "TRIGGER"
- , "TRUNCATE"
- , "TRUSTED"
- , "TYPE"
- , "UNCOMMITTED"
- , "UNENCRYPTED"
- , "UNKNOWN"
- , "UNLISTEN"
- , "UNTIL"
- , "UPDATE"
- , "VACUUM"
- , "VALID"
- , "VALIDATOR"
- , "VALUES"
- , "VARYING"
- , "VIEW"
- , "VOLATILE"
- , "WITH"
- , "WITHOUT"
- , "WORK"
- , "WRITE"
- , "YEAR"
- , "ZONE"
- , "BIGINT"
- , "BIT"
- , "BOOLEAN"
- , "CHAR"
- , "CHARACTER"
- , "COALESCE"
- , "CONVERT"
- , "DEC"
- , "DECIMAL"
- , "EXISTS"
- , "EXTRACT"
- , "FLOAT"
- , "GREATEST"
- , "INOUT"
- , "INT"
- , "INTEGER"
- , "INTERVAL"
- , "LEAST"
- , "NATIONAL"
- , "NCHAR"
- , "NONE"
- , "NULLIF"
- , "NUMERIC"
- , "OUT"
- , "OVERLAY"
- , "POSITION"
- , "PRECISION"
- , "REAL"
- , "ROW"
- , "SETOF"
- , "SMALLINT"
- , "SUBSTRING"
- , "TIME"
- , "TIMESTAMP"
- , "TREAT"
- , "TRIM"
- , "VARCHAR"
- ]
-
-indent text = " " <> text
-
-compileTriggerEventWhen :: TriggerEventWhen -> Text
-compileTriggerEventWhen Before = "BEFORE"
-compileTriggerEventWhen After = "AFTER"
-compileTriggerEventWhen InsteadOf = "INSTEAD OF"
-
-compileTriggerEvent :: TriggerEvent -> Text
-compileTriggerEvent TriggerOnInsert = "INSERT"
-compileTriggerEvent TriggerOnUpdate = "UPDATE"
-compileTriggerEvent TriggerOnDelete = "DELETE"
-compileTriggerEvent TriggerOnTruncate = "TRUNCATE"
-
-compileTriggerFor :: TriggerFor -> Text
-compileTriggerFor ForEachRow = "FOR EACH ROW"
-compileTriggerFor ForEachStatement = "FOR EACH STATEMENT"
-
-compilePolicyAction :: PolicyAction -> Text
-compilePolicyAction PolicyForAll = "ALL"
-compilePolicyAction PolicyForSelect = "SELECT"
-compilePolicyAction PolicyForInsert = "INSERT"
-compilePolicyAction PolicyForUpdate = "UPDATE"
-compilePolicyAction PolicyForDelete = "DELETE"
-
-compileGenerator :: ColumnGenerator -> Text
-compileGenerator ColumnGenerator { generate, stored } =
- "GENERATED ALWAYS AS ("
- <> compileExpressionWithOptionalParenthese generate
- <> ")"
- <> (if stored then " STORED" else "")
-
-compileIndexType :: IndexType -> Text
-compileIndexType Gin = "GIN"
-compileIndexType Btree = "BTREE"
-compileIndexType Gist = "GIST"
-
-compileIndexColumn :: IndexColumn -> Text
-compileIndexColumn IndexColumn { column, columnOrder = [] } = compileExpression column
-compileIndexColumn IndexColumn { column, columnOrder } = compileExpression column <> " " <> unwords (columnOrder |> map compileIndexColumnOrder)
-
-compileIndexColumnOrder :: IndexColumnOrder -> Text
-compileIndexColumnOrder Asc = "ASC"
-compileIndexColumnOrder Desc = "DESC"
-compileIndexColumnOrder NullsFirst = "NULLS FIRST"
-compileIndexColumnOrder NullsLast = "NULLS LAST"
diff --git a/IHP/IDE/SchemaDesigner/Controller/Columns.hs b/IHP/IDE/SchemaDesigner/Controller/Columns.hs
--- a/IHP/IDE/SchemaDesigner/Controller/Columns.hs
+++ b/IHP/IDE/SchemaDesigner/Controller/Columns.hs
@@ -1,6 +1,6 @@
module IHP.IDE.SchemaDesigner.Controller.Columns where
-import IHP.ControllerPrelude
+import IHP.IDE.Prelude
import IHP.IDE.ToolServer.Types
import IHP.IDE.SchemaDesigner.View.Columns.New
@@ -8,7 +8,7 @@
import IHP.IDE.SchemaDesigner.View.Columns.NewForeignKey
import IHP.IDE.SchemaDesigner.View.Columns.EditForeignKey
-import IHP.IDE.SchemaDesigner.Types
+import IHP.Postgres.Types
import IHP.IDE.SchemaDesigner.View.Layout (schemaDesignerLayout, findStatementByName, replace)
import IHP.IDE.SchemaDesigner.Controller.Helper
import IHP.IDE.SchemaDesigner.Controller.Validation
@@ -33,6 +33,8 @@
case validationResult of
Failure message ->
setErrorMessage message
+ FailureHtml message ->
+ setErrorMessage message
Success -> do
let options = SchemaOperations.AddColumnOptions
{ tableName
@@ -71,6 +73,8 @@
case validationResult of
Failure message ->
+ setErrorMessage message
+ FailureHtml message ->
setErrorMessage message
Success -> do
let options = SchemaOperations.UpdateColumnOptions
diff --git a/IHP/IDE/SchemaDesigner/Controller/EnumValues.hs b/IHP/IDE/SchemaDesigner/Controller/EnumValues.hs
--- a/IHP/IDE/SchemaDesigner/Controller/EnumValues.hs
+++ b/IHP/IDE/SchemaDesigner/Controller/EnumValues.hs
@@ -1,12 +1,12 @@
module IHP.IDE.SchemaDesigner.Controller.EnumValues where
-import IHP.ControllerPrelude
+import IHP.IDE.Prelude
import IHP.IDE.ToolServer.Types
import IHP.IDE.SchemaDesigner.View.EnumValues.New
import IHP.IDE.SchemaDesigner.View.EnumValues.Edit
-import IHP.IDE.SchemaDesigner.Types
+import IHP.Postgres.Types
import IHP.IDE.SchemaDesigner.View.Layout (findStatementByName, replace, schemaDesignerLayout)
import IHP.IDE.SchemaDesigner.Controller.Helper
import IHP.IDE.SchemaDesigner.Controller.Validation
@@ -28,6 +28,8 @@
case validationResult of
Failure message ->
setErrorMessage message
+ FailureHtml message ->
+ setErrorMessage message
Success -> do
updateSchema $ SchemaOperations.addValueToEnum enumName enumValueName
@@ -37,8 +39,8 @@
-- 2. Save & Add another
--
case paramOrDefault @Text "Save" "submit" of
- "Save" -> redirectTo ShowEnumAction { .. }
"Save & Add Another" -> redirectTo NewEnumValueAction { .. }
+ _ -> redirectTo ShowEnumAction { .. }
action EditEnumValueAction { .. } = do
statements <- readSchema
@@ -60,6 +62,8 @@
let validationResult = newValue |> validateEnumValue statements (Just value)
case validationResult of
Failure message ->
+ setErrorMessage message
+ FailureHtml message ->
setErrorMessage message
Success ->
updateSchema (map (updateValueInEnum enumName newValue valueId))
diff --git a/IHP/IDE/SchemaDesigner/Controller/Enums.hs b/IHP/IDE/SchemaDesigner/Controller/Enums.hs
--- a/IHP/IDE/SchemaDesigner/Controller/Enums.hs
+++ b/IHP/IDE/SchemaDesigner/Controller/Enums.hs
@@ -1,13 +1,13 @@
module IHP.IDE.SchemaDesigner.Controller.Enums where
-import IHP.ControllerPrelude
+import IHP.IDE.Prelude
import IHP.IDE.ToolServer.Types
import IHP.IDE.SchemaDesigner.View.Enums.New
import IHP.IDE.SchemaDesigner.View.Enums.Show
import IHP.IDE.SchemaDesigner.View.Enums.Edit
-import IHP.IDE.SchemaDesigner.Types
+import IHP.Postgres.Types
import IHP.IDE.SchemaDesigner.View.Layout (replace, schemaDesignerLayout)
import IHP.IDE.SchemaDesigner.Controller.Helper
import IHP.IDE.SchemaDesigner.Controller.Validation
@@ -34,6 +34,9 @@
Failure message -> do
setErrorMessage message
redirectTo TablesAction
+ FailureHtml message -> do
+ setErrorMessage message
+ redirectTo TablesAction
Success -> do
updateSchema $ SchemaOperations.addEnum enumName
redirectTo ShowEnumAction { .. }
@@ -51,6 +54,9 @@
let validationResult = enumName |> validateEnum statements (Just oldEnumName)
case validationResult of
Failure message -> do
+ setErrorMessage message
+ redirectTo ShowEnumAction { enumName = oldEnumName }
+ FailureHtml message -> do
setErrorMessage message
redirectTo ShowEnumAction { enumName = oldEnumName }
Success -> do
diff --git a/IHP/IDE/SchemaDesigner/Controller/Helper.hs b/IHP/IDE/SchemaDesigner/Controller/Helper.hs
--- a/IHP/IDE/SchemaDesigner/Controller/Helper.hs
+++ b/IHP/IDE/SchemaDesigner/Controller/Helper.hs
@@ -1,8 +1,9 @@
module IHP.IDE.SchemaDesigner.Controller.Helper where
-import IHP.ControllerPrelude
-import IHP.IDE.SchemaDesigner.Types
-import qualified IHP.IDE.SchemaDesigner.Parser as Parser
+import IHP.IDE.Prelude
+import IHP.Postgres.Types
+import qualified IHP.Postgres.Parser as Parser
+import qualified IHP.SchemaCompiler.Parser as SchemaDesignerParser
import qualified Text.Megaparsec as Megaparsec
import qualified IHP.IDE.SchemaDesigner.Compiler as SchemaCompiler
import IHP.IDE.SchemaDesigner.View.Schema.Error
@@ -27,13 +28,15 @@
( ?context::ControllerContext
, ?modelContext::ModelContext
, ?theAction::controller
+ , ?respond::Respond
+ , ?request :: Request
) => IO [Statement]
-readSchema = Parser.parseSchemaSql >>= \case
+readSchema = SchemaDesignerParser.parseSchemaSql >>= \case
Left error -> do render ErrorView { error }; pure []
Right statements -> pure statements
getSqlError :: IO (Maybe ByteString)
-getSqlError = Parser.parseSchemaSql >>= \case
+getSqlError = SchemaDesignerParser.parseSchemaSql >>= \case
Left error -> do pure (Just error)
Right statements -> do pure Nothing
@@ -41,6 +44,8 @@
( ?context :: ControllerContext
, ?modelContext::ModelContext
, ?theAction::controller
+ , ?respond::Respond
+ , ?request :: Request
) => ([Statement] -> [Statement]) -> IO ()
updateSchema updateFn = do
statements <- readSchema
diff --git a/IHP/IDE/SchemaDesigner/Controller/Indexes.hs b/IHP/IDE/SchemaDesigner/Controller/Indexes.hs
--- a/IHP/IDE/SchemaDesigner/Controller/Indexes.hs
+++ b/IHP/IDE/SchemaDesigner/Controller/Indexes.hs
@@ -1,6 +1,6 @@
module IHP.IDE.SchemaDesigner.Controller.Indexes where
-import IHP.ControllerPrelude
+import IHP.IDE.Prelude
import IHP.IDE.ToolServer.Types
import IHP.IDE.SchemaDesigner.View.Indexes.Edit
diff --git a/IHP/IDE/SchemaDesigner/Controller/Migrations.hs b/IHP/IDE/SchemaDesigner/Controller/Migrations.hs
--- a/IHP/IDE/SchemaDesigner/Controller/Migrations.hs
+++ b/IHP/IDE/SchemaDesigner/Controller/Migrations.hs
@@ -15,18 +15,25 @@
import qualified IHP.IDE.CodeGen.MigrationGenerator as MigrationGenerator
import IHP.IDE.CodeGen.Controller
import IHP.IDE.ToolServer.Helper.Controller (openEditor, clearDatabaseNeedsMigration)
-import IHP.Log.Types
import qualified Control.Exception.Safe as Exception
-import qualified System.Directory as Directory
-import qualified Database.PostgreSQL.Simple as PG
+import qualified System.Directory.OsPath as Directory
+import System.OsPath (encodeUtf)
+import qualified Hasql.Connection as Connection
+import qualified Hasql.Connection.Settings as ConnectionSettings
instance Controller MigrationsController where
beforeAction = setLayout schemaDesignerLayout
action MigrationsAction = do
migrations <- findRecentMigrations
- migratedRevisions <- findMigratedRevisions
+ result <- Exception.try findMigratedRevisions
+ migratedRevisions <- case result of
+ Left (exception :: SomeException) -> do
+ setErrorMessage ("Could not connect to the database: " <> tshow exception)
+ pure []
+ Right revisions -> pure revisions
+
migrationsWithSql <- forM migrations $ \migration -> do
sql <- readSqlStatements migration
pure (migration, sql)
@@ -59,7 +66,7 @@
case result of
Left (exception :: SomeException) -> do
let errorMessage = case fromException exception of
- Just (exception :: EnhancedSqlError) -> cs exception.sqlError.sqlErrorMsg
+ Just (exception :: EnhancedSqlError) -> enhancedSqlErrorMessage exception
Nothing -> tshow exception
setErrorMessage errorMessage
@@ -86,9 +93,10 @@
action DeleteMigrationAction { migrationId } = do
migration <- findMigrationByRevision migrationId
- path <- cs <$> SchemaMigration.migrationPath migration
+ path <- SchemaMigration.migrationPath migration
+ osPath <- encodeUtf (cs path)
- Directory.removeFile path
+ Directory.removeFile osPath
redirectTo MigrationsAction
@@ -99,7 +107,7 @@
case result of
Left (exception :: SomeException) -> do
let errorMessage = case fromException exception of
- Just (exception :: EnhancedSqlError) -> cs exception.sqlError.sqlErrorMsg
+ Just (exception :: EnhancedSqlError) -> enhancedSqlErrorMessage exception
Nothing -> tshow exception
setErrorMessage errorMessage
@@ -123,37 +131,27 @@
pure migration
migrateAppDB :: Int -> IO ()
-migrateAppDB revision = withAppModelContext do
+migrateAppDB revision = withMigrateConnection \connection -> do
let minimumRevision = Just (revision - 1)
- SchemaMigration.migrate SchemaMigration.MigrateOptions { minimumRevision }
+ SchemaMigration.migrate connection SchemaMigration.MigrateOptions { minimumRevision }
findMigratedRevisions :: IO [Int]
-findMigratedRevisions = emptyListIfTablesDoesntExists (withAppModelContext SchemaMigration.findMigratedRevisions)
+findMigratedRevisions = emptyListIfTablesDoesntExists (withMigrateConnection SchemaMigration.findMigratedRevisions)
where
-- The schema_migrations table might not have been created yet
-- In that case there cannot be any migrations that have been run yet
emptyListIfTablesDoesntExists operation = do
result <- Exception.try operation
case result of
- Left (EnhancedSqlError { sqlError }) | sqlError.sqlErrorMsg == "relation \"schema_migrations\" does not exist" -> pure []
+ Left (exception :: SomeException)
+ | "schema_migrations" `isInfixOf` tshow exception -> pure []
+ | otherwise -> Exception.throwIO exception
Right result -> pure result
-withAppModelContext :: ((?modelContext :: ModelContext) => IO result) -> IO result
-withAppModelContext inner =
- Exception.bracket initModelContext cleanupModelContext callback
+withMigrateConnection :: (Connection.Connection -> IO result) -> IO result
+withMigrateConnection inner = Exception.bracket acquire Connection.release inner
where
- callback (frameworkConfig, logger, modelContext) = let ?modelContext = modelContext in inner
- initModelContext = do
+ acquire = do
frameworkConfig <- buildFrameworkConfig (pure ())
- logger <- defaultLogger
-
- modelContext <- createModelContext
- (frameworkConfig.dbPoolIdleTime)
- (frameworkConfig.dbPoolMaxConnections)
- (frameworkConfig.databaseUrl)
- logger
-
- pure (frameworkConfig, logger, modelContext)
-
- cleanupModelContext (frameworkConfig, logger, modelContext) = do
- logger |> cleanup
+ Connection.acquire (ConnectionSettings.connectionString (cs frameworkConfig.databaseUrl))
+ >>= either (\e -> error ("DB connect failed: " <> show e)) pure
diff --git a/IHP/IDE/SchemaDesigner/Controller/Policies.hs b/IHP/IDE/SchemaDesigner/Controller/Policies.hs
--- a/IHP/IDE/SchemaDesigner/Controller/Policies.hs
+++ b/IHP/IDE/SchemaDesigner/Controller/Policies.hs
@@ -1,12 +1,12 @@
module IHP.IDE.SchemaDesigner.Controller.Policies where
-import IHP.ControllerPrelude
+import IHP.IDE.Prelude
import IHP.IDE.ToolServer.Types
import IHP.IDE.SchemaDesigner.View.Policies.New
import IHP.IDE.SchemaDesigner.View.Policies.Edit
-import IHP.IDE.SchemaDesigner.Types
+import IHP.Postgres.Types
import IHP.IDE.SchemaDesigner.View.Layout (schemaDesignerLayout, findStatementByName)
import IHP.IDE.SchemaDesigner.Controller.Helper
diff --git a/IHP/IDE/SchemaDesigner/Controller/Schema.hs b/IHP/IDE/SchemaDesigner/Controller/Schema.hs
--- a/IHP/IDE/SchemaDesigner/Controller/Schema.hs
+++ b/IHP/IDE/SchemaDesigner/Controller/Schema.hs
@@ -1,13 +1,13 @@
module IHP.IDE.SchemaDesigner.Controller.Schema where
-import IHP.ControllerPrelude
+import IHP.IDE.Prelude
import IHP.IDE.ToolServer.Types
import IHP.IDE.SchemaDesigner.View.Schema.Code
import IHP.IDE.SchemaDesigner.View.Schema.GeneratedCode
import IHP.IDE.SchemaDesigner.View.Schema.SchemaUpdateFailed
-import IHP.IDE.SchemaDesigner.Parser
+import IHP.SchemaCompiler.Parser
import qualified IHP.SchemaCompiler as SchemaCompiler
import qualified System.Process as Process
import System.Exit
@@ -17,18 +17,21 @@
import IHP.IDE.SchemaDesigner.View.Layout
import IHP.IDE.ToolServer.Routes ()
import IHP.IDE.SchemaDesigner.Controller.Helper
+import System.OsPath (decodeUtf)
instance Controller SchemaController where
beforeAction = setLayout schemaDesignerLayout
action ShowCodeAction = do
- schema <- Text.readFile schemaFilePath
+ schemaFP <- decodeUtf schemaFilePath
+ schema <- Text.readFile schemaFP
error <- getSqlError
render CodeView { .. }
action SaveCodeAction = do
+ schemaFP <- decodeUtf schemaFilePath
let schema = param "schemaSql"
- Text.writeFile schemaFilePath schema
+ Text.writeFile schemaFP schema
redirectTo ShowCodeAction
action PushToDbAction = do
diff --git a/IHP/IDE/SchemaDesigner/Controller/Tables.hs b/IHP/IDE/SchemaDesigner/Controller/Tables.hs
--- a/IHP/IDE/SchemaDesigner/Controller/Tables.hs
+++ b/IHP/IDE/SchemaDesigner/Controller/Tables.hs
@@ -1,6 +1,6 @@
module IHP.IDE.SchemaDesigner.Controller.Tables where
-import IHP.ControllerPrelude
+import IHP.IDE.Prelude
import IHP.IDE.ToolServer.Types
import IHP.IDE.SchemaDesigner.View.Tables.New
@@ -8,13 +8,14 @@
import IHP.IDE.SchemaDesigner.View.Tables.Index
import IHP.IDE.SchemaDesigner.View.Tables.Edit
-import IHP.IDE.SchemaDesigner.Types
+import IHP.Postgres.Types
import IHP.IDE.SchemaDesigner.View.Layout (findStatementByName, schemaDesignerLayout)
import qualified IHP.SchemaCompiler as SchemaCompiler
import IHP.IDE.SchemaDesigner.Controller.Helper
import IHP.IDE.SchemaDesigner.Controller.Validation
import IHP.IDE.SchemaDesigner.Controller.Columns (updateForeignKeyConstraint)
import qualified IHP.IDE.SchemaDesigner.SchemaOperations as SchemaOperations
+import IHP.IDE.CodeGen.Types (defaultUuidFunction)
instance Controller TablesController where
beforeAction = setLayout schemaDesignerLayout
@@ -49,8 +50,12 @@
Failure message -> do
setErrorMessage message
redirectTo TablesAction
+ FailureHtml message -> do
+ setErrorMessage message
+ redirectTo TablesAction
Success -> do
- updateSchema (SchemaOperations.addTable tableName)
+ uuidFunction <- defaultUuidFunction
+ updateSchema (SchemaOperations.addTable tableName uuidFunction)
redirectTo ShowTableAction { .. }
action EditTableAction { .. } = do
@@ -67,6 +72,9 @@
let validationResult = tableName |> validateTable statements (Just oldTableName)
case validationResult of
Failure message -> do
+ setErrorMessage message
+ redirectTo ShowTableAction { tableName = oldTableName }
+ FailureHtml message -> do
setErrorMessage message
redirectTo ShowTableAction { tableName = oldTableName }
Success -> do
diff --git a/IHP/IDE/SchemaDesigner/Controller/Validation.hs b/IHP/IDE/SchemaDesigner/Controller/Validation.hs
--- a/IHP/IDE/SchemaDesigner/Controller/Validation.hs
+++ b/IHP/IDE/SchemaDesigner/Controller/Validation.hs
@@ -1,6 +1,6 @@
module IHP.IDE.SchemaDesigner.Controller.Validation where
-import IHP.ControllerPrelude
+import IHP.IDE.Prelude
import Text.Countable (singularize)
isUniqueInList :: (Foldable t, Eq a) => t a -> Maybe a -> Validator a
diff --git a/IHP/IDE/SchemaDesigner/Parser.hs b/IHP/IDE/SchemaDesigner/Parser.hs
deleted file mode 100644
--- a/IHP/IDE/SchemaDesigner/Parser.hs
+++ /dev/null
@@ -1,1008 +0,0 @@
-{-|
-Module: IHP.IDE.SchemaDesigner.Types
-Description: Parser for Application/Schema.sql
-Copyright: (c) digitally induced GmbH, 2020
--}
-module IHP.IDE.SchemaDesigner.Parser
-( parseSchemaSql
-, parseSqlFile
-, schemaFilePath
-, parseDDL
-, expression
-, sqlType
-, removeTypeCasts
-, parseIndexColumns
-) where
-
-import IHP.Prelude
-import IHP.IDE.SchemaDesigner.Types
-import qualified Prelude
-import qualified Data.Text.IO as Text
-import Text.Megaparsec
-import Data.Void
-import Text.Megaparsec.Char
-import qualified Text.Megaparsec.Char.Lexer as Lexer
-import Data.Char
-import Control.Monad.Combinators.Expr
-import Data.Functor
-
-schemaFilePath = "Application/Schema.sql"
-
-parseSchemaSql :: IO (Either ByteString [Statement])
-parseSchemaSql = parseSqlFile schemaFilePath
-
-parseSqlFile :: FilePath -> IO (Either ByteString [Statement])
-parseSqlFile schemaFilePath = do
- schemaSql <- Text.readFile schemaFilePath
- let result = runParser parseDDL (cs schemaFilePath) schemaSql
- case result of
- Left error -> pure (Left (cs $ errorBundlePretty error))
- Right r -> pure (Right r)
-
-type Parser = Parsec Void Text
-
-spaceConsumer :: Parser ()
-spaceConsumer = Lexer.space
- space1
- (Lexer.skipLineComment "//")
- (Lexer.skipBlockComment "/*" "*/")
-
-lexeme :: Parser a -> Parser a
-lexeme = Lexer.lexeme spaceConsumer
-
-symbol :: Text -> Parser Text
-symbol = Lexer.symbol spaceConsumer
-
-symbol' :: Text -> Parser Text
-symbol' = Lexer.symbol' spaceConsumer
-
-stringLiteral :: Parser String
-stringLiteral = char '\'' *> manyTill Lexer.charLiteral (char '\'')
-
-parseDDL :: Parser [Statement]
-parseDDL = optional space >> (manyTill statement eof)
-
-statement = do
- space
- let create = try createExtension <|> try (StatementCreateTable <$> createTable) <|> try createIndex <|> try createFunction <|> try createTrigger <|> try createEnumType <|> try createPolicy <|> try createSequence
- let alter = do
- lexeme "ALTER"
- alterTable <|> alterType <|> alterSequence
- s <- setStatement <|> create <|> alter <|> selectStatement <|> try dropTable <|> try dropIndex <|> try dropPolicy <|> try dropFunction <|> try dropType <|> dropTrigger <|> commentStatement <|> comment <|> begin <|> commit <|> restrict <|> unrestrict
- space
- pure s
-
-
-createExtension = do
- lexeme "CREATE"
- lexeme "EXTENSION"
- ifNotExists <- isJust <$> optional (lexeme "IF" >> lexeme "NOT" >> lexeme "EXISTS")
- name <- qualifiedIdentifier
- optional do
- space
- lexeme "WITH"
- lexeme "SCHEMA"
- lexeme "public"
- char ';'
- pure CreateExtension { name, ifNotExists = True }
-
-createTable = do
- lexeme "CREATE"
- unlogged <- isJust <$> optional (lexeme "UNLOGGED")
- lexeme "TABLE"
- name <- qualifiedIdentifier
-
- -- Process columns (tagged if they're primary key) and table constraints
- -- together, as they can be in any order
- (taggedColumns, allConstraints) <- between (char '(' >> space) (char ')' >> space) do
- columnsAndConstraints <- ((Right <$> parseTableConstraint) <|> (Left <$> parseColumn)) `sepBy` (char ',' >> space)
- pure (lefts columnsAndConstraints, rights columnsAndConstraints)
-
- char ';'
-
- -- Check that either there is a single column with a PRIMARY KEY constraint,
- -- or there is a single PRIMARY KEY table constraint
- let
- columns = map snd taggedColumns
- constraints = rights allConstraints
-
- primaryKeyConstraint <- case filter fst taggedColumns of
- [] -> case lefts allConstraints of
- [] -> pure $ PrimaryKeyConstraint []
- [primaryKeyConstraint] -> pure primaryKeyConstraint
- _ -> Prelude.fail ("Multiple PRIMARY KEY constraints on table " <> cs name)
- [(_, Column { name })] -> case lefts allConstraints of
- [] -> pure $ PrimaryKeyConstraint [name]
- _ -> Prelude.fail ("Primary key defined in both column and table constraints on table " <> cs name)
- _ -> Prelude.fail "Multiple columns with PRIMARY KEY constraint"
-
- pure CreateTable { name, columns, primaryKeyConstraint, constraints, unlogged }
-
-createEnumType = do
- lexeme "CREATE"
- lexeme "TYPE"
- optional do
- lexeme "public"
- char '.'
- name <- identifier
- lexeme "AS"
- lexeme "ENUM"
- values <- between (char '(' >> space) (space >> char ')' >> space) (textExpr' `sepBy` (char ',' >> space))
- space
- char ';'
- pure CreateEnumType { name, values }
-
-addConstraint tableName = do
- constraint <- parseTableConstraint >>= \case
- Left primaryKeyConstraint -> pure AlterTableAddPrimaryKey { name = Nothing, primaryKeyConstraint }
- Right constraint -> pure constraint
- deferrable <- optional parseDeferrable
- deferrableType <- optional parseDeferrableType
- char ';'
- pure AddConstraint { tableName, constraint, deferrable, deferrableType }
-
-parseDeferrable = do
- isDeferrable <- lexeme "DEFERRABLE" <|> lexeme "NOT DEFERRABLE"
- pure $ case isDeferrable of
- "DEFERRABLE" -> True
- "NOT DEFERRABLE" -> False
-
-parseDeferrableType = do
- lexeme "INITIALLY"
- dtype <- lexeme "IMMEDIATE" <|> lexeme "DEFERRED"
- case dtype of
- "IMMEDIATE" -> pure InitiallyImmediate
- "DEFERRED" -> pure InitiallyDeferred
-
-parseTableConstraint = do
- name <- optional do
- lexeme "CONSTRAINT"
- identifier
- (Left <$> parsePrimaryKeyConstraint) <|>
- (Right <$> (parseForeignKeyConstraint name <|> parseUniqueConstraint name <|> parseCheckConstraint name <|> parseExcludeConstraint name))
-
-parsePrimaryKeyConstraint = do
- lexeme "PRIMARY"
- lexeme "KEY"
- primaryKeyColumnNames <- between (char '(' >> space) (char ')' >> space) (identifier `sepBy1` (char ',' >> space))
- pure PrimaryKeyConstraint { primaryKeyColumnNames }
-
-parseForeignKeyConstraint name = do
- lexeme "FOREIGN"
- lexeme "KEY"
- columnName <- between (char '(' >> space) (char ')' >> space) identifier
- lexeme "REFERENCES"
- referenceTable <- qualifiedIdentifier
- referenceColumn <- optional $ between (char '(' >> space) (char ')' >> space) identifier
- onDelete <- optional do
- lexeme "ON"
- lexeme "DELETE"
- parseOnDelete
- pure ForeignKeyConstraint { name, columnName, referenceTable, referenceColumn, onDelete }
-
-parseUniqueConstraint name = do
- lexeme "UNIQUE"
- columnNames <- between (char '(' >> space) (char ')' >> space) (identifier `sepBy1` (char ',' >> space))
- pure UniqueConstraint { name, columnNames }
-
-parseCheckConstraint name = do
- lexeme "CHECK"
- checkExpression <- between (char '(' >> space) (char ')' >> space) expression
- pure CheckConstraint { name, checkExpression }
-
-parseExcludeConstraint name = do
- lexeme "EXCLUDE"
- indexType <- optional parseIndexType
- excludeElements <- between (char '(' >> space) (char ')' >> space) $ excludeElement `sepBy` (char ',' >> space)
- predicate <- optional do
- lexeme "WHERE"
- between (char '(' >> space) (char ')' >> space) expression
- pure ExcludeConstraint { name, excludeElements, predicate, indexType }
- where
- excludeElement = do
- element <- identifier
- space
- lexeme "WITH"
- space
- operator <- parseCommutativeInfixOperator
- pure ExcludeConstraintElement { element, operator }
-
- parseCommutativeInfixOperator = choice $ map lexeme
- [ "="
- , "<>"
- , "!="
- , "AND"
- , "OR"
- ]
-
-parseOnDelete = choice
- [ (lexeme "NO" >> lexeme "ACTION") >> pure NoAction
- , (lexeme "RESTRICT" >> pure Restrict)
- , (lexeme "SET" >> ((lexeme "NULL" >> pure SetNull) <|> (lexeme "DEFAULT" >> pure SetDefault)))
- , (lexeme "CASCADE" >> pure Cascade)
- ]
-
-parseColumn :: Parser (Bool, Column)
-parseColumn = do
- name <- identifier
- columnType <- sqlType
- space
- defaultValue <- optional do
- lexeme "DEFAULT"
- expression
- generator <- optional do
- lexeme "GENERATED"
- lexeme "ALWAYS"
- lexeme "AS"
- generate <- expression
- stored <- isJust <$> optional (lexeme "STORED")
- pure ColumnGenerator { generate, stored }
- primaryKey <- isJust <$> optional (lexeme "PRIMARY" >> lexeme "KEY")
- notNull <- isJust <$> optional (lexeme "NOT" >> lexeme "NULL")
- isUnique <- isJust <$> optional (lexeme "UNIQUE")
- pure (primaryKey, Column { name, columnType, defaultValue, notNull, isUnique, generator })
-
-sqlType :: Parser PostgresType
-sqlType = choice $ map optionalArray
- [ uuid
- , text
- , interval --Needs higher precedence otherwise parsed as int
- , bigint
- , smallint
- , int -- order int after smallint/bigint because symbol INT is prefix of INT2, INT8
- , bool
- , timestamp
- , timestampZ
- , timestampZ'
- , timestamp'
- , real
- , double
- , point
- , polygon
- , date
- , binary
- , time
- , numericPS
- , numeric
- , character
- , varchar
- , serial
- , bigserial
- , jsonb
- , inet
- , tsvector
- , trigger
- , eventTrigger
- , singleChar
- , customType
- ]
- where
- timestamp = do
- try (symbol' "TIMESTAMP" >> symbol' "WITHOUT" >> symbol' "TIME" >> symbol' "ZONE")
- pure PTimestamp
-
- timestampZ = do
- try (symbol' "TIMESTAMP" >> symbol' "WITH" >> symbol' "TIME" >> symbol' "ZONE")
- pure PTimestampWithTimezone
-
- timestampZ' = do
- try (symbol' "TIMESTAMPZ")
- pure PTimestampWithTimezone
-
- timestamp' = do
- try (symbol' "TIMESTAMP")
- pure PTimestamp
-
- uuid = do
- try (symbol' "UUID")
- pure PUUID
-
- text = do
- try (symbol' "TEXT")
- pure PText
-
- bigint = do
- try (symbol' "BIGINT") <|> try (symbol' "INT8")
- pure PBigInt
-
- smallint = do
- try (symbol' "SMALLINT") <|> try (symbol' "INT2")
- pure PSmallInt
-
- int = do
- try (symbol' "INTEGER") <|> try (symbol' "INT4") <|> try (symbol' "INT")
- pure PInt
-
- bool = do
- try (symbol' "BOOLEAN") <|> try (symbol' "BOOL")
- pure PBoolean
-
- real = do
- try (symbol' "REAL") <|> try (symbol' "FLOAT4")
- pure PReal
-
- double = do
- try (symbol' "DOUBLE PRECISION") <|> try (symbol' "FLOAT8")
- pure PDouble
-
- point = do
- try (symbol' "POINT")
- pure PPoint
-
- polygon = do
- try (symbol' "POLYGON")
- pure PPolygon
-
- date = do
- try (symbol' "DATE")
- pure PDate
-
- binary = do
- try (symbol' "BYTEA")
- pure PBinary
-
- time = do
- try (symbol' "TIME")
- optional do
- symbol' "WITHOUT"
- symbol' "TIME"
- symbol' "ZONE"
- pure PTime
-
- interval = do
- try (symbol' "INTERVAL")
- fields <- optional do
- choice $ map symbol' intervalFields
- pure (PInterval fields)
-
- numericPS = do
- try (symbol' "NUMERIC(")
- values <- between (space) (char ')' >> space) (varExpr `sepBy` (char ',' >> space))
- case values of
- [VarExpression precision, VarExpression scale] -> do
- let p = textToInt precision
- let s = textToInt scale
- when (or [isNothing p, isNothing s]) do
- Prelude.fail "Failed to parse NUMERIC(..) expression"
- pure (PNumeric p s)
- [VarExpression precision] -> do
- let p = textToInt precision
- when (isNothing p) do
- Prelude.fail "Failed to parse NUMERIC(..) expression"
- pure (PNumeric p Nothing)
- _ -> Prelude.fail "Failed to parse NUMERIC(..) expression"
-
- numeric = do
- try (symbol' "NUMERIC")
- pure (PNumeric Nothing Nothing)
-
- varchar = do
- try (symbol' "CHARACTER VARYING") <|> try (symbol' "VARCHAR")
- value <- optional $ between (char '(' >> space) (char ')' >> space) (varExpr)
- case value of
- Just (VarExpression limit) -> do
- let l = textToInt limit
- case l of
- Nothing -> Prelude.fail "Failed to parse CHARACTER VARYING(..) expression"
- Just l -> pure (PVaryingN (Just l))
- Nothing -> pure (PVaryingN Nothing)
- _ -> Prelude.fail "Failed to parse CHARACTER VARYING(..) expression"
-
- character = do
- try (symbol' "CHAR(") <|> try (symbol' "CHARACTER(")
- value <- between (space) (char ')' >> space) (varExpr)
- case value of
- VarExpression length -> do
- let l = textToInt length
- case l of
- Nothing -> Prelude.fail "Failed to parse CHARACTER VARYING(..) expression"
- Just l -> pure (PCharacterN l)
- _ -> Prelude.fail "Failed to parse CHARACTER VARYING(..) expression"
-
- singleChar = do
- try (symbol "\"char\"")
- pure PSingleChar
-
- serial = do
- try (symbol' "SERIAL")
- pure PSerial
-
- bigserial = do
- try (symbol' "BIGSERIAL")
- pure PBigserial
-
- jsonb = do
- try (symbol' "JSONB")
- pure PJSONB
-
- inet = do
- try (symbol' "INET")
- pure PInet
-
- tsvector = do
- try (symbol' "TSVECTOR")
- pure PTSVector
-
- optionalArray typeParser= do
- arrayType <- typeParser;
- (try do symbol' "[]"; pure $ PArray arrayType) <|> pure arrayType
-
- trigger = do
- try (symbol' "TRIGGER")
- pure PTrigger
-
- eventTrigger = do
- try (symbol' "EVENT_TRIGGER")
- pure PEventTrigger
-
- customType = do
- optional do
- lexeme "public"
- char '.'
- theType <- try (takeWhile1P (Just "Custom type") (\c -> isAlphaNum c || c == '_'))
- pure (PCustomType theType)
-
-
-intervalFields :: [Text]
-intervalFields = [ "YEAR TO MONTH", "DAY TO HOUR", "DAY TO MINUTE", "DAY TO SECOND"
- , "HOUR TO MINUTE", "HOUR TO SECOND", "MINUTE TO SECOND"
- , "YEAR", "MONTH", "DAY", "HOUR", "MINUTE", "SECOND"]
-
-
-term = parens expression <|> try callExpr <|> try doubleExpr <|> try intExpr <|> selectExpr <|> varExpr <|> (textExpr <* optional space)
- where
- parens f = between (char '(' >> space) (char ')' >> space) f
-
-table = [
- [ binary "<>" NotEqExpression
- , binary "=" EqExpression
-
- , binary "<=" LessThanOrEqualToExpression
- , binary "<" LessThanExpression
- , binary ">=" GreaterThanOrEqualToExpression
- , binary ">" GreaterThanExpression
- , binary "||" ConcatenationExpression
-
- , binary "IS" IsExpression
- , inExpr
- , prefix "NOT" NotExpression
- , prefix "EXISTS" ExistsExpression
- , typeCast
- , dot
- ],
- [ binary "AND" AndExpression, binary "OR" OrExpression ]
- ]
- where
- binary name f = InfixL (f <$ try (symbol name))
- prefix name f = Prefix (f <$ symbol name)
- postfix name f = Postfix (f <$ symbol name)
-
- -- Cannot be implemented as a infix operator as that requires two expression operands,
- -- but the second is the type-cast type which is not an expression
- typeCast = Postfix do
- symbol "::"
- castType <- sqlType
- pure $ \expr -> TypeCastExpression expr castType
-
- dot = Postfix do
- char '.'
- name <- identifier
- pure $ \expr -> DotExpression expr name
-
- inExpr = Postfix do
- lexeme "IN"
- right <- try inArrayExpression <|> expression
- pure $ \expr -> InExpression expr right
-
--- | Parses a SQL expression
---
--- This parser makes use of makeExprParser as described in https://hackage.haskell.org/package/parser-combinators-1.2.0/docs/Control-Monad-Combinators-Expr.html
-expression :: Parser Expression
-expression = do
- e <- makeExprParser term table "expression"
- space
- pure e
-
-varExpr :: Parser Expression
-varExpr = VarExpression <$> identifier
-
-doubleExpr :: Parser Expression
-doubleExpr = DoubleExpression <$> (Lexer.signed spaceConsumer Lexer.float)
-
-intExpr :: Parser Expression
-intExpr = IntExpression <$> (Lexer.signed spaceConsumer Lexer.decimal)
-
-callExpr :: Parser Expression
-callExpr = do
- func <- qualifiedIdentifier
- args <- between (char '(') (char ')') (expression `sepBy` (char ',' >> space))
- space
- pure (CallExpression func args)
-
-textExpr :: Parser Expression
-textExpr = TextExpression <$> textExpr'
-
-textExpr' :: Parser Text
-textExpr' = cs <$> do
- let emptyByteString = do
- string "'\\x'"
- pure ""
- (try (char '\'' *> manyTill Lexer.charLiteral (char '\''))) <|> emptyByteString
-
-selectExpr :: Parser Expression
-selectExpr = do
- symbol' "SELECT"
- columns <- expression `sepBy` (char ',' >> space)
- symbol' "FROM"
- from <- expression
-
-
- let whereClause alias = do
- symbol' "WHERE"
- whereClause <- expression
- pure (SelectExpression Select { .. })
-
- let explicitAs = do
- symbol' "AS"
- alias <- identifier
- whereClause (Just alias)
-
- let implicitAs = do
- alias <- identifier
- whereClause (Just alias)
-
- whereClause Nothing <|> explicitAs <|> implicitAs
-
-inArrayExpression :: Parser Expression
-inArrayExpression = do
- values <- between (char '(') (char ')') (expression `sepBy` (char ',' >> space))
- pure (InArrayExpression values)
-
-
-
-identifier :: Parser Text
-identifier = do
- i <- (between (char '"') (char '"') (takeWhile1P Nothing (\c -> c /= '"'))) <|> takeWhile1P (Just "identifier") (\c -> isAlphaNum c || c == '_')
- space
- pure i
-
-comment = do
- (char '-' >> char '-') "Line comment"
- content <- takeWhileP Nothing (/= '\n')
- pure Comment { content }
-
-createIndex = do
- lexeme "CREATE"
- unique <- isJust <$> optional (lexeme "UNIQUE")
- lexeme "INDEX"
- indexName <- identifier
- lexeme "ON"
- tableName <- qualifiedIdentifier
- indexType <- optional parseIndexType
- columns <- between (char '(' >> space) (char ')' >> space) parseIndexColumns
- whereClause <- optional do
- lexeme "WHERE"
- expression
- char ';'
- pure CreateIndex { indexName, unique, tableName, columns, whereClause, indexType }
-
-parseIndexColumns = parseIndexColumn `sepBy` (char ',' >> space)
-
-parseIndexColumn = do
- column <- expression
- orderOption1 <- optional $ space *> lexeme "ASC" $> Asc <|> space *> lexeme "DESC" $> Desc
- orderOption2 <- optional $ space *> lexeme "NULLS FIRST" $> NullsFirst <|> space *> lexeme "NULLS LAST" $> NullsLast
- pure IndexColumn { column, columnOrder = catMaybes [orderOption1, orderOption2] }
-
-parseIndexType = do
- lexeme "USING"
-
- choice $ map (\(s, v) -> do symbol' s; pure v)
- [ ("btree", Btree)
- , ("gin", Gin)
- , ("gist", Gist)
- ]
-
-createFunction = do
- lexeme "CREATE"
- orReplace <- isJust <$> optional (lexeme "OR" >> lexeme "REPLACE")
- lexeme "FUNCTION"
- functionName <- qualifiedIdentifier
- functionArguments <- between (char '(') (char ')') (functionArgument `sepBy` (char ',' >> space))
- space
- lexeme "RETURNS"
- returns <- sqlType
- space
-
- language <- optional do
- lexeme "language" <|> lexeme "LANGUAGE"
- symbol' "plpgsql" <|> symbol' "SQL"
-
- lexeme "AS"
- space
- functionBody <- cs <$> between (char '$' >> char '$') (char '$' >> char '$') (many (anySingleBut '$'))
- space
-
- language <- case language of
- Just language -> pure language
- Nothing -> do
- lexeme "language" <|> lexeme "LANGUAGE"
- symbol' "plpgsql" <|> symbol' "SQL"
- char ';'
- pure CreateFunction { functionName, functionArguments, functionBody, orReplace, returns, language }
- where
- functionArgument = do
- argumentName <- qualifiedIdentifier
- space
- argumentType <- sqlType
- pure (argumentName, argumentType)
-
-createTrigger = do
- lexeme "CREATE"
- createEventTrigger <|> createTrigger'
-
-createEventTrigger = do
- lexeme "EVENT"
- lexeme "TRIGGER"
-
- name <- qualifiedIdentifier
- lexeme "ON"
- eventOn <- identifier
-
- whenCondition <- optional do
- lexeme "WHEN"
- expression
-
- lexeme "EXECUTE"
- (lexeme "FUNCTION") <|> (lexeme "PROCEDURE")
-
- (CallExpression functionName arguments) <- callExpr
-
- char ';'
-
- pure CreateEventTrigger
- { name
- , eventOn
- , whenCondition
- , functionName
- , arguments
- }
-
-
-
-createTrigger' = do
- lexeme "TRIGGER"
-
- name <- qualifiedIdentifier
- eventWhen <- (lexeme "AFTER" >> pure After) <|> (lexeme "BEFORE" >> pure Before) <|> (lexeme "INSTEAD OF" >> pure InsteadOf)
- event <- (lexeme "INSERT" >> pure TriggerOnInsert) <|> (lexeme "UPDATE" >> pure TriggerOnUpdate) <|> (lexeme "DELETE" >> pure TriggerOnDelete) <|> (lexeme "TRUNCATE" >> pure TriggerOnTruncate)
-
- lexeme "ON"
- tableName <- qualifiedIdentifier
-
- lexeme "FOR"
- optional (lexeme "EACH")
-
- for <- (lexeme "ROW" >> pure ForEachRow) <|> (lexeme "STATEMENT" >> pure ForEachStatement)
-
- whenCondition <- optional do
- lexeme "WHEN"
- expression
-
- lexeme "EXECUTE"
- optional (lexeme "FUNCTION" <|> lexeme "PROCEDURE")
-
- (CallExpression functionName arguments) <- callExpr
-
- char ';'
-
- pure CreateTrigger
- { name
- , eventWhen
- , event
- , tableName
- , for
- , whenCondition
- , functionName
- , arguments
- }
-
-alterTable = do
- lexeme "TABLE"
- optional (lexeme "ONLY")
- tableName <- qualifiedIdentifier
- let add = do
- lexeme "ADD"
- let addUnique = do
- unique <- parseUniqueConstraint Nothing
- deferrable <- optional parseDeferrable
- deferrableType <- optional parseDeferrableType
- char ';'
- pure (AddConstraint tableName unique deferrable deferrableType)
- addConstraint tableName <|> addColumn tableName <|> addUnique
- let drop = do
- lexeme "DROP"
- dropColumn tableName <|> dropConstraint tableName
- let rename = do
- lexeme "RENAME"
- renameColumn tableName <|> renameTable tableName
- let alter = do
- lexeme "ALTER"
- alterColumn tableName
- enableRowLevelSecurity tableName <|> add <|> drop <|> rename <|> alter
-
-alterType = do
- lexeme "TYPE"
- typeName <- qualifiedIdentifier
- addValue typeName
-
-alterSequence = do
- lexeme "SEQUENCE"
- raw <- cs <$> someTill (anySingle) (char ';')
- pure UnknownStatement { raw = "ALTER SEQUENCE " <> raw };
-
--- | ALTER TABLE users ALTER COLUMN email DROP NOT NULL;
--- ALTER TABLE users ALTER COLUMN email SET NOT NULL;
--- ALTER TABLE users ALTER COLUMN email SET DEFAULT 'value';
--- ALTER TABLE users ALTER COLUMN email DROP DEFAULT;
-alterColumn tableName = do
- lexeme "COLUMN"
- columnName <- identifier
-
- let drop = do
- lexeme "DROP"
- let notNull = do
- lexeme "NOT"
- lexeme "NULL"
- char ';'
- pure DropNotNull { tableName, columnName }
- let defaultValue = do
- lexeme "DEFAULT"
- char ';'
- pure DropDefaultValue { tableName, columnName }
- notNull <|> defaultValue
-
- let set = do
- lexeme "SET"
- let notNull = do
- lexeme "NOT"
- lexeme "NULL"
- char ';'
- pure SetNotNull { tableName, columnName }
- let defaultValue = do
- lexeme "DEFAULT"
- value <- expression
- char ';'
- pure SetDefaultValue { tableName, columnName, value }
- notNull <|> defaultValue
-
- drop <|> set
-
-
-
-
-enableRowLevelSecurity tableName = do
- lexeme "ENABLE"
- lexeme "ROW"
- lexeme "LEVEL"
- lexeme "SECURITY"
- char ';'
- pure EnableRowLevelSecurity { tableName }
-
-createPolicy = do
- lexeme "CREATE"
- lexeme "POLICY"
- name <- identifier
- lexeme "ON"
- tableName <- qualifiedIdentifier
-
- action <- optional (lexeme "FOR" >> policyAction)
-
- using <- optional do
- lexeme "USING"
- expression
-
- check <- optional do
- lexeme "WITH"
- lexeme "CHECK"
- expression
-
- char ';'
-
- pure CreatePolicy { name, action, tableName, using, check }
-
-policyAction =
- (lexeme "ALL" >> pure PolicyForAll)
- <|> (lexeme "SELECT" >> pure PolicyForSelect)
- <|> (lexeme "INSERT" >> pure PolicyForInsert)
- <|> (lexeme "UPDATE" >> pure PolicyForUpdate)
- <|> (lexeme "DELETE" >> pure PolicyForDelete)
-
-setStatement = do
- lexeme "SET"
- name <- identifier
- lexeme "="
- value <- expression
- char ';'
- pure Set { name, value }
-
-selectStatement = do
- lexeme "SELECT"
- query <- takeWhile1P (Just "SQL Query") (\c -> c /= ';')
- char ';'
- pure SelectStatement { query }
-
-
-commentStatement = do
- lexeme "COMMENT"
- content <- takeWhile1P (Just "SQL Query") (\c -> c /= ';')
- char ';'
- pure Comment { content }
-
-qualifiedIdentifier = do
- optional $ try do
- lexeme "public"
- char '.'
- identifier
-
-addColumn tableName = do
- lexeme "COLUMN"
- (_, column) <- parseColumn
- char ';'
- pure AddColumn { tableName, column }
-
-dropColumn tableName = do
- lexeme "COLUMN"
- columnName <- identifier
- char ';'
- pure DropColumn { tableName, columnName }
-
-dropConstraint tableName = do
- lexeme "CONSTRAINT"
- constraintName <- identifier
- char ';'
- pure DropConstraint { tableName, constraintName }
-
-renameColumn tableName = do
- lexeme "COLUMN"
- from <- identifier
- lexeme "TO"
- to <- identifier
- char ';'
- pure RenameColumn { tableName, from, to }
-
-renameTable tableName = do
- lexeme "TO"
- to <- identifier
- char ';'
- pure RenameTable { from = tableName, to }
-
-dropTable = do
- lexeme "DROP"
- lexeme "TABLE"
- tableName <- identifier
- char ';'
- pure DropTable { tableName }
-
-dropType = do
- lexeme "DROP"
- lexeme "TYPE"
- name <- qualifiedIdentifier
- char ';'
- pure DropEnumType { name }
-
-dropFunction = do
- lexeme "DROP"
- lexeme "FUNCTION"
- functionName <- qualifiedIdentifier
- char ';'
- pure DropFunction { functionName }
-
-dropIndex = do
- lexeme "DROP"
- lexeme "INDEX"
- indexName <- qualifiedIdentifier
- char ';'
- pure DropIndex { indexName }
-
-dropPolicy = do
- lexeme "DROP"
- lexeme "POLICY"
- policyName <- qualifiedIdentifier
- lexeme "ON"
- tableName <- qualifiedIdentifier
- char ';'
- pure DropPolicy { tableName, policyName }
-
-dropTrigger = do
- lexeme "DROP"
-
- dropEventTrigger <|> dropTrigger'
-
-dropTrigger' = do
- lexeme "TRIGGER"
- name <- qualifiedIdentifier
- lexeme "ON"
- tableName <- qualifiedIdentifier
- char ';'
- pure DropTrigger { name, tableName }
-
-
-dropEventTrigger = do
- lexeme "EVENT"
- lexeme "TRIGGER"
- name <- qualifiedIdentifier
- char ';'
- pure DropEventTrigger { name }
-
-createSequence = do
- lexeme "CREATE"
- lexeme "SEQUENCE"
- name <- qualifiedIdentifier
-
- -- We accept all the following SEQUENCE attributes, but don't save them
- -- This is mostly to void issues in migrations when parsing the pg_dump output
- optional do
- lexeme "AS"
- sqlType
-
- optional do
- lexeme "START"
- lexeme "WITH"
- expression
-
- optional do
- lexeme "INCREMENT"
- lexeme "BY"
- expression
-
- optional do
- lexeme "NO"
- lexeme "MINVALUE"
-
- optional do
- lexeme "NO"
- lexeme "MAXVALUE"
-
- optional do
- lexeme "CACHE"
- expression
-
- char ';'
- pure CreateSequence { name }
-
-addValue typeName = do
- lexeme "ADD"
- lexeme "VALUE"
- ifNotExists <- isJust <$> optional do
- lexeme "IF"
- lexeme "NOT"
- lexeme "EXISTS"
- newValue <- textExpr'
- char ';'
- pure AddValueToEnumType { enumName = typeName, newValue, ifNotExists }
-
-begin = do
- lexeme "BEGIN"
- char ';'
- pure Begin
-
-commit = do
- lexeme "COMMIT"
- char ';'
- pure Commit
-
--- | Turns sql like '1::double precision' into just '1'
-removeTypeCasts :: Expression -> Expression
-removeTypeCasts (TypeCastExpression value _) = value
-removeTypeCasts otherwise = otherwise
-
-restrict = do
- lexeme "\\restrict"
- key <- identifier
- pure Comment { content = "" }
-
-unrestrict = do
- lexeme "\\unrestrict"
- key <- identifier
- pure Comment { content = "" }
diff --git a/IHP/IDE/SchemaDesigner/SchemaOperations.hs b/IHP/IDE/SchemaDesigner/SchemaOperations.hs
--- a/IHP/IDE/SchemaDesigner/SchemaOperations.hs
+++ b/IHP/IDE/SchemaDesigner/SchemaOperations.hs
@@ -6,7 +6,7 @@
module IHP.IDE.SchemaDesigner.SchemaOperations where
import IHP.Prelude
-import IHP.IDE.SchemaDesigner.Types
+import IHP.Postgres.Types
import Data.Maybe (fromJust)
import qualified Data.List as List
import qualified Data.Text as Text
@@ -15,14 +15,17 @@
type Schema = [Statement]
-- | Creates a new tables with a 'id' columns as the primary key
-addTable :: Text -> Schema -> Schema
-addTable tableName list = list <> [StatementCreateTable CreateTable
+--
+-- The second parameter is the UUID function name to use as default value
+-- (e.g. @"uuid_generate_v4"@ or @"uuidv7"@).
+addTable :: Text -> Text -> Schema -> Schema
+addTable tableName uuidFunction list = list <> [StatementCreateTable CreateTable
{ name = tableName
, columns =
[Column
{ name = "id"
, columnType = PUUID
- , defaultValue = Just (CallExpression "uuid_generate_v4" [])
+ , defaultValue = Just (CallExpression uuidFunction [])
, notNull = True
, isUnique = False
, generator = Nothing
@@ -30,6 +33,7 @@
, primaryKeyConstraint = PrimaryKeyConstraint ["id"]
, constraints = []
, unlogged = False
+ , inherits = Nothing
}]
@@ -443,8 +447,11 @@
otheriwse -> False
|> fmap \case
StatementCreateTable table -> table
+ _ -> error "resolveFK: expected StatementCreateTable"
+ resolveFK _ = Nothing
emptyPolicy = CreatePolicy { name = "", action = Nothing, tableName, using = Nothing, check = Nothing }
+suggestPolicy _ _ = error "suggestPolicy: expected StatementCreateTable"
isUserIdColumn :: Column -> Bool
isUserIdColumn Column { name = "user_id" } = True
@@ -490,7 +497,7 @@
trigger = CreateTrigger
{ name = updatedAtTriggerName tableName
, eventWhen = Before
- , event = TriggerOnUpdate
+ , event = [TriggerOnUpdate]
, tableName
, for = ForEachRow
, whenCondition = Nothing
@@ -525,6 +532,7 @@
, orReplace = False
, returns = PTrigger
, language = "plpgsql"
+ , securityDefiner = False
}
deleteTriggerIfExists :: Text -> [Statement] -> [Statement]
@@ -565,6 +573,7 @@
(Just using, Nothing) -> not (isRef using)
(Nothing, Just check) -> not (isRef check)
(Just using, Just check) -> not (isRef using && isRef check)
+ (Nothing, Nothing) -> True
where
isRef :: Expression -> Bool
isRef (TextExpression {}) = False
@@ -575,6 +584,7 @@
isRef (AndExpression a b) = isRef a || isRef b
isRef (IsExpression a b) = isRef a || isRef b
isRef (InExpression a b) = isRef a || isRef b
+ isRef (InArrayExpression exprs) = foldl' (||) False (map isRef exprs)
isRef (NotExpression a) = isRef a
isRef (ExistsExpression a) = isRef a
isRef (OrExpression a b) = isRef a || isRef b
@@ -633,12 +643,21 @@
EqExpression a b -> expressionReferencesColumn a || expressionReferencesColumn b
AndExpression a b -> expressionReferencesColumn a || expressionReferencesColumn b
IsExpression a b -> expressionReferencesColumn a || expressionReferencesColumn b
+ InExpression a b -> expressionReferencesColumn a || expressionReferencesColumn b
+ InArrayExpression exprs -> exprs |> map expressionReferencesColumn |> List.or
NotExpression a -> expressionReferencesColumn a
+ ExistsExpression a -> expressionReferencesColumn a
OrExpression a b -> expressionReferencesColumn a || expressionReferencesColumn b
LessThanExpression a b -> expressionReferencesColumn a || expressionReferencesColumn b
LessThanOrEqualToExpression a b -> expressionReferencesColumn a || expressionReferencesColumn b
GreaterThanExpression a b -> expressionReferencesColumn a || expressionReferencesColumn b
GreaterThanOrEqualToExpression a b -> expressionReferencesColumn a || expressionReferencesColumn b
+ DoubleExpression _ -> False
+ IntExpression _ -> False
+ TypeCastExpression a _ -> expressionReferencesColumn a
+ SelectExpression _ -> False
+ DotExpression a _ -> expressionReferencesColumn a
+ ConcatenationExpression a b -> expressionReferencesColumn a || expressionReferencesColumn b
doesHaveExistingPolicies :: [Statement] -> Text -> Bool
doesHaveExistingPolicies statements tableName = statements
diff --git a/IHP/IDE/SchemaDesigner/Types.hs b/IHP/IDE/SchemaDesigner/Types.hs
--- a/IHP/IDE/SchemaDesigner/Types.hs
+++ b/IHP/IDE/SchemaDesigner/Types.hs
@@ -2,272 +2,11 @@
Module: IHP.IDE.SchemaDesigner.Types
Description: Types for representing an AST of SQL DDL
Copyright: (c) digitally induced GmbH, 2020
--}
-module IHP.IDE.SchemaDesigner.Types where
-import IHP.Prelude
-
-data Statement
- =
- -- | CREATE TABLE name ( columns );
- StatementCreateTable { unsafeGetCreateTable :: CreateTable }
- -- | CREATE TYPE name AS ENUM ( values );
- | CreateEnumType { name :: Text, values :: [Text] }
- -- | DROP TYPE name;
- | DropEnumType { name :: Text }
- -- | CREATE EXTENSION IF NOT EXISTS "name";
- | CreateExtension { name :: Text, ifNotExists :: Bool }
- -- | ALTER TABLE tableName ADD CONSTRAINT constraint;
- | AddConstraint { tableName :: Text, constraint :: Constraint, deferrable :: Maybe Bool, deferrableType :: Maybe DeferrableType }
- -- | ALTER TABLE tableName DROP CONSTRAINT constraintName;
- | DropConstraint { tableName, constraintName :: Text }
- -- | ALTER TABLE tableName ADD COLUMN column;
- | AddColumn { tableName :: Text, column :: Column }
- -- | ALTER TABLE tableName DROP COLUMN columnName;
- | DropColumn { tableName :: Text, columnName :: Text }
- -- | DROP TABLE tableName;
- | DropTable { tableName :: Text }
- | UnknownStatement { raw :: Text }
- | Comment { content :: Text }
- -- | CREATE INDEX indexName ON tableName (columnName); CREATE INDEX indexName ON tableName (LOWER(columnName));
- -- | CREATE UNIQUE INDEX name ON table (column [, ...]);
- | CreateIndex { indexName :: Text, unique :: Bool, tableName :: Text, columns :: [IndexColumn], whereClause :: Maybe Expression, indexType :: Maybe IndexType }
- -- | DROP INDEX indexName;
- | DropIndex { indexName :: Text }
- -- | CREATE OR REPLACE FUNCTION functionName(param1 TEXT, param2 INT) RETURNS TRIGGER AS $$functionBody$$ language plpgsql;
- | CreateFunction { functionName :: Text, functionArguments :: [(Text, PostgresType)], functionBody :: Text, orReplace :: Bool, returns :: PostgresType, language :: Text }
- -- | ALTER TABLE tableName ENABLE ROW LEVEL SECURITY;
- | EnableRowLevelSecurity { tableName :: Text }
- -- CREATE POLICY name ON tableName USING using WITH CHECK check;
- | CreatePolicy { name :: Text, tableName :: Text, action :: Maybe PolicyAction, using :: Maybe Expression, check :: Maybe Expression }
- -- SET name = value;
- | Set { name :: Text, value :: Expression }
- -- SELECT query;
- | SelectStatement { query :: Text }
- -- CREATE SEQUENCE name;
- | CreateSequence { name :: Text }
- -- ALTER TABLE tableName RENAME COLUMN from TO to;
- | RenameColumn { tableName :: Text, from :: Text, to :: Text }
- -- ALTER TYPE enumName ADD VALUE newValue;
- | AddValueToEnumType { enumName :: Text, newValue :: Text, ifNotExists :: Bool }
- -- ALTER TABLE tableName ALTER COLUMN columnName DROP NOT NULL;
- | DropNotNull { tableName :: Text, columnName :: Text }
- -- ALTER TABLE tableName ALTER COLUMN columnName SET NOT NULL;
- | SetNotNull { tableName :: Text, columnName :: Text }
- -- | ALTER TABLE from RENAME TO to;
- | RenameTable { from :: Text, to :: Text }
- -- | DROP POLICY policyName ON tableName;
- | DropPolicy { tableName :: Text, policyName :: Text }
- -- ALTER TABLE tableName ALTER COLUMN columnName SET DEFAULT 'value';
- | SetDefaultValue { tableName :: Text, columnName :: Text, value :: Expression }
- -- ALTER TABLE tableName ALTER COLUMN columnName DROP DEFAULT;
- | DropDefaultValue { tableName :: Text, columnName :: Text }
- -- | CREATE TRIGGER ..;
- | CreateTrigger { name :: !Text, eventWhen :: !TriggerEventWhen, event :: !TriggerEvent, tableName :: !Text, for :: !TriggerFor, whenCondition :: Maybe Expression, functionName :: !Text, arguments :: ![Expression] }
- -- | CREATE EVENT TRIGGER ..;
- | CreateEventTrigger { name :: !Text, eventOn :: !Text, whenCondition :: Maybe Expression, functionName :: !Text, arguments :: ![Expression] }
- -- | DROP TRIGGER .. ON ..;
- | DropTrigger { name :: !Text, tableName :: !Text }
- -- | DROP EVENT TRIGGER ..;
- | DropEventTrigger { name :: !Text }
- -- | BEGIN;
- | Begin
- -- | COMMIT;
- | Commit
- | DropFunction { functionName :: !Text }
- deriving (Eq, Show)
-
-data DeferrableType
- = InitiallyImmediate
- | InitiallyDeferred
- deriving (Eq, Show)
-
-data CreateTable
- = CreateTable
- { name :: Text
- , columns :: [Column]
- , primaryKeyConstraint :: PrimaryKeyConstraint
- , constraints :: [Constraint]
- , unlogged :: !Bool
- }
- deriving (Eq, Show)
-
-data Column = Column
- { name :: Text
- , columnType :: PostgresType
- , defaultValue :: Maybe Expression
- , notNull :: Bool
- , isUnique :: Bool
- , generator :: Maybe ColumnGenerator
- }
- deriving (Eq, Show)
-
-data OnDelete
- = NoAction
- | Restrict
- | SetNull
- | SetDefault
- | Cascade
- deriving (Show, Eq)
-
-data ColumnGenerator
- = ColumnGenerator
- { generate :: !Expression
- , stored :: !Bool
- } deriving (Show, Eq)
-
-newtype PrimaryKeyConstraint
- = PrimaryKeyConstraint { primaryKeyColumnNames :: [Text] }
- deriving (Eq, Show)
-
-data Constraint
- -- | FOREIGN KEY (columnName) REFERENCES referenceTable (referenceColumn) ON DELETE onDelete;
- = ForeignKeyConstraint
- { name :: !(Maybe Text)
- , columnName :: !Text
- , referenceTable :: !Text
- , referenceColumn :: !(Maybe Text)
- , onDelete :: !(Maybe OnDelete)
- }
- | UniqueConstraint
- { name :: !(Maybe Text)
- , columnNames :: ![Text]
- }
- | CheckConstraint
- { name :: !(Maybe Text)
- , checkExpression :: !Expression
- }
- | ExcludeConstraint
- { name :: !(Maybe Text)
- , excludeElements :: ![ExcludeConstraintElement]
- , predicate :: !(Maybe Expression)
- , indexType :: !(Maybe IndexType)
- }
- | AlterTableAddPrimaryKey
- { name :: !(Maybe Text)
- , primaryKeyConstraint :: !PrimaryKeyConstraint
- }
- deriving (Eq, Show)
-
-data ExcludeConstraintElement = ExcludeConstraintElement { element :: !Text, operator :: !Text }
- deriving (Eq, Show)
-
-data Expression =
- -- | Sql string like @'hello'@
- TextExpression Text
- -- | Simple variable like @users@
- | VarExpression Text
- -- | Simple call, like @COALESCE(name, 'unknown name')@
- | CallExpression Text [Expression]
- -- | Not equal operator, a <> b
- | NotEqExpression Expression Expression
- -- | Equal operator, a = b
- | EqExpression Expression Expression
- -- | a AND b
- | AndExpression Expression Expression
- -- | a IS b
- | IsExpression Expression Expression
- -- | a IN b
- | InExpression Expression Expression
- -- | ('a', 'b')
- | InArrayExpression [Expression]
- -- | NOT a
- | NotExpression Expression
- -- | EXISTS a
- | ExistsExpression Expression
- -- | a OR b
- | OrExpression Expression Expression
- -- | a < b
- | LessThanExpression Expression Expression
- -- | a <= b
- | LessThanOrEqualToExpression Expression Expression
- -- | a > b
- | GreaterThanExpression Expression Expression
- -- | a >= b
- | GreaterThanOrEqualToExpression Expression Expression
- -- | Double literal value, e.g. 0.1337
- | DoubleExpression Double
- -- | Integer literal value, e.g. 1337
- | IntExpression Int
- -- | value::type
- | TypeCastExpression Expression PostgresType
- | SelectExpression Select
- | DotExpression Expression Text
- | ConcatenationExpression Expression Expression -- ^ a || b
- deriving (Eq, Show)
-
-data Select = Select
- { columns :: [Expression]
- , from :: Expression
- , alias :: Maybe Text
- , whereClause :: Expression
- } deriving (Eq, Show)
-
-data PostgresType
- = PUUID
- | PText
- | PInt
- | PSmallInt
- | PBigInt
- | PBoolean
- | PTimestampWithTimezone
- | PTimestamp
- | PReal
- | PDouble
- | PPoint
- | PPolygon
- | PDate
- | PBinary
- | PTime
- | PInterval { fields :: Maybe Text }
- | PNumeric { precision :: Maybe Int, scale :: Maybe Int }
- | PVaryingN (Maybe Int)
- | PCharacterN Int
- | PSingleChar
- | PSerial
- | PBigserial
- | PJSONB
- | PInet
- | PTSVector
- | PArray PostgresType
- | PTrigger
- | PEventTrigger
- | PCustomType Text
- deriving (Eq, Show)
-
-data TriggerEventWhen
- = Before
- | After
- | InsteadOf
- deriving (Eq, Show)
-
-data TriggerEvent
- = TriggerOnInsert
- | TriggerOnUpdate
- | TriggerOnDelete
- | TriggerOnTruncate
- deriving (Eq, Show)
-
-data TriggerFor
- = ForEachRow
- | ForEachStatement
- deriving (Eq, Show)
-
-data PolicyAction
- = PolicyForAll
- | PolicyForSelect
- | PolicyForInsert
- | PolicyForUpdate
- | PolicyForDelete
- deriving (Eq, Show)
-
-data IndexType = Btree | Gin | Gist
- deriving (Eq, Show)
-
-data IndexColumn
- = IndexColumn { column :: Expression, columnOrder :: [IndexColumnOrder] }
- deriving (Eq, Show)
+This module re-exports types from 'IHP.Postgres.Types' for backwards compatibility.
+-}
+module IHP.IDE.SchemaDesigner.Types
+( module IHP.Postgres.Types
+) where
-data IndexColumnOrder
- = Asc | Desc | NullsFirst | NullsLast
- deriving (Eq, Show)
+import IHP.Postgres.Types
diff --git a/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs b/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs
--- a/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs
+++ b/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs
@@ -1,8 +1,8 @@
module IHP.IDE.SchemaDesigner.View.Columns.Edit where
import IHP.ViewPrelude hiding (primaryKeyColumnNames)
-import IHP.IDE.SchemaDesigner.Types
-import qualified IHP.IDE.SchemaDesigner.Compiler as Compiler
+import IHP.Postgres.Types
+import qualified IHP.Postgres.Compiler as Compiler
import IHP.IDE.ToolServer.Types
import IHP.IDE.SchemaDesigner.View.Layout
import Text.Countable (singularize)
@@ -17,7 +17,7 @@
instance View EditColumnView where
html EditColumnView { column = column@Column { name }, .. } = [hsx|
-
+
{renderObjectSelector (zip [0..] statements) (Just tableName)}
{renderColumnSelector tableName (zip [0..] columns) statements}
@@ -26,7 +26,7 @@
|]
where
table = findStatementByName tableName statements
- columns = maybe [] ((.columns) . unsafeGetCreateTable) table
+ columns = getTableColumns tableName statements
primaryKeyColumns = maybe [] (primaryKeyColumnNames . (.primaryKeyConstraint) . unsafeGetCreateTable) table
isArrayType (PArray _) = True
@@ -40,7 +40,7 @@
-