packages feed

ihp-ide 1.4.0 → 1.5.0

raw patch · 109 files changed

+8495/−4450 lines, 109 filesdep +filepathdep +hasqldep +hasql-dynamic-statementsdep −parser-combinatorsdep −postgresql-simpledep −wai-sessiondep ~directory

Dependencies added: filepath, hasql, hasql-dynamic-statements, hasql-implicits, hasql-pool, hspec, ihp-log, ihp-migrate, ihp-modal, ihp-postgres-parser, ihp-schema-compiler, wai-asset-path, wai-request-params, wai-session-clientsession-deferred, wai-session-maybe

Dependencies removed: parser-combinators, postgresql-simple, wai-session, wai-session-clientsession

Dependency ranges changed: directory

Files

IHP/IDE/CodeGen/ActionGenerator.hs view
@@ -3,8 +3,7 @@ import IHP.Prelude import qualified Data.Text as Text import IHP.IDE.CodeGen.Types-import qualified IHP.IDE.SchemaDesigner.Parser as SchemaDesigner-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import qualified IHP.IDE.CodeGen.ViewGenerator as ViewGenerator import Text.Countable (pluralize) @@ -20,9 +19,7 @@     if (null actionName || null controllerName)         then pure $ Left "Neither action name nor controller name can be empty"         else do-            schema <- SchemaDesigner.parseSchemaSql >>= \case-                Left parserError -> pure []-                Right statements -> pure statements+            schema <- loadAppSchema             let actionConfig = ActionConfig {controllerName, applicationName, modelName, actionName }             let actionPlan = generateGenericAction schema actionConfig doGenerateView             if doGenerateView@@ -49,12 +46,7 @@             controllerName = config.controllerName             name = ucfirst $ config.actionName             singularName = config.modelName-            nameWithSuffix = if "Action" `isSuffixOf` name-                    then name-                    else name <> "Action" -- e.g. TestAction-            viewName = if "Action" `isSuffixOf` name-                then Text.dropEnd 6 name-                else name+            (nameWithSuffix, viewName) = ensureSuffix "Action" name             indexAction = pluralize singularName <> "Action"             specialCases = [                   (indexAction, indexContent)@@ -79,63 +71,26 @@             idFieldName = lcfirst singularName <> "Id"             idType = "Id " <> singularName             model = ucfirst singularName++            tableFound = [ modelNameToTableName modelVariableSingular, modelVariableSingular ]+                    |> mapMaybe (columnsForTable schema)+                    |> headMay+                    |> isJust++            actionBodyConfig = ActionBodyConfig { singularName, modelVariableSingular, idFieldName, model, indexAction = name <> "Action", tableFound }+             indexContent =                 ""                 <> "    action " <> name <> "Action = do\n"                 <> "        " <> modelVariablePlural <> " <- query @" <> model <> " |> fetch\n"                 <> "        render IndexView { .. }\n" -            newContent =-                ""-                <> "    action New" <> singularName <> "Action = do\n"-                <> "        let " <> modelVariableSingular <> " = newRecord\n"-                <> "        render NewView { .. }\n"--            showContent =-                ""-                <> "    action Show" <> singularName <> "Action { " <> idFieldName <> " } = do\n"-                <> "        " <> modelVariableSingular <> " <- fetch " <> idFieldName <> "\n"-                <> "        render ShowView { .. }\n"--            editContent =-                ""-                <> "    action Edit" <> singularName <> "Action { " <> idFieldName <> " } = do\n"-                <> "        " <> modelVariableSingular <> " <- fetch " <> idFieldName <> "\n"-                <> "        render EditView { .. }\n"--            updateContent =-                ""-                <> "    action Update" <> singularName <> "Action { " <> idFieldName <> " } = do\n"-                <> "        " <> modelVariableSingular <> " <- fetch " <> idFieldName <> "\n"-                <> "        " <> modelVariableSingular <> "\n"-                <> "            |> build" <> singularName <> "\n"-                <> "            |> ifValid \\case\n"-                <> "                Left " <> modelVariableSingular <> " -> render EditView { .. }\n"-                <> "                Right " <> modelVariableSingular <> " -> do\n"-                <> "                    " <> modelVariableSingular <> " <- " <> modelVariableSingular <> " |> updateRecord\n"-                <> "                    setSuccessMessage \"" <> model <> " updated\"\n"-                <> "                    redirectTo Edit" <> singularName <> "Action { .. }\n"--            createContent =-                ""-                <> "    action Create" <> singularName <> "Action = do\n"-                <> "        let " <> modelVariableSingular <> " = newRecord @"  <> model <> "\n"-                <> "        " <> modelVariableSingular <> "\n"-                <> "            |> build" <> singularName <> "\n"-                <> "            |> ifValid \\case\n"-                <> "                Left " <> modelVariableSingular <> " -> render NewView { .. }\n"-                <> "                Right " <> modelVariableSingular <> " -> do\n"-                <> "                    " <> modelVariableSingular <> " <- " <> modelVariableSingular <> " |> createRecord\n"-                <> "                    setSuccessMessage \"" <> model <> " created\"\n"-                <> "                    redirectTo " <> name <> "Action\n"--            deleteContent =-                ""-                <> "    action Delete" <> singularName <> "Action { " <> idFieldName <> " } = do\n"-                <> "        " <> modelVariableSingular <> " <- fetch " <> idFieldName <> "\n"-                <> "        deleteRecord " <> modelVariableSingular <> "\n"-                <> "        setSuccessMessage \"" <> model <> " deleted\"\n"-                <> "        redirectTo " <> name <> "Action\n"+            newContent = generateNewActionBody actionBodyConfig+            showContent = generateShowActionBody actionBodyConfig+            editContent = generateEditActionBody actionBodyConfig+            updateContent = generateUpdateActionBody actionBodyConfig+            createContent = generateCreateActionBody actionBodyConfig+            deleteContent = generateDeleteActionBody actionBodyConfig              typesContentGeneric =                    "    | " <> nameWithSuffix@@ -150,6 +105,6 @@                 else typesContentWithParameter          in-            [ AddAction { filePath = config.applicationName <> "/Controller/" <> controllerName <> ".hs", fileContent = chosenContent}-            , AddToDataConstructor { dataConstructor = "data " <> controllerName, filePath = config.applicationName <> "/Types.hs", fileContent = chosenType }+            [ AddAction { filePath = textToOsPath (config.applicationName <> "/Controller/" <> controllerName <> ".hs"), fileContent = chosenContent}+            , AddToDataConstructor { dataConstructor = "data " <> controllerName, filePath = textToOsPath (config.applicationName <> "/Types.hs"), fileContent = chosenType }             ]
IHP/IDE/CodeGen/ApplicationGenerator.hs view
@@ -47,7 +47,6 @@                 <> "instance InitControllerContext " <> applicationName <> "Application where\n"                 <> "    initContext = do\n"                 <> "        setLayout defaultLayout\n"-                <> "        initAutoRefresh\n"             controllerPreludeHs =                 "module " <> applicationName <> ".Controller.Prelude\n"                 <> "( module " <> applicationName <> ".Types\n"@@ -68,7 +67,6 @@                 <> "import IHP.ViewPrelude\n"                 <> "import IHP.Environment\n"                 <> "import Generated.Types\n"-                <> "import IHP.Controller.RequestContext\n"                 <> "import " <> applicationName <> ".Types\n"                 <> "import " <> applicationName <> ".Routes\n"                 <> "import Application.Helper.View\n"@@ -100,7 +98,7 @@                 <> "\n"                 <> "stylesheets :: Html\n"                 <> "stylesheets = [hsx|\n"-                <> "        <link rel=\"stylesheet\" href={assetPath \"/vendor/bootstrap-5.2.1/bootstrap.min.css\"}/>\n"+                <> "        <link rel=\"stylesheet\" href={assetPath \"/vendor/bootstrap-5.3.8/bootstrap.min.css\"}/>\n"                 <> "        <link rel=\"stylesheet\" href={assetPath \"/vendor/flatpickr.min.css\"}/>\n"                 <> "        <link rel=\"stylesheet\" href={assetPath \"/app.css\"}/>\n"                 <> "    |]\n"@@ -108,10 +106,10 @@                 <> "scripts :: Html\n"                 <> "scripts = [hsx|\n"                 <> "        {when isDevelopment devScripts}\n"-                <> "        <script src={assetPath \"/vendor/jquery-3.6.0.slim.min.js\"}></script>\n"+                <> "        <script src={assetPath \"/vendor/jquery-4.0.0.slim.min.js\"}></script>\n"                 <> "        <script src={assetPath \"/vendor/timeago.js\"}></script>\n"                 <> "        <script src={assetPath \"/vendor/popper-2.11.6.min.js\"}></script>\n"-                <> "        <script src={assetPath \"/vendor/bootstrap-5.2.1/bootstrap.min.js\"}></script>\n"+                <> "        <script src={assetPath \"/vendor/bootstrap-5.3.8/bootstrap.min.js\"}></script>\n"                 <> "        <script src={assetPath \"/vendor/flatpickr.js\"}></script>\n"                 <> "        <script src={assetPath \"/vendor/morphdom-umd.min.js\"}></script>\n"                 <> "        <script src={assetPath \"/vendor/turbolinks.js\"}></script>\n"@@ -207,19 +205,19 @@              <>"|]"          in-            [ EnsureDirectory { directory = applicationName }-            , EnsureDirectory { directory = applicationName <> "/Controller" }-            , EnsureDirectory { directory = applicationName <> "/View" }-            , EnsureDirectory { directory = applicationName <> "/View/Static" }+            [ EnsureDirectory { directory = textToOsPath applicationName }+            , EnsureDirectory { directory = textToOsPath (applicationName <> "/Controller") }+            , EnsureDirectory { directory = textToOsPath (applicationName <> "/View") }+            , EnsureDirectory { directory = textToOsPath (applicationName <> "/View/Static") }             , AddImport  { filePath = "Main.hs", fileContent = "import " <> applicationName <> ".FrontController" }             , AddImport  { filePath = "Main.hs", fileContent = "import " <> applicationName <> ".Types" }             , AddMountToFrontController { filePath = "Main.hs", applicationName = applicationName }-            , CreateFile { filePath = applicationName <> "/Types.hs", fileContent = typesHs }-            , CreateFile { filePath = applicationName <> "/Routes.hs", fileContent = routesHs }-            , CreateFile { filePath = applicationName <> "/FrontController.hs", fileContent = frontControllerHs }-            , CreateFile { filePath = applicationName <> "/Controller/Prelude.hs", fileContent = controllerPreludeHs }-            , CreateFile { filePath = applicationName <> "/View/Layout.hs", fileContent = viewLayoutHs }-            , CreateFile { filePath = applicationName <> "/View/Prelude.hs", fileContent = viewPreludeHs }-            , CreateFile { filePath = applicationName <> "/Controller/Static.hs", fileContent = welcomeControllerStaticHs }-            , CreateFile { filePath = applicationName <> "/View/Static/Welcome.hs", fileContent = welcomeViewStaticHs }+            , CreateFile { filePath = textToOsPath (applicationName <> "/Types.hs"), fileContent = typesHs }+            , CreateFile { filePath = textToOsPath (applicationName <> "/Routes.hs"), fileContent = routesHs }+            , CreateFile { filePath = textToOsPath (applicationName <> "/FrontController.hs"), fileContent = frontControllerHs }+            , CreateFile { filePath = textToOsPath (applicationName <> "/Controller/Prelude.hs"), fileContent = controllerPreludeHs }+            , CreateFile { filePath = textToOsPath (applicationName <> "/View/Layout.hs"), fileContent = viewLayoutHs }+            , CreateFile { filePath = textToOsPath (applicationName <> "/View/Prelude.hs"), fileContent = viewPreludeHs }+            , CreateFile { filePath = textToOsPath (applicationName <> "/Controller/Static.hs"), fileContent = welcomeControllerStaticHs }+            , CreateFile { filePath = textToOsPath (applicationName <> "/View/Static/Welcome.hs"), fileContent = welcomeViewStaticHs }             ]
IHP/IDE/CodeGen/Controller.hs view
@@ -20,11 +20,11 @@ import IHP.IDE.CodeGen.JobGenerator as JobGenerator import IHP.IDE.ToolServer.Helper.Controller import qualified System.Process as Process-import qualified System.Directory as Directory+import qualified System.Directory.OsPath as Directory import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Text.Inflections as Inflector-import System.Directory+import System.OsPath (decodeUtf)  instance Controller CodeGenController where     action GeneratorsAction = do@@ -34,28 +34,64 @@         let controllerName = paramOrDefault "" "name"         let applicationName = paramOrDefault "Web" "applicationName"         let pagination = paramOrDefault False "pagination"+        let indexAction = paramOrDefault True "indexAction"+        let newAction = paramOrDefault True "newAction"+        let showAction = paramOrDefault True "showAction"+        let createAction = paramOrDefault True "createAction"+        let editAction = paramOrDefault True "editAction"+        let updateAction = paramOrDefault True "updateAction"+        let deleteAction = paramOrDefault True "deleteAction"         controllerAlreadyExists <- doesControllerExist controllerName applicationName         applications <- findApplications         when controllerAlreadyExists do             setErrorMessage "Controller with this name does already exist."             redirectTo NewControllerAction-        plan <- ControllerGenerator.buildPlan controllerName applicationName pagination+        let config = ControllerGenerator.defaultControllerConfig+                { ControllerGenerator.applicationName = applicationName+                , ControllerGenerator.paginationEnabled = pagination+                , ControllerGenerator.indexActionEnabled = indexAction+                , ControllerGenerator.newActionEnabled = newAction+                , ControllerGenerator.showActionEnabled = showAction+                , ControllerGenerator.createActionEnabled = createAction+                , ControllerGenerator.editActionEnabled = editAction+                , ControllerGenerator.updateActionEnabled = updateAction+                , ControllerGenerator.deleteActionEnabled = deleteAction+                }+        plan <- ControllerGenerator.buildPlan controllerName config         render NewControllerView { .. }         where-            doesControllerExist controllerName applicationName = doesFileExist $ cs applicationName <> "/Controller/" <> cs controllerName <> ".hs"+            doesControllerExist controllerName applicationName = Directory.doesFileExist $ textToOsPath $ applicationName <> "/Controller/" <> controllerName <> ".hs"      action CreateControllerAction = do         let controllerName = param "name"         let applicationName = param "applicationName"         let pagination = paramOrDefault False "pagination"-        (Right plan) <- ControllerGenerator.buildPlan controllerName applicationName pagination+        let indexAction = paramOrDefault True "indexAction"+        let newAction = paramOrDefault True "newAction"+        let showAction = paramOrDefault True "showAction"+        let createAction = paramOrDefault True "createAction"+        let editAction = paramOrDefault True "editAction"+        let updateAction = paramOrDefault True "updateAction"+        let deleteAction = paramOrDefault True "deleteAction"+        let config = ControllerGenerator.defaultControllerConfig+                { ControllerGenerator.applicationName = applicationName+                , ControllerGenerator.paginationEnabled = pagination+                , ControllerGenerator.indexActionEnabled = indexAction+                , ControllerGenerator.newActionEnabled = newAction+                , ControllerGenerator.showActionEnabled = showAction+                , ControllerGenerator.createActionEnabled = createAction+                , ControllerGenerator.editActionEnabled = editAction+                , ControllerGenerator.updateActionEnabled = updateAction+                , ControllerGenerator.deleteActionEnabled = deleteAction+                }+        (Right plan) <- ControllerGenerator.buildPlan controllerName config         executePlan plan         setSuccessMessage "Controller generated"         redirectTo GeneratorsAction      action NewScriptAction = do         let scriptName = paramOrDefault "" "name"-        scriptAlreadyExists <- doesFileExist $ "Application/Script/" <> cs scriptName <> ".hs"+        scriptAlreadyExists <- Directory.doesFileExist $ textToOsPath $ "Application/Script/" <> scriptName <> ".hs"         when scriptAlreadyExists do             setErrorMessage "Script with this name already exists."             redirectTo NewScriptAction@@ -73,7 +109,7 @@         let viewName = paramOrDefault "" "name"         let applicationName = paramOrDefault "Web" "applicationName"         let controllerName = paramOrDefault "" "controllerName"-        viewAlreadyExists <- doesFileExist $ (cs applicationName) <> "/View/" <> (cs controllerName) <> "/" <> (cs viewName) <>".hs"+        viewAlreadyExists <- Directory.doesFileExist $ textToOsPath $ applicationName <> "/View/" <> controllerName <> "/" <> viewName <> ".hs"         when viewAlreadyExists do             setErrorMessage "View with this name already exists."             redirectTo NewViewAction@@ -95,7 +131,7 @@         let mailName = paramOrDefault "" "name"         let applicationName = paramOrDefault "Web" "applicationName"         let controllerName = paramOrDefault "" "controllerName"-        mailAlreadyExists <- doesFileExist $ (cs applicationName) <> "/Mail/" <> (cs controllerName) <> "/" <> (cs mailName) <>".hs"+        mailAlreadyExists <- Directory.doesFileExist $ textToOsPath $ applicationName <> "/Mail/" <> controllerName <> "/" <> mailName <> ".hs"         when mailAlreadyExists do             setErrorMessage "Mail with this name already exists."             redirectTo NewMailAction@@ -174,34 +210,38 @@ executePlan actions = forEach actions evalAction     where         evalAction CreateFile { filePath, fileContent } = do-            Text.writeFile (cs filePath) (cs fileContent)-            putStrLn ("+ " <> filePath)+            fp <- decodeUtf filePath+            Text.writeFile fp (cs fileContent)+            putStrLn ("+ " <> osPathToText filePath)         evalAction AppendToFile { filePath, fileContent } = do-            Text.appendFile (cs filePath) fileContent-            putStrLn ("* " <> filePath)+            fp <- decodeUtf filePath+            Text.appendFile fp fileContent+            putStrLn ("* " <> osPathToText filePath)         evalAction AppendToMarker { marker, filePath, fileContent } = do-            content <- Text.readFile (cs filePath)+            fp <- decodeUtf filePath+            content <- Text.readFile fp             let newContent = Text.replace marker (marker <> "\n" <> cs fileContent) (cs content)-            Text.writeFile (cs filePath) (cs newContent)-            putStrLn ("* " <> filePath <> " (import)")+            Text.writeFile fp (cs newContent)+            putStrLn ("* " <> osPathToText filePath <> " (import)")         evalAction AddImport { filePath, fileContent } = do             addImport filePath fileContent-            putStrLn ("* " <> filePath <> " (import)")+            putStrLn ("* " <> osPathToText filePath <> " (import)")         evalAction AddAction { filePath, fileContent } = do             addAction filePath [fileContent]-            putStrLn ("* " <> filePath <> " (AddAction)")+            putStrLn ("* " <> osPathToText filePath <> " (AddAction)")         evalAction AddMountToFrontController { filePath, applicationName } = do             addMountControllerStatement filePath applicationName-            putStrLn ("* " <> filePath <> " (AddMountToFrontController)")+            putStrLn ("* " <> osPathToText filePath <> " (AddMountToFrontController)")         evalAction AddToDataConstructor { dataConstructor, filePath, fileContent } = do-            content <- Text.readFile (cs filePath)+            fp <- decodeUtf filePath+            content <- Text.readFile fp             case addToDataConstructor content dataConstructor fileContent of                 Just newContent -> do-                    Text.writeFile (cs filePath) (cs newContent)-                    putStrLn ("* " <> filePath <> " (AddToDataConstructor)")-                Nothing -> putStrLn ("Could not automatically add " <> tshow content <> " to " <> filePath)+                    Text.writeFile fp (cs newContent)+                    putStrLn ("* " <> osPathToText filePath <> " (AddToDataConstructor)")+                Nothing -> putStrLn ("Could not automatically add " <> tshow content <> " to " <> osPathToText filePath)         evalAction EnsureDirectory { directory } = do-            Directory.createDirectoryIfMissing True (cs directory)+            Directory.createDirectoryIfMissing True directory         evalAction RunShellCommand { shellCommand } = do             _ <- Process.system (cs shellCommand)             putStrLn ("* " <> shellCommand)@@ -209,41 +249,46 @@ undoPlan :: [GeneratorAction] -> IO() undoPlan actions = forEach actions evalAction     where-        evalAction CreateFile { filePath, fileContent } = do-            (Directory.removeFile (cs filePath)) `catch` handleError-            putStrLn ("- " <> filePath)+        evalAction CreateFile { filePath } = do+            Directory.removeFile filePath `catch` handleError+            putStrLn ("- " <> osPathToText filePath)         evalAction AppendToFile { filePath, fileContent } = do-            deleteTextFromFile (cs filePath) fileContent `catch` handleError-            putStrLn ("* " <> filePath)-        evalAction AppendToMarker { marker, filePath, fileContent } = do-            (deleteTextFromFile (cs filePath) (fileContent <> "\n")) `catch` handleError-            putStrLn ("* " <> filePath <> " (import)")+            deleteTextFromFile filePath fileContent `catch` handleError+            putStrLn ("* " <> osPathToText filePath)+        evalAction AppendToMarker { filePath, fileContent } = do+            deleteTextFromFile filePath (fileContent <> "\n") `catch` handleError+            putStrLn ("* " <> osPathToText filePath <> " (import)")         evalAction AddImport { filePath, fileContent } = do-            (deleteTextFromFile (cs filePath) (fileContent <> "\n")) `catch` handleError-            putStrLn ("* " <> filePath <> " (import)")+            deleteTextFromFile filePath (fileContent <> "\n") `catch` handleError+            putStrLn ("* " <> osPathToText filePath <> " (import)")         evalAction AddAction { filePath, fileContent } = do-            (deleteTextFromFile (cs filePath) (fileContent <> "\n")) `catch` handleError-            putStrLn ("* " <> filePath <> " (RemoveAction)")-        evalAction AddToDataConstructor { dataConstructor, filePath, fileContent } = do-            (deleteTextFromFile (cs filePath) (fileContent <> "\n")) `catch` handleError-            putStrLn ("* " <> filePath <> " (RemoveFromDataConstructor)")+            deleteTextFromFile filePath (fileContent <> "\n") `catch` handleError+            putStrLn ("* " <> osPathToText filePath <> " (RemoveAction)")+        evalAction AddMountToFrontController { filePath, applicationName } = do+            -- Undo is best-effort; removing the mount statement is not straightforward+            putStrLn ("* " <> osPathToText filePath <> " (RemoveMountFromFrontController - manual removal may be needed)")+        evalAction AddToDataConstructor { filePath, fileContent } = do+            deleteTextFromFile filePath (fileContent <> "\n") `catch` handleError+            putStrLn ("* " <> osPathToText filePath <> " (RemoveFromDataConstructor)")         evalAction EnsureDirectory { directory } = do-            (Directory.removeDirectory (cs directory)) `catch` handleError+            Directory.removeDirectory directory `catch` handleError         evalAction RunShellCommand { shellCommand } = pure ()         handleError :: SomeException -> IO ()         handleError ex = putStrLn (tshow ex) -deleteTextFromFile :: Text -> Text -> IO ()+deleteTextFromFile :: OsPath -> Text -> IO () deleteTextFromFile filePath lineContent = do-    fileContent <- Text.readFile (cs filePath)+    fp <- decodeUtf filePath+    fileContent <- Text.readFile fp     let replacedContent = Text.replace lineContent "" fileContent-    Text.writeFile (cs filePath) replacedContent+    Text.writeFile fp replacedContent -addImport :: Text -> Text -> IO ()+addImport :: OsPath -> Text -> IO () addImport file importStatement = do-    content :: Text <- Text.readFile (cs file)+    fp <- decodeUtf file+    content :: Text <- Text.readFile fp     case addImport' content importStatement of-        Just newContent -> Text.writeFile (cs file) (cs newContent)+        Just newContent -> Text.writeFile fp (cs newContent)         Nothing -> pure ()     pure () @@ -253,23 +298,25 @@         then Nothing         else appendLineAfter content ("import" `isPrefixOf`) [importStatement] -addAction :: Text -> [Text] -> IO ()+addAction :: OsPath -> [Text] -> IO () addAction filePath fileContent = do-    content <- Text.readFile (cs filePath)+    fp <- decodeUtf filePath+    content <- Text.readFile fp     case addAction' content fileContent of-        Just newContent -> Text.writeFile (cs filePath) (cs newContent)-        Nothing -> putStrLn ("Could not automatically add " <> tshow content <> " to " <> filePath)+        Just newContent -> Text.writeFile fp (cs newContent)+        Nothing -> putStrLn ("Could not automatically add " <> tshow content <> " to " <> osPathToText filePath)     pure ()  addAction' :: Text -> [Text] -> Maybe Text addAction' fileContent = appendLineAfter fileContent ("instance Controller" `isPrefixOf`) -addMountControllerStatement :: Text -> Text -> IO ()+addMountControllerStatement :: OsPath -> Text -> IO () addMountControllerStatement file applicationName = do-    content :: Text <- Text.readFile (cs file)+    fp <- decodeUtf file+    content :: Text <- Text.readFile fp     case addMountControllerStatement' applicationName content of-        Just newContent -> Text.writeFile (cs file) (cs newContent)-        Nothing -> putStrLn ("Could not automatically add " <> tshow applicationName <> " to " <> file)+        Just newContent -> Text.writeFile fp (cs newContent)+        Nothing -> putStrLn ("Could not automatically add " <> tshow applicationName <> " to " <> osPathToText file)     pure ()  addMountControllerStatement' :: Text -> Text -> Maybe Text
IHP/IDE/CodeGen/ControllerGenerator.hs view
@@ -1,35 +1,33 @@-module IHP.IDE.CodeGen.ControllerGenerator (buildPlan, buildPlan') where+module IHP.IDE.CodeGen.ControllerGenerator (buildPlan, buildPlan', ControllerConfig(..), defaultControllerConfig) where  import ClassyPrelude+import IHP.Prelude (textToOsPath) import IHP.NameSupport import IHP.HaskellSupport import qualified Data.Text as Text import qualified Data.Char as Char-import qualified IHP.IDE.SchemaDesigner.Parser as SchemaDesigner-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.CodeGen.Types import qualified IHP.IDE.CodeGen.ViewGenerator as ViewGenerator import Text.Countable (singularize, pluralize) -buildPlan :: Text -> Text -> Bool -> IO (Either Text [GeneratorAction])-buildPlan rawControllerName applicationName paginationEnabled = do-    schema <- SchemaDesigner.parseSchemaSql >>= \case-        Left parserError -> pure []-        Right statements -> pure statements+buildPlan :: Text -> ControllerConfig -> IO (Either Text [GeneratorAction])+buildPlan rawControllerName config = do+    schema <- loadAppSchema     let controllerName = tableNameToControllerName rawControllerName     let modelName = tableNameToModelName rawControllerName-    pure $ Right $ buildPlan' schema applicationName controllerName modelName paginationEnabled+    pure $ Right $ buildPlan' schema config { controllerName, modelName } -buildPlan' schema applicationName controllerName modelName paginationEnabled =+buildPlan' :: [Statement] -> ControllerConfig -> [GeneratorAction]+buildPlan' schema config =     let-        config = ControllerConfig { modelName, controllerName, applicationName, paginationEnabled }-        viewPlans = generateViews schema applicationName controllerName paginationEnabled+        viewPlans = generateViews schema config     in-        [ CreateFile { filePath = applicationName <> "/Controller/" <> controllerName <> ".hs", fileContent = (generateController schema config) }-        , AppendToFile { filePath = applicationName <> "/Routes.hs", fileContent = "\n" <> (controllerInstance config) }-        , AppendToFile { filePath = applicationName <> "/Types.hs", fileContent = (generateControllerData config) }-        , AppendToMarker { marker = "-- Controller Imports", filePath = applicationName <> "/FrontController.hs", fileContent = ("import " <> applicationName <> ".Controller." <> controllerName) }-        , AppendToMarker { marker = "-- Generator Marker", filePath = applicationName <> "/FrontController.hs", fileContent = ("        , parseRoute @" <> controllerName <> "Controller") }+        [ CreateFile { filePath = textToOsPath (config.applicationName <> "/Controller/" <> config.controllerName <> ".hs"), fileContent = (generateController schema config) }+        , AppendToFile { filePath = textToOsPath (config.applicationName <> "/Routes.hs"), fileContent = "\n" <> (controllerInstance config) }+        , AppendToFile { filePath = textToOsPath (config.applicationName <> "/Types.hs"), fileContent = (generateControllerData schema config) }+        , AppendToMarker { marker = "-- Controller Imports", filePath = textToOsPath (config.applicationName <> "/FrontController.hs"), fileContent = ("import " <> config.applicationName <> ".Controller." <> config.controllerName) }+        , AppendToMarker { marker = "-- Generator Marker", filePath = textToOsPath (config.applicationName <> "/FrontController.hs"), fileContent = ("        , parseRoute @" <> config.controllerName <> "Controller") }         ]         <> viewPlans @@ -38,33 +36,71 @@     , applicationName :: Text     , modelName :: Text     , paginationEnabled :: Bool+    , indexActionEnabled :: Bool+    , newActionEnabled :: Bool+    , showActionEnabled :: Bool+    , createActionEnabled :: Bool+    , editActionEnabled :: Bool+    , updateActionEnabled :: Bool+    , deleteActionEnabled :: Bool     } deriving (Eq, Show) +defaultControllerConfig :: ControllerConfig+defaultControllerConfig = ControllerConfig+    { controllerName = ""+    , applicationName = "Web"+    , modelName = ""+    , paginationEnabled = False+    , indexActionEnabled = True+    , newActionEnabled = True+    , showActionEnabled = True+    , createActionEnabled = True+    , editActionEnabled = True+    , updateActionEnabled = True+    , deleteActionEnabled = True+    }+ controllerInstance :: ControllerConfig -> Text controllerInstance ControllerConfig { controllerName, modelName, applicationName } =     "instance AutoRoute " <> controllerName <> "Controller\n\n"  data HaskellModule = HaskellModule { moduleName :: Text, body :: Text } -generateControllerData :: ControllerConfig -> Text-generateControllerData config =+generateControllerData :: [Statement] -> ControllerConfig -> Text+generateControllerData schema config =     let         name = config.controllerName         pluralName = config.controllerName |> lcfirst |> pluralize |> ucfirst         singularName = config.modelName |> lcfirst |> singularize |> ucfirst+        modelVariableSingular = lcfirst singularName         idFieldName = lcfirst singularName <> "Id"         idType = "Id " <> singularName+        tableFound = [ modelNameToTableName modelVariableSingular, modelVariableSingular ]+                |> mapMaybe (columnsForTable schema)+                |> headMay+                |> isJust+        idRecord suffix = if tableFound+            then suffix <> " { " <> idFieldName <> " :: !(" <> idType <> ") }"+            else suffix+        constructors = catMaybes+            [ if config.indexActionEnabled then Just (pluralName <> "Action") else Nothing+            , if config.newActionEnabled then Just ("New" <> singularName <> "Action") else Nothing+            , if config.showActionEnabled then Just (idRecord $ "Show" <> singularName <> "Action") else Nothing+            , if config.createActionEnabled then Just ("Create" <> singularName <> "Action") else Nothing+            , if config.editActionEnabled then Just (idRecord $ "Edit" <> singularName <> "Action") else Nothing+            , if config.updateActionEnabled then Just (idRecord $ "Update" <> singularName <> "Action") else Nothing+            , if config.deleteActionEnabled then Just (idRecord $ "Delete" <> singularName <> "Action") else Nothing+            ]+        formattedConstructors = case constructors of+            (first:rest) ->+                "    = " <> first <> "\n"+                <> concatMap (\c -> "    | " <> c <> "\n") rest+                <> "    deriving (Eq, Show, Data)\n"+            [] -> "    deriving (Eq, Show, Data)\n"     in         "\n"         <> "data " <> name <> "Controller\n"-        <> "    = " <> pluralName <> "Action\n"-        <> "    | New" <> singularName <> "Action\n"-        <> "    | Show" <> singularName <> "Action { " <> idFieldName <> " :: !(" <> idType <> ") }\n"-        <> "    | Create" <> singularName <> "Action\n"-        <> "    | Edit" <> singularName <> "Action { " <> idFieldName <> " :: !(" <> idType <> ") }\n"-        <> "    | Update" <> singularName <> "Action { " <> idFieldName <> " :: !(" <> idType <> ") }\n"-        <> "    | Delete" <> singularName <> "Action { " <> idFieldName <> " :: !(" <> idType <> ") }\n"-        <> "    deriving (Eq, Show, Data)\n"+        <> formattedConstructors  generateController :: [Statement] -> ControllerConfig -> Text generateController schema config =@@ -76,13 +112,18 @@         moduleName =  applicationName <> ".Controller." <> name         controllerName = name <> "Controller" -        importStatements =-            [ "import " <> applicationName <> ".Controller.Prelude"-            , "import " <> qualifiedViewModuleName config "Index"-            , "import " <> qualifiedViewModuleName config "New"-            , "import " <> qualifiedViewModuleName config "Edit"-            , "import " <> qualifiedViewModuleName config "Show"+        -- Create/Update reference NewView/EditView on validation errors+        needsNewView = config.newActionEnabled || config.createActionEnabled+        needsEditView = config.editActionEnabled || config.updateActionEnabled+        needsIndexView = config.indexActionEnabled+        needsShowView = config.showActionEnabled +        importStatements = catMaybes+            [ Just ("import " <> applicationName <> ".Controller.Prelude")+            , if needsIndexView then Just ("import " <> qualifiedViewModuleName config "Index") else Nothing+            , if needsNewView then Just ("import " <> qualifiedViewModuleName config "New") else Nothing+            , if needsEditView then Just ("import " <> qualifiedViewModuleName config "Edit") else Nothing+            , if needsShowView then Just ("import " <> qualifiedViewModuleName config "Show") else Nothing             ]          modelVariablePlural = lcfirst name@@ -91,6 +132,8 @@         model = ucfirst singularName         paginationEnabled = config.paginationEnabled +        actionBodyConfig = ActionBodyConfig { singularName, modelVariableSingular, idFieldName, model, indexAction = pluralName <> "Action", tableFound }+         indexAction =             ""             <> "    action " <> pluralName <> "Action = do\n"@@ -101,70 +144,92 @@             )             <> "        render IndexView { .. }\n" -        newAction =-            ""-            <> "    action New" <> singularName <> "Action = do\n"-            <> "        let " <> modelVariableSingular <> " = newRecord\n"-            <> "        render NewView { .. }\n"--        showAction =-            ""-            <> "    action Show" <> singularName <> "Action { " <> idFieldName <> " } = do\n"-            <> "        " <> modelVariableSingular <> " <- fetch " <> idFieldName <> "\n"-            <> "        render ShowView { .. }\n"+        newAction = generateNewActionBody actionBodyConfig+        showAction = generateShowActionBody actionBodyConfig+        editAction = generateEditActionBody actionBodyConfig -        editAction =-            ""-            <> "    action Edit" <> singularName <> "Action { " <> idFieldName <> " } = do\n"-            <> "        " <> modelVariableSingular <> " <- fetch " <> idFieldName <> "\n"-            <> "        render EditView { .. }\n"+        tableFound :: Bool+        tableFound = [ modelNameToTableName modelVariableSingular, modelVariableSingular ]+                |> mapMaybe (columnsForTable schema)+                |> headMay+                |> isJust -        modelFields :: [Text]-        modelFields = [ modelNameToTableName modelVariableSingular, modelVariableSingular ]-                |> mapMaybe (fieldsForTable schema)+        modelColumns :: [Column]+        modelColumns = [ modelNameToTableName modelVariableSingular, modelVariableSingular ]+                |> mapMaybe (columnsForTable schema)                 |> headMay                 |> fromMaybe [] -        updateAction =-            ""-            <> "    action Update" <> singularName <> "Action { " <> idFieldName <> " } = do\n"-            <> "        " <> modelVariableSingular <> " <- fetch " <> idFieldName <> "\n"-            <> "        " <> modelVariableSingular <> "\n"-            <> "            |> build" <> singularName <> "\n"-            <> "            |> ifValid \\case\n"-            <> "                Left " <> modelVariableSingular <> " -> render EditView { .. }\n"-            <> "                Right " <> modelVariableSingular <> " -> do\n"-            <> "                    " <> modelVariableSingular <> " <- " <> modelVariableSingular <> " |> updateRecord\n"-            <> "                    setSuccessMessage \"" <> model <> " updated\"\n"-            <> "                    redirectTo Edit" <> singularName <> "Action { .. }\n"+        modelFields :: [Text]+        modelFields = modelColumns+                |> map (.name)+                |> map columnNameToFieldName -        createAction =-            ""-            <> "    action Create" <> singularName <> "Action = do\n"-            <> "        let " <> modelVariableSingular <> " = newRecord @"  <> model <> "\n"-            <> "        " <> modelVariableSingular <> "\n"-            <> "            |> build" <> singularName <> "\n"-            <> "            |> ifValid \\case\n"-            <> "                Left " <> modelVariableSingular <> " -> render NewView { .. } \n"-            <> "                Right " <> modelVariableSingular <> " -> do\n"-            <> "                    " <> modelVariableSingular <> " <- " <> modelVariableSingular <> " |> createRecord\n"-            <> "                    setSuccessMessage \"" <> model <> " created\"\n"-            <> "                    redirectTo " <> pluralName <> "Action\n"+        foreignKeys :: [(Text, Text)]+        foreignKeys = [ modelNameToTableName modelVariableSingular, modelVariableSingular ]+                |> map (foreignKeysForTable schema)+                |> concat -        deleteAction =-            ""-            <> "    action Delete" <> singularName <> "Action { " <> idFieldName <> " } = do\n"-            <> "        " <> modelVariableSingular <> " <- fetch " <> idFieldName <> "\n"-            <> "        deleteRecord " <> modelVariableSingular <> "\n"-            <> "        setSuccessMessage \"" <> model <> " deleted\"\n"-            <> "        redirectTo " <> pluralName <> "Action\n"+        extraUniqueColumns :: [Text]+        extraUniqueColumns = [ modelNameToTableName modelVariableSingular, modelVariableSingular ]+                |> map (uniqueColumnsForTable schema)+                |> concat +        updateAction = generateUpdateActionBody actionBodyConfig+        createAction = generateCreateActionBody actionBodyConfig+        deleteAction = generateDeleteActionBody actionBodyConfig++        needsBuildModel = config.createActionEnabled || config.updateActionEnabled+         fromParams =-            ""-            <> "build" <> singularName <> " " <> modelVariableSingular <> " = " <> modelVariableSingular <> "\n"-            <> "    |> fill " <> toTypeLevelList modelFields <> "\n"+            if needsBuildModel+            then ""+                <> "build" <> singularName <> " " <> modelVariableSingular <> " = " <> modelVariableSingular <> "\n"+                <> "    |> fill " <> toTypeLevelList modelFields <> "\n"+                <> validationLines+            else ""          toTypeLevelList values = "@'" <> (values |> tshow |> Text.replace "," ", ")++        validationLines :: Text+        validationLines =+            let+                fkColumnNames = map fst foreignKeys+                isTextLike = isTextLikeType . (.columnType)+                isTextLikeType PText = True+                isTextLikeType (PVaryingN _) = True+                isTextLikeType (PCharacterN _) = True+                isTextLikeType _ = False++                validationsFor col =+                    let fieldName = columnNameToFieldName col.name+                        nonEmptyLine+                            | col.notNull && isTextLike col && col.name `notElem` fkColumnNames+                            = ["    |> validateField #" <> fieldName <> " nonEmpty"]+                            | otherwise = []+                        emailLine+                            | "email" `Text.isSuffixOf` col.name && isTextLike col+                            = ["    |> validateField #" <> fieldName <> " isEmail"]+                            | otherwise = []+                        uniqueLine+                            | col.name `elem` extraUniqueColumns+                            = ["    -- TODO: |> validateIsUnique #" <> fieldName]+                            | otherwise = []+                    in nonEmptyLine <> emailLine <> uniqueLine+            in+                case concatMap validationsFor modelColumns of+                    [] -> ""+                    lines -> intercalate "\n" lines <> "\n"++        actionBodies = catMaybes+            [ if config.indexActionEnabled then Just indexAction else Nothing+            , if config.newActionEnabled then Just newAction else Nothing+            , if config.showActionEnabled then Just showAction else Nothing+            , if config.editActionEnabled then Just editAction else Nothing+            , if config.updateActionEnabled then Just updateAction else Nothing+            , if config.createActionEnabled then Just createAction else Nothing+            , if config.deleteActionEnabled then Just deleteAction else Nothing+            ]     in         ""         <> "module " <> moduleName <> " where" <> "\n"@@ -172,45 +237,40 @@         <> intercalate "\n" importStatements         <> "\n\n"         <> "instance Controller " <> controllerName <> " where\n"-        <> indexAction-        <> "\n"-        <> newAction-        <> "\n"-        <> showAction-        <> "\n"-        <> editAction-        <> "\n"-        <> updateAction-        <> "\n"-        <> createAction-        <> "\n"-        <> deleteAction+        <> intercalate "\n" actionBodies         <> "\n"         <> fromParams  -- E.g. qualifiedViewModuleName config "Edit" == "Web.View.Users.Edit" qualifiedViewModuleName :: ControllerConfig -> Text -> Text qualifiedViewModuleName config viewName =-    config.applicationName <> ".View." <> config.controllerName <> "." <> viewName+    qualifiedModuleName config.applicationName "View" config.controllerName viewName  pathToModuleName :: Text -> Text pathToModuleName moduleName = Text.replace "." "/" moduleName -generateViews :: [Statement] -> Text -> Text -> Bool -> [GeneratorAction]-generateViews schema applicationName controllerName' paginationEnabled =-    if null controllerName'+generateViews :: [Statement] -> ControllerConfig -> [GeneratorAction]+generateViews schema config =+    if null config.controllerName         then []         else do-            let indexPlan = ViewGenerator.buildPlan' schema (config "IndexView")-            let newPlan = ViewGenerator.buildPlan' schema (config "NewView")-            let showPlan = ViewGenerator.buildPlan' schema (config "ShowView")-            let editPlan = ViewGenerator.buildPlan' schema (config "EditView")-            indexPlan <> newPlan <> showPlan <> editPlan+            let needsIndexView = config.indexActionEnabled+            let needsNewView = config.newActionEnabled || config.createActionEnabled+            let needsShowView = config.showActionEnabled+            let needsEditView = config.editActionEnabled || config.updateActionEnabled+            concat $ catMaybes+                [ if needsIndexView then Just (ViewGenerator.buildPlan' schema (viewConfig "IndexView")) else Nothing+                , if needsNewView then Just (ViewGenerator.buildPlan' schema (viewConfig "NewView")) else Nothing+                , if needsShowView then Just (ViewGenerator.buildPlan' schema (viewConfig "ShowView")) else Nothing+                , if needsEditView then Just (ViewGenerator.buildPlan' schema (viewConfig "EditView")) else Nothing+                ]     where-        config viewName = do-            let modelName = tableNameToModelName controllerName'-            let controllerName = tableNameToControllerName controllerName'-            ViewGenerator.ViewConfig { .. }+        viewConfig viewName =+            let modelName = config.modelName+                controllerName = config.controllerName+                applicationName = config.applicationName+                paginationEnabled = config.paginationEnabled+            in ViewGenerator.ViewConfig { .. }   isAlphaOnly :: Text -> Bool
+ IHP/IDE/CodeGen/DefaultUuidFunction.hs view
@@ -0,0 +1,3 @@+module IHP.IDE.CodeGen.DefaultUuidFunction (defaultUuidFunction) where++import IHP.PGVersion (defaultUuidFunction)
IHP/IDE/CodeGen/JobGenerator.hs view
@@ -3,18 +3,21 @@ import IHP.Prelude import qualified Data.Text as Text import IHP.IDE.CodeGen.Types-import qualified System.Directory as Directory+import qualified System.Directory.OsPath as Directory  data JobConfig = JobConfig     { applicationName :: Text     , tableName :: Text -- E.g. create_container_jobs     , modelName :: Text -- E.g. CreateContainerJob     , isFirstJobInApplication :: Bool -- If true, creates Worker.hs in application directory+    , uuidFunction :: Text -- E.g. "uuid_generate_v4" or "uuidv7"     } deriving (Eq, Show)  buildPlan :: Text -> Text -> IO (Either Text [GeneratorAction]) buildPlan jobName applicationName = do-    isFirstJobInApplication <- not <$> Directory.doesFileExist (cs $ applicationName <> "/Worker.hs")+    let workerPath = textToOsPath (applicationName <> "/Worker.hs")+    isFirstJobInApplication <- not <$> Directory.doesFileExist workerPath+    uuidFunction <- defaultUuidFunction     if null jobName         then pure $ Left "Job name cannot be empty"         else do@@ -23,10 +26,11 @@                     , tableName = jobName                     , modelName = tableNameToModelName jobName                     , isFirstJobInApplication+                    , uuidFunction                     }             pure $ Right $ buildPlan' jobConfig --- E.g. qualifiedMailModuleName config "Confirmation" == "Web.Mail.Users.Confirmation"+-- E.g. qualifiedJobModuleName config == "Web.Job.CreateContainer" qualifiedJobModuleName :: JobConfig -> Text qualifiedJobModuleName config =     config.applicationName <> ".Job." <> unqualifiedJobModuleName config@@ -39,12 +43,7 @@         let             name = config.modelName             tableName = modelNameToTableName nameWithSuffix-            nameWithSuffix = if "Job" `isSuffixOf` name-                then name-                else name <> "Job" --e.g. "Test" -> "TestJob"-            nameWithoutSuffix = if "Job" `isSuffixOf` name-                then Text.replace "Job" "" name-                else name --e.g. "TestJob" -> "Test""+            (nameWithSuffix, nameWithoutSuffix) = ensureSuffix "Job" name              job =                 ""@@ -58,7 +57,7 @@             schemaSql =                 ""                 <> "CREATE TABLE " <> tableName <> " (\n"-                <> "    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,\n"+                <> "    id UUID DEFAULT " <> config.uuidFunction <> "() PRIMARY KEY NOT NULL,\n"                 <> "    created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n"                 <> "    updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n"                 <> "    status JOB_STATUS DEFAULT 'job_status_not_started' NOT NULL,\n"@@ -91,13 +90,13 @@         ] |]         in-            [ EnsureDirectory { directory = config.applicationName <> "/Job" }+            [ EnsureDirectory { directory = textToOsPath (config.applicationName <> "/Job") }             , AppendToFile { filePath = "Application/Schema.sql", fileContent = schemaSql }-            , CreateFile { filePath = config.applicationName <> "/Job/" <> nameWithoutSuffix <> ".hs", fileContent = job }+            , CreateFile { filePath = textToOsPath (config.applicationName <> "/Job/" <> nameWithoutSuffix <> ".hs"), fileContent = job }             ]             <> if config.isFirstJobInApplication-                    then [ CreateFile { filePath = config.applicationName <> "/Worker.hs", fileContent = emptyWorkerHs } ]+                    then [ CreateFile { filePath = textToOsPath (config.applicationName <> "/Worker.hs"), fileContent = emptyWorkerHs } ]                     else-                        [ AddImport { filePath = config.applicationName <> "/Worker.hs", fileContent = "import " <> qualifiedJobModuleName config }-                        , AppendToMarker { marker = "-- Generator Marker", filePath = config.applicationName <> "/Worker.hs", fileContent = "        , worker @" <> nameWithSuffix }+                        [ AddImport { filePath = textToOsPath (config.applicationName <> "/Worker.hs"), fileContent = "import " <> qualifiedJobModuleName config }+                        , AppendToMarker { marker = "-- Generator Marker", filePath = textToOsPath (config.applicationName <> "/Worker.hs"), fileContent = "        , worker @" <> nameWithSuffix }                         ]
IHP/IDE/CodeGen/MailGenerator.hs view
@@ -2,10 +2,8 @@  import IHP.Prelude import IHP.IDE.CodeGen.Types-import qualified Data.Text as Text-import qualified IHP.IDE.SchemaDesigner.Parser as SchemaDesigner-import IHP.IDE.SchemaDesigner.Types-import Text.Countable (singularize, pluralize)+import IHP.Postgres.Types+import Text.Countable (pluralize)  data MailConfig = MailConfig     { controllerName :: Text@@ -19,18 +17,16 @@     if (null mailName || null controllerName')         then pure $ Left "Neither mail name nor controller name can be empty"         else do-            schema <- SchemaDesigner.parseSchemaSql >>= \case-                Left parserError -> pure []-                Right statements -> pure statements+            schema <- loadAppSchema             let modelName = tableNameToModelName controllerName'             let controllerName = tableNameToControllerName controllerName'             let viewConfig = MailConfig { .. }             pure $ Right $ buildPlan' schema viewConfig  -- E.g. qualifiedMailModuleName config "Confirmation" == "Web.Mail.Users.Confirmation"-qualifiedViewModuleName :: MailConfig -> Text -> Text-qualifiedViewModuleName config mailName =-    config.applicationName <> ".Mail." <> config.controllerName <> "." <> ucfirst mailName+qualifiedMailModuleName :: MailConfig -> Text -> Text+qualifiedMailModuleName config mailName =+    qualifiedModuleName config.applicationName "Mail" config.controllerName (ucfirst mailName)  buildPlan' :: [Statement] -> MailConfig -> [GeneratorAction] buildPlan' schema config =@@ -40,12 +36,7 @@             singularName = config.modelName             singularVariableName = lcfirst singularName             pluralVariableName = lcfirst controllerName-            nameWithSuffix = if "Mail" `isSuffixOf` name-                then name-                else name <> "Mail" --e.g. "Test" -> "TestMail"-            nameWithoutSuffix = if "Mail" `isSuffixOf` name-                then Text.replace "Mail" "" name-                else name --e.g. "TestMail" -> "Test"+            (nameWithSuffix, nameWithoutSuffix) = ensureSuffix "Mail" name              indexAction = pluralize singularName <> "Action" @@ -57,7 +48,7 @@              mail =                 ""-                <> "module " <> qualifiedViewModuleName config nameWithoutSuffix <> " where\n"+                <> "module " <> qualifiedMailModuleName config nameWithoutSuffix <> " where\n"                 <> "import " <> config.applicationName <> ".View.Prelude\n"                 <> "import IHP.MailPrelude\n"                 <> "\n"@@ -71,7 +62,7 @@                 <> "        Hello World\n"                 <> "    |]\n"         in-            [ EnsureDirectory { directory = config.applicationName <> "/Mail/" <> controllerName }-            , CreateFile { filePath = config.applicationName <> "/Mail/" <> controllerName <> "/" <> nameWithoutSuffix <> ".hs", fileContent = mail }-            , AddImport { filePath = config.applicationName <> "/Controller/" <> controllerName <> ".hs", fileContent = "import " <> qualifiedViewModuleName config nameWithoutSuffix }+            [ EnsureDirectory { directory = textToOsPath (config.applicationName <> "/Mail/" <> controllerName) }+            , CreateFile { filePath = textToOsPath (config.applicationName <> "/Mail/" <> controllerName <> "/" <> nameWithoutSuffix <> ".hs"), fileContent = mail }+            , AddImport { filePath = textToOsPath (config.applicationName <> "/Controller/" <> controllerName <> ".hs"), fileContent = "import " <> qualifiedMailModuleName config nameWithoutSuffix }             ]
IHP/IDE/CodeGen/MigrationGenerator.hs view
@@ -12,10 +12,11 @@ import qualified IHP.NameSupport as NameSupport import qualified Data.Char as Char import qualified System.Process as Process-import qualified IHP.IDE.SchemaDesigner.Parser as Parser-import IHP.IDE.SchemaDesigner.Types+import qualified IHP.Postgres.Parser as Parser+import qualified IHP.SchemaCompiler.Parser as SchemaDesignerParser+import IHP.Postgres.Types import Text.Megaparsec-import IHP.IDE.SchemaDesigner.Compiler (compileSql)+import IHP.Postgres.Compiler (compileSql) import IHP.IDE.CodeGen.Types import qualified IHP.FrameworkConfig as FrameworkConfig import Paths_ihp_ide (getDataFileName)@@ -42,11 +43,11 @@                 else compileSql appDiff     pure (revision,             [ EnsureDirectory { directory = "Application/Migration" }-            , CreateFile { filePath = "Application/Migration/" <> migrationFile, fileContent = migrationSql }+            , CreateFile { filePath = textToOsPath ("Application/Migration/" <> migrationFile), fileContent = migrationSql }             ])  diffAppDatabase includeIHPSchema databaseUrl = do-    (Right schemaSql) <- Parser.parseSchemaSql+    (Right schemaSql) <- SchemaDesignerParser.parseSchemaSql     (Right ihpSchemaSql) <- if includeIHPSchema             then parseIHPSchema             else pure (Right [])@@ -61,8 +62,11 @@     ihpSchemaSql <- findIHPSchemaSql     Parser.parseSqlFile ihpSchemaSql -findIHPSchemaSql :: IO FilePath-findIHPSchemaSql = getDataFileName "IHPSchema.sql"+findIHPSchemaSql :: IO OsPath+findIHPSchemaSql = do+    fp <- getDataFileName ("IHPSchema.sql" :: String)+    let fpText :: Text = cs fp+    pure (textToOsPath fpText)  diffSchemas :: [Statement] -> [Statement] -> [Statement] diffSchemas targetSchema' actualSchema' = (drop <> create)@@ -134,6 +138,7 @@                             to = createTable'.name                         in                             (RenameTable { from, to }):(applyRenameTable (fixIdentifiers from to (delete createTable statements)))+                    Just _ -> s:(applyRenameTable statements)  -- Not a StatementCreateTable, skip rename                     Nothing -> s:(applyRenameTable statements)             where                 createTable :: Maybe Statement@@ -150,6 +155,7 @@                 actualTable' :: CreateTable                 actualTable' = case actualTable of                     StatementCreateTable { unsafeGetCreateTable = table } -> table+                    _ -> error "diffSchemas: expected StatementCreateTable"                  fixIdentifiers :: Text -> Text -> [Statement] -> [Statement]                 fixIdentifiers tableFrom tableTo statements = map fixIdentifier statements@@ -339,6 +345,7 @@                                 normalizeCol col = col { notNull = False, defaultValue = Just (VarExpression "null") }                 applyToggleNull (statement:rest) = statement:(applyToggleNull rest)                 applyToggleNull [] = []+migrateTable _ _ = error "migrateTable: expected StatementCreateTable"  migrateEnum :: Statement -> Statement -> [Statement] migrateEnum CreateEnumType { name, values = targetValues } CreateEnumType { values = actualValues } = map addValue newValues@@ -348,6 +355,7 @@          addValue :: Text -> Statement         addValue value = AddValueToEnumType { enumName = name, newValue = value, ifNotExists = True }+migrateEnum _ _ = error "migrateEnum: expected CreateEnumType"  getAppDBSchema :: Text -> IO [Statement] getAppDBSchema databaseUrl = do@@ -519,6 +527,7 @@         unqualifiedName name = name normalizeExpression (DotExpression a b) = DotExpression (normalizeExpression a) b normalizeExpression (ExistsExpression a) = ExistsExpression (normalizeExpression a)+normalizeExpression (InArrayExpression exprs) = InArrayExpression (map normalizeExpression exprs)  -- | Replaces @table.field@ with just @field@ --@@ -554,6 +563,7 @@             in                 SelectExpression Select { columns = (recurse <$> columns), from = from, whereClause = recurse whereClause, alias }         doUnqualify (ExistsExpression a) = ExistsExpression (doUnqualify a)+        doUnqualify (InArrayExpression exprs) = InArrayExpression (map doUnqualify exprs)         doUnqualify (DotExpression (VarExpression scope') b) | scope == scope' = VarExpression b         doUnqualify (DotExpression a b) = DotExpression (doUnqualify a) b @@ -585,6 +595,8 @@         e@(SelectExpression Select { columns, from, whereClause, alias }) -> SelectExpression Select { columns = rec <$> columns, from = rec from, whereClause = rec whereClause, alias = alias }         e@(DotExpression a b) -> DotExpression (rec a) b         e@(ExistsExpression a) -> ExistsExpression (rec a)+        e@(ConcatenationExpression a b) -> ConcatenationExpression (rec a) (rec b)+        e@(InArrayExpression exprs) -> InArrayExpression (map rec exprs) resolveAlias Nothing fromExpression expression = expression  normalizeSqlType :: PostgresType -> PostgresType@@ -600,7 +612,7 @@                     CreateFile {} -> True                     otherwise     -> False                 |> \case-                    Just CreateFile { filePath } -> Just filePath+                    Just CreateFile { filePath } -> Just (osPathToText filePath)                     otherwise                    -> Nothing         in             path@@ -663,6 +675,7 @@                                     |> isNothing                             Nothing -> True                     )+                Just _ -> True  -- Not a CreateIndex, keep it                 Nothing -> True         isImplicitlyDeleted (DropConstraint { tableName = constraintTableName }) = constraintTableName /= dropTableName         isImplicitlyDeleted (DropPolicy { tableName = policyTableName }) = not (isNothing dropColumnName && policyTableName == dropTableName)@@ -682,6 +695,7 @@         (dropTableName, dropColumnName) = case dropStatement of             DropTable { tableName } -> (tableName, Nothing)             DropColumn { tableName, columnName } -> (tableName, Just columnName)+            _ -> error "removeImplicitDeletions: unexpected statement type"  -- Guard ensures only DropTable/DropColumn reach here removeImplicitDeletions actualSchema (statement:rest) = statement:(removeImplicitDeletions actualSchema rest) removeImplicitDeletions actualSchema [] = []
IHP/IDE/CodeGen/ScriptGenerator.hs view
@@ -7,11 +7,11 @@ buildPlan scriptName =     if null scriptName         then Left "Script name cannot be empty"-        else do -            let filePath = "Application/Script/" <> cs scriptName <> ".hs"+        else do+            let filePath = textToOsPath ("Application/Script/" <> cs scriptName <> ".hs")             let fileContent = renderScript scriptName             Right [ CreateFile { filePath, fileContent }-                  , RunShellCommand { shellCommand = "chmod +x " <> filePath }+                  , RunShellCommand { shellCommand = "chmod +x " <> osPathToText filePath }                   ]  renderScript :: Text -> Text
IHP/IDE/CodeGen/Types.hs view
@@ -1,17 +1,20 @@-module IHP.IDE.CodeGen.Types where+module IHP.IDE.CodeGen.Types (module IHP.IDE.CodeGen.Types, defaultUuidFunction) where  import IHP.Prelude-import IHP.IDE.SchemaDesigner.Types+import qualified Data.Text as Text+import IHP.Postgres.Types+import qualified IHP.SchemaCompiler.Parser as SchemaDesigner+import IHP.IDE.CodeGen.DefaultUuidFunction (defaultUuidFunction)  data GeneratorAction-    = CreateFile { filePath :: Text, fileContent :: Text }-    | AppendToFile { filePath :: Text, fileContent :: Text }-    | AppendToMarker { marker :: Text, filePath :: Text, fileContent :: Text }-    | AddImport { filePath :: Text, fileContent :: Text }-    | AddAction { filePath :: Text, fileContent :: Text }-    | AddToDataConstructor { dataConstructor :: Text, filePath :: Text, fileContent :: Text }-    | AddMountToFrontController { filePath :: Text, applicationName :: Text }-    | EnsureDirectory { directory :: Text }+    = CreateFile { filePath :: OsPath, fileContent :: Text }+    | AppendToFile { filePath :: OsPath, fileContent :: Text }+    | AppendToMarker { marker :: Text, filePath :: OsPath, fileContent :: Text }+    | AddImport { filePath :: OsPath, fileContent :: Text }+    | AddAction { filePath :: OsPath, fileContent :: Text }+    | AddToDataConstructor { dataConstructor :: Text, filePath :: OsPath, fileContent :: Text }+    | AddMountToFrontController { filePath :: OsPath, applicationName :: Text }+    | EnsureDirectory { directory :: OsPath }     | RunShellCommand { shellCommand :: Text }     deriving (Show, Eq) @@ -19,13 +22,8 @@  fieldsForTable :: [Statement] -> Text -> Maybe [Text] fieldsForTable database name =-    case getTable database name of-        Just (StatementCreateTable CreateTable { columns, primaryKeyConstraint }) -> columns-                |> filter (columnRelevantForCreateOrEdit primaryKeyConstraint)-                |> map (.name)-                |> map columnNameToFieldName-                |> Just-        _ -> Nothing+    columnsForTable database name+        |> fmap (map (\col -> col.name |> columnNameToFieldName)) -- | Returns True when a column should be part of the generated controller or forms -- -- Returrns @False@ for primary keys, or fields such as @created_at@@@ -43,3 +41,165 @@         isTable :: Statement -> Bool         isTable table@(StatementCreateTable CreateTable { name = name' }) | name == name' = True         isTable _ = False++-- | Like 'fieldsForTable' but returns full 'Column' records (filtered to exclude PKs and auto-timestamps)+columnsForTable :: [Statement] -> Text -> Maybe [Column]+columnsForTable database name =+    case getTable database name of+        Just (StatementCreateTable CreateTable { columns, primaryKeyConstraint }) -> columns+                |> filter (columnRelevantForCreateOrEdit primaryKeyConstraint)+                |> Just+        _ -> Nothing++-- | Returns @[(columnName, referenceTable)]@ for all foreign key constraints on a table.+--+-- Scans both inline table constraints and top-level 'AddConstraint' statements.+foreignKeysForTable :: [Statement] -> Text -> [(Text, Text)]+foreignKeysForTable schema tableName = inlineFK <> topLevelFK+    where+        inlineFK = case getTable schema tableName of+            Just (StatementCreateTable CreateTable { constraints }) ->+                [(c.columnName, c.referenceTable) | c@ForeignKeyConstraint {} <- constraints]+            _ -> []+        topLevelFK =+            [ (c.columnName, c.referenceTable)+            | AddConstraint { tableName = tbl, constraint = c@ForeignKeyConstraint {} } <- schema+            , tbl == tableName+            ]++-- | Returns column names that have single-column UNIQUE constraints (from 'AddConstraint' or inline table constraints).+--+-- Does not include primary key columns.+uniqueColumnsForTable :: [Statement] -> Text -> [Text]+uniqueColumnsForTable schema tableName = inlineUnique <> topLevelUnique+    where+        inlineUnique = case getTable schema tableName of+            Just (StatementCreateTable CreateTable { constraints }) ->+                [col | UniqueConstraint { columnNames = [col] } <- constraints]+            _ -> []+        topLevelUnique =+            [ col+            | AddConstraint { tableName = tbl, constraint = UniqueConstraint { columnNames = [col] } } <- schema+            , tbl == tableName+            ]++loadAppSchema :: IO [Statement]+loadAppSchema = SchemaDesigner.parseSchemaSql >>= \case+    Left _parserError -> pure []+    Right statements -> pure statements++-- | Ensures a name has the given suffix, returning both the suffixed and unsuffixed versions.+--+-- >>> ensureSuffix "View" "EditView"+-- ("EditView", "Edit")+-- >>> ensureSuffix "View" "Edit"+-- ("EditView", "Edit")+ensureSuffix :: Text -> Text -> (Text, Text)+ensureSuffix suffix name+    | suffix `isSuffixOf` name = (name, Text.dropEnd (Text.length suffix) name)+    | otherwise = (name <> suffix, name)++-- | Build a qualified Haskell module name from application, category, controller, and module name.+--+-- >>> qualifiedModuleName "Web" "View" "Users" "Edit"+-- "Web.View.Users.Edit"+qualifiedModuleName :: Text -> Text -> Text -> Text -> Text+qualifiedModuleName applicationName category controllerName moduleName =+    applicationName <> "." <> category <> "." <> controllerName <> "." <> moduleName++-- | Configuration for generating standard CRUD action bodies.+data ActionBodyConfig = ActionBodyConfig+    { singularName :: Text          -- ^ e.g. "User"+    , modelVariableSingular :: Text -- ^ e.g. "user"+    , idFieldName :: Text           -- ^ e.g. "userId"+    , model :: Text                 -- ^ e.g. "User"+    , indexAction :: Text           -- ^ redirect target for create/delete, e.g. "UsersAction"+    , tableFound :: Bool            -- ^ whether the corresponding table exists in the schema+    }++generateShowActionBody :: ActionBodyConfig -> Text+generateShowActionBody config+    | config.tableFound =+        ""+        <> "    action Show" <> config.singularName <> "Action { " <> config.idFieldName <> " } = do\n"+        <> "        " <> config.modelVariableSingular <> " <- fetch " <> config.idFieldName <> "\n"+        <> "        render ShowView { .. }\n"+    | otherwise =+        ""+        <> "    action Show" <> config.singularName <> "Action = do\n"+        <> "        render ShowView { .. }\n"++generateNewActionBody :: ActionBodyConfig -> Text+generateNewActionBody config =+    ""+    <> "    action New" <> config.singularName <> "Action = do\n"+    <> "        let " <> config.modelVariableSingular <> " = newRecord\n"+    <> "        render NewView { .. }\n"++generateEditActionBody :: ActionBodyConfig -> Text+generateEditActionBody config+    | config.tableFound =+        ""+        <> "    action Edit" <> config.singularName <> "Action { " <> config.idFieldName <> " } = do\n"+        <> "        " <> config.modelVariableSingular <> " <- fetch " <> config.idFieldName <> "\n"+        <> "        render EditView { .. }\n"+    | otherwise =+        ""+        <> "    action Edit" <> config.singularName <> "Action = do\n"+        <> "        render EditView { .. }\n"++generateUpdateActionBody :: ActionBodyConfig -> Text+generateUpdateActionBody config+    | config.tableFound =+        ""+        <> "    action Update" <> config.singularName <> "Action { " <> config.idFieldName <> " } = do\n"+        <> "        " <> config.modelVariableSingular <> " <- fetch " <> config.idFieldName <> "\n"+        <> "        " <> config.modelVariableSingular <> "\n"+        <> "            |> build" <> config.singularName <> "\n"+        <> "            |> ifValid \\case\n"+        <> "                Left " <> config.modelVariableSingular <> " -> render EditView { .. }\n"+        <> "                Right " <> config.modelVariableSingular <> " -> do\n"+        <> "                    " <> config.modelVariableSingular <> " <- " <> config.modelVariableSingular <> " |> updateRecord\n"+        <> "                    setSuccessMessage \"" <> config.model <> " updated\"\n"+        <> "                    redirectTo Edit" <> config.singularName <> "Action { .. }\n"+    | otherwise =+        ""+        <> "    action Update" <> config.singularName <> "Action = do\n"+        <> "        let " <> config.modelVariableSingular <> " = newRecord\n"+        <> "        " <> config.modelVariableSingular <> "\n"+        <> "            |> build" <> config.singularName <> "\n"+        <> "            |> ifValid \\case\n"+        <> "                Left " <> config.modelVariableSingular <> " -> render EditView { .. }\n"+        <> "                Right " <> config.modelVariableSingular <> " -> do\n"+        <> "                    " <> config.modelVariableSingular <> " <- " <> config.modelVariableSingular <> " |> updateRecord\n"+        <> "                    setSuccessMessage \"" <> config.model <> " updated\"\n"+        <> "                    redirectTo Edit" <> config.singularName <> "Action\n"++generateCreateActionBody :: ActionBodyConfig -> Text+generateCreateActionBody config =+    ""+    <> "    action Create" <> config.singularName <> "Action = do\n"+    <> "        let " <> config.modelVariableSingular <> " = newRecord @" <> config.model <> "\n"+    <> "        " <> config.modelVariableSingular <> "\n"+    <> "            |> build" <> config.singularName <> "\n"+    <> "            |> ifValid \\case\n"+    <> "                Left " <> config.modelVariableSingular <> " -> render NewView { .. } \n"+    <> "                Right " <> config.modelVariableSingular <> " -> do\n"+    <> "                    " <> config.modelVariableSingular <> " <- " <> config.modelVariableSingular <> " |> createRecord\n"+    <> "                    setSuccessMessage \"" <> config.model <> " created\"\n"+    <> "                    redirectTo " <> config.indexAction <> "\n"++generateDeleteActionBody :: ActionBodyConfig -> Text+generateDeleteActionBody config+    | config.tableFound =+        ""+        <> "    action Delete" <> config.singularName <> "Action { " <> config.idFieldName <> " } = do\n"+        <> "        " <> config.modelVariableSingular <> " <- fetch " <> config.idFieldName <> "\n"+        <> "        deleteRecord " <> config.modelVariableSingular <> "\n"+        <> "        setSuccessMessage \"" <> config.model <> " deleted\"\n"+        <> "        redirectTo " <> config.indexAction <> "\n"+    | otherwise =+        ""+        <> "    action Delete" <> config.singularName <> "Action = do\n"+        <> "        setSuccessMessage \"" <> config.model <> " deleted\"\n"+        <> "        redirectTo " <> config.indexAction <> "\n"
IHP/IDE/CodeGen/View/NewAction.hs view
@@ -53,7 +53,7 @@                             name="doGenerateView"                             id="doGenerateView"                             />-                        <label class="pl-1" for="doGenerateView">With View</label>+                        <label class="ps-1" for="doGenerateView">With View</label>                     </div>                 </form>|]             renderControllerOptions = forM_ controllers (\x -> [hsx|<option>{x}</option>|])@@ -86,7 +86,7 @@                             checked = {doGenerateView}                             onchange = "this.form.submit()"                             />-                        <label class="pl-1" for="doGenerateView">With View</label>+                        <label class="ps-1" for="doGenerateView">With View</label>                         <input type="hidden" name="name" value={actionName}/>                         <input type="hidden" name="controllerName" value={controllerName}/>                     </form>
IHP/IDE/CodeGen/View/NewController.hs view
@@ -11,6 +11,13 @@     , applicationName :: Text     , applications :: [Text]     , pagination :: Bool+    , indexAction :: Bool+    , newAction :: Bool+    , showAction :: Bool+    , createAction :: Bool+    , editAction :: Bool+    , updateAction :: Bool+    , deleteAction :: Bool     }  instance View NewControllerView where@@ -47,6 +54,13 @@                     <input type="hidden" name="name" value={controllerName}/>                     <input type="hidden" name="applicationName" value={applicationName}/>                     <input type="hidden" name="pagination" value={inputValue pagination}/>+                    <input type="hidden" name="indexAction" value={inputValue indexAction}/>+                    <input type="hidden" name="newAction" value={inputValue newAction}/>+                    <input type="hidden" name="showAction" value={inputValue showAction}/>+                    <input type="hidden" name="createAction" value={inputValue createAction}/>+                    <input type="hidden" name="editAction" value={inputValue editAction}/>+                    <input type="hidden" name="updateAction" value={inputValue updateAction}/>+                    <input type="hidden" name="deleteAction" value={inputValue deleteAction}/>                      <button class="btn btn-primary" type="submit">Generate</button>                 </form>@@ -54,24 +68,37 @@                 <div class="generator-options">                     <form method="POST" action={NewControllerAction}>                         <input type="hidden" name="name" value={controllerName}/>-                        <input type="hidden" name="applicationName" value={applicationName}/>-                        <input-                            type="checkbox"-                            name="pagination"-                            id="pagination"-                            checked={pagination}-                            onchange="this.form.submit()"-                            />-                        <label class="pl-1" for="pagination">Pagination</label>+                        {renderApplicationNameSelector}+                        <input type="checkbox" name="pagination" id="pagination" checked={pagination} onchange="this.form.submit()"/>+                        <label class="ps-1" for="pagination">Pagination</label>++                        <span class="ms-3">Actions:</span>+                        {renderActionCheckbox "indexAction" "Index" indexAction}+                        {renderActionCheckbox "newAction" "New" newAction}+                        {renderActionCheckbox "showAction" "Show" showAction}+                        {renderActionCheckbox "createAction" "Create" createAction}+                        {renderActionCheckbox "editAction" "Edit" editAction}+                        {renderActionCheckbox "updateAction" "Update" updateAction}+                        {renderActionCheckbox "deleteAction" "Delete" deleteAction}                     </form>                 </div>             |]+            renderActionCheckbox :: Text -> Text -> Bool -> Html+            renderActionCheckbox name label checked = [hsx|+                <input type="checkbox" name={name} id={name} checked={checked} onchange="this.form.submit()"/>+                <input type="hidden" name={name} value={inputValue False}/>+                <label class="ps-1 me-2" for={name}>{label}</label>+            |]+            renderApplicationNameSelector = if length applications /= 1+                then renderApplicationSelector+                else [hsx|<input type="hidden" name="applicationName" value={applicationName}/>|]             renderApplicationOptions = forM_ applications (\x -> [hsx|<option selected={x == applicationName}>{x}</option>|])             renderApplicationSelector = [hsx|                 <select                     name="applicationName"                     class="form-control select2-simple"                     size="1"+                    onchange="this.form.submit()"                 >                     {renderApplicationOptions}                 </select>|]
IHP/IDE/CodeGen/View/NewMigration.hs view
@@ -54,7 +54,7 @@                         />                         <input type="hidden" name="runMigration" value={inputValue False}/>                         <input type="hidden" name="description" value=""/>-                        <label class="pl-1" for="runMigration">Run Migration after <q>Generate</q></label>+                        <label class="ps-1" for="runMigration">Run Migration after <q>Generate</q></label>                     </form>                 </div>             |]
IHP/IDE/CodeGen/ViewGenerator.hs view
@@ -1,10 +1,8 @@-module IHP.IDE.CodeGen.ViewGenerator (buildPlan, buildPlan', ViewConfig (..)) where+module IHP.IDE.CodeGen.ViewGenerator (buildPlan, buildPlan', ViewConfig (..), postgresTypeToFieldHelper) where  import IHP.Prelude-import qualified Data.Text as Text import IHP.IDE.CodeGen.Types-import qualified IHP.IDE.SchemaDesigner.Parser as SchemaDesigner-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import Text.Countable (singularize, pluralize)  data ViewConfig = ViewConfig@@ -20,9 +18,7 @@     if (null viewName' || null controllerName')         then pure $ Left "Neither view name nor controller name can be empty"         else do-            schema <- SchemaDesigner.parseSchemaSql >>= \case-                Left parserError -> pure []-                Right statements -> pure statements+            schema <- loadAppSchema             let modelName = tableNameToModelName controllerName'             let controllerName = tableNameToControllerName controllerName'             let viewName = tableNameToViewName viewName'@@ -33,7 +29,7 @@ -- E.g. qualifiedViewModuleName config "Edit" == "Web.View.Users.Edit" qualifiedViewModuleName :: ViewConfig -> Text -> Text qualifiedViewModuleName config viewName =-    config.applicationName <> ".View." <> config.controllerName <> "." <> viewName+    qualifiedModuleName config.applicationName "View" config.controllerName viewName  buildPlan' :: [Statement] -> ViewConfig -> [GeneratorAction] buildPlan' schema config =@@ -44,12 +40,7 @@             pluralName = singularName |> lcfirst |> pluralize |> ucfirst -- TODO: `pluralize` Should Support Lower-Cased Words             singularVariableName = lcfirst singularName             pluralVariableName = lcfirst controllerName-            nameWithSuffix = if "View" `isSuffixOf` name-                then name-                else name <> "View" --e.g. "Test" -> "TestView"-            nameWithoutSuffix = if "View" `isSuffixOf` name-                then Text.replace "View" "" name-                else name --e.g. "TestView" -> "Test"+            (nameWithSuffix, nameWithoutSuffix) = ensureSuffix "View" name              indexAction = pluralName <> "Action"             specialCases = [@@ -61,12 +52,23 @@              paginationEnabled = config.paginationEnabled -            modelFields :: [Text]-            modelFields =  [ modelNameToTableName pluralVariableName, pluralVariableName ]-                    |> mapMaybe (fieldsForTable schema)+            tableFound :: Bool+            tableFound = [ modelNameToTableName pluralVariableName, pluralVariableName ]+                    |> mapMaybe (columnsForTable schema)+                    |> headMay+                    |> isJust++            modelColumns :: [Column]+            modelColumns = [ modelNameToTableName pluralVariableName, pluralVariableName ]+                    |> mapMaybe (columnsForTable schema)                     |> head                     |> fromMaybe [] +            foreignKeySet :: [(Text, Text)]+            foreignKeySet = [ modelNameToTableName pluralVariableName, pluralVariableName ]+                    |> map (foreignKeysForTable schema)+                    |> concat+             -- when using the trimming quasiquoter we can't have another |] closure, like for the one we use with hsx.             qqClose = "|]" @@ -99,6 +101,16 @@                     pluralizedName = pluralize name  +            showViewBody =+                if null modelColumns+                then "<p>{" <> singularVariableName <> "}</p>"+                else "<dl>" <> mconcat (map showColumn modelColumns) <> "\n</dl>"+                where+                    showColumn column =+                        let fieldName = columnNameToFieldName column.name+                            label = columnNameToFieldLabel column.name+                        in "\n    <dt>" <> label <> "</dt><dd>{" <> singularVariableName <> "." <> fieldName <> "}</dd>"+             showView = [trimming|                 ${viewHeader} @@ -108,7 +120,7 @@                     html ShowView { .. } = [hsx|                         {breadcrumb}                         <h1>Show ${singularName}</h1>-                        <p>{${singularVariableName}}</p>+                        ${showViewBody}                      ${qqClose}                         where@@ -129,7 +141,14 @@             |]                 where                     formFields =-                        intercalate "\n" (map (\field -> "{(textField #" <> field <> ")}") modelFields)+                        intercalate "\n" (map columnToFormField modelColumns)+                    columnToFormField column =+                        let fieldName = columnNameToFieldName column.name+                            isForeignKey = any (\(colName, _) -> colName == column.name) foreignKeySet+                            helper = postgresTypeToFieldHelper column.columnType+                        in if isForeignKey+                            then "{- " <> fieldName <> " needs to be a selectField -}\n    {(" <> helper <> " #" <> fieldName <> ")}"+                            else "{(" <> helper <> " #" <> fieldName <> ")}"               newView = [trimming|@@ -172,6 +191,16 @@                 ${renderForm}             |] +            indexHeaders =+                if null modelColumns+                then "<th>" <> singularName <> "</th>"+                else intercalate "\n" (map (\c -> "<th>" <> columnNameToFieldLabel c.name <> "</th>") modelColumns)++            indexCells =+                if null modelColumns+                then "<td>{" <> singularVariableName <> "}</td>"+                else intercalate "\n" (map (\c -> "<td>{" <> singularVariableName <> "." <> columnNameToFieldName c.name <> "}</td>") modelColumns)+             indexView = [trimming|                 ${viewHeader} @@ -186,7 +215,7 @@                             <table class="table">                                 <thead>                                     <tr>-                                        <th>${singularName}</th>+                                        ${indexHeaders}                                         <th></th>                                         <th></th>                                         <th></th>@@ -205,22 +234,43 @@                 render${singularName} :: ${singularName} -> Html                 render${singularName} ${singularVariableName} = [hsx|                     <tr>-                        <td>{${singularVariableName}}</td>-                        <td><a href={Show${singularName}Action ${singularVariableName}.id}>Show</a></td>-                        <td><a href={Edit${singularName}Action ${singularVariableName}.id} class="text-muted">Edit</a></td>-                        <td><a href={Delete${singularName}Action ${singularVariableName}.id} class="js-delete text-muted">Delete</a></td>+                        ${indexCells}+                        <td><a href={${showLink}}>Show</a></td>+                        <td><a href={${editLink}} class="text-muted">Edit</a></td>+                        <td><a href={${deleteLink}} class="js-delete text-muted">Delete</a></td>                     </tr>                 ${qqClose}             |]                 where                     importPagination = if paginationEnabled then ", pagination :: Pagination" else ""                     renderPagination = if paginationEnabled then "{renderPagination pagination}" else ""+                    idSuffix = if tableFound then " " <> singularVariableName <> ".id" else ""+                    showLink = "Show" <> singularName <> "Action" <> idSuffix+                    editLink = "Edit" <> singularName <> "Action" <> idSuffix+                    deleteLink = "Delete" <> singularName <> "Action" <> idSuffix                chosenView = fromMaybe genericView (lookup nameWithSuffix specialCases)         in-            [ EnsureDirectory { directory = config.applicationName <> "/View/" <> controllerName }-            , CreateFile { filePath = config.applicationName <> "/View/" <> controllerName <> "/" <> nameWithoutSuffix <> ".hs", fileContent = chosenView }-            , AddImport { filePath = config.applicationName <> "/Controller/" <> controllerName <> ".hs", fileContent = "import " <> qualifiedViewModuleName config nameWithoutSuffix }+            [ EnsureDirectory { directory = textToOsPath (config.applicationName <> "/View/" <> controllerName) }+            , CreateFile { filePath = textToOsPath (config.applicationName <> "/View/" <> controllerName <> "/" <> nameWithoutSuffix <> ".hs"), fileContent = chosenView }+            , AddImport { filePath = textToOsPath (config.applicationName <> "/Controller/" <> controllerName <> ".hs"), fileContent = "import " <> qualifiedViewModuleName config nameWithoutSuffix }             ]++-- | Maps a Postgres column type to the appropriate IHP form field helper name.+postgresTypeToFieldHelper :: PostgresType -> Text+postgresTypeToFieldHelper PBoolean = "checkboxField"+postgresTypeToFieldHelper PInt = "numberField"+postgresTypeToFieldHelper PSmallInt = "numberField"+postgresTypeToFieldHelper PBigInt = "numberField"+postgresTypeToFieldHelper PSerial = "numberField"+postgresTypeToFieldHelper PBigserial = "numberField"+postgresTypeToFieldHelper PReal = "numberField"+postgresTypeToFieldHelper PDouble = "numberField"+postgresTypeToFieldHelper (PNumeric _ _) = "numberField"+postgresTypeToFieldHelper PDate = "dateField"+postgresTypeToFieldHelper PTimestamp = "dateTimeField"+postgresTypeToFieldHelper PTimestampWithTimezone = "dateTimeField"+postgresTypeToFieldHelper PTime = "timeField"+postgresTypeToFieldHelper _ = "textField"
IHP/IDE/Data/Controller.hs view
@@ -10,19 +10,23 @@ import IHP.IDE.Data.View.EditValue import IHP.IDE.Data.View.ShowForeignKeyHoverCard -import qualified Database.PostgreSQL.Simple as PG-import qualified Database.PostgreSQL.Simple.FromField as PG-import qualified Database.PostgreSQL.Simple.FromRow as PG-import qualified Database.PostgreSQL.Simple.ToField as PG-import qualified Database.PostgreSQL.Simple.Types as PG+import qualified Hasql.Session as Session+import qualified Hasql.Errors as HasqlErrors+import qualified Hasql.Decoders as Decoders+import qualified Hasql.DynamicStatements.Snippet as Snippet+import Hasql.DynamicStatements.Snippet (Snippet)+import qualified Hasql.Pool as HasqlPool+import IHP.Hasql.Pool (usePoolWithRetry) import qualified Data.Text as T-import qualified Data.ByteString.Builder+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as Aeson+import qualified Data.Aeson.Key as Aeson+import qualified Data.List as List+import IHP.QueryBuilder.HasqlHelpers (wrapDynamicQuery, quoteIdentifier)  instance Controller DataController where     action ShowDatabaseAction = do-        connection <- connectToAppDb-        tableNames <- fetchTableNames connection-        PG.close connection+        tableNames <- fetchTableNames         case headMay tableNames of             Just tableName -> jumpToAction ShowTableRowsAction { tableName }             Nothing -> render ShowDatabaseView { .. }@@ -30,13 +34,11 @@     action ShowTableRowsAction { tableName } = do         let page :: Int = paramOrDefault @Int 1 "page"         let pageSize :: Int = paramOrDefault @Int 20 "rows"-        connection <- connectToAppDb-        tableNames <- fetchTableNames connection-        primaryKeyFields <- tablePrimaryKeyFields connection tableName-        rows :: [[DynamicField]] <- fetchRowsPage connection tableName page pageSize-        tableCols <- fetchTableCols connection tableName-        totalRows <- tableLength connection tableName-        PG.close connection+        tableNames <- fetchTableNames+        primaryKeyFields <- tablePrimaryKeyFields tableName+        tableCols <- fetchTableCols tableName+        rows <- map (reorderFields tableCols) <$> fetchRowsPage tableName page pageSize+        totalRows <- tableLength tableName         render ShowTableRowsView { .. }      action NewQueryAction = do@@ -45,260 +47,300 @@         render ShowQueryView { .. }      action QueryAction = do-        connection <- connectToAppDb         let queryText = param @Text "query"         when (isEmpty queryText) do             redirectTo NewQueryAction -        let query = fromString $ cs queryText--        queryResult :: Maybe (Either PG.SqlError SqlConsoleResult) <- Just <$> if isQuery queryText then-                (Right . SelectQueryResult <$> PG.query_ connection query) `catch` (pure . Left)-            else-                (Right . InsertOrUpdateResult <$> PG.execute_ connection query) `catch` (pure . Left)+        queryResult :: Maybe (Either SqlConsoleError SqlConsoleResult) <- do+            let pool = ?modelContext.hasqlPool+            Just <$> if isQuery queryText then do+                    let snippet = wrapDynamicQuery (Snippet.sql (cs queryText))+                    let statement = Snippet.toStatement snippet dynamicFieldDecoder+                    let session = Session.statement () statement+                    result <- HasqlPool.use pool session+                    case result of+                        Right rows -> pure (Right (SelectQueryResult rows))+                        Left err -> pure (Left (usageErrorToConsoleError err))+                else do+                    let statement = Snippet.toStatement (Snippet.sql (cs queryText)) Decoders.rowsAffected+                    let session = Session.statement () statement+                    result <- HasqlPool.use pool session+                    case result of+                        Right count -> pure (Right (InsertOrUpdateResult count))+                        Left err -> pure (Left (usageErrorToConsoleError err)) -        PG.close connection         render ShowQueryView { .. }      action DeleteEntryAction { primaryKey, tableName } = do-        connection <- connectToAppDb-        tableNames <- fetchTableNames connection-        primaryKeyFields <- tablePrimaryKeyFields connection tableName+        primaryKeyFields <- tablePrimaryKeyFields tableName         let primaryKeyValues = T.splitOn "---" primaryKey-        let query = "DELETE FROM " <> tableName <> " WHERE " <> intercalate " AND " ((<> " = ?") <$> primaryKeyFields)-        PG.execute connection (PG.Query . cs $! query) primaryKeyValues-        PG.close connection+        let whereClause = mconcat $ List.intersperse (Snippet.sql " AND ") $+                zipWith (\field val -> quoteIdentifier field <> Snippet.sql "::text = " <> Snippet.param val) primaryKeyFields primaryKeyValues+        let snippet = Snippet.sql "DELETE FROM " <> quoteIdentifier tableName <> Snippet.sql " WHERE " <> whereClause+        runSnippetExec snippet         redirectTo ShowTableRowsAction { .. }      action NewRowAction { tableName } = do-        connection <- connectToAppDb-        tableNames <- fetchTableNames connection--        rows :: [[DynamicField]] <- fetchRows connection tableName--        tableCols <- fetchTableCols connection tableName--        PG.close connection+        tableNames <- fetchTableNames+        tableCols <- fetchTableCols tableName+        rows :: [[DynamicField]] <- map (reorderFields tableCols) <$> fetchRows tableName         render NewRowView { .. }      action CreateRowAction = do-        connection <- connectToAppDb-        tableNames <- fetchTableNames connection         let tableName = param "tableName"-        tableCols <- fetchTableCols connection tableName-        let values :: [PG.Action] = map (\col -> parseValues (param @Bool (cs (col.columnName) <> "_")) (param @Bool (cs (col.columnName) <> "-isBoolean")) (param @Text (cs (col.columnName)))) tableCols-        let query = "INSERT INTO " <> tableName <> " VALUES (" <> intercalate "," (map (const "?") values) <> ")"-        PG.execute connection (PG.Query . cs $! query) values-        PG.close connection+        tableCols <- fetchTableCols tableName+        let values :: [Snippet] = map (\col -> parseValues (param @Bool (cs (col.columnName) <> "_")) (param @Bool (cs (col.columnName) <> "-isBoolean")) (param @Text (cs (col.columnName)))) tableCols+        let snippet = Snippet.sql "INSERT INTO " <> quoteIdentifier tableName <> Snippet.sql " VALUES (" <> (mconcat $ List.intersperse (Snippet.sql ", ") values) <> Snippet.sql ")"+        runSnippetExec snippet         redirectTo ShowTableRowsAction { .. }      action EditRowAction { tableName, targetPrimaryKey } = do-        connection <- connectToAppDb-        tableNames <- fetchTableNames connection-        primaryKeyFields <- tablePrimaryKeyFields connection tableName--        rows :: [[DynamicField]] <- fetchRows connection tableName--        tableCols <- fetchTableCols connection tableName+        tableNames <- fetchTableNames+        primaryKeyFields <- tablePrimaryKeyFields tableName+        tableCols <- fetchTableCols tableName+        rows :: [[DynamicField]] <- map (reorderFields tableCols) <$> fetchRows tableName         let targetPrimaryKeyValues = T.splitOn "---" targetPrimaryKey-        values <- fetchRow connection (cs tableName) targetPrimaryKeyValues-        let (Just rowValues) = head values-        PG.close connection+        values <- fetchRow tableName targetPrimaryKeyValues+        rowValues <- case values of+            [rowValues] -> pure (reorderFields tableCols rowValues)+            _ -> error ("Row not found in " <> cs tableName)         render EditRowView { .. }      action UpdateRowAction = do         let tableName = param "tableName"-        connection <- connectToAppDb-        tableNames <- fetchTableNames connection-        tableCols <- fetchTableCols connection tableName-        primaryKeyFields <- tablePrimaryKeyFields connection tableName+        tableCols <- fetchTableCols tableName+        primaryKeyFields <- tablePrimaryKeyFields tableName -        let values :: [PG.Action] = map (\col -> parseValues (param @Bool (cs (col.columnName) <> "_")) (param @Bool (cs (col.columnName) <> "-isBoolean")) (param @Text (cs (col.columnName)))) tableCols-        let columns :: [Text] = map (\col -> cs (col.columnName)) tableCols-        let primaryKeyValues = map (\pkey -> "'" <> (param @Text (cs pkey <> "-pk")) <> "'") primaryKeyFields+        let values :: [Snippet] = map (\col -> parseValues (param @Bool (cs (col.columnName) <> "_")) (param @Bool (cs (col.columnName) <> "-isBoolean")) (param @Text (cs (col.columnName)))) tableCols+        let columns :: [Text] = map (\col -> col.columnName) tableCols -        let query = "UPDATE " <> tableName <> " SET " <> intercalate ", " (updateValues (zip columns (map (const "?") values))) <> " WHERE " <> intercalate " AND " (updateValues (zip primaryKeyFields primaryKeyValues))-        PG.execute connection (PG.Query . cs $! query) values-        PG.close connection+        let setClause = mconcat $ List.intersperse (Snippet.sql ", ") $+                zipWith (\col val -> quoteIdentifier col <> Snippet.sql " = " <> val) columns values+        let whereClause = mconcat $ List.intersperse (Snippet.sql " AND ") $+                map (\pkey -> quoteIdentifier pkey <> Snippet.sql "::text = " <> Snippet.param (param @Text (cs pkey <> "-pk"))) primaryKeyFields++        let snippet = Snippet.sql "UPDATE " <> quoteIdentifier tableName <> Snippet.sql " SET " <> setClause <> Snippet.sql " WHERE " <> whereClause+        runSnippetExec snippet         redirectTo ShowTableRowsAction { .. }      action EditRowValueAction { tableName, targetName, id } = do-        connection <- connectToAppDb-        tableNames <- fetchTableNames connection--        rows :: [[DynamicField]] <- fetchRows connection tableName-+        tableNames <- fetchTableNames+        tableCols <- fetchTableCols tableName+        rows :: [[DynamicField]] <- map (reorderFields tableCols) <$> fetchRows tableName         let targetId = cs id-        PG.close connection         render EditValueView { .. }      action ToggleBooleanFieldAction { tableName, targetName, targetPrimaryKey } = do         let id :: String = cs (param @Text "id")         let tableName = param "tableName"-        connection <- connectToAppDb-        tableNames <- fetchTableNames connection-        tableCols <- fetchTableCols connection tableName-        primaryKeyFields <- tablePrimaryKeyFields connection tableName-        let targetPrimaryKeyValues = PG.Escape . cs <$> T.splitOn "---" targetPrimaryKey-        let query = PG.Query . cs $! "UPDATE ? SET ? = NOT ? WHERE " <> intercalate " AND " ((<> " = ?") <$> primaryKeyFields)-        let params = [PG.toField $ PG.Identifier tableName, PG.toField $ PG.Identifier targetName, PG.toField $ PG.Identifier targetName] <> targetPrimaryKeyValues-        PG.execute connection query params-        PG.close connection+        primaryKeyFields <- tablePrimaryKeyFields tableName+        let targetPrimaryKeyValues = T.splitOn "---" targetPrimaryKey+        let whereClause = mconcat $ List.intersperse (Snippet.sql " AND ") $+                zipWith (\field val -> quoteIdentifier field <> Snippet.sql "::text = " <> Snippet.param val) primaryKeyFields targetPrimaryKeyValues+        let snippet = Snippet.sql "UPDATE " <> quoteIdentifier tableName <> Snippet.sql " SET " <> quoteIdentifier targetName <> Snippet.sql " = NOT " <> quoteIdentifier targetName <> Snippet.sql " WHERE " <> whereClause+        runSnippetExec snippet         redirectTo ShowTableRowsAction { .. }      action UpdateValueAction = do         let id :: String = cs (param @Text "id")         let tableName = param "tableName"-        connection <- connectToAppDb-        let targetCol = param "targetName"-        let targetValue = param "targetValue"-        let query = "UPDATE " <> tableName <> " SET " <> targetCol <> " = '" <> targetValue <> "' WHERE id = '" <> cs id <> "'"-        PG.execute_ connection (PG.Query . cs $! query)-        PG.close connection+        let targetCol = param @Text "targetName"+        let targetValue = param @Text "targetValue"+        let snippet = Snippet.sql "UPDATE " <> quoteIdentifier tableName <> Snippet.sql " SET " <> quoteIdentifier targetCol <> Snippet.sql " = " <> Snippet.param targetValue <> Snippet.sql " WHERE " <> quoteIdentifier "id" <> Snippet.sql "::text = " <> Snippet.param (cs id :: Text)+        runSnippetExec snippet         redirectTo ShowTableRowsAction { .. }      action DeleteTableRowsAction { tableName } = do-        connection <- connectToAppDb-        let query = "TRUNCATE TABLE " <> tableName-        PG.execute_ connection (PG.Query . cs $! query)-        PG.close connection+        let snippet = Snippet.sql "TRUNCATE TABLE " <> quoteIdentifier tableName+        runSnippetExec snippet         redirectTo ShowTableRowsAction { .. }      action AutocompleteForeignKeyColumnAction { tableName, columnName, term } = do-        connection <- connectToAppDb-        rows :: Maybe [[DynamicField]] <- do-            foreignKeyInfo <- fetchForeignKeyInfo connection tableName columnName--            case foreignKeyInfo of-                Just (foreignTable, foreignColumn) -> Just <$> fetchRowsPage connection foreignTable 1 50-                Nothing -> pure Nothing+        foreignKeyInfo <- fetchForeignKeyInfo tableName columnName -        PG.close connection+        rows :: Maybe [[DynamicField]] <- case foreignKeyInfo of+            Just (foreignTable, foreignColumn) -> Just <$> fetchRowsPage foreignTable 1 50+            Nothing -> pure Nothing          case rows of             Just rows -> renderJson rows             Nothing -> renderNotFound      action ShowForeignKeyHoverCardAction { tableName, id, columnName } = do-        connection <- connectToAppDb         hovercardData <- do-            [Only (foreignId :: UUID)] <- PG.query connection "SELECT ? FROM ? WHERE id = ?" (PG.Identifier columnName, PG.Identifier tableName, id)+            let fetchIdSnippet = Snippet.sql "SELECT " <> quoteIdentifier columnName <> Snippet.sql "::text FROM " <> quoteIdentifier tableName <> Snippet.sql " WHERE " <> quoteIdentifier "id" <> Snippet.sql "::text = " <> Snippet.param id+            foreignIdResult <- runSnippetQuery fetchIdSnippet (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text))) -            foreignKeyInfo <- fetchForeignKeyInfo connection tableName columnName+            case foreignIdResult of+                [foreignId] -> do+                    foreignKeyInfo <- fetchForeignKeyInfo tableName columnName -            case foreignKeyInfo of-                Just (foreignTable, foreignColumn) -> do-                    [record] <- PG.query connection "SELECT * FROM ? WHERE ? = ? LIMIT 1" (PG.Identifier foreignTable, PG.Identifier foreignColumn, foreignId)-                    pure $ Just (record, foreignTable)-                Nothing -> pure Nothing-        PG.close connection+                    case foreignKeyInfo of+                        Just (foreignTable, foreignColumn) -> do+                            let fetchRecordSnippet = wrapDynamicQuery (Snippet.sql "SELECT * FROM " <> quoteIdentifier foreignTable <> Snippet.sql " WHERE " <> quoteIdentifier foreignColumn <> Snippet.sql "::text = " <> Snippet.param foreignId <> Snippet.sql " LIMIT 1")+                            records <- runSnippetQuery fetchRecordSnippet dynamicFieldDecoder+                            case records of+                                [record] -> pure $ Just (record, foreignTable)+                                _ -> pure Nothing+                        Nothing -> pure Nothing+                _ -> pure Nothing          case hovercardData of             Just (record, foreignTableName) -> render ShowForeignKeyHoverCardView { record, foreignTableName }             Nothing -> renderNotFound -connectToAppDb :: (?context :: ControllerContext) => IO PG.Connection-connectToAppDb = PG.connectPostgreSQL ?context.frameworkConfig.databaseUrl+runSnippetQuery :: (?modelContext :: ModelContext) => Snippet -> Decoders.Result a -> IO a+runSnippetQuery snippet decoder = do+    let pool = ?modelContext.hasqlPool+    let statement = Snippet.toPreparableStatement snippet decoder+    let session = Session.statement () statement+    usePoolWithRetry pool session -fetchTableNames :: PG.Connection -> IO [Text]-fetchTableNames connection = do-    values :: [[Text]] <- PG.query_ connection "SELECT tablename FROM pg_catalog.pg_tables where schemaname = 'public'"-    pure (join values)+runSnippetExec :: (?modelContext :: ModelContext) => Snippet -> IO ()+runSnippetExec snippet = do+    let pool = ?modelContext.hasqlPool+    let statement = Snippet.toPreparableStatement snippet Decoders.noResult+    let session = Session.statement () statement+    usePoolWithRetry pool session -fetchTableCols :: PG.Connection -> Text -> IO [ColumnDefinition]-fetchTableCols connection tableName = do-    PG.query connection "SELECT column_name,data_type,column_default,CASE WHEN is_nullable='YES' THEN true ELSE false END FROM information_schema.columns where table_name = ? ORDER BY ordinal_position" (PG.Only tableName)+fetchTableNames :: (?modelContext :: ModelContext) => IO [Text]+fetchTableNames =+    runSnippetQuery+        (Snippet.sql "SELECT tablename::text FROM pg_catalog.pg_tables WHERE schemaname = 'public'")+        (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text))) -fetchRow :: PG.Connection -> Text -> [Text] -> IO [[DynamicField]]-fetchRow connection tableName primaryKeyValues = do-    pkFields <- tablePrimaryKeyFields connection tableName-    let query = "SELECT * FROM " <> tableName <> " WHERE " <> intercalate " AND " ((<> " = ?") <$> pkFields)-    PG.query connection (PG.Query . cs $! query) primaryKeyValues+fetchTableCols :: (?modelContext :: ModelContext) => Text -> IO [ColumnDefinition]+fetchTableCols tableName =+    runSnippetQuery+        (Snippet.sql "SELECT column_name::text, data_type::text, column_default::text, CASE WHEN is_nullable='YES' THEN true ELSE false END FROM information_schema.columns WHERE table_name = " <> Snippet.param tableName <> Snippet.sql " ORDER BY ordinal_position")+        columnDefinitionDecoder -instance PG.FromField DynamicField where-    fromField field fieldValue = pure DynamicField { .. }-        where-            fieldName = fromMaybe "" (PG.name field)+fetchRow :: (?modelContext :: ModelContext) => Text -> [Text] -> IO [[DynamicField]]+fetchRow tableName primaryKeyValues = do+    pkFields <- tablePrimaryKeyFields tableName+    let whereClause = mconcat $ List.intersperse (Snippet.sql " AND ") $+            zipWith (\field val -> quoteIdentifier field <> Snippet.sql "::text = " <> Snippet.param val) pkFields primaryKeyValues+    let snippet = wrapDynamicQuery (Snippet.sql "SELECT * FROM " <> quoteIdentifier tableName <> Snippet.sql " WHERE " <> whereClause)+    runSnippetQuery snippet dynamicFieldDecoder -instance PG.FromRow ColumnDefinition where-    fromRow = ColumnDefinition <$> PG.field <*> PG.field <*> PG.field <*> PG.field+columnDefinitionDecoder :: Decoders.Result [ColumnDefinition]+columnDefinitionDecoder = Decoders.rowList $+    ColumnDefinition+        <$> Decoders.column (Decoders.nonNullable Decoders.text)+        <*> Decoders.column (Decoders.nonNullable Decoders.text)+        <*> Decoders.column (Decoders.nullable Decoders.text)+        <*> Decoders.column (Decoders.nonNullable Decoders.bool) -tablePrimaryKeyFields :: PG.Connection -> Text -> IO [Text]-tablePrimaryKeyFields connection tableName = do-    fields <- PG.query connection "SELECT a.attname FROM pg_index i JOIN pg_attribute a ON a.attrelid = i.indrelid AND a.attnum = ANY(i.indkey) WHERE i.indrelid = ?::regclass AND i.indisprimary" (PG.Only tableName) :: IO [PG.Only Text]-    pure $ PG.fromOnly <$> fields+-- | Decoder for dynamic query results wrapped with 'wrapDynamicQuery'.+-- Each row comes back as a single JSONB column (from row_to_json), which is then+-- parsed into a list of DynamicField values.+dynamicFieldDecoder :: Decoders.Result [[DynamicField]]+dynamicFieldDecoder = Decoders.rowList $+    Decoders.column (Decoders.nonNullable Decoders.jsonb)+    |> fmap (\case+        Aeson.Object obj -> map jsonFieldToDynamicField (Aeson.toList obj)+        _ -> error "Expected JSON object from row_to_json"+    ) -fetchRows :: FromRow r => PG.Connection -> Text -> IO [r]-fetchRows connection tableName = do-    pkFields <- tablePrimaryKeyFields connection tableName+jsonFieldToDynamicField :: (Aeson.Key, Aeson.Value) -> DynamicField+jsonFieldToDynamicField (key, val) = DynamicField+    { fieldValue = case val of+        Aeson.Null -> Nothing+        Aeson.String t -> Just (cs t)+        Aeson.Bool True -> Just "true"+        Aeson.Bool False -> Just "false"+        other -> Just (cs (Aeson.encode other))+    , fieldName = cs (Aeson.toText key)+    } -    let query = "SELECT * FROM "-            <> tableName-            <> (if null pkFields-                    then ""-                    else " ORDER BY " <> intercalate ", " pkFields-                )+tablePrimaryKeyFields :: (?modelContext :: ModelContext) => Text -> IO [Text]+tablePrimaryKeyFields tableName =+    runSnippetQuery+        (Snippet.sql "SELECT a.attname::text FROM pg_index i JOIN pg_attribute a ON a.attrelid = i.indrelid AND a.attnum = ANY(i.indkey) WHERE i.indrelid = " <> Snippet.param tableName <> Snippet.sql "::regclass AND i.indisprimary")+        (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text))) -    PG.query_ connection (PG.Query . cs $! query)+fetchRows :: (?modelContext :: ModelContext) => Text -> IO [[DynamicField]]+fetchRows tableName = do+    pkFields <- tablePrimaryKeyFields tableName -fetchRowsPage :: FromRow r => PG.Connection -> Text -> Int -> Int -> IO [r]-fetchRowsPage connection tableName page rows = do-    pkFields <- tablePrimaryKeyFields connection tableName-    let slice = " OFFSET " <> show (page * rows - rows) <> " ROWS FETCH FIRST " <> show rows <> " ROWS ONLY"-    let query = "SELECT * FROM "-            <> tableName-            <> (if null pkFields-                    then ""-                    else " ORDER BY " <> intercalate ", " pkFields-                )-            <> slice+    let orderBy = if null pkFields+            then mempty+            else Snippet.sql " ORDER BY " <> (mconcat $ List.intersperse (Snippet.sql ", ") (map quoteIdentifier pkFields)) -    PG.query_ connection (PG.Query . cs $! query)+    let snippet = wrapDynamicQuery (Snippet.sql "SELECT * FROM " <> quoteIdentifier tableName <> orderBy)+    runSnippetQuery snippet dynamicFieldDecoder -tableLength :: PG.Connection -> Text -> IO Int-tableLength connection tableName = do-    [Only count] <- PG.query connection "SELECT COUNT(*) FROM ?" [PG.Identifier tableName]-    pure count+fetchRowsPage :: (?modelContext :: ModelContext) => Text -> Int -> Int -> IO [[DynamicField]]+fetchRowsPage tableName page rows = do+    pkFields <- tablePrimaryKeyFields tableName +    let orderBy = if null pkFields+            then mempty+            else Snippet.sql " ORDER BY " <> (mconcat $ List.intersperse (Snippet.sql ", ") (map quoteIdentifier pkFields)) --- parseValues sqlMode isBoolField input-parseValues :: Bool -> Bool -> Text -> PG.Action-parseValues _ True "on" = PG.toField True-parseValues _ True "off" = PG.toField False-parseValues False _ text = PG.toField text-parseValues _ _ text = PG.Plain (Data.ByteString.Builder.byteString (cs text))+    let snippet = wrapDynamicQuery (+            Snippet.sql "SELECT * FROM " <> quoteIdentifier tableName+            <> orderBy+            <> Snippet.sql " OFFSET " <> Snippet.param (fromIntegral (page * rows - rows) :: Int64)+            <> Snippet.sql " ROWS FETCH FIRST " <> Snippet.param (fromIntegral rows :: Int64)+            <> Snippet.sql " ROWS ONLY"+            )+    runSnippetQuery snippet dynamicFieldDecoder -updateValues list = map (\elem -> fst elem <> " = " <> snd elem) list+tableLength :: (?modelContext :: ModelContext) => Text -> IO Int+tableLength tableName = do+    count <- runSnippetQuery+        (Snippet.sql "SELECT COUNT(*) FROM " <> quoteIdentifier tableName)+        (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))+    pure (fromIntegral count) +-- parseValues sqlMode isBoolField input+parseValues :: Bool -> Bool -> Text -> Snippet+parseValues _ True "on" = Snippet.param True+parseValues _ True "off" = Snippet.param False+parseValues False _ text = Snippet.param text+parseValues _ _ text = Snippet.sql (cs text)  -- raw SQL mode (for expressions like now(), DEFAULT, NULL)++isQuery :: Text -> Bool isQuery sql = T.isInfixOf "SELECT" u     where u = T.toUpper sql ---fetchForeignKeyInfo :: PG.Connection -> Text -> Text -> IO (Maybe (Text, Text))-fetchForeignKeyInfo connection tableName columnName = do-    let sql = [plain|-        SELECT-            ccu.table_name AS foreign_table_name,-            ccu.column_name AS foreign_column_name-        FROM-            information_schema.table_constraints AS tc-            JOIN information_schema.key_column_usage AS kcu-              ON tc.constraint_name = kcu.constraint_name-              AND tc.table_schema = kcu.table_schema-            JOIN information_schema.constraint_column_usage AS ccu-              ON ccu.constraint_name = tc.constraint_name-              AND ccu.table_schema = tc.table_schema-        WHERE-            tc.constraint_type = 'FOREIGN KEY'-            AND tc.table_name = ?-            AND kcu.column_name = ?-    |]-    let args = (tableName, columnName)-    result <- PG.query connection (PG.Query $ cs sql) args+fetchForeignKeyInfo :: (?modelContext :: ModelContext) => Text -> Text -> IO (Maybe (Text, Text))+fetchForeignKeyInfo tableName columnName = do+    let snippet =+            Snippet.sql "SELECT ccu.table_name::text AS foreign_table_name, ccu.column_name::text AS foreign_column_name FROM information_schema.table_constraints AS tc JOIN information_schema.key_column_usage AS kcu ON tc.constraint_name = kcu.constraint_name AND tc.table_schema = kcu.table_schema JOIN information_schema.constraint_column_usage AS ccu ON ccu.constraint_name = tc.constraint_name AND ccu.table_schema = tc.table_schema WHERE tc.constraint_type = 'FOREIGN KEY' AND tc.table_name = "+            <> Snippet.param tableName+            <> Snippet.sql " AND kcu.column_name = "+            <> Snippet.param columnName+    let decoder = Decoders.rowList $+            (,) <$> Decoders.column (Decoders.nonNullable Decoders.text)+                <*> Decoders.column (Decoders.nonNullable Decoders.text)+    result <- runSnippetQuery snippet decoder     case result of         [(foreignTableName, foreignColumnName)] -> pure $ Just (foreignTableName, foreignColumnName)-        otherwise -> pure $ Nothing+        _ -> pure Nothing++usageErrorToConsoleError :: HasqlPool.UsageError -> SqlConsoleError+usageErrorToConsoleError (HasqlPool.SessionUsageError sessionError) = sessionErrorToConsoleError sessionError+usageErrorToConsoleError err =+    SqlConsoleError { errorMessage = cs (show err), errorDetail = "", errorHint = "", errorState = "" }++sessionErrorToConsoleError :: HasqlErrors.SessionError -> SqlConsoleError+sessionErrorToConsoleError (HasqlErrors.StatementSessionError _ _ _ _ _ (HasqlErrors.ServerStatementError (HasqlErrors.ServerError code message detail hint _))) =+    SqlConsoleError { errorMessage = message, errorDetail = fromMaybe "" detail, errorHint = fromMaybe "" hint, errorState = code }+sessionErrorToConsoleError (HasqlErrors.ScriptSessionError _ (HasqlErrors.ServerError code message detail hint _)) =+    SqlConsoleError { errorMessage = message, errorDetail = fromMaybe "" detail, errorHint = fromMaybe "" hint, errorState = code }+sessionErrorToConsoleError err =+    SqlConsoleError { errorMessage = cs (HasqlErrors.toDetailedText err), errorDetail = "", errorHint = "", errorState = "" }++-- | Reorder DynamicField results to match the column order from information_schema.+-- The row_to_json → Aeson decoding returns fields in alphabetical order (KeyMap.toList),+-- but views like EditRowView zip fields with tableCols which are in ordinal_position order.+reorderFields :: [ColumnDefinition] -> [DynamicField] -> [DynamicField]+reorderFields cols fields = map findField cols+    where+        findField col = fromMaybe (DynamicField { fieldName = cs col.columnName, fieldValue = Nothing }) $+            List.find (\f -> f.fieldName == cs col.columnName) fields  instance {-# OVERLAPS #-} ToJSON [DynamicField] where     toJSON fields = object (map (\DynamicField { fieldName, fieldValue } -> (cs fieldName) .= (fieldValueToJSON fieldValue)) fields)
IHP/IDE/Data/View/EditRow.hs view
@@ -22,7 +22,7 @@     html EditRowView { .. } = [hsx|         <div class="h-100">             {headerNav}-            <div class="h-100 row no-gutters">+            <div class="h-100 row g-0">                 {renderTableSelector tableNames tableName}                 <div class="col" style="overflow: scroll; max-height: 80vh">                     {renderRows rows tableBody tableName}@@ -37,7 +37,7 @@                 where                     id = (cs (fromMaybe "" ((fromJust (headMay fields)).fieldValue)))             renderField id DynamicField { .. } | fieldName == "id" = [hsx|<td><span data-fieldname={fieldName}><a class="no-link border rounded p-1" href={EditRowValueAction tableName (cs fieldName) id}>{renderId (sqlValueToText fieldValue)}</a></span></td>|]-            renderField id DynamicField { .. } | isBoolField fieldName tableCols && not (isNothing fieldValue) = [hsx|<td><span data-fieldname={fieldName}><input type="checkbox" onclick={onClick tableName fieldName id} checked={sqlValueToText fieldValue == "t"} /></span></td>|]+            renderField id DynamicField { .. } | isBoolField fieldName tableCols && not (isNothing fieldValue) = [hsx|<td><span data-fieldname={fieldName}><input type="checkbox" onclick={onClick tableName fieldName id} checked={sqlValueToText fieldValue == "true"} /></span></td>|]             renderField id DynamicField { .. } = [hsx|<td><span data-fieldname={fieldName}><a class="no-link" href={EditRowValueAction tableName (cs fieldName) id}>{sqlValueToText fieldValue}</a></span></td>|]  @@ -46,7 +46,7 @@                     <input type="hidden" name="tableName" value={tableName}/>                     {forEach (zip tableCols rowValues) renderFormField}                     {forEach (zip primaryKeyFields (T.splitOn "---" targetPrimaryKey)) renderPrimaryKeyInput}-                    <div class="text-right">+                    <div class="text-end">                         <button type="submit" class="btn btn-primary">Edit Row</button>                     </div>                 </form>@@ -60,7 +60,7 @@                          renderFormField :: (ColumnDefinition, DynamicField) -> Html             renderFormField (def, val) = [hsx|-                    <div class="form-group">+                    <div class="mb-3">                         <label class="row-form">{def.columnName}</label>                         <span style="float:right;">                             <a class="text-muted row-form">{def.columnType}</a>@@ -79,7 +79,7 @@                                 id={def.columnName <> "-alt"}                                 type="text"                                 name={def.columnName}-                                class="form-control text-monospace text-secondary bg-light"+                                class="form-control font-monospace text-secondary bg-light"                                 value="NULL"                                 />                             <div class="form-control" id={def.columnName <> "-boxcontainer"}>@@ -88,7 +88,7 @@                                     type="checkbox"                                     class="d-none"                                     name={def.columnName <> "-inactive"}-                                    checked={(value val) == "t"}+                                    checked={(value val) == "true"}                                     />                             </div>                             <input@@ -97,9 +97,8 @@                                 name={def.columnName}                                 value={inputValue False}                                 />-                            <div class="input-group-append">-                                <button class="btn dropdown-toggle" type="button" data-toggle="dropdown" aria-haspopup="true" aria-expanded="false"></button>-                                <div class="dropdown-menu dropdown-menu-right custom-menu menu-for-column shadow backdrop-blur">+                                <button class="btn dropdown-toggle" type="button" data-bs-toggle="dropdown" aria-haspopup="true" aria-expanded="false"></button>+                                <div class="dropdown-menu dropdown-menu-end custom-menu menu-for-column shadow backdrop-blur">                                     <a class="dropdown-item" data-value="DEFAULT" data-issql="True" onclick={fillField def "DEFAULT" "true"}>DEFAULT</a>                                     <a class="dropdown-item" data-value="NULL" data-issql="True" onclick={fillField def "NULL" "true"}>NULL</a>                                     <a class="dropdown-item">@@ -108,7 +107,7 @@                                             type="checkbox"                                             name={def.columnName <> "_"}                                             checked={True}-                                            class="mr-1"+                                            class="me-1"                                             onclick={"sqlModeCheckbox('" <> def.columnName <> "', this, true)"}                                             />                                         <label class="form-check-label" for={def.columnName <> "-sqlbox"}> Parse as SQL</label>@@ -119,7 +118,6 @@                                         value={inputValue False}                                         />                                 </div>-                            </div>                                 |]             renderInputMethod (def, val) | (def.columnType) == "boolean" = [hsx|                             {isBooleanParam True def}@@ -127,14 +125,14 @@                                 id={def.columnName <> "-alt"}                                 type="text"                                 name={def.columnName <> "-inactive"}-                                class="form-control text-monospace text-secondary bg-light d-none"+                                class="form-control font-monospace text-secondary bg-light d-none"                                 />                             <div class="form-control" id={def.columnName <> "-boxcontainer"}>                                 <input                                     id={def.columnName <> "-input"}                                     type="checkbox"                                     name={def.columnName}-                                    checked={(value val) == "t"}+                                    checked={(value val) == "true"}                                     />                             </div>                             <input@@ -143,9 +141,8 @@                                 name={def.columnName}                                 value={inputValue False}                                 />-                            <div class="input-group-append">-                                <button class="btn dropdown-toggle" type="button" data-toggle="dropdown" aria-haspopup="true" aria-expanded="false"></button>-                                <div class="dropdown-menu dropdown-menu-right custom-menu menu-for-column shadow backdrop-blur">+                                <button class="btn dropdown-toggle" type="button" data-bs-toggle="dropdown" aria-haspopup="true" aria-expanded="false"></button>+                                <div class="dropdown-menu dropdown-menu-end custom-menu menu-for-column shadow backdrop-blur">                                     <a class="dropdown-item" data-value="DEFAULT" data-issql="True" onclick={fillField def "DEFAULT" "true"}>DEFAULT</a>                                     <a class="dropdown-item" data-value="NULL" data-issql="True" onclick={fillField def "NULL" "true"}>NULL</a>                                     <a class="dropdown-item">@@ -154,7 +151,7 @@                                             type="checkbox"                                             name={def.columnName <> "_"}                                             checked={isSqlFunction (getColDefaultValue def)}-                                            class="mr-1"+                                            class="me-1"                                             onclick={"sqlModeCheckbox('" <> def.columnName <> "', this, true)"}                                             />                                         <label class="form-check-label" for={def.columnName <> "-sqlbox"}> Parse as SQL</label>@@ -165,7 +162,6 @@                                         value={inputValue False}                                         />                                 </div>-                            </div>                                 |]             renderInputMethod (def, val) = [hsx|                             {isBooleanParam False def}@@ -173,13 +169,12 @@                                 id={def.columnName <> "-input"}                                 type="text"                                 name={def.columnName}-                                class={classes ["form-control", ("text-monospace text-secondary bg-light", isSqlFunction_ (value val))]}+                                class={classes ["form-control", ("font-monospace text-secondary bg-light", isSqlFunction_ (value val))]}                                 value={value val}                                 oninput={"stopSqlModeOnInput('" <> def.columnName <> "')"}                                 />-                            <div class="input-group-append">-                                <button class="btn dropdown-toggle" type="button" data-toggle="dropdown" aria-haspopup="true" aria-expanded="false"></button>-                                <div class="dropdown-menu dropdown-menu-right custom-menu menu-for-column shadow backdrop-blur">+                                <button class="btn dropdown-toggle" type="button" data-bs-toggle="dropdown" aria-haspopup="true" aria-expanded="false"></button>+                                <div class="dropdown-menu dropdown-menu-end custom-menu menu-for-column shadow backdrop-blur">                                     <a class="dropdown-item" data-value="DEFAULT" data-issql="True" onclick={fillField def "DEFAULT" "false"}>DEFAULT</a>                                     <a class="dropdown-item" data-value="NULL" data-issql="True" onclick={fillField def "NULL" "false"}>NULL</a>                                     <a class="dropdown-item">@@ -188,7 +183,7 @@                                             type="checkbox"                                             name={def.columnName <> "_"}                                             checked={isSqlFunction_ (value val)}-                                            class="mr-1"+                                            class="me-1"                                             onclick={"sqlModeCheckbox('" <> def.columnName <> "', this)"}                                             />                                         <label class="form-check-label" for={def.columnName <> "-sqlbox"}> Parse as SQL</label>@@ -199,6 +194,6 @@                                         value={inputValue False}                                         />                                 </div>-                            </div>|]+                            |]  value val = fromMaybe BS.empty (val.fieldValue)
IHP/IDE/Data/View/EditValue.hs view
@@ -18,7 +18,7 @@     html EditValueView { .. } = [hsx|         <div class="h-100">             {headerNav}-            <div class="h-100 row no-gutters">+            <div class="h-100 row g-0">                 {renderTableSelector tableNames tableName}                 <div class="col" style="overflow: scroll; max-height: 80vh">                     {renderRows rows tableBody tableName}@@ -35,7 +35,7 @@             </tr>             <div class="custom-menu menu-for-column shadow backdrop-blur" id={contextMenuId}>                 <a href={EditRowAction tableName id}>Edit Row</a>-                <a href={DeleteEntryAction tableName id} class="js-delete">Delete Row</a>+                <a href={DeleteEntryAction id tableName} class="js-delete">Delete Row</a>                 <div></div>                 <a href={NewRowAction tableName}>Add Row</a>             </div>|]
IHP/IDE/Data/View/Layout.hs view
@@ -35,9 +35,6 @@                         <a                             href={NewRowAction tableName}                             class="btn btn-link btn-add"-                            data-toggle="tooltip"-                            data-placement="bottom"-                            title={"Add " <> tableNameToModelName tableName}                         >{addIcon}</a>                     </div>                 </th>@@ -67,16 +64,16 @@     Nothing -> False  isSqlFunction :: Text -> Bool-isSqlFunction text = text `elem`-    [ "uuid_generate_v4()"-    , "NOW()"-    , "NULL"]+isSqlFunction text = Text.toLower text `elem`+    [ "uuidv7()"+    , "uuidv4()"+    , "uuid_generate_v4()"+    , "now()"+    , "null"+    , "default"]  isSqlFunction_ :: ByteString -> Bool-isSqlFunction_ text = text `elem`-    [ "uuid_generate_v4()"-    , "NOW()"-    , "NULL"]+isSqlFunction_ text = isSqlFunction (cs text)  fillField col value isBoolField = "fillField('" <> col.columnName <> "', '" <> value <> "'," <> isBoolField <> ");"
IHP/IDE/Data/View/NewRow.hs view
@@ -18,7 +18,7 @@     html NewRowView { .. } = [hsx|         <div class="h-100">             {headerNav}-            <div class="h-100 row no-gutters">+            <div class="h-100 row g-0">                 {renderTableSelector tableNames tableName}                 <div class="col" style="overflow: scroll; max-height: 80vh">                     {renderRows rows tableBody tableName}@@ -33,7 +33,7 @@                 where                     id = (cs (fromMaybe "" ((fromJust (headMay fields)).fieldValue)))             renderField id DynamicField { .. } | fieldName == "id" = [hsx|<td><span data-fieldname={fieldName}><a class="no-link border rounded p-1" href={EditRowValueAction tableName (cs fieldName) id}>{renderId (sqlValueToText fieldValue)}</a></span></td>|]-            renderField id DynamicField { .. } | isBoolField fieldName tableCols && not (isNothing fieldValue) = [hsx|<td><span data-fieldname={fieldName}><input type="checkbox" onclick={onClick tableName fieldName id} checked={sqlValueToText fieldValue == "t"} /></span></td>|]+            renderField id DynamicField { .. } | isBoolField fieldName tableCols && not (isNothing fieldValue) = [hsx|<td><span data-fieldname={fieldName}><input type="checkbox" onclick={onClick tableName fieldName id} checked={sqlValueToText fieldValue == "true"} /></span></td>|]             renderField id DynamicField { .. } = [hsx|<td><span data-fieldname={fieldName}><a class="no-link" href={EditRowValueAction tableName (cs fieldName) id}>{sqlValueToText fieldValue}</a></span></td>|]              modalContent = [hsx|@@ -41,7 +41,7 @@                     <input type="hidden" name="tableName" value={tableName}/>                     {forEach tableCols renderFormField}                     {renderFlashMessages}-                    <div class="text-right">+                    <div class="text-end">                         <button type="submit" class="btn btn-primary">Add Row</button>                     </div>                 </form>@@ -52,13 +52,13 @@             modal = Modal { modalContent, modalFooter, modalCloseUrl, modalTitle }              renderFormField col = [hsx|-                    <div class="form-group">+                    <div class="mb-3">                         <label class="row-form">{col.columnName}</label>                         <span style="float:right;">                             <a class="text-muted row-form">{col.columnType}</a>                         </span> -                        <div class="d-flex">+                        <div class="input-group">                             {renderInputMethod col}                         </div>                     </div>|]@@ -71,7 +71,7 @@                                 id={col.columnName <> "-alt"}                                 type="text"                                 name={col.columnName <> "-inactive"}-                                class="form-control text-monospace text-secondary d-none"+                                class="form-control font-monospace text-secondary d-none"                                 />                             <div class="form-control" id={col.columnName <> "-boxcontainer"}>                                 <input@@ -87,9 +87,8 @@                                 name={col.columnName}                                 value={inputValue False}                                 />-                            <div class="input-group-append">-                                <button class="btn dropdown-toggle" type="button" data-toggle="dropdown" aria-haspopup="true" aria-expanded="false"></button>-                                <div class="dropdown-menu dropdown-menu-right custom-menu menu-for-column shadow backdrop-blur">+                                <button class="btn dropdown-toggle" type="button" data-bs-toggle="dropdown" aria-haspopup="true" aria-expanded="false"></button>+                                <div class="dropdown-menu dropdown-menu-end custom-menu menu-for-column shadow backdrop-blur">                                     <a class="dropdown-item" data-value="DEFAULT" data-issql="True" onclick={fillField col "DEFAULT" "true"}>DEFAULT</a>                                     <a class="dropdown-item" data-value="NULL" data-issql="True" onclick={fillField col "NULL" "true"}>NULL</a>                                     <a class="dropdown-item">@@ -98,7 +97,7 @@                                             type="checkbox"                                             name={col.columnName <> "_"}                                             checked={isSqlFunction (getColDefaultValue col)}-                                            class="mr-1"+                                            class="me-1"                                             onclick={"sqlModeCheckbox('" <> col.columnName <> "', this, true)"}                                             />                                         <label class="form-check-label" for={col.columnName <> "-sqlbox"}> Parse as SQL</label>@@ -109,7 +108,6 @@                                         value={inputValue False}                                         />                                 </div>-                            </div>                                 |]             renderInputMethod col = [hsx|                                 {isBooleanParam False col}@@ -117,8 +115,8 @@                                         then select                                         else theInput                                 }-                                <button class="btn dropdown-toggle" type="button" data-toggle="dropdown" aria-haspopup="true" aria-expanded="false"></button>-                                <div class="dropdown-menu dropdown-menu-right custom-menu menu-for-column shadow backdrop-blur">+                                <button class="btn dropdown-toggle" type="button" data-bs-toggle="dropdown" aria-haspopup="true" aria-expanded="false"></button>+                                <div class="dropdown-menu dropdown-menu-end custom-menu menu-for-column shadow backdrop-blur">                                     <a class="dropdown-item" data-value="DEFAULT" data-issql="True" onclick={fillField col "DEFAULT" "false"}>DEFAULT</a>                                     <a class="dropdown-item" data-value="NULL" data-issql="True" onclick={fillField col "NULL" "false"}>NULL</a>                                     <a class="dropdown-item">@@ -127,7 +125,7 @@                                             type="checkbox"                                             name={col.columnName <> "_"}                                             checked={isSqlFunction (getColDefaultValue col)}-                                            class="mr-1"+                                            class="me-1"                                             onclick={"sqlModeCheckbox('" <> col.columnName <> "', this, false)"}                                             />                                         <label class="form-check-label" for={col.columnName <> "-sqlbox"}> Parse as SQL</label>@@ -150,7 +148,7 @@                                             id={col.columnName <> "-input"}                                             type="text"                                             name={col.columnName}-                                            class={classes ["form-control", ("text-monospace", isSqlFunction (getColDefaultValue col)), ("is-foreign-key-column", isForeignKeyColumn)]}+                                            class={classes ["form-control", ("font-monospace", isSqlFunction (getColDefaultValue col)), ("is-foreign-key-column", isForeignKeyColumn)]}                                             value={renderDefaultWithoutType (getColDefaultValue col)}                                             oninput={"stopSqlModeOnInput('" <> col.columnName <> "')"}                                         />
IHP/IDE/Data/View/ShowDatabase.hs view
@@ -12,7 +12,7 @@     html ShowDatabaseView { .. } = [hsx|         <div class="h-100">             {headerNav}-            <div class="h-100 row no-gutters" oncontextmenu="event.preventDefault();">+            <div class="h-100 row g-0" oncontextmenu="event.preventDefault();">                 {renderTableSelector tableNames ""}             </div>         </div>@@ -23,7 +23,7 @@ renderTableSelector tableNames activeTableName = [hsx|     <div class="col-2 object-selector" oncontextmenu="event.preventDefault();">         <div class="d-flex">-            <h5 class="pl-3">Tables</h5>+            <h5 class="ps-3">Tables</h5>         </div>         {forEach tableNames renderTable}         <div class="text-muted context-menu-notice">Right click to open context menu</div>@@ -34,7 +34,7 @@         renderTable name = [hsx|             <a                 href={ShowTableRowsAction name}-                class={classes [("object object-table w-100 context-table pl-3", True), ("active", name == activeTableName)]}+                class={classes [("object object-table w-100 context-table ps-3", True), ("active", name == activeTableName)]}                 oncontextmenu={"showContextMenu('" <> contextMenuId <> "'); event.stopPropagation();"}             >                 {name}
IHP/IDE/Data/View/ShowQuery.hs view
@@ -1,12 +1,11 @@ module IHP.IDE.Data.View.ShowQuery where -import qualified Database.PostgreSQL.Simple as PG import IHP.ViewPrelude import IHP.IDE.ToolServer.Types import IHP.IDE.Data.View.Layout  data ShowQueryView = ShowQueryView-    { queryResult :: Maybe (Either PG.SqlError SqlConsoleResult)+    { queryResult :: Maybe (Either SqlConsoleError SqlConsoleResult)     , queryText :: Text     } @@ -24,8 +23,8 @@                      <button                         class="btn btn-primary"-                        data-toggle="tooltip"-                        data-placement="right"+                        data-bs-toggle="tooltip"+                        data-bs-placement="right"                         title="⌘ Enter"                     >Run SQL Query</button>                 </form>@@ -55,11 +54,11 @@                 |]                 Just (Left sqlError) -> [hsx|                     <div class="alert alert-danger" role="alert">-                        <h4 class="alert-heading">SQL Error - {sqlError.sqlExecStatus}</h4>-                        {showIfNotEmpty "Message" (sqlError.sqlErrorMsg)}-                        {showIfNotEmpty "Details" (sqlError.sqlErrorDetail)}-                        {showIfNotEmpty "Hint" (sqlError.sqlErrorHint)}-                        {showIfNotEmpty "State" (sqlError.sqlState)}+                        <h4 class="alert-heading">SQL Error</h4>+                        {showIfNotEmpty "Message" (sqlError.errorMessage)}+                        {showIfNotEmpty "Details" (sqlError.errorDetail)}+                        {showIfNotEmpty "Hint" (sqlError.errorHint)}+                        {showIfNotEmpty "State" (sqlError.errorState)}                     </div>                 |]                 Nothing -> mempty@@ -73,7 +72,7 @@              columnNames rows = maybe [] (map (.fieldName)) (head rows) -            showIfNotEmpty :: Text -> ByteString -> Html+            showIfNotEmpty :: Text -> Text -> Html             showIfNotEmpty title = \case                 "" -> mempty                 text -> [hsx|<div><strong>{title}:</strong> {text}</div>|]
IHP/IDE/Data/View/ShowTableRows.hs view
@@ -21,7 +21,7 @@     html ShowTableRowsView { .. } = [hsx|         <div class="h-100">             {headerNav}-            <div class="h-100 row no-gutters">+            <div class="h-100 row g-0">                 {renderTableSelector tableNames tableName}                 <div class="col" oncontextmenu="showContextMenu('context-menu-data-root')">                     <div style="overflow: scroll; max-height: 80vh">@@ -52,7 +52,7 @@                     primaryKey = intercalate "---" . map (cs . fromMaybe "" . (.fieldValue)) $ filter ((`elem` primaryKeyFields) . cs . (.fieldName)) fields             renderField primaryKey DynamicField { .. }                 | fieldName == "id" = [hsx|<td><span data-fieldname={fieldName}><a class="border rounded p-1" href={EditRowValueAction tableName (cs fieldName) primaryKey}>{renderId (sqlValueToText fieldValue)}</a></span></td>|]-                | isBoolField fieldName tableCols && not (isNothing fieldValue) = [hsx|<td><span data-fieldname={fieldName}><input type="checkbox" onclick={onClick tableName fieldName primaryKey} checked={sqlValueToText fieldValue == "t"} /></span></td>|]+                | isBoolField fieldName tableCols && not (isNothing fieldValue) = [hsx|<td><span data-fieldname={fieldName}><input type="checkbox" onclick={onClick tableName fieldName primaryKey} checked={sqlValueToText fieldValue == "true"} /></span></td>|]                 | otherwise = renderNormalField primaryKey DynamicField { .. }              renderNormalField primaryKey DynamicField { .. } = [hsx|@@ -101,7 +101,7 @@                                       renderPageButton :: Int -> Html-            renderPageButton nr = [hsx|<a href={pathTo (ShowTableRowsAction tableName) <> "&page=" <> show nr <> "&rows=" <> show pageSize} class={classes ["mx-2", (if page==nr then "text-dark font-weight-bold" else "text-muted")]}>{nr}</a>|]+            renderPageButton nr = [hsx|<a href={pathTo (ShowTableRowsAction tableName) <> "&page=" <> show nr <> "&rows=" <> show pageSize} class={classes ["mx-2", (if page==nr then "text-dark fw-bold" else "text-muted")]}>{nr}</a>|]              emptyState :: Html             emptyState = [hsx|
IHP/IDE/FileWatcher.hs view
@@ -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
IHP/IDE/LiveReloadNotificationServer.hs view
@@ -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
IHP/IDE/Logs/Controller.hs view
@@ -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 { .. }
+ IHP/IDE/Logs/ServiceLog.hs view
@@ -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
IHP/IDE/Logs/View/Logs.hs view
@@ -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|         <div id="logs">-            <div class="logs-navigation">-                <a href={AppLogsAction} class={classes [("active", isActivePath AppLogsAction)]}>App</a>-                <a href={PostgresLogsAction} class={classes [("active", isActivePath PostgresLogsAction)]}>Postgres</a>+            <div class="logs-tab-bar">+                <a href={AppLogsAction} class={classes [("logs-tab", True), ("active", activeService == "app")]}>App</a>+                <a href={PostgresLogsAction} class={classes [("logs-tab", True), ("active", activeService == "postgres")]}>Postgres</a>+                {forEach services serviceTab}             </div> -            <pre>{standardOutput}</pre>-            <pre>{errorOutput}</pre>+            <div class="logs-output">+                <pre>{standardOutput}</pre>+                {renderStderr}+            </div>         </div>+        <script>+            document.addEventListener('turbolinks:load', function() {+                var output = document.querySelector('.logs-output');+                if (output) output.scrollTop = output.scrollHeight;+            });+        </script>     |]+        where+            renderStderr = if errorOutput /= ""+                then [hsx|<pre class="stderr">{errorOutput}</pre>|]+                else mempty++            serviceTab :: Text -> Html+            serviceTab name = [hsx|+                <a href={ServiceLogsAction name} class={classes [("logs-tab", True), ("active", activeService == name)]}>{name}</a>+            |]
IHP/IDE/PortConfig.hs view
@@ -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
IHP/IDE/Postgres.hs view
@@ -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
+ IHP/IDE/Prelude.hs view
@@ -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)
IHP/IDE/SchemaDesigner/Compiler.hs view
@@ -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"
IHP/IDE/SchemaDesigner/Controller/Columns.hs view
@@ -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
IHP/IDE/SchemaDesigner/Controller/EnumValues.hs view
@@ -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))
IHP/IDE/SchemaDesigner/Controller/Enums.hs view
@@ -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
IHP/IDE/SchemaDesigner/Controller/Helper.hs view
@@ -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
IHP/IDE/SchemaDesigner/Controller/Indexes.hs view
@@ -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
IHP/IDE/SchemaDesigner/Controller/Migrations.hs view
@@ -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
IHP/IDE/SchemaDesigner/Controller/Policies.hs view
@@ -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
IHP/IDE/SchemaDesigner/Controller/Schema.hs view
@@ -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
IHP/IDE/SchemaDesigner/Controller/Tables.hs view
@@ -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
IHP/IDE/SchemaDesigner/Controller/Validation.hs view
@@ -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
− IHP/IDE/SchemaDesigner/Parser.hs 
@@ -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 = "" }
IHP/IDE/SchemaDesigner/SchemaOperations.hs view
@@ -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
IHP/IDE/SchemaDesigner/Types.hs view
@@ -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
IHP/IDE/SchemaDesigner/View/Columns/Edit.hs view
@@ -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|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just tableName)}             {renderColumnSelector tableName (zip [0..] columns) statements}         </div>@@ -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 @@                     <input type="hidden" name="tableName" value={tableName}/>                     <input type="hidden" name="columnId" value={tshow columnId}/> -                    <div class="form-group">+                    <div class="mb-3">                         <input                             id="nameInput"                             name="name"@@ -52,45 +52,45 @@                             />                     </div> -                    <div class="form-group">+                    <div class="mb-3">                         {typeSelector (Just (column.columnType)) enumNames}                          <div class="d-flex text-muted mt-1" id="column-options">-                            <div class="custom-control custom-checkbox mr-2">-                                <input id="allowNull" type="checkbox" name="allowNull" class="custom-control-input" checked={not (column.notNull)}/>-                                <label class="mr-1 custom-control-label" for="allowNull">+                            <div class="form-check me-2">+                                <input id="allowNull" type="checkbox" name="allowNull" class="form-check-input" checked={not (column.notNull)}/>+                                <label class="me-1 form-check-label" for="allowNull">                                     Nullable                                 </label>                             </div> -                            <div class="custom-control custom-checkbox mr-2">-                                <input type="checkbox" id="isUnique" name="isUnique" class="custom-control-input" checked={column.isUnique}/>-                                <label class="custom-control-label" for="isUnique">+                            <div class="form-check me-2">+                                <input type="checkbox" id="isUnique" name="isUnique" class="form-check-input" checked={column.isUnique}/>+                                <label class="form-check-label" for="isUnique">                                     Unique                                 </label>                             </div> -                            <div class="custom-control custom-checkbox mr-2">-                                <input type="checkbox" id="primaryKey" name="primaryKey" class="custom-control-input" checked={isPrimaryKey}/>-                                <label class="custom-control-label" for="primaryKey">+                            <div class="form-check me-2">+                                <input type="checkbox" id="primaryKey" name="primaryKey" class="form-check-input" checked={isPrimaryKey}/>+                                <label class="form-check-label" for="primaryKey">                                     Primary Key                                 </label>                             </div> -                            <div class="custom-control custom-checkbox mr-2">-                                <input id="isArray" type="checkbox" name="isArray" class="custom-control-input" checked={isArrayType (column.columnType)}/>-                                <label class="custom-control-label">+                            <div class="form-check me-2">+                                <input id="isArray" type="checkbox" name="isArray" class="form-check-input" checked={isArrayType (column.columnType)}/>+                                <label class="form-check-label">                                      Array Type                                 </label>                             </div>                         </div>                     </div> -                    <div class="form-group row">+                    <div class="mb-3 row">                         {defaultSelector (column.defaultValue)}                     </div> -                    <div class="text-right">+                    <div class="text-end">                         <button type="submit" class="btn btn-primary">Edit Column</button>                     </div>                     <input type="hidden" name="primaryKey" value={inputValue False}/>
IHP/IDE/SchemaDesigner/View/Columns/EditForeignKey.hs view
@@ -1,9 +1,10 @@ module IHP.IDE.SchemaDesigner.View.Columns.EditForeignKey where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.SchemaDesigner.View.Layout+import IHP.IDE.SchemaDesigner.View.Columns.NewForeignKey (foreignKeyFormModal)  data EditForeignKeyView = EditForeignKeyView     { statements :: [Statement]@@ -17,7 +18,7 @@  instance View EditForeignKeyView where     html EditForeignKeyView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just tableName)}             {renderColumnSelector tableName  (zip [0..] columns) statements}         </div>@@ -25,62 +26,14 @@         {renderModal modal}     |]         where-            table = findStatementByName tableName statements-            columns = maybe [] ((.columns) . unsafeGetCreateTable) table--            modalContent = [hsx|-                <form method="POST" action={UpdateForeignKeyAction}>-                    <input type="hidden" name="tableName" value={tableName}/>-                    <input type="hidden" name="columnName" value={columnName}/>--                    <div class="form-group row">-                        <label class="col-sm-2 col-form-label">Reference Table:</label>-                        <div class="col-sm-10">-                            <select name="referenceTable" class="form-control select2" autofocus="autofocus">-                                {forEach tableNames renderTableNameSelector}-                            </select>-                        </div>-                    </div>--                    <div class="form-group row">-                        <label class="col-sm-2 col-form-label">Name:</label>-                        <div class="col-sm-10">-                            <input name="constraintName" type="text" class="form-control" value={constraintName}/>-                        </div>-                    </div>--                    <div class="form-group row">-                        <label class="col-sm-2 col-form-label">On Delete:</label>-                        <div class="col-sm-10">-                            <select name="onDelete" class="form-control select2">-                                {onDeleteSelector "NoAction"}-                                {onDeleteSelector "Restrict"}-                                {onDeleteSelector "SetNull"}-                                {onDeleteSelector "SetDefault"}-                                {onDeleteSelector "Cascade"}-                            </select>-                        </div>-                    </div>--                    <div class="text-right">-                        <button type="submit" class="btn btn-primary">Edit Constraint</button>-                    </div>-                </form>-                {select2}-            |]-                where-                    renderTableNameSelector tableName = if tableName == referenceTable-                        then preEscapedToHtml [plain|<option selected>#{tableName}</option>|]-                        else preEscapedToHtml [plain|<option>#{tableName}</option>|]-                    onDeleteSelector option = if option == onDelete-                        then preEscapedToHtml [plain|<option selected>#{option}</option>|]-                        else preEscapedToHtml [plain|<option>#{option}</option>|]-                    select2 = preEscapedToHtml [plain|-                        <script>-                            $('.select2').select2();-                        </script>-                    |]-            modalFooter = mempty -            modalCloseUrl = pathTo ShowTableAction { tableName }-            modalTitle = "Edit Foreign Key Constraint"-            modal = Modal { modalContent, modalFooter, modalCloseUrl, modalTitle }+            columns = getTableColumns tableName statements+            modal = foreignKeyFormModal+                (pathTo UpdateForeignKeyAction)+                tableName+                columnName+                tableNames+                constraintName+                (Just referenceTable)+                onDelete+                "Edit Constraint"+                "Edit Foreign Key Constraint"
IHP/IDE/SchemaDesigner/View/Columns/New.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.Columns.New where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.ToolServer.Routes () import IHP.IDE.SchemaDesigner.View.Layout@@ -17,7 +17,7 @@  instance View NewColumnView where     html NewColumnView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just tableName)}             {renderColumnSelector tableName  (zip [0..] columns) statements}         </div>@@ -25,15 +25,14 @@         {renderModal modal}     |]         where-            table = findStatementByName tableName statements-            columns = maybe [] ((.columns) . unsafeGetCreateTable) table+            columns = getTableColumns tableName statements              modalContent = [hsx|                 {renderFlashMessages}                 <form method="POST" action={CreateColumnAction} id="new-column">                     <input type="hidden" name="tableName" value={tableName}/> -                    <div class="form-group">+                    <div class="mb-3">                         <input                             id="colName"                             name="name"@@ -45,35 +44,35 @@                             />                     </div> -                    <div class="form-group">+                    <div class="mb-3">                         {typeSelector Nothing enumNames}                         <div class="mt-1 text-muted" id="column-options">                             {generateReferenceCheckboxes}                             <div class="d-flex">-                                <div class="custom-control custom-checkbox">-                                    <input id="allowNull" type="checkbox" name="allowNull" class="mr-1 custom-control-input"/>-                                    <label class="custom-control-label mr-2" for="allowNull">+                                <div class="form-check">+                                    <input id="allowNull" type="checkbox" name="allowNull" class="me-1 form-check-input"/>+                                    <label class="form-check-label me-2" for="allowNull">                                         Nullable                                     </label>                                 </div> -                                <div class="custom-control custom-checkbox">-                                    <input type="checkbox" id="isUnique" name="isUnique" class="mr-1 custom-control-input"/>-                                    <label class="mx-2 custom-control-label" for="isUnique">+                                <div class="form-check">+                                    <input type="checkbox" id="isUnique" name="isUnique" class="me-1 form-check-input"/>+                                    <label class="mx-2 form-check-label" for="isUnique">                                         Unique                                     </label>                                 </div> -                                <div class="custom-control custom-checkbox">-                                    <input type="checkbox" name="primaryKey" id="primaryKey" class="mr-1 custom-control-input"/>-                                    <label class="mx-2 custom-control-label" for="primaryKey">+                                <div class="form-check">+                                    <input type="checkbox" name="primaryKey" id="primaryKey" class="me-1 form-check-input"/>+                                    <label class="mx-2 form-check-label" for="primaryKey">                                         Primary Key                                     </label>                                 </div> -                                <div class="custom-control custom-checkbox">-                                    <input id="isArray" type="checkbox" name="isArray" class="mr-1 custom-control-input"/>-                                    <label class="mx-2 custom-control-label" for="isArray">+                                <div class="form-check">+                                    <input id="isArray" type="checkbox" name="isArray" class="me-1 form-check-input"/>+                                    <label class="mx-2 form-check-label" for="isArray">                                         Array Type                                     </label>                                 </div>@@ -81,11 +80,11 @@                         </div>                     </div> -                    <div class="form-group">+                    <div class="mb-3">                         {defaultSelector}                     </div> -                    <div class="text-right">+                    <div class="text-end">                         <button type="submit" class="btn btn-primary">Create Column</button>                     </div> @@ -102,9 +101,9 @@                         where                             checkbox tableName = [hsx|                             <div>-                                <div class="custom-control custom-checkbox ref" style="display: none;" data-attribute={(singularize tableName) <> "_id"} data-table={tableName} >-                                    <input id={"checkbox-ref-" <> tableName} type="checkbox" name="isReference" class="mr-1 custom-control-input"/>-                                    <label for={"checkbox-ref-" <> tableName} class="mx-2 custom-control-label" id="refText">+                                <div class="form-check ref" style="display: none;" data-attribute={(singularize tableName) <> "_id"} data-table={tableName} >+                                    <input id={"checkbox-ref-" <> tableName} type="checkbox" name="isReference" class="me-1 form-check-input"/>+                                    <label for={"checkbox-ref-" <> tableName} class="mx-2 form-check-label" id="refText">                                         References {tableName}                                     </label>                                 </div>
IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs view
@@ -1,7 +1,7 @@-module IHP.IDE.SchemaDesigner.View.Columns.NewForeignKey where+module IHP.IDE.SchemaDesigner.View.Columns.NewForeignKey (NewForeignKeyView (..), foreignKeyFormModal) where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.SchemaDesigner.View.Layout @@ -14,7 +14,7 @@  instance View NewForeignKeyView where     html NewForeignKeyView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just tableName)}             {renderColumnSelector tableName  (zip [0..] columns) statements}         </div>@@ -22,61 +22,86 @@         {renderModal modal}     |]         where-            table = findStatementByName tableName statements-            columns = maybe [] ((.columns) . unsafeGetCreateTable) table+            columns = getTableColumns tableName statements+            modal = foreignKeyFormModal+                (pathTo CreateForeignKeyAction)+                tableName+                columnName+                tableNames+                (tableName <> "_ref_" <> columnName)+                Nothing+                "NoAction"+                "Add Constraint"+                "New Foreign Key Constraint" -            modalContent = [hsx|-                <form method="POST" action={CreateForeignKeyAction}>-                    <input type="hidden" name="tableName" value={tableName}/>-                    <input type="hidden" name="columnName" value={columnName}/>+-- | Shared form modal for creating and editing foreign key constraints.+foreignKeyFormModal+    :: (?context :: ControllerContext, ?request :: Request)+    => Text           -- ^ Form action URL+    -> Text           -- ^ Table name+    -> Text           -- ^ Column name+    -> [Text]         -- ^ Available table names+    -> Text           -- ^ Constraint name value+    -> Maybe Text     -- ^ Selected reference table (Nothing = no preselection)+    -> Text           -- ^ Selected onDelete value+    -> Text           -- ^ Button text+    -> Text           -- ^ Modal title+    -> Modal+foreignKeyFormModal formAction tableName columnName tableNames constraintNameValue selectedReferenceTable selectedOnDelete buttonText modalTitle =+    Modal { modalContent, modalFooter, modalCloseUrl, modalTitle }+    where+        modalContent = [hsx|+            <form method="POST" action={formAction}>+                <input type="hidden" name="tableName" value={tableName}/>+                <input type="hidden" name="columnName" value={columnName}/> -                    <div class="form-group row">-                        <label class="col-sm-2 col-form-label">Reference Table:</label>-                        <div class="col-sm-10">-                            <select name="referenceTable" class="form-control select2" autofocus="autofocus">-                                {forEach tableNames renderTableNameSelector}-                            </select>-                        </div>+                <div class="mb-3 row">+                    <label class="col-sm-2 col-form-label">Reference Table:</label>+                    <div class="col-sm-10">+                        <select name="referenceTable" class="form-control select2" autofocus="autofocus">+                            {forEach tableNames renderTableNameSelector}+                        </select>                     </div>+                </div> -                    <div class="form-group row">-                        <label class="col-sm-2 col-form-label">Name:</label>-                        <div class="col-sm-10">-                            <input name="constraintName" type="text" class="form-control" value={tableName <> "_ref_" <> columnName}/>-                        </div>+                <div class="mb-3 row">+                    <label class="col-sm-2 col-form-label">Name:</label>+                    <div class="col-sm-10">+                        <input name="constraintName" type="text" class="form-control" value={constraintNameValue}/>                     </div>+                </div> -                    <div class="form-group row">-                        <label class="col-sm-2 col-form-label">On Delete:</label>-                        <div class="col-sm-10">-                            <select name="onDelete" class="form-control select2">-                                {onDeleteSelector "NoAction"}-                                {onDeleteSelector "Restrict"}-                                {onDeleteSelector "SetNull"}-                                {onDeleteSelector "SetDefault"}-                                {onDeleteSelector "Cascade"}-                            </select>-                        </div>+                <div class="mb-3 row">+                    <label class="col-sm-2 col-form-label">On Delete:</label>+                    <div class="col-sm-10">+                        <select name="onDelete" class="form-control select2">+                            {onDeleteSelector "NoAction"}+                            {onDeleteSelector "Restrict"}+                            {onDeleteSelector "SetNull"}+                            {onDeleteSelector "SetDefault"}+                            {onDeleteSelector "Cascade"}+                        </select>                     </div>+                </div> -                    <div class="text-right">-                        <button type="submit" class="btn btn-primary">Add Constraint</button>-                    </div>-                </form>-                {select2}-            |]-                where-                    onDeleteSelector option = if option == "NoAction"-                        then preEscapedToHtml [plain|<option selected>#{option}</option>|]-                        else preEscapedToHtml [plain|<option>#{option}</option>|]-                    renderTableNameSelector tableName = [hsx|<option>{tableName}</option>|]-                    select2 = preEscapedToHtml [plain|-                        <script>-                            $('.select2').select2();-                        </script>-                    |]-            modalFooter = mempty -            modalCloseUrl = pathTo ShowTableAction { tableName }-            modalTitle = "New Foreign Key Constraint"-            modal = Modal { modalContent, modalFooter, modalCloseUrl, modalTitle }-            +                <div class="text-end">+                    <button type="submit" class="btn btn-primary">{buttonText}</button>+                </div>+            </form>+            {select2}+        |]+            where+                renderTableNameSelector name = case selectedReferenceTable of+                    Just selected | name == selected ->+                        preEscapedToHtml [plain|<option selected>#{name}</option>|]+                    _ -> preEscapedToHtml [plain|<option>#{name}</option>|]+                onDeleteSelector option = if option == selectedOnDelete+                    then preEscapedToHtml [plain|<option selected>#{option}</option>|]+                    else preEscapedToHtml [plain|<option>#{option}</option>|]+                select2 = preEscapedToHtml [plain|+                    <script>+                        $('.select2').select2();+                    </script>+                |]+        modalFooter = mempty+        modalCloseUrl = pathTo ShowTableAction { tableName }
IHP/IDE/SchemaDesigner/View/EnumValues/Edit.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.EnumValues.Edit where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.SchemaDesigner.View.Layout @@ -14,7 +14,7 @@  instance View EditEnumValueView where     html EditEnumValueView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just enumName)}             {renderEnumSelector enumName (zip [0..] values)}         </div>@@ -30,14 +30,14 @@                     <input type="hidden" name="enumName" value={enumName}/>                     <input type="hidden" name="valueId" value={tshow valueId}/> -                    <div class="form-group row">+                    <div class="mb-3 row">                         <label class="col-sm-2 col-form-label">Name:</label>                         <div class="col-sm-10">                             <input name="enumValueName" type="text" class="form-control" autofocus="autofocus" value={value}/>                         </div>                     </div> -                    <div class="text-right">+                    <div class="text-end">                         <button type="submit" class="btn btn-primary">Edit Enum Value</button>                     </div>                 </form>
IHP/IDE/SchemaDesigner/View/EnumValues/New.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.EnumValues.New where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.SchemaDesigner.View.Layout @@ -12,7 +12,7 @@  instance View NewEnumValueView where     html NewEnumValueView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just enumName)}             {renderEnumSelector enumName (zip [0..] values)}         </div>@@ -27,7 +27,7 @@                 <form method="POST" action={CreateEnumValueAction}>                     <input type="hidden" name="enumName" value={enumName}/> -                    <div class="form-group row">+                    <div class="mb-3 row">                         <label class="col-sm-2 col-form-label">Name:</label>                         <div class="col-sm-10">                             <input name="enumValueName" type="text" class="form-control" autofocus="autofocus"/>@@ -38,8 +38,8 @@                         </div>                     </div> -                    <div class="text-right">-                        <input type="submit" name="submit" value="Save" class="btn btn-secondary mr-2">+                    <div class="text-end">+                        <input type="submit" name="submit" value="Save" class="btn btn-secondary me-2">                         <input type="submit" name="submit" value="Save & Add Another" class="btn btn-primary">                     </div>                 </form>
IHP/IDE/SchemaDesigner/View/Enums/Edit.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.Enums.Edit where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.SchemaDesigner.View.Layout @@ -13,7 +13,7 @@  instance View EditEnumView where     html EditEnumView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) Nothing}             {emptyColumnSelectorContainer}         </div>@@ -24,14 +24,14 @@             modalContent = [hsx|                 <form method="POST" action={UpdateEnumAction}>                     <input type="hidden" name="enumId" value={tshow enumId}/>-                    <div class="form-group row">+                    <div class="mb-3 row">                         <label class="col-sm-2 col-form-label">Name:</label>                         <div class="col-sm-10">                             <input id="nameInput" name="enumName" type="text" class="form-control" autofocus="autofocus" value={enumName}/>                         </div>                     </div> -                    <div class="text-right">+                    <div class="text-end">                         <button type="submit" class="btn btn-primary">Edit Table</button>                     </div>                 </form>
IHP/IDE/SchemaDesigner/View/Enums/New.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.Enums.New where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.SchemaDesigner.View.Layout @@ -9,7 +9,7 @@  instance View NewEnumView where     html NewEnumView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) Nothing}             {emptyColumnSelectorContainer}         </div>@@ -20,14 +20,14 @@             modalContent = [hsx|                 <form method="POST" action={CreateEnumAction}> -                    <div class="form-group row">+                    <div class="mb-3 row">                         <label class="col-sm-2 col-form-label">Name:</label>                         <div class="col-sm-10">                             <input id="nameInput" name="enumName" type="text" class="form-control" autofocus="autofocus"/>                         </div>                     </div> -                    <div class="text-right">+                    <div class="text-end">                         <button type="submit" class="btn btn-primary">Create Enum</button>                     </div>                 </form>
IHP/IDE/SchemaDesigner/View/Enums/Show.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.Enums.Show where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.SchemaDesigner.View.Layout  data ShowEnumView = ShowEnumView@@ -13,7 +13,7 @@ instance View ShowEnumView where     html ShowEnumView { .. } = [hsx|         {renderFlashMessages}-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just name)}             {renderEnumSelector name (zip [0..] values)}         </div>
IHP/IDE/SchemaDesigner/View/Indexes/Edit.hs view
@@ -1,8 +1,8 @@ module IHP.IDE.SchemaDesigner.View.Indexes.Edit where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types-import qualified IHP.IDE.SchemaDesigner.Compiler as SqlCompiler+import IHP.Postgres.Types+import qualified IHP.Postgres.Compiler as SqlCompiler import IHP.IDE.ToolServer.Types import IHP.IDE.SchemaDesigner.View.Layout @@ -14,7 +14,7 @@  instance View EditIndexView where     html EditIndexView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just tableName)}             {renderColumnSelector tableName  (zip [0..] columns) statements}         </div>@@ -27,10 +27,7 @@                     CreateIndex { indexName = name } | name == indexName -> True                     otherwise -> False -            table :: Maybe Statement-            table = findStatementByName tableName statements--            columns = maybe [] ((.columns) . unsafeGetCreateTable) table+            columns = getTableColumns tableName statements              indexColumns = index.columns                     |> map SqlCompiler.compileIndexColumn@@ -40,21 +37,21 @@                 <form method="POST" action={UpdateIndexAction tableName indexName}>                     <input type="hidden" name="indexName" value={indexName}/> -                    <div class="form-group row">+                    <div class="mb-3 row">                         <label class="col-sm-2 col-form-label">Name:</label>                         <div class="col-sm-10">                             <input name="newIndexName" type="text" class="form-control" value={indexName}/>                         </div>                     </div>                     -                    <div class="form-group row">+                    <div class="mb-3 row">                         <label class="col-sm-2 col-form-label">Column:</label>                         <div class="col-sm-10">                             <input name="indexColumns" type="text" class="form-control" value={indexColumns}/>                         </div>                     </div> -                    <div class="text-right">+                    <div class="text-end">                         <button type="submit" class="btn btn-primary">Update Index</button>                     </div>                 </form>
IHP/IDE/SchemaDesigner/View/Layout.hs view
@@ -1,6 +1,7 @@ module IHP.IDE.SchemaDesigner.View.Layout ( schemaDesignerLayout , findStatementByName+, getTableColumns , visualNav , renderColumnSelector , renderColumn@@ -16,12 +17,13 @@ ) where  import IHP.ViewPrelude hiding (primaryKeyColumnNames)-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.ToolServer.Helper.View import IHP.IDE.ToolServer.Layout hiding (tableIcon)-import IHP.IDE.SchemaDesigner.Compiler (compilePostgresType, compileExpression)+import IHP.Postgres.Compiler (compilePostgresType, compileExpression) import qualified Data.List as List+import IHP.RequestVault.Helper (lookupRequestVault)  schemaDesignerLayout :: Html -> Html schemaDesignerLayout inner = toolServerLayout [hsx|@@ -33,7 +35,7 @@     </div> |]     where-        (DatabaseNeedsMigration hasUnmigratedChanges) = fromFrozenContext @DatabaseNeedsMigration+        (DatabaseNeedsMigration hasUnmigratedChanges) = lookupRequestVault databaseNeedsMigrationVaultKey ?request  unmigratedChanges :: Html unmigratedChanges = [hsx|@@ -53,7 +55,7 @@             then unmigratedChanges             else mempty     where-        (DatabaseNeedsMigration databaseNeedsMigration) = fromFrozenContext @DatabaseNeedsMigration+        (DatabaseNeedsMigration databaseNeedsMigration) = lookupRequestVault databaseNeedsMigrationVaultKey ?request          hasPendingMigrations :: Bool         hasPendingMigrations = False@@ -63,11 +65,11 @@         <div id="migration-status-container">             <div class="alert alert-primary d-flex align-items-center shadow-lg" role="alert">                 {migrationStatusIcon}-                <div class="user-select-none">+                <div class="user-select-none flex-grow-1">                     <div><strong>Unmigrated Changes</strong></div>                     Your app database is not in sync with the Schema                 </div>-                <div class="ml-auto d-flex justify-content-end">+                <div class="ms-auto d-flex justify-content-end">                     <a                         href={NewMigrationAction}                         class="btn px-4 btn-dark"@@ -82,11 +84,11 @@         <div id="migration-status-container">             <div class="alert alert-primary d-flex align-items-center shadow-lg" role="alert">                 {migrationStatusIcon}-                <div class="user-select-none">+                <div class="user-select-none flex-grow-1">                     <div><strong>Pending Changes</strong></div>                     You have migrations that haven't been run yet                 </div>-                <div class="ml-auto d-flex justify-content-end">+                <div class="ms-auto d-flex justify-content-end">                     <a                         href="#"                         class="btn px-4 btn-dark"@@ -98,7 +100,7 @@          migrationStatusIcon :: Html         migrationStatusIcon = preEscapedToHtml [plain|-            <svg width="33px" height="33px" viewBox="0 0 33 33" version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" class="mr-3">+            <svg width="33px" height="33px" viewBox="0 0 33 33" version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" class="me-3">                 <g id="Schema" stroke="none" stroke-width="1" fill="none" fill-rule="evenodd">                     <g id="Message" transform="translate(-383.000000, -813.000000)" fill="#FFCD1B">                         <g id="Group" transform="translate(383.000000, 813.000000)">@@ -114,7 +116,7 @@  databaseControls :: Html databaseControls = [hsx|-<div class="d-flex justify-content-end ml-auto">+<div class="d-flex justify-content-end ms-auto">     <form method="POST" action={pathTo UpdateDbAction} id="update-db-form"/>     <form method="POST" action={pathTo PushToDbAction} id="push-to-db-form"/>     <form method="POST" action={pathTo DumpDbAction} id="db-to-fixtures-form"/>@@ -125,18 +127,18 @@             onclick="checkBeforeUnload()"             >Migrate DB →</a> -        <button type="button" class="btn btn-primary dropdown-toggle dropdown-toggle-split" data-toggle="dropdown" aria-haspopup="true" aria-expanded="false">-            <span class="sr-only">Toggle Dropdown</span>+        <button type="button" class="btn btn-primary dropdown-toggle dropdown-toggle-split" data-bs-toggle="dropdown" aria-haspopup="true" aria-expanded="false">+            <span class="visually-hidden">Toggle Dropdown</span>         </button> -        <div class="dropdown-menu dropdown-menu-right" aria-labelledby="dropdownMenuLink">+        <div class="dropdown-menu dropdown-menu-end" aria-labelledby="dropdownMenuLink">             <button                 type="submit"                 form="update-db-form"                 class="dropdown-item"-                data-toggle="tooltip"-                data-placement="left"-                data-html="true"+                data-bs-toggle="tooltip"+                data-bs-placement="left"+                data-bs-html="true"                 title="Dumps DB to Fixtures.sql.<br><br>Delete the DB.<br><br>Recreate using Schema.sql and Fixtures.sql"                 onclick="checkBeforeUnload()"                 >Update DB</button>@@ -145,9 +147,9 @@                 type="submit"                 class="dropdown-item"                 form="db-to-fixtures-form"-                data-toggle="tooltip"-                data-placement="left"-                data-html="true"+                data-bs-toggle="tooltip"+                data-bs-placement="left"+                data-bs-html="true"                 title="Saves the content of all tables to Application/Fixtures.sql"                 onclick="checkBeforeUnload()"                 >Save DB to Fixtures</button>@@ -155,9 +157,9 @@                 type="submit"                 class="dropdown-item"                 form="push-to-db-form"-                data-toggle="tooltip"-                data-placement="left"-                data-html="true"+                data-bs-toggle="tooltip"+                data-bs-placement="left"+                data-bs-html="true"                 title="Delete the DB and recreate using Application/Schema.sql and Application/Fixture.sql<br><br><strong class=text-danger>Save DB to Fixtures before using this to avoid data loss</strong>"                 onclick="checkBeforeUnload()"                 >Push to DB</button>@@ -174,6 +176,10 @@         pred CreateEnumType { name } | (toUpper name) == (toUpper (tshow statementName)) = True         pred _ = False +getTableColumns :: Text -> [Statement] -> [Column]+getTableColumns tableName statements =+    maybe [] ((.columns) . unsafeGetCreateTable) (findStatementByName tableName statements)+ visualNav :: Html visualNav = [hsx|     <div class="view-selector">@@ -211,8 +217,8 @@                 <a                     href={NewColumnAction tableName}                     class="btn btn-link btn-add"-                    data-toggle="tooltip"-                    data-placement="bottom"+                    data-bs-toggle="tooltip"+                    data-bs-placement="bottom"                     title="Add Column"                 >{addIcon}</a>             </div>@@ -530,9 +536,9 @@         <div class="toolbox">             <a                 href={NewEnumValueAction enumName}-                class="btn btn-link btn-add mr-1"-                data-toggle="tooltip"-                data-placement="bottom"+                class="btn btn-link btn-add me-1"+                data-bs-toggle="tooltip"+                data-bs-placement="bottom"                 title="Add Table"                 >{addIcon}</a>         </div>@@ -566,14 +572,14 @@  renderObjectSelector statements activeObjectName = [hsx|     <div class={classes ["col", "object-selector", ("empty", isEmptySelector)]} oncontextmenu="showContextMenu('context-menu-object-root')">-        <div class="d-flex align-items-center pl-2">+        <div class="d-flex align-items-center ps-2">             <h5>Tables</h5>             <div class="toolbox">                 <a                     href={NewTableAction}-                    class="btn btn-link btn-add mr-1"-                    data-toggle="tooltip"-                    data-placement="bottom"+                    class="btn btn-link btn-add me-1"+                    data-bs-toggle="tooltip"+                    data-bs-placement="bottom"                     title="Add Table"                     >{addIcon}</a>             </div>@@ -603,7 +609,7 @@             otherwise -> False          enums = whenNonEmpty enumStatements [hsx|-            <div class="d-flex pl-2">+            <div class="d-flex ps-2">                 <h5>Enums</h5>             </div>             {forEach enumStatements (\statement -> renderObject (snd statement) (fst statement))}@@ -611,7 +617,7 @@          renderObject :: Statement -> Int -> Html         renderObject (StatementCreateTable CreateTable { name }) id = [hsx|-            <div class={classes [("object object-table w-100 context-table pl-3", True), ("active", Just name == activeObjectName)]} oncontextmenu={"showContextMenu('" <> contextMenuId <> "'); event.stopPropagation();"}>+            <div class={classes [("object object-table w-100 context-table ps-3", True), ("active", Just name == activeObjectName)]} oncontextmenu={"showContextMenu('" <> contextMenuId <> "'); event.stopPropagation();"}>                 <div class="d-flex justify-content-between">                     <a href={ShowTableAction name} class="flex-grow-1">{name}</a> @@ -637,7 +643,7 @@                 generateControllerLink = [hsx|<a href={pathTo NewControllerAction <> "?name=" <> name}>Generate Controller</a>|]                 openControllerLink = [hsx|<a href={pathTo OpenControllerAction <> "?name=" <> name} target="_blank">Open Controller</a>|]                 controllerDoesNotExist = not $ (ucfirst name) `elem` webControllers-                (WebControllers webControllers) = fromFrozenContext @WebControllers+                (WebControllers webControllers) = lookupRequestVault webControllersVaultKey ?request                  rlsEnabled = statements                         |> map snd@@ -649,15 +655,15 @@                 rlsIcon = [hsx|                         <span                             class="rls-enabled"-                            data-toggle="tooltip"-                            data-placement="right"-                            data-html="true"+                            data-bs-toggle="tooltip"+                            data-bs-placement="right"+                            data-bs-html="true"                             title="Row Level Security enabled"                             >{shieldIcon}</span>                         |]          renderObject CreateEnumType { name } id = [hsx|-            <a href={ShowEnumAction name} class={classes [("object object-table w-100 context-enum pl-3", True), ("active", Just name == activeObjectName)]} oncontextmenu={"showContextMenu('" <> contextMenuId <> "'); event.stopPropagation();"}>+            <a href={ShowEnumAction name} class={classes [("object object-table w-100 context-enum ps-3", True), ("active", Just name == activeObjectName)]} oncontextmenu={"showContextMenu('" <> contextMenuId <> "'); event.stopPropagation();"}>                 <div class="d-flex">                     {name}                 </div>@@ -684,6 +690,7 @@         renderObject UnknownStatement {} id = mempty         renderObject EnableRowLevelSecurity {} id = mempty         renderObject CreatePolicy {} id = mempty+        renderObject _ id = mempty          shouldRenderObject (StatementCreateTable CreateTable {}) = True         shouldRenderObject CreateEnumType {} = True
IHP/IDE/SchemaDesigner/View/Migrations/Edit.hs view
@@ -22,15 +22,15 @@ renderForm :: Migration -> Text -> Html renderForm migration sqlStatements = [hsx| <form method="POST" action={UpdateMigrationAction (migration.revision)}>-    <div class="form-group" id="form-group-migration_sqlStatements">+    <div class="mb-3" id="form-group-migration_sqlStatements">         <textarea name="sqlStatements" placeholder="" id="migration_sqlStatements" class="form-control">{sqlStatements}</textarea>     </div>     <div id="migration_sqlStatements_ace"/>      <button         class="btn btn-primary"-        data-toggle="tooltip"-        data-placement="right"+        data-bs-toggle="tooltip"+        data-bs-placement="right"         title="⌘ Enter"         >Save Migration</button> </form>
IHP/IDE/SchemaDesigner/View/Migrations/Index.hs view
@@ -18,12 +18,12 @@     html IndexView { migrationsWithSql = [] } = emptyState     html IndexView { .. } = [hsx|         <div class="pt-3 flex-grow-1" oncontextmenu="showContextMenu('context-menu-migrations')">-            <div class="d-flex align-items-center mb-3 pr-2">+            <div class="d-flex align-items-center mb-3 pe-2">                 <a                     href={NewMigrationAction}-                    class="ml-auto btn btn-link btn-add"-                    data-toggle="tooltip"-                    data-placement="bottom"+                    class="ms-auto btn btn-link btn-add"+                    data-bs-toggle="tooltip"+                    data-bs-placement="bottom"                     title="Add Migration"                     >                     {addIcon}@@ -60,16 +60,16 @@                             <a                                 href={EditMigrationAction (migration.revision)}                                 class="btn btn-link btn-add"-                                data-toggle="tooltip"-                                data-placement="bottom"+                                data-bs-toggle="tooltip"+                                data-bs-placement="bottom"                                 title="Edit Migration"                             >{editIcon}</a>                              <a                                 href={DeleteMigrationAction (migration.revision)}                                 class="btn btn-link btn-add js-delete"-                                data-toggle="tooltip"-                                data-placement="bottom"+                                data-bs-toggle="tooltip"+                                data-bs-placement="bottom"                                 title="Delete Migration"                             >{deleteIcon}</a>                         </div>@@ -77,7 +77,7 @@                       currentErrorHtml = unless (isNothing currentError) [hsx|-                        <div class="text-danger font-weight-bold mr-2">+                        <div class="text-danger fw-bold me-2">                             {currentError}                         </div>                     |]@@ -86,7 +86,7 @@                     runOrStatus =                         if pending                                 then [hsx|-                                <form method="POST" action={RunMigrationAction (migration.revision)} class="mr-2 d-flex align-items-center">+                                <form method="POST" action={RunMigrationAction (migration.revision)} class="me-2 d-flex align-items-center">                                     {currentErrorHtml}                                     <button                                         class="btn btn-secondary migration-run-button"@@ -95,7 +95,7 @@                             |]                             else [hsx|                                 <div class="d-flex justify-content-end mb-2">-                                    <span class="text-muted mr-2 user-select-none" style="opacity: 0.5">{timeAgo revisionTime}</span>+                                    <span class="text-muted me-2 user-select-none" style="opacity: 0.5">{timeAgo revisionTime}</span>                                     <strong class="text-success">                                         {checkmark}                                     </strong>
IHP/IDE/SchemaDesigner/View/Migrations/New.hs view
@@ -27,7 +27,7 @@ renderForm :: Text -> Html renderForm sqlStatements = [hsx| <form method="POST" action={CreateMigrationAction}>-    <div class="form-group" id="form-group-migration_sqlStatements">+    <div class="mb-3" id="form-group-migration_sqlStatements">         <textarea name="sqlStatements" placeholder="" id="migration_sqlStatements" class="form-control">{sqlStatements}</textarea>     </div>     <div id="migration_sqlStatements_ace"/>@@ -37,10 +37,10 @@             <span id="addMigrationVerb">Run</span> Migration         </button> -        <div class="ml-3 d-flex align-items-center">-            <div class="custom-control custom-switch d-flex align-items-center">-                <input type="checkbox" class="custom-control-input" id="createOnlySwitch" name="createOnly" onchange="addMigrationVerb.innerText = this.checked ? 'Add' : 'Run'"/>-                <label class="custom-control-label text-muted" for="createOnlySwitch" style="font-size: 14px">Create only, don't run yet</label>+        <div class="ms-3 d-flex align-items-center">+            <div class="form-check form-switch d-flex align-items-center">+                <input type="checkbox" class="form-check-input" id="createOnlySwitch" name="createOnly" onchange="addMigrationVerb.innerText = this.checked ? 'Add' : 'Run'"/>+                <label class="form-check-label text-muted" for="createOnlySwitch" style="font-size: 14px">Create only, don't run yet</label>             </div>         </div>     </div>
IHP/IDE/SchemaDesigner/View/Policies/Edit.hs view
@@ -1,10 +1,10 @@ module IHP.IDE.SchemaDesigner.View.Policies.Edit where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types-import qualified IHP.IDE.SchemaDesigner.Compiler as Compiler+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.SchemaDesigner.View.Layout+import IHP.IDE.SchemaDesigner.View.Policies.New (policyFormModal)  data EditPolicyView = EditPolicyView     { statements :: [Statement]@@ -15,7 +15,7 @@  instance View EditPolicyView where     html EditPolicyView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just tableName)}             {renderColumnSelector tableName (zip [0..] columns) statements}         </div>@@ -23,71 +23,11 @@         {renderModal modal}     |]         where-            modalContent = [hsx|-                <form method="POST" action={UpdatePolicyAction} class="edit-policy">-                    <input type="hidden" name="tableName" value={tableName}/>-                    <!---                        The hidden name field is required as the user could be changing the name and we don't have any other-                        identifier to refer to the policy besides the name-                    -->-                    <input type="hidden" name="name" value={policy.name}/>--                    <!-- These will be filled via JS from the ace editors -->-                    <input type="hidden" name="using" value={using}/>-                    <input type="hidden" name="check" value={check}/>--                    <div class="form-group">-                        <input-                            id="nameInput"-                            name="policyName"-                            type="text"-                            class="form-control"-                            autofocus="autofocus"-                            value={policy.name}-                            />-                    </div>--                    <div class="form-group">-                        <label for="using">Visible if:</label>-                        <textarea-                            id="using"-                            name="using"-                            type="text"-                            class="form-control sql-expression"-                            data-autocomplete-suggestions={autocompleteSuggestions}-                        >{using}</textarea>-                        <small class="form-text text-muted">This SQL expression needs to return True if the row should be visible to the current user. This is the <code>USING</code> condition of the Postgres Policy</small>-                    </div>--                    <div class="form-group">-                        <label for="using">Additionally, allow INSERT and UPDATE only if:</label>-                        <textarea-                            id="check"-                            name="check"-                            type="text"-                            class="form-control sql-expression"-                            data-autocomplete-suggestions={autocompleteSuggestions}-                        >{check}</textarea>-                        <small class="form-text text-muted">Use this to e.g. disallow users changing the user_id to another user's id. This is the <code>CHECK</code> condition of the Postgres Policy</small>-                    </div>--                    <div class="text-right">-                        <button type="submit" class="btn btn-primary">Update Policy</button>-                    </div>-                </form>+            extraHiddenFields = [hsx|+                <!--+                    The hidden name field is required as the user could be changing the name and we don't have any other+                    identifier to refer to the policy besides the name+                -->+                <input type="hidden" name="name" value={policy.name}/>             |]-            modalFooter = mempty-            modalCloseUrl = pathTo ShowTableAction { tableName }-            modalTitle = "Edit Policy"-            modal = Modal { modalContent, modalFooter, modalCloseUrl, modalTitle }--            using = policy.using-                    |> maybe "" Compiler.compileExpression--            check = policy.check-                    |> maybe "" Compiler.compileExpression--            autocompleteSuggestions =-                    columns-                    |> map (.name)-                    |> intercalate ","+            modal = policyFormModal tableName columns policy (pathTo UpdatePolicyAction) extraHiddenFields "Update Policy" "Edit Policy"
IHP/IDE/SchemaDesigner/View/Policies/New.hs view
@@ -1,8 +1,8 @@-module IHP.IDE.SchemaDesigner.View.Policies.New where+module IHP.IDE.SchemaDesigner.View.Policies.New (NewPolicyView (..), policyFormModal) where  import IHP.ViewPrelude-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 @@ -15,7 +15,7 @@  instance View NewPolicyView where     html NewPolicyView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just tableName)}             {renderColumnSelector tableName (zip [0..] columns) statements}         </div>@@ -23,66 +23,71 @@         {renderModal modal}     |]         where-            modalContent = [hsx|-                <form method="POST" action={CreatePolicyAction} class="edit-policy">-                    <input type="hidden" name="tableName" value={tableName}/>+            modal = policyFormModal tableName columns policy (pathTo CreatePolicyAction) mempty "Create Policy" "New Policy" -                    <!-- These will be filled via JS from the ace editors -->-                    <input type="hidden" name="using" value={using}/>-                    <input type="hidden" name="check" value={check}/>+-- | Shared form modal for creating and editing policies.+policyFormModal :: (?context :: ControllerContext, ?request :: Request) => Text -> [Column] -> Statement -> Text -> Html -> Text -> Text -> Modal+policyFormModal tableName columns policy formAction extraHiddenFields buttonText modalTitle = Modal { modalContent, modalFooter, modalCloseUrl, modalTitle }+    where+        modalContent = [hsx|+            <form method="POST" action={formAction} class="edit-policy">+                <input type="hidden" name="tableName" value={tableName}/>+                {extraHiddenFields} -                    <div class="form-group">-                        <input-                            id="nameInput"-                            name="policyName"-                            type="text"-                            class="form-control"-                            autofocus="autofocus"-                            value={policy.name}-                            />-                    </div>+                <!-- These will be filled via JS from the ace editors -->+                <input type="hidden" name="using" value={using}/>+                <input type="hidden" name="check" value={check}/> -                    <div class="form-group">-                        <label for="using">Visible if:</label>-                        <textarea-                            id="using"-                            name="using"-                            type="text"-                            class="form-control sql-expression"-                            data-autocomplete-suggestions={autocompleteSuggestions}-                        >{using}</textarea>-                        <small class="form-text text-muted">This SQL expression needs to return True if the row should be visible to the current user. This is the <code>USING</code> condition of the Postgres Policy</small>-                    </div>+                <div class="mb-3">+                    <input+                        id="nameInput"+                        name="policyName"+                        type="text"+                        class="form-control"+                        autofocus="autofocus"+                        value={policy.name}+                        />+                </div> -                    <div class="form-group">-                        <label for="using">Additionally, allow INSERT and UPDATE only if:</label>-                        <textarea-                            id="check"-                            name="check"-                            type="text"-                            class="form-control sql-expression"-                            data-autocomplete-suggestions={autocompleteSuggestions}-                        >{check}</textarea>-                        <small class="form-text text-muted">Use this to e.g. disallow users changing the user_id to another user's id. This is the <code>CHECK</code> condition of the Postgres Policy</small>-                    </div>+                <div class="mb-3">+                    <label for="using">Visible if:</label>+                    <textarea+                        id="using"+                        name="using"+                        type="text"+                        class="form-control sql-expression"+                        data-autocomplete-suggestions={autocompleteSuggestions}+                    >{using}</textarea>+                    <small class="form-text">This SQL expression needs to return True if the row should be visible to the current user. This is the <code>USING</code> condition of the Postgres Policy</small>+                </div> -                    <div class="text-right">-                        <button type="submit" class="btn btn-primary">Create Policy</button>-                    </div>-                </form>-            |]-            modalFooter = mempty-            modalCloseUrl = pathTo ShowTableAction { tableName }-            modalTitle = "New Policy"-            modal = Modal { modalContent, modalFooter, modalCloseUrl, modalTitle }+                <div class="mb-3">+                    <label for="using">Additionally, allow INSERT and UPDATE only if:</label>+                    <textarea+                        id="check"+                        name="check"+                        type="text"+                        class="form-control sql-expression"+                        data-autocomplete-suggestions={autocompleteSuggestions}+                    >{check}</textarea>+                    <small class="form-text">Use this to e.g. disallow users changing the user_id to another user's id. This is the <code>CHECK</code> condition of the Postgres Policy</small>+                </div> -            using = policy.using-                    |> maybe "" Compiler.compileExpression+                <div class="text-end">+                    <button type="submit" class="btn btn-primary">{buttonText}</button>+                </div>+            </form>+        |]+        modalFooter = mempty+        modalCloseUrl = pathTo ShowTableAction { tableName } -            check = policy.check-                    |> maybe "" Compiler.compileExpression+        using = policy.using+                |> maybe "" Compiler.compileExpression -            autocompleteSuggestions =-                    columns-                    |> map (.name)-                    |> intercalate ","+        check = policy.check+                |> maybe "" Compiler.compileExpression++        autocompleteSuggestions =+                columns+                |> map (.name)+                |> intercalate ","
IHP/IDE/SchemaDesigner/View/Schema/GeneratedCode.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.Schema.GeneratedCode where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.SchemaDesigner.View.Layout @@ -14,7 +14,7 @@     html GeneratedCodeView { .. } = [hsx|         {visualNav}         <div class="container">-            <div class="row no-gutters bg-white">+            <div class="row g-0 bg-white">                 {renderObjectSelector (zip [0..] statements) Nothing}             </div>         </div>
IHP/IDE/SchemaDesigner/View/Tables/Edit.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.Tables.Edit where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.ToolServer.Routes () import IHP.IDE.SchemaDesigner.View.Layout@@ -14,7 +14,7 @@  instance View EditTableView where     html EditTableView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) Nothing}         </div>         {renderModal modal}@@ -23,14 +23,14 @@             modalContent = [hsx|                 <form method="POST" action={UpdateTableAction}>                     <input type="hidden" name="tableId" value={tshow tableId}/>-                    <div class="form-group row">+                    <div class="mb-3 row">                         <label class="col-sm-2 col-form-label">Name:</label>                         <div class="col-sm-10">                             <input id="nameInput" name="tableName" type="text" class="form-control" autofocus="autofocus" value={tableName}/>                         </div>                     </div> -                    <div class="text-right">+                    <div class="text-end">                         <button type="submit" class="btn btn-primary">Edit Table</button>                     </div>                 </form>
IHP/IDE/SchemaDesigner/View/Tables/Index.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.Tables.Index where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.SchemaDesigner.View.Layout  data IndexView = IndexView@@ -12,7 +12,7 @@     html IndexView { .. } = [hsx|         {renderFlashMessages}         {modal}-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) Nothing}             {emptyColumnSelectorContainer}         </div>
IHP/IDE/SchemaDesigner/View/Tables/New.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.Tables.New where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.ToolServer.Types import IHP.IDE.ToolServer.Routes () import IHP.IDE.SchemaDesigner.View.Layout@@ -10,7 +10,7 @@  instance View NewTableView where     html NewTableView { .. } = [hsx|-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) Nothing}             {emptyColumnSelectorContainer}         </div>@@ -21,7 +21,7 @@             modalContent = [hsx|                 <form method="POST" action={CreateTableAction}> -                    <div class="form-group row">+                    <div class="mb-3 row">                         <label class="col-sm-2 col-form-label">Name:</label>                         <div class="col-sm-10">                             <input id="nameInput" name="tableName" type="text" class="form-control" autofocus="autofocus"/>@@ -31,7 +31,7 @@                         </div>                     </div> -                    <div class="text-right">+                    <div class="text-end">                         <button type="submit" class="btn btn-primary">Create Table</button>                     </div>                 </form>
IHP/IDE/SchemaDesigner/View/Tables/Show.hs view
@@ -1,7 +1,7 @@ module IHP.IDE.SchemaDesigner.View.Tables.Show where  import IHP.ViewPrelude-import IHP.IDE.SchemaDesigner.Types+import IHP.Postgres.Types import IHP.IDE.SchemaDesigner.View.Layout  data ShowView = ShowView@@ -13,7 +13,7 @@ instance View ShowView where     html ShowView { .. } = [hsx|         {renderFlashMessages}-        <div class="row no-gutters bg-white" id="schema-designer-viewer">+        <div class="row g-0 bg-white" id="schema-designer-viewer">             {renderObjectSelector (zip [0..] statements) (Just name)}             {renderColumnSelector name (zip [0..] columns) statements}         </div>
IHP/IDE/StatusServer.hs view
@@ -35,14 +35,14 @@     pure a  runStatusServer ghciIsLoadingVar standardOutput errorOutput clients startMVar stopMVar = do--    let port = ?context.portConfig.appPort |> fromIntegral+    let appSocket = ?context.appSocket+    let warpSettings = Warp.defaultSettings      forever do         _ <- takeMVar startMVar          race_-            (Warp.run port (waiApp ghciIsLoadingVar clients standardOutput errorOutput))+            (Warp.runSettingsSocket warpSettings appSocket (waiApp ghciIsLoadingVar clients standardOutput errorOutput))             (readMVar stopMVar)          isStoppedVar <- takeMVar stopMVar@@ -202,7 +202,7 @@                         <a href={("https://github.com/digitallyinduced/ihp/issues/new?body=" :: Text) <> cs (URI.escapeURIString URI.isUnescapedInURI (cs $ ByteString.unlines errorOutput))} target="_blank">Open a GitHub Issue</a>                     </div> -                    <pre style="font-family: Menlo, monospace; font-size: 10px" id="stdout">{ByteString.unlines (reverse standardOutput)}</pre>+                    <pre style="font-family: Menlo, monospace; font-size: 10px" id="stdout">{ByteString.unlines (reverse (take 5000 standardOutput))}</pre>                 </div>             |]                 where
IHP/IDE/ToolServer.hs view
@@ -1,4 +1,4 @@-module IHP.IDE.ToolServer (runToolServer) where+module IHP.IDE.ToolServer (runToolServer, withToolServerApplication, ToolServerApplicationWithConfig(..)) where  import IHP.Prelude import qualified Network.Wai as Wai@@ -6,13 +6,12 @@ import IHP.IDE.Types import IHP.IDE.PortConfig import qualified IHP.ControllerSupport as ControllerSupport-import IHP.ApplicationContext import IHP.ModelSupport import IHP.RouterSupport hiding (get)-import Network.Wai.Session.ClientSession (clientsessionStore)+import Network.Wai.Session.ClientSession.Deferred (clientsessionStore) import qualified Web.ClientSession as ClientSession import Network.Wai.Middleware.MethodOverridePost (methodOverridePost)-import Network.Wai.Session (withSession)+import Network.Wai.Session.Maybe (withSession) import qualified Network.WebSockets as Websocket import qualified Network.Wai.Handler.WebSockets as Websocket @@ -34,14 +33,12 @@ import qualified System.Process as Process import System.Info import qualified IHP.EnvVar as EnvVar-import qualified IHP.AutoRefresh.Types as AutoRefresh import qualified IHP.AutoRefresh as AutoRefresh-import IHP.Controller.Context import qualified IHP.IDE.ToolServer.Layout as Layout import IHP.Controller.Layout import qualified IHP.IDE.LiveReloadNotificationServer as LiveReloadNotificationServer import qualified IHP.Version as Version-import qualified IHP.PGListener as PGListener+import qualified Control.Exception.Safe as Exception  import qualified Network.Wai.Application.Static as Static import qualified Network.Wai.Middleware.Approot as Approot@@ -49,6 +46,12 @@ import IHP.Controller.NotFound (handleNotFound) import IHP.Controller.Session (sessionVaultKey) import Paths_ihp_ide (getDataFileName)+import IHP.RequestVault+import qualified Data.Vault.Lazy as Vault+import IHP.Controller.Response (responseHeadersVaultKey)+import IHP.ControllerSupport (rlsContextVaultKey)+import Wai.Request.Params.Middleware (requestBodyMiddleware)+import IHP.Modal.Types (modalContainerVaultKey)  runToolServer :: (?context :: Context) => ToolServerApplication -> _ -> IO () runToolServer toolServerApplication liveReloadClients = do@@ -59,7 +62,36 @@  startToolServer' :: (?context :: Context) => ToolServerApplication -> Int -> Bool -> _ -> IO () startToolServer' toolServerApplication port isDebugMode liveReloadClients = do+    withToolServerApplication toolServerApplication port liveReloadClients \weightedApp -> do+        let openAppUrl = openUrl ("http://localhost:" <> tshow port <> "/")+        let warpSettings = Warp.defaultSettings+                |> Warp.setPort port+                |> Warp.setBeforeMainLoop openAppUrl +        let logMiddleware = if isDebugMode then weightedApp.frameworkConfig.requestLoggerMiddleware else IHP.Prelude.id++        Warp.runSettings warpSettings (logMiddleware weightedApp.application)++-- | Result of building the ToolServer application+data ToolServerApplicationWithConfig = ToolServerApplicationWithConfig+    { application :: Wai.Application+    , frameworkConfig :: Config.FrameworkConfig+    }++-- | Builds the full ToolServer WAI application with all middlewares applied+-- and runs the given action with it. The model context is released when the+-- action completes.+--+-- The application includes:+-- - methodOverridePost (for PUT/DELETE via POST)+-- - sessionMiddleware (for session handling)+-- - approotMiddleware (for app root path)+-- - viewLayoutMiddleware (for setLayout/getLayout support)+-- - frameworkConfigMiddleware (for framework config in request vault)+-- - requestBodyMiddleware (for parsing form params - required for controllers)+-- - websocket support (for live reload)+withToolServerApplication :: ToolServerApplication -> Int -> _ -> (ToolServerApplicationWithConfig -> IO result) -> IO result+withToolServerApplication toolServerApplication port liveReloadClients action = do     frameworkConfig <- Config.buildFrameworkConfig do         Config.option $ Config.AppHostname "localhost"         Config.option $ Config.AppPort port@@ -70,35 +102,56 @@             Just baseUrl -> Config.option $ Config.BaseUrl baseUrl             Nothing -> pure () -    store <- fmap clientsessionStore (ClientSession.getKey "Config/client_session_key.aes")-    let sessionMiddleware :: Wai.Middleware = withSession store "SESSION" (frameworkConfig.sessionCookie) sessionVaultKey-    let modelContext = notConnectedModelContext undefined+    withModelContext frameworkConfig.databaseUrl frameworkConfig.logger \modelContext -> do+        store <- fmap clientsessionStore (ClientSession.getKey "Config/client_session_key.aes")+        let sessionMiddleware :: Wai.Middleware = withSession store "SESSION" (frameworkConfig.sessionCookie) sessionVaultKey -    approotMiddleware <- Approot.envFallback-    -    PGListener.withPGListener modelContext \pgListener -> do-        autoRefreshServer <- newIORef (AutoRefresh.newAutoRefreshServer pgListener)+        approotMiddleware <- Approot.envFallbackNamed "IDE_APPROOT"+         staticApp <- initStaticApp -        let applicationContext = ApplicationContext { modelContext, autoRefreshServer, frameworkConfig, pgListener }-        let application :: Wai.Application = \request respond -> do-                let ?applicationContext = applicationContext+        let innerApplication :: Wai.Application = \request respond -> do                 frontControllerToWAIApp @ToolServerApplication @AutoRefresh.AutoRefreshWSApp (\app -> app) toolServerApplication staticApp request respond -        let openAppUrl = openUrl ("http://localhost:" <> tshow port <> "/")-        let warpSettings = Warp.defaultSettings-                |> Warp.setPort port-                |> Warp.setBeforeMainLoop openAppUrl+        let responseHeadersMiddleware = insertNewIORefVaultMiddleware responseHeadersVaultKey []+        let rlsContextMiddleware = insertNewIORefVaultMiddleware rlsContextVaultKey Nothing+        let modalMiddleware = insertNewIORefVaultMiddleware modalContainerVaultKey Nothing -        let logMiddleware = if isDebugMode then frameworkConfig.requestLoggerMiddleware else IHP.Prelude.id+        let toolServerVaultMiddleware app req respond = do+                availableApps <- AvailableApps <$> findApplications+                webControllers <- WebControllers <$> findWebControllers+                let defaultAppUrl = "http://localhost:" <> tshow toolServerApplication.appPort+                appUrl <- AppUrl <$> EnvVar.envOrDefault "IHP_BASEURL" defaultAppUrl+                databaseNeedsMigration <- DatabaseNeedsMigration <$> readIORef toolServerApplication.databaseNeedsMigration+                hooglePort <- EnvVar.envOrNothing "IHP_HOOGLE_PORT"+                let hoogleUrl = HoogleUrl $ case hooglePort of+                        Just port | port /= "" -> Just ("http://localhost:" <> port)+                        _ -> Nothing+                let req' = req { Wai.vault = Vault.insert availableAppsVaultKey availableApps+                                       . Vault.insert webControllersVaultKey webControllers+                                       . Vault.insert appUrlVaultKey appUrl+                                       . Vault.insert databaseNeedsMigrationVaultKey databaseNeedsMigration+                                       . Vault.insert hoogleUrlVaultKey hoogleUrl+                                       $ req.vault }+                app req' respond -        Warp.runSettings warpSettings $-                logMiddleware $ methodOverridePost $ sessionMiddleware $ approotMiddleware+        let application =+                methodOverridePost $ sessionMiddleware $ approotMiddleware+                    $ viewLayoutMiddleware+                    $ responseHeadersMiddleware+                    $ rlsContextMiddleware+                    $ modalMiddleware+                    $ toolServerVaultMiddleware+                    $ modelContextMiddleware modelContext+                    $ frameworkConfigMiddleware frameworkConfig+                    $ requestBodyMiddleware frameworkConfig.parseRequestBodyOptions                     $ Websocket.websocketsOr                         Websocket.defaultConnectionOptions                         (LiveReloadNotificationServer.app liveReloadClients)-                        application+                        innerApplication +        action ToolServerApplicationWithConfig { application, frameworkConfig }+ initStaticApp :: IO Wai.Application initStaticApp = do     toolServerStatic <- getDataFileName "static"@@ -121,6 +174,7 @@     let defaultOSBrowser = case os of             "linux" -> "xdg-open"             "darwin" -> "open"+            _ -> "xdg-open"     let browser = selectedBrowser |> fromMaybe defaultOSBrowser     async $ Process.callCommand (browser <> " " <> cs url)     pure ()@@ -143,23 +197,4 @@  instance ControllerSupport.InitControllerContext ToolServerApplication where     initContext = do-        availableApps <- AvailableApps <$> findApplications-        webControllers <- WebControllers <$> findWebControllers--        appPort <- Helper.theAppPort-        let defaultAppUrl = "http://localhost:" <> tshow appPort-        appUrl :: Text <- EnvVar.envOrDefault "IHP_BASEURL" defaultAppUrl--        putContext availableApps-        putContext webControllers-        putContext (AppUrl appUrl)         setLayout Layout.toolServerLayout--        databaseNeedsMigration <- readDatabaseNeedsMigration-        putContext (DatabaseNeedsMigration databaseNeedsMigration)---readDatabaseNeedsMigration :: (?context :: ControllerContext) => IO Bool-readDatabaseNeedsMigration = do-    context <- fromContext @ToolServerApplication-    readIORef context.databaseNeedsMigration
IHP/IDE/ToolServer/Helper/Controller.hs view
@@ -17,18 +17,16 @@ import IHP.Prelude import IHP.ControllerSupport import IHP.IDE.ToolServer.Types-import qualified IHP.IDE.PortConfig as PortConfig-import IHP.IDE.Types import qualified Network.Socket as Socket import qualified System.Process as Process import System.Info (os) import qualified IHP.EnvVar as EnvVar import IHP.Controller.Context-import System.IO.Unsafe (unsafePerformIO)  import qualified Data.Text as Text-import System.Directory+import qualified System.Directory.OsPath as Directory import qualified Data.Text.IO as IO+import System.OsPath (encodeUtf, decodeUtf)  -- | Returns the port used by the running app. Usually returns @8000@. theAppPort :: (?context :: ControllerContext) => IO Socket.PortNumber@@ -61,27 +59,41 @@         [] -> case os of             "linux" -> (False, "xdg-open")             "darwin" -> (False, "open")+            _ -> (False, "xdg-open")   findWebControllers :: IO [Text] findWebControllers = do-    directoryFiles <-  listDirectory "Web/Controller"-    let controllerFiles :: [Text] =  filter (\x -> not $ "Prelude" `isInfixOf` x || "Context" `isInfixOf` x)  $ map cs directoryFiles-    pure $ map (Text.replace ".hs" "") controllerFiles+    osPath <- encodeUtf "Web/Controller"+    exists <- Directory.doesDirectoryExist osPath+    if exists+        then do+            osEntries <- Directory.listDirectory osPath+            directoryFiles <- mapM decodeUtf osEntries+            let controllerFiles :: [Text] =  filter (\x -> not $ "Prelude" `isInfixOf` x || "Context" `isInfixOf` x)  $ map cs directoryFiles+            pure $ map (Text.replace ".hs" "") controllerFiles+        else pure []  findControllers :: Text -> IO [Text] findControllers application = do-    directoryFiles <-  listDirectory $ cs $ application <> "/Controller"+    osPath <- encodeUtf (cs $ application <> "/Controller")+    osEntries <- Directory.listDirectory osPath+    directoryFiles <- mapM decodeUtf osEntries     let controllerFiles :: [Text] =  filter (\x -> not $ "Prelude" `isInfixOf` x || "Context" `isInfixOf` x)  $ map cs directoryFiles     pure $ map (Text.replace ".hs" "") controllerFiles  findApplications :: IO ([Text]) findApplications = do-    mainhs <- IO.readFile "Main.hs"-    let imports = filter (\line -> "import " `isPrefixOf` line && ".FrontController" `isSuffixOf` line) (lines mainhs)-    pure (map removeImport imports)-        where-            removeImport line = Text.replace ".FrontController" "" (Text.replace "import " "" line)+    osPath <- encodeUtf "Main.hs"+    exists <- Directory.doesFileExist osPath+    if exists+        then do+            mainhs <- IO.readFile "Main.hs"+            let imports = filter (\line -> "import " `isPrefixOf` line && ".FrontController" `isSuffixOf` line) (lines mainhs)+            pure (map removeImport imports)+        else pure []+    where+        removeImport line = Text.replace ".FrontController" "" (Text.replace "import " "" line)  theToolServerApplication :: (?context :: ControllerContext) => IO ToolServerApplication theToolServerApplication = fromContext @ToolServerApplication
IHP/IDE/ToolServer/Helper/View.hs view
@@ -57,6 +57,17 @@ |]  +searchIcon :: Html+searchIcon = preEscapedToHtml [plain|+<svg width="20px" height="20px" viewBox="0 0 20 20" version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+    <g stroke="none" stroke-width="1" fill="none" fill-rule="evenodd">+        <g fill="#E5EAEB">+            <path d="M8,2 C11.3137,2 14,4.68629 14,8 C14,9.29583 13.5892,10.4957 12.8907,11.4765 L17.7071,16.2929 C18.0976,16.6834 18.0976,17.3166 17.7071,17.7071 C17.3166,18.0976 16.6834,18.0976 16.2929,17.7071 L11.4765,12.8907 C10.4957,13.5892 9.29583,14 8,14 C4.68629,14 2,11.3137 2,8 C2,4.68629 4.68629,2 8,2 Z M8,4 C5.79086,4 4,5.79086 4,8 C4,10.2091 5.79086,12 8,12 C10.2091,12 12,10.2091 12,8 C12,5.79086 10.2091,4 8,4 Z"></path>+        </g>+    </g>+</svg>+|]+ startIcon :: Html startIcon = preEscapedToHtml [plain| <svg xmlns="http://www.w3.org/2000/svg" enable-background="new 0 0 24 24" fill="currentColor"><g><rect fill="none" height="24" width="24"/></g><g><path d="M12,2C6.48,2,2,6.48,2,12s4.48,10,10,10s10-4.48,10-10S17.52,2,12,2z M12,20c-4.41,0-8-3.59-8-8s3.59-8,8-8s8,3.59,8,8 S16.41,20,12,20z M9.5,16.5l7-4.5l-7-4.5V16.5z"/></g></svg>
IHP/IDE/ToolServer/Layout.hs view
@@ -5,6 +5,9 @@ import IHP.IDE.ToolServer.Routes () import qualified IHP.Version as Version import IHP.IDE.ToolServer.Helper.View+import System.IO.Unsafe (unsafePerformIO)+import IHP.RequestVault.Helper (lookupRequestVault)+import IHP.IDE.CodeGen.Types (defaultUuidFunction)  toolServerLayout :: Html -> Html toolServerLayout inner = [hsx|@@ -20,9 +23,9 @@         <link rel="stylesheet" href={assetPath "/vendor/select2.min.css"}/>          <script src={assetPath "/vendor/morphdom-umd.min.js"}></script>-        <script src={assetPath "/vendor/jquery-3.6.0.min.js"}></script>+        <script src={assetPath "/vendor/jquery-4.0.0.min.js"}></script>         <script src={assetPath "/vendor/timeago.js"}></script>-        <script src={assetPath "/vendor/popper.min.js"}></script>+        <script src={assetPath "/vendor/popper-2.11.6.min.js"}></script>         <script src={assetPath "/vendor/bootstrap.min.js"}></script>          @@ -49,7 +52,7 @@          <title>IHP IDE</title>     </head>-    <body class="d-flex h-100 flex-row">+    <body class="d-flex h-100 flex-row" data-default-uuid-function={defaultUuidFn <> "()"}>         <div id="nav">             <img id="nav-logo" src="/ihp-icon.svg" alt="IHP: Integrated Haskell Platform">             <div id="ihp-plan">{ihpEditionTitle}</div>@@ -59,6 +62,7 @@             {codegen}             {logs}             {docu}+            {hpiHoogle}              {when isBasicEdition getPro}             {help}@@ -70,7 +74,10 @@     </body> </html> |]  where-        (AvailableApps appNames) = fromFrozenContext @AvailableApps+        defaultUuidFn :: Text+        defaultUuidFn = unsafePerformIO defaultUuidFunction+        {-# NOINLINE defaultUuidFn #-}+        (AvailableApps appNames) = lookupRequestVault availableAppsVaultKey ?request         apps = forEach appNames appNavItem         schema = navItem "SCHEMA" schemaIcon (pathTo TablesAction) (isSchemaEditorController)         data_ = navItem "DATA" dataIcon (pathTo ShowDatabaseAction) (isActiveController @DataController)@@ -79,7 +86,12 @@         logs = navItem "LOGS" serverIcon (pathTo AppLogsAction) (isActiveController @LogsController)         lint = navItem "LINT" flagIcon "#" False         docu = navItem "DOCS" docsIcon "https://ihp.digitallyinduced.com/Guide/" False-        ++        (HoogleUrl hoogleUrl) = lookupRequestVault hoogleUrlVaultKey ?request+        hpiHoogle = case hoogleUrl of+            Just url -> navItem "HOOGLE" searchIcon url False+            Nothing -> mempty+         isSchemaEditorController =                     (  isActiveController @SchemaController                     || isActiveController @TablesController@@ -93,11 +105,12 @@             <a                 href="#"                 class="nav-item"-                data-container="body"-                data-toggle="popover"-                data-placement="right"-                data-title="Questions, or need help with Haskell type errors?"-                data-trigger="focus"+                data-bs-container="body"+                data-bs-toggle="popover"+                data-bs-placement="right"+                data-bs-title="Questions, or need help with Haskell type errors?"+                data-bs-trigger="focus"+                tabindex="0"                 id="nav-help"             >                 {helpIcon}@@ -153,8 +166,8 @@                 target :: Maybe Text                 target = if isExternal then "_blank" else Nothing -appUrl :: (?context :: ControllerContext) => Text-appUrl = let (AppUrl url) = fromFrozenContext @AppUrl in url+appUrl :: (?context :: ControllerContext, ?request :: Request) => Text+appUrl = let (AppUrl url) = lookupRequestVault appUrlVaultKey ?request in url  -- | https://github.com/encharm/Font-Awesome-SVG-PNG/blob/master/white/svg/terminal.svg terminalIcon = preEscapedToHtml [plain|<svg viewBox="0 0 1792 1792" xmlns="http://www.w3.org/2000/svg"><path d="M649 983l-466 466q-10 10-23 10t-23-10l-50-50q-10-10-10-23t10-23l393-393-393-393q-10-10-10-23t10-23l50-50q10-10 23-10t23 10l466 466q10 10 10 23t-10 23zm1079 457v64q0 14-9 23t-23 9h-960q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h960q14 0 23 9t9 23z" fill="#fff"/></svg>|]
IHP/IDE/ToolServer/Types.hs view
@@ -1,15 +1,12 @@ module IHP.IDE.ToolServer.Types where  import IHP.Prelude-import qualified IHP.IDE.Types as DevServer-import Control.Concurrent.MVar-import qualified Data.ByteString.Builder as ByteString import Network.Socket (PortNumber)+import qualified Data.Vault.Lazy as Vault+import System.IO.Unsafe (unsafePerformIO)  data ToolServerApplication = ToolServerApplication-        { postgresStandardOutput :: !(IORef ByteString.Builder)-        , postgresErrorOutput :: !(IORef ByteString.Builder)-        , appStandardOutput :: !(IORef [ByteString])+        { appStandardOutput :: !(IORef [ByteString])         , appErrorOutput :: !(IORef [ByteString])         , appPort :: !PortNumber         , databaseNeedsMigration :: !(IORef Bool)@@ -94,6 +91,7 @@ data LogsController     = AppLogsAction     | PostgresLogsAction+    | ServiceLogsAction { serviceName :: Text }     | OpenEditorAction     deriving (Eq, Show, Data) @@ -162,6 +160,37 @@  newtype DatabaseNeedsMigration = DatabaseNeedsMigration Bool +-- | Wrapper to pass the Hoogle URL to the layout.+-- Contains Nothing when Hoogle is not enabled.+newtype HoogleUrl = HoogleUrl (Maybe Text)++availableAppsVaultKey :: Vault.Key AvailableApps+availableAppsVaultKey = unsafePerformIO Vault.newKey+{-# NOINLINE availableAppsVaultKey #-}++webControllersVaultKey :: Vault.Key WebControllers+webControllersVaultKey = unsafePerformIO Vault.newKey+{-# NOINLINE webControllersVaultKey #-}++appUrlVaultKey :: Vault.Key AppUrl+appUrlVaultKey = unsafePerformIO Vault.newKey+{-# NOINLINE appUrlVaultKey #-}++databaseNeedsMigrationVaultKey :: Vault.Key DatabaseNeedsMigration+databaseNeedsMigrationVaultKey = unsafePerformIO Vault.newKey+{-# NOINLINE databaseNeedsMigrationVaultKey #-}++hoogleUrlVaultKey :: Vault.Key HoogleUrl+hoogleUrlVaultKey = unsafePerformIO Vault.newKey+{-# NOINLINE hoogleUrlVaultKey #-}+ data SqlConsoleResult     = SelectQueryResult ![[DynamicField]]     | InsertOrUpdateResult !Int64++data SqlConsoleError = SqlConsoleError+    { errorMessage :: Text+    , errorDetail :: Text+    , errorHint :: Text+    , errorState :: Text+    }
IHP/IDE/Types.hs view
@@ -1,7 +1,6 @@ module IHP.IDE.Types where  import ClassyPrelude-import System.Process.Internals import qualified System.Process as Process import qualified GHC.IO.Handle as Handle import qualified Network.WebSockets as Websocket@@ -11,14 +10,16 @@ import Data.UUID import qualified IHP.Log.Types as Log import qualified IHP.Log as Log-import qualified Data.ByteString.Builder as ByteString import qualified Control.Concurrent.Chan.Unagi as Queue+import qualified Network.Socket as Socket+import System.OsPath (OsPath, decodeUtf) -procDirenvAware :: (?context :: Context) => FilePath -> [String] -> Process.CreateProcess-procDirenvAware command args =-    if ?context.wrapWithDirenv-        then Process.proc "direnv" (["exec", ".", command] <> args)-        else Process.proc command args+procDirenvAware :: (?context :: Context) => OsPath -> [String] -> IO Process.CreateProcess+procDirenvAware command args = do+    commandStr <- decodeUtf command+    pure if ?context.wrapWithDirenv+        then Process.proc "direnv" (["exec", ".", commandStr] <> args)+        else Process.proc commandStr args  sendGhciCommand :: (?context :: Context) => Handle -> ByteString -> IO () sendGhciCommand inputHandle command = do@@ -41,4 +42,5 @@     , liveReloadClients :: !(IORef (Map UUID Websocket.Connection))     , wrapWithDirenv :: !Bool     , lastSchemaCompilerError :: !(IORef (Maybe SomeException))+    , appSocket :: !Socket.Socket -- ^ Shared socket for seamless app restarts     }
− IHP/SchemaCompiler.hs 
@@ -1,976 +0,0 @@-module IHP.SchemaCompiler-( compile-, compileStatementPreview-) where--import ClassyPrelude-import Data.String.Conversions (cs)-import "interpolate" Data.String.Interpolate (i)-import IHP.NameSupport (tableNameToModelName, columnNameToFieldName, enumValueToControllerName)-import qualified Data.Text as Text-import qualified System.Directory as Directory-import Data.List.Split-import IHP.HaskellSupport-import qualified IHP.IDE.SchemaDesigner.Parser as SchemaDesigner-import IHP.IDE.SchemaDesigner.Types-import qualified IHP.IDE.SchemaDesigner.Compiler as SqlCompiler-import qualified Control.Exception as Exception-import NeatInterpolation-import Text.Countable (pluralize)--data CompileException = CompileException ByteString deriving (Show)-instance Exception CompileException where-    displayException (CompileException message) = cs message--compile :: IO ()-compile = do-    let options = fullCompileOptions-    SchemaDesigner.parseSchemaSql >>= \case-        Left parserError -> Exception.throwIO (CompileException parserError)-        Right statements -> do-            -- let validationErrors = validate database-            -- unless (null validationErrors) (error $ "Schema.hs contains errors: " <> cs (unsafeHead validationErrors))-            Directory.createDirectoryIfMissing True "build/Generated"--            forEach (compileModules options (Schema statements)) \(path, body) -> do-                    writeIfDifferent path body--compileModules :: CompilerOptions -> Schema -> [(FilePath, Text)]-compileModules options schema =-    [ ("build/Generated/Enums.hs", compileEnums options schema)-    , ("build/Generated/ActualTypes.hs", compileTypes options schema)-    ] <> tableModules options schema <>-    [ ("build/Generated/Types.hs", compileIndex schema)-    ]--applyTables :: (CreateTable -> (FilePath, Text)) -> Schema -> [(FilePath, Text)]-applyTables applyFunction schema =-    let ?schema = schema-    in-        schema.statements-        |> mapMaybe (\case-                StatementCreateTable table | tableHasPrimaryKey table -> Just (applyFunction table)-                otherwise -> Nothing-            )--tableModules :: CompilerOptions -> Schema -> [(FilePath, Text)]-tableModules options schema =-    let ?schema = schema-    in-        applyTables (tableModule options) schema-        <> applyTables tableIncludeModule schema--tableModule :: (?schema :: Schema) => CompilerOptions -> CreateTable -> (FilePath, Text)-tableModule options table =-        ("build/Generated/" <> cs (tableNameToModelName table.name) <> ".hs", body)-    where-        body = Text.unlines-            [ prelude-            , tableModuleBody options table-            ]-        moduleName = "Generated." <> tableNameToModelName table.name-        prelude = [trimming|-            -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"-            {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, MultiParamTypeClasses, TypeFamilies, DataKinds, TypeOperators, UndecidableInstances, ConstraintKinds, StandaloneDeriving  #-}-            {-# OPTIONS_GHC -Wno-unused-imports -Wno-dodgy-imports -Wno-unused-matches #-}-            module $moduleName where-            $defaultImports-            import Generated.ActualTypes-        |]--tableIncludeModule :: (?schema :: Schema) => CreateTable -> (FilePath, Text)-tableIncludeModule table =-        ("build/Generated/" <> cs (tableNameToModelName table.name) <> "Include.hs", prelude <> compileInclude table)-    where-        moduleName = "Generated." <> tableNameToModelName table.name <> "Include"-        prelude = [trimming|-            -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"-            module $moduleName where-            import Generated.ActualTypes-            import IHP.ModelSupport (Include, GetModelById)-        |] <> "\n\n"---tableModuleBody :: (?schema :: Schema) => CompilerOptions -> CreateTable -> Text-tableModuleBody options table = Text.unlines-    [ compileInputValueInstance table-    , compileFromRowInstance table-    , compileGetModelName table-    , compileCreate table-    , compileUpdate table-    , compileBuild table-    , compileFilterPrimaryKeyInstance table-    , if needsHasFieldId table-            then compileHasFieldId table-            else ""-    , if options.compileGetAndSetFieldInstances-            then compileSetFieldInstances table <> compileUpdateFieldInstances table-            else ""-    ]--newtype Schema = Schema { statements :: [Statement] }--data CompilerOptions = CompilerOptions {-        -- | We can toggle the generation of @SetField@ and @GetField@ instances.-        -- This is e.g. disabled when showing the code preview in the schema designer-        -- as it's very noisy and does not add any values. But of course it's needed-        -- when do a compilation for the Types.hs-        compileGetAndSetFieldInstances :: Bool-    }--fullCompileOptions :: CompilerOptions-fullCompileOptions = CompilerOptions { compileGetAndSetFieldInstances = True }--previewCompilerOptions :: CompilerOptions-previewCompilerOptions = CompilerOptions { compileGetAndSetFieldInstances = False }--atomicType :: PostgresType -> Text-atomicType = \case-    PSmallInt -> "Int"-    PInt -> "Int"-    PBigInt -> "Integer"-    PJSONB -> "Data.Aeson.Value"-    PText -> "Text"-    PBoolean   -> "Bool"-    PTimestampWithTimezone -> "UTCTime"-    PUUID -> "UUID"-    PSerial -> "Int"-    PBigserial -> "Integer"-    PReal -> "Float"-    PDouble -> "Double"-    PDate -> "Data.Time.Calendar.Day"-    PBinary -> "(Binary ByteString)"-    PTime -> "TimeOfDay"-    (PInterval _) -> "PGInterval"-    PCustomType theType -> tableNameToModelName theType-    PTimestamp -> "LocalTime"-    (PNumeric _ _) -> "Scientific"-    (PVaryingN _) -> "Text"-    (PCharacterN _) -> "Text"-    PArray type_ -> "[" <> atomicType type_ <> "]"-    PPoint -> "Point"-    PPolygon -> "Polygon"-    PInet -> "Net.IP.IP"-    PTSVector -> "TSVector"--haskellType :: (?schema :: Schema) => CreateTable -> Column -> Text-haskellType table@CreateTable { name = tableName, primaryKeyConstraint } column@Column { name, columnType, notNull, generator }-    | [name] == primaryKeyColumnNames primaryKeyConstraint = "(" <> primaryKeyTypeName tableName <> ")"-    | otherwise =-        let-            actualType =-                case findForeignKeyConstraint table column of-                    Just (ForeignKeyConstraint { referenceTable }) -> "(" <> primaryKeyTypeName referenceTable <> ")"-                    _ -> atomicType columnType-        in-            if not notNull || isJust generator-                then "(Maybe " <> actualType <> ")"-                else actualType--- haskellType table (HasMany {name}) = "(QueryBuilder.QueryBuilder " <> tableNameToModelName name <> ")"---writeIfDifferent :: FilePath -> Text -> IO ()-writeIfDifferent path content = do-    alreadyExists <- Directory.doesFileExist path-    existingContent <- if alreadyExists then readFile path else pure ""-    when (existingContent /= cs content) do-        putStrLn $ "Updating " <> cs path-        writeFile (cs path) (cs content)--compileTypes :: CompilerOptions -> Schema -> Text-compileTypes options schema@(Schema statements) = Text.unlines-        [ prelude-        , let ?schema = schema in body-        ]-    where-        body :: (?schema :: Schema) => Text-        body =-            statements-                |> mapMaybe (\case-                    StatementCreateTable table | tableHasPrimaryKey table -> Just (compileActualTypesForTable table)-                    otherwise -> Nothing-                )-                |> Text.intercalate "\n\n"-        prelude = [trimming|-            -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"-            {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, MultiParamTypeClasses, TypeFamilies, DataKinds, TypeOperators, UndecidableInstances, ConstraintKinds, StandaloneDeriving  #-}-            {-# OPTIONS_GHC -Wno-unused-imports -Wno-dodgy-imports -Wno-unused-matches #-}-            module Generated.ActualTypes (module Generated.ActualTypes, module Generated.Enums) where-            $defaultImports-            import Generated.Enums-        |]--compileActualTypesForTable :: (?schema :: Schema) => CreateTable -> Text-compileActualTypesForTable table = Text.unlines-    [ compileData table-    , compilePrimaryKeyInstance table-    , compileTypeAlias table-    , compileHasTableNameInstance table-    , compileDefaultIdInstance table-    , compileTableInstance table-    ]--compileIndex :: Schema -> Text-compileIndex schema = [trimming|-        -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"-        module Generated.Types ($rexports) where-        import Generated.ActualTypes-        $tableModuleImports-    |]-        where-            tableModuleNames =-                schema.statements-                |> map (\case-                        StatementCreateTable table ->-                            let modelName = tableNameToModelName table.name-                            in-                                [ "Generated." <> modelName-                                , "Generated." <> modelName <> "Include"-                                ]-                        otherwise -> []-                    )-                |> concat-            tableModuleImports = tableModuleNames-                    |> map (\name -> "import " <> name)-                    |> Text.unlines--            rexportedModules = ["Generated.ActualTypes"] <> tableModuleNames--            rexports = rexportedModules-                    |> map (\moduleName -> "module " <> moduleName)-                    |> Text.intercalate ", "---defaultImports = [trimming|-    import IHP.HaskellSupport-    import IHP.ModelSupport-    import CorePrelude hiding (id)-    import Data.Time.Clock-    import Data.Time.LocalTime-    import qualified Data.Time.Calendar-    import qualified Data.List as List-    import qualified Data.ByteString as ByteString-    import qualified Net.IP-    import Database.PostgreSQL.Simple-    import Database.PostgreSQL.Simple.FromRow-    import Database.PostgreSQL.Simple.FromField hiding (Field, name)-    import Database.PostgreSQL.Simple.ToField hiding (Field)-    import qualified IHP.Controller.Param-    import GHC.TypeLits-    import Data.UUID (UUID)-    import Data.Default-    import qualified IHP.QueryBuilder as QueryBuilder-    import qualified Data.Proxy-    import GHC.Records-    import Data.Data-    import qualified Data.String.Conversions-    import qualified Data.Text.Encoding-    import qualified Data.Aeson-    import Database.PostgreSQL.Simple.Types (Query (Query), Binary ( .. ))-    import qualified Database.PostgreSQL.Simple.Types-    import IHP.Job.Types-    import IHP.Job.Queue ()-    import qualified Control.DeepSeq as DeepSeq-    import qualified Data.Dynamic-    import Data.Scientific-|]----compileEnums :: CompilerOptions -> Schema -> Text-compileEnums options schema@(Schema statements) = Text.unlines-        [ prelude-        , let ?schema = schema-          in intercalate "\n\n" (mapMaybe compileStatement statements)-        ]-    where-        compileStatement enum@(CreateEnumType {}) = Just (compileEnumDataDefinitions enum)-        compileStatement _ = Nothing-        prelude = [trimming|-            -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n"-            module Generated.Enums where-            import CorePrelude-            import IHP.ModelSupport-            import Database.PostgreSQL.Simple-            import Database.PostgreSQL.Simple.FromField hiding (Field, name)-            import Database.PostgreSQL.Simple.ToField hiding (Field)-            import qualified IHP.Controller.Param-            import Data.Default-            import qualified IHP.QueryBuilder as QueryBuilder-            import qualified Data.String.Conversions-            import qualified Data.Text.Encoding-            import qualified Control.DeepSeq as DeepSeq-        |]--compileStatementPreview :: [Statement] -> Statement -> Text-compileStatementPreview statements statement =-    let ?schema = Schema statements-    in-        case statement of-            CreateEnumType {} -> compileEnumDataDefinitions statement-            StatementCreateTable table -> Text.unlines-                [ compileActualTypesForTable table-                , tableModuleBody previewCompilerOptions table-                ]---- | Skip generation of tables with no primary keys-tableHasPrimaryKey :: CreateTable -> Bool-tableHasPrimaryKey table = table.primaryKeyConstraint /= (PrimaryKeyConstraint [])--compileTypeAlias :: (?schema :: Schema) => CreateTable -> Text-compileTypeAlias table@(CreateTable { name, columns }) =-        "type "-        <> modelName-        <> " = "-        <> modelName-        <> "' "-        <> unwords (map (haskellType table) (variableAttributes table))-        <> hasManyDefaults-        <> "\n"-    where-        modelName = tableNameToModelName name-        hasManyDefaults = columnsReferencingTable name-                |> map (\(tableName, columnName) -> "(QueryBuilder.QueryBuilder \"" <> tableName <> "\")")-                |> unwords--primaryKeyTypeName :: Text -> Text-primaryKeyTypeName name = "Id' " <> tshow name <> ""--compileData :: (?schema :: Schema) => CreateTable -> Text-compileData table@(CreateTable { name, columns }) =-        "data " <> modelName <> "' " <> typeArguments-        <> " = " <> modelName <> " {"-        <>-            table-            |> dataFields-            |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType)-            |> commaSep-        <> "} deriving (Eq, Show)\n"-    where-        modelName = tableNameToModelName name-        typeArguments :: Text-        typeArguments = dataTypeArguments table |> unwords--compileInputValueInstance :: CreateTable -> Text-compileInputValueInstance table =-        "instance InputValue " <> modelName <> " where inputValue = IHP.ModelSupport.recordToInputValue\n"-    where-        modelName = qualifiedConstructorNameFromTableName table.name---- | Returns all the type arguments of the data structure for an entity-dataTypeArguments :: (?schema :: Schema) => CreateTable -> [Text]-dataTypeArguments table = (map columnNameToFieldName belongsToVariables) <> hasManyVariables-    where-        belongsToVariables = variableAttributes table |> map (.name)-        hasManyVariables =-            columnsReferencingTable table.name-            |> compileQueryBuilderFields-            |> map snd---- | Returns the field names and types for the @data MyRecord = MyRecord { .. }@ for a given table-dataFields :: (?schema :: Schema) => CreateTable -> [(Text, Text)]-dataFields table@(CreateTable { name, columns }) = columnFields <> queryBuilderFields <> [("meta", "MetaBag")]-    where-        columnFields = columns |> map columnField--        columnField column =-            let fieldName = columnNameToFieldName column.name-            in-                ( fieldName-                , if isVariableAttribute table column-                        then fieldName-                        else haskellType table column-                )--        queryBuilderFields = columnsReferencingTable name |> compileQueryBuilderFields--compileQueryBuilderFields :: [(Text, Text)] -> [(Text, Text)]-compileQueryBuilderFields columns = map compileQueryBuilderField columns-    where-        compileQueryBuilderField (refTableName, refColumnName) =-            let-                -- Given a relationship like the following:-                ---                -- CREATE TABLE referrals (-                --     user_id UUID NOT NULL,-                --     referred_user_id UUID DEFAULT uuid_generate_v4() NOT NULL-                -- );-                ---                -- We would have two fields on the @User@ record called @referrals@ which are-                -- going to be used with fetchRelated (user >>= fetchRelated #referrals).-                ---                -- Of course having two fields in the same record does not work, so we have to-                -- detect these duplicate query builder fields and use a more qualified name.-                ---                -- In the example this will lead to two fileds called @referralsUsers@ and @referralsReferredUsers@-                -- being added to the data structure.-                hasDuplicateQueryBuilder =-                    columns-                    |> map fst-                    |> map columnNameToFieldName-                    |> filter (columnNameToFieldName refTableName ==)-                    |> length-                    |> (\count -> count > 1)--                stripIdSuffix :: Text -> Text-                stripIdSuffix name = fromMaybe name (Text.stripSuffix "_id" name)--                fieldName = if hasDuplicateQueryBuilder-                    then-                        (refTableName <> "_" <> (refColumnName |> stripIdSuffix))-                        |> columnNameToFieldName-                        |> pluralize-                    else columnNameToFieldName refTableName-            in-                (fieldName, fieldName)----- | Finds all the columns referencing a specific table via a foreign key constraint------ __Example:__------ Given the schema:------ > CREATE TABLE users (id SERIAL, company_id INT);--- > CREATE TABLE companies (id SERIAL);------ you can do the following:------ >>> columnsReferencingTable "companies"--- [ ("users", "company_id") ]-columnsReferencingTable :: (?schema :: Schema) => Text -> [(Text, Text)]-columnsReferencingTable theTableName =-    let-        (Schema statements) = ?schema-    in-        statements-        |> mapMaybe \case-            AddConstraint { tableName, constraint = ForeignKeyConstraint { columnName, referenceTable, referenceColumn } } | referenceTable == theTableName -> Just (tableName, columnName)-            _ -> Nothing--variableAttributes :: (?schema :: Schema) => CreateTable -> [Column]-variableAttributes table@(CreateTable { columns }) = filter (isVariableAttribute table) columns--isVariableAttribute :: (?schema :: Schema) => CreateTable -> Column -> Bool-isVariableAttribute = isRefCol----- | Returns @True@ when the coluns is referencing another column via foreign key constraint-isRefCol :: (?schema :: Schema) => CreateTable -> Column -> Bool-isRefCol table column = isJust (findForeignKeyConstraint table column)---- | Returns the foreign key constraint bound on the given column-findForeignKeyConstraint :: (?schema :: Schema) => CreateTable -> Column -> Maybe Constraint-findForeignKeyConstraint CreateTable { name } column =-        case find isFkConstraint statements of-            Just (AddConstraint { constraint }) -> Just constraint-            Nothing -> Nothing-    where-        isFkConstraint (AddConstraint { tableName, constraint = ForeignKeyConstraint { columnName }}) = tableName == name && columnName == column.name-        isFkConstraint _ = False--        (Schema statements) = ?schema--compileEnumDataDefinitions :: (?schema :: Schema) => Statement -> Text-compileEnumDataDefinitions CreateEnumType { values = [] } = "" -- Ignore enums without any values-compileEnumDataDefinitions enum@(CreateEnumType { name, values }) =-        "data " <> modelName <> " = " <> (intercalate " | " valueConstructors) <> " deriving (Eq, Show, Read, Enum, Bounded, Ord)\n"-        <> "instance FromField " <> modelName <> " where\n"-        <> indent (unlines (map compileFromFieldInstanceForValue values))-        <> "    fromField field (Just value) = returnError ConversionFailed field (\"Unexpected value for enum value. Got: \" <> Data.String.Conversions.cs value)\n"-        <> "    fromField field Nothing = returnError UnexpectedNull field \"Unexpected null for enum value\"\n"-        <> "instance Default " <> modelName <> " where def = " <> enumValueToConstructorName (unsafeHead values) <> "\n"-        <> "instance ToField " <> modelName <> " where\n" <> indent (unlines (map compileToFieldInstanceForValue values))-        <> "instance InputValue " <> modelName <> " where\n" <> indent (unlines (map compileInputValue values))-        <> "instance DeepSeq.NFData " <> modelName <> " where" <> " rnf a = seq a ()" <> "\n"-        <> "instance IHP.Controller.Param.ParamReader " <> modelName <> " where readParameter = IHP.Controller.Param.enumParamReader; readParameterJSON = IHP.Controller.Param.enumParamReaderJSON\n"-    where-        modelName = tableNameToModelName name-        valueConstructors = map enumValueToConstructorName values--        enumValueToConstructorName :: Text -> Text-        enumValueToConstructorName enumValue = if isEnumValueUniqueInSchema enumValue-                then enumValueToControllerName enumValue-                else modelName <> (enumValueToControllerName enumValue)--        compileFromFieldInstanceForValue value = "fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 " <> tshow value <> ") = pure " <> enumValueToConstructorName value-        compileToFieldInstanceForValue value = "toField " <> enumValueToConstructorName value <> " = toField (" <> tshow value <> " :: Text)"-        compileInputValue value = "inputValue " <> enumValueToConstructorName value <> " = " <> tshow value <> " :: Text"--        -- Let's say we have a schema like this:-        ---        -- > CREATE TYPE property_type AS ENUM ('APARTMENT', 'HOUSE');-        -- > CREATE TYPE apartment_type AS ENUM ('LOFT', 'APARTMENT');-        ---        -- A naive enum implementation will generate these data constructors:-        ---        -- > data PropertyType = Apartment | House-        -- > data ApartmentType = Loft | Apartment-        ---        -- Now we have two data constructors with the name 'Apartment'. This fails to compile.-        ---        -- To avoid this we detect if a name is unique across the schema. When it's not unique-        -- we use the following naming schema:-        ---        -- > data PropertyType = PropertyTypeApartment | House-        -- > data ApartmentType = Loft | ApartmentTypeApartment-        ---        -- This function returns True if the given enumValue (like 'APARTMENT') is unique across the schema.-        isEnumValueUniqueInSchema :: Text -> Bool-        isEnumValueUniqueInSchema enumValue =-                ?schema-                |> \case Schema statements -> statements-                |> filter (\case-                        CreateEnumType { name, values } | enumValue `elem` values -> True-                        _                                                         -> False-                    )-                |> length-                |> \count -> count == 1--compileToRowValues :: [Text] -> Text-compileToRowValues bindingValues | length bindingValues == 1 = "Only (" <> (unsafeHead bindingValues) <> ")"-compileToRowValues bindingValues = "(" <> intercalate ") :. (" (map (\list -> if length list == 1 then "Only (" <> (unsafeHead list) <> ")" else intercalate ", " list) (chunksOf 8 bindingValues)) <> ")"---- When we do an INSERT or UPDATE query like @INSERT INTO values (uuids) VALUES (?)@ where the type of @uuids@ is @UUID[]@--- we need to add a typecast to the placeholder @?@, otherwise this will throw an sql error--- See https://github.com/digitallyinduced/ihp/issues/593--- See https://github.com/digitallyinduced/ihp/issues/913-columnPlaceholder :: Column -> Text-columnPlaceholder column@Column { columnType } = if columnPlaceholderNeedsTypecast column-        then "? :: " <> SqlCompiler.compilePostgresType columnType-        else "?"-    where-        columnPlaceholderNeedsTypecast Column { columnType = PArray {} } = True-        columnPlaceholderNeedsTypecast _ = False--qualifiedConstructorNameFromTableName :: Text -> Text-qualifiedConstructorNameFromTableName unqualifiedName = "Generated.ActualTypes." <> (tableNameToModelName unqualifiedName)--compileCreate :: CreateTable -> Text-compileCreate table@(CreateTable { name, columns }) =-    let-        writableColumns = onlyWritableColumns columns-        modelName = qualifiedConstructorNameFromTableName name-        columnNames = commaSep (map (.name) writableColumns)-        values = commaSep (map columnPlaceholder writableColumns)--        toBinding column@(Column { name }) =-                if hasExplicitOrImplicitDefault column && not isArrayColumn-                    then "fieldWithDefault #" <> columnNameToFieldName name <> " model"-                    else "model." <> columnNameToFieldName name-            where-                -- We cannot use DEFAULT with array columns as postgres will throw an error:-                ---                -- > DEFAULT is not allowed in this context-                ---                -- To walk around this error, we explicitly specify an empty array.-                isArrayColumn = case column.columnType of-                    PArray _ -> True-                    _        -> False---        bindings :: [Text]-        bindings = map toBinding writableColumns--        createManyFieldValues :: Text-        createManyFieldValues = if null bindings-                then "()"-                else "(List.concat $ List.map (\\model -> [" <> (intercalate ", " (map (\b -> "toField (" <> b <> ")") bindings)) <> "]) models)"-    in-        "instance CanCreate " <> modelName <> " where\n"-        <> indent (-            "create :: (?modelContext :: ModelContext) => " <> modelName <> " -> IO " <> modelName <> "\n"-                <> "create model = do\n"-                <> indent ("sqlQuerySingleRow \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES (" <> values <> ") RETURNING " <> columnNames <> "\" (" <> compileToRowValues bindings <> ")\n")-                <> "createMany [] = pure []\n"-                <> "createMany models = do\n"-                <> indent ("sqlQuery (Query $ \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES \" <> (ByteString.intercalate \", \" (List.map (\\_ -> \"(" <> values <> ")\") models)) <> \" RETURNING " <> columnNames <> "\") " <> createManyFieldValues <> "\n"-                    )-            )-        <> indent (-            "createRecordDiscardResult :: (?modelContext :: ModelContext) => " <> modelName <> " -> IO ()\n"-                <> "createRecordDiscardResult model = do\n"-                <> indent ("sqlExecDiscardResult \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES (" <> values <> ")\" (" <> compileToRowValues bindings <> ")\n")-            )--commaSep :: [Text] -> Text-commaSep = intercalate ", "--toBinding :: Text -> Column -> Text-toBinding modelName Column { name } = "let " <> modelName <> "{" <> columnNameToFieldName name <> "} = model in " <> columnNameToFieldName name--onlyWritableColumns columns = columns |> filter (\Column { generator } -> isNothing generator)--compileUpdate :: CreateTable -> Text-compileUpdate table@(CreateTable { name, columns }) =-    let-        modelName = qualifiedConstructorNameFromTableName name-        writableColumns = onlyWritableColumns columns--        toUpdateBinding Column { name } = "fieldWithUpdate #" <> columnNameToFieldName name <> " model"-        toPrimaryKeyBinding Column { name } = "model." <> columnNameToFieldName name--        bindings :: Text-        bindings =-            let-                bindingValues = map toUpdateBinding writableColumns <> map toPrimaryKeyBinding (primaryKeyColumns table)-            in-                compileToRowValues bindingValues--        updates = commaSep (map (\column -> column.name <> " = " <> columnPlaceholder column ) writableColumns)--        columnNames = writableColumns-                |> map (.name)-                |> intercalate ", "--        primaryKeyPattern = case primaryKeyColumns table of-                                [] -> error $ "Impossible happened in compileUpdate. No primary keys found for table " <> cs name <> ". At least one primary key is required."-                                [col] -> col.name-                                cols -> "(" <> commaSep (map (\col -> col.name) cols) <> ")"--        primaryKeyParameters = case primaryKeyColumns table of-                                [] -> error $ "Impossible happened in compileUpdate. No primary keys found for table " <> cs name <> ". At least one primary key is required."-                                [col] -> "?"-                                cols -> "(" <> commaSep (map (const "?") (primaryKeyColumns table)) <> ")"-    in-        "instance CanUpdate " <> modelName <> " where\n"-        <> indent ("updateRecord model = do\n"-                <> indent (-                    "sqlQuerySingleRow \"UPDATE " <> name <> " SET " <> updates <> " WHERE " <> primaryKeyPattern <> " = "<> primaryKeyParameters <> " RETURNING " <> columnNames <> "\" (" <> bindings <> ")\n"-                )-            )-        <> indent ("updateRecordDiscardResult model = do\n"-                <> indent (-                    "sqlExecDiscardResult \"UPDATE " <> name <> " SET " <> updates <> " WHERE " <> primaryKeyPattern <> " = "<> primaryKeyParameters <> "\" (" <> bindings <> ")\n"-                )-            )--compileFromRowInstance :: (?schema :: Schema) => CreateTable -> Text-compileFromRowInstance table@(CreateTable { name, columns }) = cs [i|-instance FromRow #{modelName} where-    fromRow = do-#{unsafeInit . indent . indent . unlines $ map columnBinding columnNames}-        let theRecord = #{modelName} #{intercalate " " (map compileField (dataFields table))}-        pure theRecord--|]-    where-        modelName = qualifiedConstructorNameFromTableName name-        columnNames = map (columnNameToFieldName . (.name)) columns-        columnBinding columnName = columnName <> " <- field"--        referencing = columnsReferencingTable table.name--        compileField (fieldName, _)-            | isColumn fieldName = fieldName-            | isOneToManyField fieldName = let (Just ref) = find (\(n, _) -> columnNameToFieldName n == fieldName) referencing in compileSetQueryBuilder ref-            | fieldName == "meta" = "def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }"-            | otherwise = "def"--        isPrimaryKey name = name `elem` primaryKeyColumnNames table.primaryKeyConstraint-        isColumn name = name `elem` columnNames-        isOneToManyField fieldName = fieldName `elem` (referencing |> map (columnNameToFieldName . fst))--        compileSetQueryBuilder (refTableName, refFieldName) = "(QueryBuilder.filterWhere (#" <> columnNameToFieldName refFieldName <> ", " <> primaryKeyField <> ") (QueryBuilder.query @" <> tableNameToModelName refTableName <> "))"-            where-                -- | When the referenced column is nullable, we have to wrap the @Id@ in @Just@-                primaryKeyField :: Text-                primaryKeyField = if refColumn.notNull then actualPrimaryKeyField else "Just " <> actualPrimaryKeyField-                actualPrimaryKeyField :: Text-                actualPrimaryKeyField = case primaryKeyColumns table of-                        [] -> error $ "Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " <> cs name <> ". At least one primary key is required."-                        [pk] -> columnNameToFieldName pk.name-                        pks -> error $ "No support yet for composite foreign keys. Tables cannot have foreign keys to table '" <> cs name <> "' which has more than one column as its primary key."---                (Just refTable) = let (Schema statements) = ?schema in-                        statements-                        |> find \case-                                StatementCreateTable CreateTable { name } -> name == refTableName-                                otherwise -> False--                refColumn :: Column-                refColumn = refTable-                        |> \case StatementCreateTable CreateTable { columns } -> columns-                        |> find (\col -> col.name == refFieldName)-                        |> \case-                            Just refColumn -> refColumn-                            Nothing -> error (cs $ "Could not find " <> refTable.name <> "." <> refFieldName <> " referenced by a foreign key constraint. Make sure that there is no typo in the foreign key constraint")--        compileQuery column@(Column { name }) = columnNameToFieldName name <> " = (" <> toBinding modelName column <> ")"-        -- compileQuery column@(Column { name }) | isReferenceColum column = columnNameToFieldName name <> " = (" <> toBinding modelName column <> ")"-        --compileQuery (HasMany hasManyName inverseOf) = columnNameToFieldName hasManyName <> " = (QueryBuilder.filterWhere (Data.Proxy.Proxy @" <> tshow relatedFieldName <> ", " <> (fromJust $ toBinding' (tableNameToModelName name) relatedIdField)  <> ") (QueryBuilder.query @" <> tableNameToModelName hasManyName <>"))"-        --    where-        --        compileInverseOf Nothing = (columnNameToFieldName (singularize name)) <> "Id"-        --        compileInverseOf (Just name) = columnNameToFieldName (singularize name)-        --        relatedFieldName = compileInverseOf inverseOf-        --        relatedIdField = relatedField "id"-        --        relatedForeignKeyField = relatedField relatedFieldName-        --        relatedField :: Text -> Attribute-        --        relatedField relatedFieldName =-        --            let-        --                isFieldName name (Field fieldName _) = (columnNameToFieldName fieldName) == name-        --                (Table _ attributes) = relatedTable-        --            in case find (isFieldName relatedFieldName) (fieldsOnly attributes) of-        --                Just a -> a-        --                Nothing ->-        --                    let (Table tableName _) = relatedTable-        --                    in error (-        --                            "Could not find field "-        --                            <> show relatedFieldName-        --                            <> " in table"-        --                            <> cs tableName-        --                            <> " "-        --                            <> (show $ fieldsOnly attributes)-        --                            <> ".\n\nThis is caused by `+ hasMany " <> show hasManyName <> "`"-        --                        )-        --        relatedTable = case find (\(Table tableName _) -> tableName == hasManyName) database of-        --            Just t -> t-        --            Nothing -> error ("Could not find table " <> show hasManyName)-        --        toBinding' modelName attributes =-        --            case relatedForeignKeyField of-        --                Field _ fieldType | allowNull fieldType -> Just $ "Just (" <> fromJust (toBinding modelName attributes) <> ")"-        --                otherwise -> toBinding modelName attributes--compileBuild :: (?schema :: Schema) => CreateTable -> Text-compileBuild table@(CreateTable { name, columns }) =-    let-        constructor = qualifiedConstructorNameFromTableName name-    in-        "instance Record " <> constructor <> " where\n"-        <> "    {-# INLINE newRecord #-}\n"-        <> "    newRecord = " <> constructor <> " " <> unwords (map toDefaultValueExpr columns) <> " " <> (columnsReferencingTable name |> map (const "def") |> unwords) <> " def\n"---compileDefaultIdInstance :: CreateTable -> Text-compileDefaultIdInstance table = "instance Default (Id' \"" <> table.name <> "\") where def = Id def"---toDefaultValueExpr :: Column -> Text-toDefaultValueExpr Column { columnType, notNull, defaultValue = Just theDefaultValue } =-            let-                wrapNull False value = "(Just " <> value <> ")"-                wrapNull True value = value--                isNullExpr (VarExpression varName) = toUpper varName == "NULL"-                isNullExpr _ = False--                -- We remove type casts here, as we need the actual value literal for setting our default value-                theNormalizedDefaultValue = theDefaultValue |> SchemaDesigner.removeTypeCasts-            in-                if isNullExpr theDefaultValue-                    then "Nothing"-                    else-                        case columnType of-                            PText -> case theNormalizedDefaultValue of-                                TextExpression value -> wrapNull notNull (tshow value)-                                otherwise            -> error ("toDefaultValueExpr: TEXT column needs to have a TextExpression as default value. Got: " <> show otherwise)-                            PBoolean -> case theNormalizedDefaultValue of-                                VarExpression value -> wrapNull notNull (tshow (toLower value == "true"))-                                otherwise           -> error ("toDefaultValueExpr: BOOL column needs to have a VarExpression as default value. Got: " <> show otherwise)-                            PDouble -> case theNormalizedDefaultValue of-                                DoubleExpression value -> wrapNull notNull (tshow value)-                                IntExpression value -> wrapNull notNull (tshow value)-                                otherwise           -> error ("toDefaultValueExpr: DOUBLE column needs to have a DoubleExpression as default value. Got: " <> show otherwise)-                            _ -> "def"-toDefaultValueExpr _ = "def"--compileHasTableNameInstance :: (?schema :: Schema) => CreateTable -> Text-compileHasTableNameInstance table@(CreateTable { name }) =-    "type instance GetTableName (" <> tableNameToModelName name <> "' " <> unwords (map (const "_") (dataTypeArguments table)) <>  ") = " <> tshow name <> "\n"-    <> "type instance GetModelByTableName " <> tshow name <> " = Generated.ActualTypes." <> tableNameToModelName name <> "\n"--compilePrimaryKeyInstance :: (?schema :: Schema) => CreateTable -> Text-compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = [trimming|type instance PrimaryKey $symbol = $idType|] <> "\n"-    where-        symbol = tshow name-        idType :: Text-        idType = case primaryKeyColumns table of-                [] -> error $ "Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " <> cs name <> ". At least one primary key is required."-                [column] -> atomicType column.columnType -- PrimaryKey User = UUID-                cs -> "(" <> intercalate ", " (map colType cs) <> ")" -- PrimaryKey PostsTag = (Id' "posts", Id' "tags")-            where-                colType column = haskellType table column--compileFilterPrimaryKeyInstance :: (?schema :: Schema) => CreateTable -> Text-compileFilterPrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = cs [i|-instance QueryBuilder.FilterPrimaryKey "#{name}" where-    filterWhereId #{primaryKeyPattern} builder =-        builder |> #{intercalate " |> " primaryKeyFilters}-    {-# INLINE filterWhereId #-}-|]-    where-        primaryKeyPattern = case primaryKeyColumns table of-            [] -> error $ "Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " <> cs name <> ". At least one primary key is required."-            [c] -> columnNameToFieldName c.name-            cs -> "(Id (" <> intercalate ", " (map (columnNameToFieldName . (.name)) cs) <> "))"--        primaryKeyFilters :: [Text]-        primaryKeyFilters = map primaryKeyFilter $ primaryKeyColumns table--        primaryKeyFilter :: Column -> Text-        primaryKeyFilter Column {name} = "QueryBuilder.filterWhere (#" <> columnNameToFieldName name <> ", " <> columnNameToFieldName name <> ")"--compileTableInstance :: (?schema :: Schema) => CreateTable -> Text-compileTableInstance table@(CreateTable { name, columns, constraints }) = cs [i|-instance #{instanceHead} where-    tableName = \"#{name}\"-    tableNameByteString = Data.Text.Encoding.encodeUtf8 \"#{name}\"-    columnNames = #{columnNames}-    primaryKeyColumnNames = #{primaryKeyColumnNames}-    primaryKeyConditionForId (#{pattern}) = #{condition}-    {-# INLINABLE primaryKeyConditionForId #-}-|]-    where-        instanceHead :: Text-        instanceHead = instanceConstraints <> " => IHP.ModelSupport.Table (" <> compileTypePattern table <> ")"-            where-                instanceConstraints =-                    table-                    |> primaryKeyColumns-                    |> map (.name)-                    |> map columnNameToFieldName-                    |> filter (\field -> field `elem` (dataTypeArguments table))-                    |> map (\field -> "ToField " <> field)-                    |> intercalate ", "-                    |> \inner -> "(" <> inner <> ")"--        primaryKeyColumnNames :: [Text]-        primaryKeyColumnNames = primaryKeyColumns table |> map (.name)--        primaryKeyFieldNames :: [Text]-        primaryKeyFieldNames = primaryKeyColumnNames |> map columnNameToFieldName--        pattern :: Text-        pattern = "Id (" <> intercalate ", " primaryKeyFieldNames <> ")"--        condition :: Text-        condition = case primaryKeyColumns table of-                            [] -> error $ "Impossible happened in compileUpdate. No primary keys found for table " <> cs name <> ". At least one primary key is required."-                            [column] -> primaryKeyToCondition column-                            cols -> "Many [Plain \"(\", " <> intercalate ", Plain \",\", " (map primaryKeyToCondition cols)<> ", Plain \")\"]"--        primaryKeyToCondition :: Column -> Text-        primaryKeyToCondition column = "toField " <> columnNameToFieldName column.name--        columnNames = columns-                |> map (.name)-                |> tshow--compileGetModelName :: (?schema :: Schema) => CreateTable -> Text-compileGetModelName table@(CreateTable { name }) = "type instance GetModelName (" <> tableNameToModelName name <> "' " <> unwords (map (const "_") (dataTypeArguments table)) <>  ") = " <> tshow (tableNameToModelName name) <> "\n"--compileDataTypePattern :: (?schema :: Schema) => CreateTable -> Text-compileDataTypePattern table@(CreateTable { name }) = tableNameToModelName name <> " " <> unwords (table |> dataFields |> map fst)--compileTypePattern :: (?schema :: Schema) => CreateTable -> Text-compileTypePattern table@(CreateTable { name }) = tableNameToModelName name <> "' " <> unwords (dataTypeArguments table)--compileInclude :: (?schema :: Schema) => CreateTable -> Text-compileInclude table@(CreateTable { name, columns }) = (belongsToIncludes <> hasManyIncludes) |> unlines-    where-        belongsToIncludes = map compileBelongsTo (filter (isRefCol table) columns)-        hasManyIncludes = columnsReferencingTable name-                |> (\refs -> zip (map fst refs) (map fst (compileQueryBuilderFields refs)))-                |> map compileHasMany-        typeArgs = dataTypeArguments table-        modelName = tableNameToModelName name-        modelConstructor = modelName <> "'"--        includeType :: Text -> Text -> Text-        includeType fieldName includedType = "type instance Include " <> tshow fieldName <> " (" <> leftModelType <> ") = " <> rightModelType-            where-                leftModelType = unwords (modelConstructor:typeArgs)-                rightModelType = unwords (modelConstructor:(map compileTypeVariable' typeArgs))-                compileTypeVariable' name | name == fieldName = includedType-                compileTypeVariable' name = name--        compileBelongsTo :: Column -> Text-        compileBelongsTo column = includeType (columnNameToFieldName column.name) ("(GetModelById " <> columnNameToFieldName column.name <> ")")--        compileHasMany :: (Text, Text) -> Text-        compileHasMany (refTableName, refColumnName) = includeType refColumnName ("[" <> tableNameToModelName refTableName <> "]")---compileSetFieldInstances :: (?schema :: Schema) => CreateTable -> Text-compileSetFieldInstances table@(CreateTable { name, columns }) = unlines (map compileSetField (dataFields table))-    where-        setMetaField = "instance SetField \"meta\" (" <> compileTypePattern table <>  ") MetaBag where\n    {-# INLINE setField #-}\n    setField newValue (" <> compileDataTypePattern table <> ") = " <> tableNameToModelName name <> " " <> (unwords (map (.name) columns)) <> " newValue"-        modelName = tableNameToModelName name-        typeArgs = dataTypeArguments table-        compileSetField (name, fieldType) =-            "instance SetField " <> tshow name <> " (" <> compileTypePattern table <>  ") " <> fieldType <> " where\n" <>-            "    {-# INLINE setField #-}\n" <>-            "    setField newValue (" <> compileDataTypePattern table <> ") =\n" <>-            "        " <> modelName <> " " <> (unwords (map compileAttribute (table |> dataFields |> map fst)))-            where-                compileAttribute name'-                    | name' == name = "newValue"-                    | name' == "meta" = "(meta { touchedFields = \"" <> name <> "\" : touchedFields meta })"-                    | otherwise = name'--compileUpdateFieldInstances :: (?schema :: Schema) => CreateTable -> Text-compileUpdateFieldInstances table@(CreateTable { name, columns }) = unlines (map compileSetField (dataFields table))-    where-        modelName = tableNameToModelName name-        typeArgs = dataTypeArguments table-        compileSetField (name, fieldType) = "instance UpdateField " <> tshow name <> " (" <> compileTypePattern table <>  ") (" <> compileTypePattern' name  <> ") " <> valueTypeA <> " " <> valueTypeB <> " where\n    {-# INLINE updateField #-}\n    updateField newValue (" <> compileDataTypePattern table <> ") = " <> modelName <> " " <> (unwords (map compileAttribute (table |> dataFields |> map fst)))-            where-                (valueTypeA, valueTypeB) =-                    if name `elem` typeArgs-                        then (name, name <> "'")-                        else (fieldType, fieldType)--                compileAttribute name'-                    | name' == name = "newValue"-                    | name' == "meta" = "(meta { touchedFields = \"" <> name <> "\" : touchedFields meta })"-                    | otherwise = name'--                compileTypePattern' ::  Text -> Text-                compileTypePattern' name = tableNameToModelName table.name <> "' " <> unwords (map (\f -> if f == name then name <> "'" else f) (dataTypeArguments table))--compileHasFieldId :: (?schema :: Schema) => CreateTable -> Text-compileHasFieldId table@CreateTable { name, primaryKeyConstraint } = cs [i|-instance HasField "id" #{tableNameToModelName name} (Id' "#{name}") where-    getField (#{compileDataTypePattern table}) = #{compilePrimaryKeyValue}-    {-# INLINE getField #-}-|]-    where-        compilePrimaryKeyValue = case primaryKeyColumnNames primaryKeyConstraint of-            [id] -> columnNameToFieldName id-            ids -> "Id (" <> commaSep (map columnNameToFieldName ids) <> ")"--needsHasFieldId :: CreateTable -> Bool-needsHasFieldId CreateTable { primaryKeyConstraint } =-  case primaryKeyColumnNames primaryKeyConstraint of-    [] -> False-    ["id"] -> False-    _ -> True--primaryKeyColumns :: CreateTable -> [Column]-primaryKeyColumns CreateTable { name, columns, primaryKeyConstraint } =-    map getColumn (primaryKeyColumnNames primaryKeyConstraint)-  where-    getColumn columnName = case find ((==) columnName . (.name)) columns of-      Just c -> c-      Nothing -> error ("Missing column " <> cs columnName <> " used in primary key for " <> cs name)---- | Indents a block of code with 4 spaces.------ Empty lines are not indented.-indent :: Text -> Text-indent code = code-        |> Text.lines-        |> map indentLine-        |> Text.unlines-    where-        indentLine ""   = ""-        indentLine line = "    " <> line---- | Returns 'True' when the column has an explicit default value or when it's a SERIAL or BIGSERIAL-hasExplicitOrImplicitDefault :: Column -> Bool-hasExplicitOrImplicitDefault column = case column of-        Column { defaultValue = Just _ } -> True-        Column { columnType = PSerial } -> True-        Column { columnType = PBigserial } -> True-        _ -> False
IHP/Telemetry.hs view
@@ -12,8 +12,9 @@ import qualified Network.Wreq as Wreq import qualified Control.Exception.Safe as Exception import qualified Crypto.Hash.SHA512 as SHA512-import qualified System.Directory as Directory+import qualified System.Directory.OsPath as Directory import qualified Data.ByteString.Base16 as Base16+import System.OsPath (decodeUtf) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -63,7 +64,8 @@ -- is able to get back the original path from the hash. getProjectId :: IO Text getProjectId = do-    cwd <- Directory.getCurrentDirectory+    cwdOsPath <- Directory.getCurrentDirectory+    cwd <- decodeUtf cwdOsPath     cwd         |> cs         |> SHA512.hash
− IHP/Test/Database.hs 
@@ -1,96 +0,0 @@-module IHP.Test.Database (withIHPApp) where--import IHP.Prelude-import qualified Database.PostgreSQL.Simple as PG-import qualified Database.PostgreSQL.Simple.Types as PG-import qualified Data.UUID.V4 as UUID-import qualified Data.UUID as UUID-import qualified Data.Text as Text-import qualified Control.Exception as Exception-import IHP.IDE.CodeGen.MigrationGenerator (findIHPSchemaSql)---import qualified Data.Vault.Lazy                           as Vault-import           Network.Wai-import           Network.Wai.Internal                      (ResponseReceived (..))---import           IHP.ApplicationContext                    (ApplicationContext (..))-import qualified IHP.AutoRefresh.Types                     as AutoRefresh-import           IHP.Controller.RequestContext             (RequestBody (..), RequestContext (..))-import           IHP.ControllerSupport                     (InitControllerContext, Controller, runActionWithNewContext)-import           IHP.FrameworkConfig                       (ConfigBuilder (..), FrameworkConfig (..))-import qualified IHP.FrameworkConfig                       as FrameworkConfig-import           IHP.ModelSupport                          (createModelContext, Id')-import           IHP.Prelude-import           IHP.Log.Types-import qualified IHP.PGListener as PGListener-import IHP.Controller.Session (sessionVaultKey)--import qualified System.Process as Process-import IHP.Test.Mocking--withConnection databaseUrl = Exception.bracket (PG.connectPostgreSQL databaseUrl) PG.close---- | Create contexts that can be used for mocking-withIHPApp :: (InitControllerContext application) => application -> ConfigBuilder -> (MockContext application -> IO ()) -> IO ()-withIHPApp application configBuilder hspecAction = do-    FrameworkConfig.withFrameworkConfig configBuilder \frameworkConfig -> do-        let FrameworkConfig { dbPoolMaxConnections, dbPoolIdleTime } = frameworkConfig--        logger <- newLogger def { level = Warn } -- don't log queries---        withTestDatabase frameworkConfig.databaseUrl \testDatabaseUrl -> do-            modelContext <- createModelContext dbPoolIdleTime dbPoolMaxConnections testDatabaseUrl logger--            PGListener.withPGListener modelContext \pgListener -> do-                autoRefreshServer <- newIORef (AutoRefresh.newAutoRefreshServer pgListener)-                let sessionVault = Vault.insert sessionVaultKey mempty Vault.empty-                let applicationContext = ApplicationContext { modelContext = modelContext, autoRefreshServer, frameworkConfig, pgListener }--                let requestContext = RequestContext-                     { request = defaultRequest {vault = sessionVault}-                     , requestBody = FormBody [] []-                     , respond = const (pure ResponseReceived)-                     , frameworkConfig = frameworkConfig }--                (hspecAction MockContext { .. })--withTestDatabase masterDatabaseUrl callback = do-    testDatabaseName <- randomDatabaseName--    withConnection masterDatabaseUrl \masterConnection ->-        Exception.bracket_-            (PG.execute masterConnection "CREATE DATABASE ?" [PG.Identifier testDatabaseName])-            (-                -- The WITH FORCE is required to force close open connections-                -- Otherwise the DROP DATABASE takes a few seconds to execute-                PG.execute masterConnection "DROP DATABASE ? WITH (FORCE)" [PG.Identifier testDatabaseName]-            )-            (do-                importSchema (testDatabaseUrl masterDatabaseUrl testDatabaseName)-                callback (testDatabaseUrl masterDatabaseUrl testDatabaseName)-            )--testDatabaseUrl :: ByteString -> Text -> ByteString-testDatabaseUrl masterDatabaseUrl testDatabaseName =-    masterDatabaseUrl-        |> cs-        |> Text.replace "postgresql:///app" ("postgresql:///" <> testDatabaseName)-        |> cs--randomDatabaseName :: IO Text-randomDatabaseName = do-    databaseId <- UUID.nextRandom-    pure ("test-" <> UUID.toText databaseId)--importSchema :: ByteString -> IO ()-importSchema databaseUrl = do-    -- We use the system psql to handle the initial Schema Import as it can handle-    -- complex Schema including variations in formatting, custom types, functions, and table definitions.-    let importSql file = Process.callCommand ("psql " <> (cs databaseUrl) <> " < " <> file)--    ihpSchemaSql <- findIHPSchemaSql-    importSql ihpSchemaSql-    importSql "Application/Schema.sql"
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2020 digitally induced GmbH++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Test/IDE/CodeGeneration/ControllerGenerator.hs view
@@ -0,0 +1,300 @@+{-|+Module: Test.IDE.CodeGeneration.ControllerGenerator+Copyright: (c) digitally induced GmbH, 2020+-}+module Test.IDE.CodeGeneration.ControllerGenerator where++import Test.Hspec+import IHP.Prelude+import qualified IHP.IDE.CodeGen.ControllerGenerator as ControllerGenerator+import IHP.IDE.CodeGen.Types+import IHP.Postgres.Types+++tests = do+    describe "Controller Generator Tests:" do+        let schema = [+                    StatementCreateTable (table "pages") {+                        columns = [+                            (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                        ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    },+                    StatementCreateTable (table "people") {+                        columns = [+                            (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                            , (col "name" PText) { notNull = True }+                            , (col "email" PText) { notNull = True }+                        ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    },+                    StatementCreateTable (table "page_comments") {+                        columns = [+                            (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                        ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    }+                ]++        let makeConfig controllerName modelName applicationName paginationEnabled =+                ControllerGenerator.defaultControllerConfig+                    { ControllerGenerator.controllerName = controllerName+                    , ControllerGenerator.modelName = modelName+                    , ControllerGenerator.applicationName = applicationName+                    , ControllerGenerator.paginationEnabled = paginationEnabled+                    }++        it "should build a controller with name \"pages\"" do+            let rawControllerName = "pages"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let pagination = False+            let builtPlan = ControllerGenerator.buildPlan' schema (makeConfig controllerName modelName applicationName pagination)++            builtPlan `shouldBe`+                [ CreateFile {filePath = "Web/Controller/Pages.hs", fileContent = "module Web.Controller.Pages where\n\nimport Web.Controller.Prelude\nimport Web.View.Pages.Index\nimport Web.View.Pages.New\nimport Web.View.Pages.Edit\nimport Web.View.Pages.Show\n\ninstance Controller PagesController where\n    action PagesAction = do\n        pages <- query @Page |> fetch\n        render IndexView { .. }\n\n    action NewPageAction = do\n        let page = newRecord\n        render NewView { .. }\n\n    action ShowPageAction { pageId } = do\n        page <- fetch pageId\n        render ShowView { .. }\n\n    action EditPageAction { pageId } = do\n        page <- fetch pageId\n        render EditView { .. }\n\n    action UpdatePageAction { pageId } = do\n        page <- fetch pageId\n        page\n            |> buildPage\n            |> ifValid \\case\n                Left page -> render EditView { .. }\n                Right page -> do\n                    page <- page |> updateRecord\n                    setSuccessMessage \"Page updated\"\n                    redirectTo EditPageAction { .. }\n\n    action CreatePageAction = do\n        let page = newRecord @Page\n        page\n            |> buildPage\n            |> ifValid \\case\n                Left page -> render NewView { .. } \n                Right page -> do\n                    page <- page |> createRecord\n                    setSuccessMessage \"Page created\"\n                    redirectTo PagesAction\n\n    action DeletePageAction { pageId } = do\n        page <- fetch pageId\n        deleteRecord page\n        setSuccessMessage \"Page deleted\"\n        redirectTo PagesAction\n\nbuildPage page = page\n    |> fill @'[]\n"}+                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PagesController\n\n"}+                , AppendToFile {filePath = "Web/Types.hs", fileContent = "\ndata PagesController\n    = PagesAction\n    | NewPageAction\n    | ShowPageAction { pageId :: !(Id Page) }\n    | CreatePageAction\n    | EditPageAction { pageId :: !(Id Page) }\n    | UpdatePageAction { pageId :: !(Id Page) }\n    | DeletePageAction { pageId :: !(Id Page) }\n    deriving (Eq, Show, Data)\n"}+                , AppendToMarker {marker = "-- Controller Imports", filePath = "Web/FrontController.hs", fileContent = "import Web.Controller.Pages"}+                , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/FrontController.hs", fileContent = "        , parseRoute @PagesController"}+                , EnsureDirectory {directory = "Web/View/Pages"}+                , CreateFile {filePath = "Web/View/Pages/Index.hs", fileContent = "module Web.View.Pages.Index where\nimport Web.View.Prelude\n\ndata IndexView = IndexView { pages :: [Page] }\n\ninstance View IndexView where\n    html IndexView { .. } = [hsx|\n        {breadcrumb}\n\n        <h1>Index<a href={pathTo NewPageAction} class=\"btn btn-primary ms-4\">+ New</a></h1>\n        <div class=\"table-responsive\">\n            <table class=\"table\">\n                <thead>\n                    <tr>\n                        <th>Page</th>\n                        <th></th>\n                        <th></th>\n                        <th></th>\n                    </tr>\n                </thead>\n                <tbody>{forEach pages renderPage}</tbody>\n            </table>\n            \n        </div>\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"Pages\" PagesAction\n                ]\n\nrenderPage :: Page -> Html\nrenderPage page = [hsx|\n    <tr>\n        <td>{page}</td>\n        <td><a href={ShowPageAction page.id}>Show</a></td>\n        <td><a href={EditPageAction page.id} class=\"text-muted\">Edit</a></td>\n        <td><a href={DeletePageAction page.id} class=\"js-delete text-muted\">Delete</a></td>\n    </tr>\n|]"}+                , AddImport {filePath = "Web/Controller/Pages.hs", fileContent = "import Web.View.Pages.Index"}+                , EnsureDirectory {directory = "Web/View/Pages"}+                , CreateFile {filePath = "Web/View/Pages/New.hs", fileContent = "module Web.View.Pages.New where\nimport Web.View.Prelude\n\ndata NewView = NewView { page :: Page }\n\ninstance View NewView where\n    html NewView { .. } = [hsx|\n        {breadcrumb}\n        <h1>New Page</h1>\n        {renderForm page}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"Pages\" PagesAction\n                , breadcrumbText \"New Page\"\n                ]\n\nrenderForm :: Page -> Html\nrenderForm page = formFor page [hsx|\n    \n    {submitButton}\n\n|]"}+                , AddImport {filePath = "Web/Controller/Pages.hs", fileContent = "import Web.View.Pages.New"}+                , EnsureDirectory {directory = "Web/View/Pages"}+                , CreateFile {filePath = "Web/View/Pages/Show.hs", fileContent = "module Web.View.Pages.Show where\nimport Web.View.Prelude\n\ndata ShowView = ShowView { page :: Page }\n\ninstance View ShowView where\n    html ShowView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Show Page</h1>\n        <p>{page}</p>\n\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                            [ breadcrumbLink \"Pages\" PagesAction\n                            , breadcrumbText \"Show Page\"\n                            ]"}+                , AddImport {filePath = "Web/Controller/Pages.hs", fileContent = "import Web.View.Pages.Show"}+                , EnsureDirectory {directory = "Web/View/Pages"}+                , CreateFile {filePath = "Web/View/Pages/Edit.hs", fileContent = "module Web.View.Pages.Edit where\nimport Web.View.Prelude\n\ndata EditView = EditView { page :: Page }\n\ninstance View EditView where\n    html EditView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Edit Page</h1>\n        {renderForm page}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"Pages\" PagesAction\n                , breadcrumbText \"Edit Page\"\n                ]\n\nrenderForm :: Page -> Html\nrenderForm page = formFor page [hsx|\n    \n    {submitButton}\n\n|]"}+                , AddImport {filePath = "Web/Controller/Pages.hs", fileContent = "import Web.View.Pages.Edit"}+                ]++        it "should build a controller with name \"page\"" do+            let rawControllerName = "page"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let pagination = False+            let builtPlan = ControllerGenerator.buildPlan' schema (makeConfig controllerName modelName applicationName pagination)++            builtPlan `shouldBe`+                [ CreateFile {filePath = "Web/Controller/Page.hs", fileContent = "module Web.Controller.Page where\n\nimport Web.Controller.Prelude\nimport Web.View.Page.Index\nimport Web.View.Page.New\nimport Web.View.Page.Edit\nimport Web.View.Page.Show\n\ninstance Controller PageController where\n    action PagesAction = do\n        page <- query @Page |> fetch\n        render IndexView { .. }\n\n    action NewPageAction = do\n        let page = newRecord\n        render NewView { .. }\n\n    action ShowPageAction { pageId } = do\n        page <- fetch pageId\n        render ShowView { .. }\n\n    action EditPageAction { pageId } = do\n        page <- fetch pageId\n        render EditView { .. }\n\n    action UpdatePageAction { pageId } = do\n        page <- fetch pageId\n        page\n            |> buildPage\n            |> ifValid \\case\n                Left page -> render EditView { .. }\n                Right page -> do\n                    page <- page |> updateRecord\n                    setSuccessMessage \"Page updated\"\n                    redirectTo EditPageAction { .. }\n\n    action CreatePageAction = do\n        let page = newRecord @Page\n        page\n            |> buildPage\n            |> ifValid \\case\n                Left page -> render NewView { .. } \n                Right page -> do\n                    page <- page |> createRecord\n                    setSuccessMessage \"Page created\"\n                    redirectTo PagesAction\n\n    action DeletePageAction { pageId } = do\n        page <- fetch pageId\n        deleteRecord page\n        setSuccessMessage \"Page deleted\"\n        redirectTo PagesAction\n\nbuildPage page = page\n    |> fill @'[]\n"}+                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PageController\n\n"}+                , AppendToFile {filePath = "Web/Types.hs", fileContent = "\ndata PageController\n    = PagesAction\n    | NewPageAction\n    | ShowPageAction { pageId :: !(Id Page) }\n    | CreatePageAction\n    | EditPageAction { pageId :: !(Id Page) }\n    | UpdatePageAction { pageId :: !(Id Page) }\n    | DeletePageAction { pageId :: !(Id Page) }\n    deriving (Eq, Show, Data)\n"}+                , AppendToMarker {marker = "-- Controller Imports", filePath = "Web/FrontController.hs", fileContent = "import Web.Controller.Page"}+                , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/FrontController.hs", fileContent = "        , parseRoute @PageController"}+                , EnsureDirectory {directory = "Web/View/Page"}+                , CreateFile {filePath = "Web/View/Page/Index.hs", fileContent = "module Web.View.Page.Index where\nimport Web.View.Prelude\n\ndata IndexView = IndexView { page :: [Page] }\n\ninstance View IndexView where\n    html IndexView { .. } = [hsx|\n        {breadcrumb}\n\n        <h1>Index<a href={pathTo NewPageAction} class=\"btn btn-primary ms-4\">+ New</a></h1>\n        <div class=\"table-responsive\">\n            <table class=\"table\">\n                <thead>\n                    <tr>\n                        <th>Page</th>\n                        <th></th>\n                        <th></th>\n                        <th></th>\n                    </tr>\n                </thead>\n                <tbody>{forEach page renderPage}</tbody>\n            </table>\n            \n        </div>\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"Pages\" PagesAction\n                ]\n\nrenderPage :: Page -> Html\nrenderPage page = [hsx|\n    <tr>\n        <td>{page}</td>\n        <td><a href={ShowPageAction page.id}>Show</a></td>\n        <td><a href={EditPageAction page.id} class=\"text-muted\">Edit</a></td>\n        <td><a href={DeletePageAction page.id} class=\"js-delete text-muted\">Delete</a></td>\n    </tr>\n|]"}+                , AddImport {filePath = "Web/Controller/Page.hs", fileContent = "import Web.View.Page.Index"}+                , EnsureDirectory {directory = "Web/View/Page"}+                , CreateFile {filePath = "Web/View/Page/New.hs", fileContent = "module Web.View.Page.New where\nimport Web.View.Prelude\n\ndata NewView = NewView { page :: Page }\n\ninstance View NewView where\n    html NewView { .. } = [hsx|\n        {breadcrumb}\n        <h1>New Page</h1>\n        {renderForm page}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"Pages\" PagesAction\n                , breadcrumbText \"New Page\"\n                ]\n\nrenderForm :: Page -> Html\nrenderForm page = formFor page [hsx|\n    \n    {submitButton}\n\n|]"}+                , AddImport {filePath = "Web/Controller/Page.hs", fileContent = "import Web.View.Page.New"}+                , EnsureDirectory {directory = "Web/View/Page"}+                , CreateFile {filePath = "Web/View/Page/Show.hs", fileContent = "module Web.View.Page.Show where\nimport Web.View.Prelude\n\ndata ShowView = ShowView { page :: Page }\n\ninstance View ShowView where\n    html ShowView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Show Page</h1>\n        <p>{page}</p>\n\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                            [ breadcrumbLink \"Pages\" PagesAction\n                            , breadcrumbText \"Show Page\"\n                            ]"}+                , AddImport {filePath = "Web/Controller/Page.hs", fileContent = "import Web.View.Page.Show"}+                , EnsureDirectory {directory = "Web/View/Page"}+                , CreateFile {filePath = "Web/View/Page/Edit.hs", fileContent = "module Web.View.Page.Edit where\nimport Web.View.Prelude\n\ndata EditView = EditView { page :: Page }\n\ninstance View EditView where\n    html EditView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Edit Page</h1>\n        {renderForm page}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"Pages\" PagesAction\n                , breadcrumbText \"Edit Page\"\n                ]\n\nrenderForm :: Page -> Html\nrenderForm page = formFor page [hsx|\n    \n    {submitButton}\n\n|]"}+                , AddImport {filePath = "Web/Controller/Page.hs", fileContent = "import Web.View.Page.Edit"}+                ]++        it "should build a controller with name \"page_comment\"" do+            let rawControllerName = "page_comment"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let pagination = False+            let builtPlan = ControllerGenerator.buildPlan' schema (makeConfig controllerName modelName applicationName pagination)++            builtPlan `shouldBe`+                [ CreateFile {filePath = "Web/Controller/PageComment.hs", fileContent = "module Web.Controller.PageComment where\n\nimport Web.Controller.Prelude\nimport Web.View.PageComment.Index\nimport Web.View.PageComment.New\nimport Web.View.PageComment.Edit\nimport Web.View.PageComment.Show\n\ninstance Controller PageCommentController where\n    action PageCommentsAction = do\n        pageComment <- query @PageComment |> fetch\n        render IndexView { .. }\n\n    action NewPageCommentAction = do\n        let pageComment = newRecord\n        render NewView { .. }\n\n    action ShowPageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        render ShowView { .. }\n\n    action EditPageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        render EditView { .. }\n\n    action UpdatePageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        pageComment\n            |> buildPageComment\n            |> ifValid \\case\n                Left pageComment -> render EditView { .. }\n                Right pageComment -> do\n                    pageComment <- pageComment |> updateRecord\n                    setSuccessMessage \"PageComment updated\"\n                    redirectTo EditPageCommentAction { .. }\n\n    action CreatePageCommentAction = do\n        let pageComment = newRecord @PageComment\n        pageComment\n            |> buildPageComment\n            |> ifValid \\case\n                Left pageComment -> render NewView { .. } \n                Right pageComment -> do\n                    pageComment <- pageComment |> createRecord\n                    setSuccessMessage \"PageComment created\"\n                    redirectTo PageCommentsAction\n\n    action DeletePageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        deleteRecord pageComment\n        setSuccessMessage \"PageComment deleted\"\n        redirectTo PageCommentsAction\n\nbuildPageComment pageComment = pageComment\n    |> fill @'[]\n"}+                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PageCommentController\n\n"}+                , AppendToFile {filePath = "Web/Types.hs", fileContent = "\ndata PageCommentController\n    = PageCommentsAction\n    | NewPageCommentAction\n    | ShowPageCommentAction { pageCommentId :: !(Id PageComment) }\n    | CreatePageCommentAction\n    | EditPageCommentAction { pageCommentId :: !(Id PageComment) }\n    | UpdatePageCommentAction { pageCommentId :: !(Id PageComment) }\n    | DeletePageCommentAction { pageCommentId :: !(Id PageComment) }\n    deriving (Eq, Show, Data)\n"}+                , AppendToMarker {marker = "-- Controller Imports", filePath = "Web/FrontController.hs", fileContent = "import Web.Controller.PageComment"}+                , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/FrontController.hs", fileContent = "        , parseRoute @PageCommentController"}+                , EnsureDirectory {directory = "Web/View/PageComment"}+                , CreateFile {filePath = "Web/View/PageComment/Index.hs", fileContent = "module Web.View.PageComment.Index where\nimport Web.View.Prelude\n\ndata IndexView = IndexView { pageComment :: [PageComment] }\n\ninstance View IndexView where\n    html IndexView { .. } = [hsx|\n        {breadcrumb}\n\n        <h1>Index<a href={pathTo NewPageCommentAction} class=\"btn btn-primary ms-4\">+ New</a></h1>\n        <div class=\"table-responsive\">\n            <table class=\"table\">\n                <thead>\n                    <tr>\n                        <th>PageComment</th>\n                        <th></th>\n                        <th></th>\n                        <th></th>\n                    </tr>\n                </thead>\n                <tbody>{forEach pageComment renderPageComment}</tbody>\n            </table>\n            \n        </div>\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"PageComments\" PageCommentsAction\n                ]\n\nrenderPageComment :: PageComment -> Html\nrenderPageComment pageComment = [hsx|\n    <tr>\n        <td>{pageComment}</td>\n        <td><a href={ShowPageCommentAction pageComment.id}>Show</a></td>\n        <td><a href={EditPageCommentAction pageComment.id} class=\"text-muted\">Edit</a></td>\n        <td><a href={DeletePageCommentAction pageComment.id} class=\"js-delete text-muted\">Delete</a></td>\n    </tr>\n|]"}+                , AddImport {filePath = "Web/Controller/PageComment.hs", fileContent = "import Web.View.PageComment.Index"}+                , EnsureDirectory {directory = "Web/View/PageComment"}+                , CreateFile {filePath = "Web/View/PageComment/New.hs", fileContent = "module Web.View.PageComment.New where\nimport Web.View.Prelude\n\ndata NewView = NewView { pageComment :: PageComment }\n\ninstance View NewView where\n    html NewView { .. } = [hsx|\n        {breadcrumb}\n        <h1>New PageComment</h1>\n        {renderForm pageComment}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"PageComments\" PageCommentsAction\n                , breadcrumbText \"New PageComment\"\n                ]\n\nrenderForm :: PageComment -> Html\nrenderForm pageComment = formFor pageComment [hsx|\n    \n    {submitButton}\n\n|]"}+                , AddImport {filePath = "Web/Controller/PageComment.hs", fileContent = "import Web.View.PageComment.New"}+                , EnsureDirectory {directory = "Web/View/PageComment"}+                , CreateFile {filePath = "Web/View/PageComment/Show.hs", fileContent = "module Web.View.PageComment.Show where\nimport Web.View.Prelude\n\ndata ShowView = ShowView { pageComment :: PageComment }\n\ninstance View ShowView where\n    html ShowView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Show PageComment</h1>\n        <p>{pageComment}</p>\n\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                            [ breadcrumbLink \"PageComments\" PageCommentsAction\n                            , breadcrumbText \"Show PageComment\"\n                            ]"}+                , AddImport {filePath = "Web/Controller/PageComment.hs", fileContent = "import Web.View.PageComment.Show"}+                , EnsureDirectory {directory = "Web/View/PageComment"}+                , CreateFile {filePath = "Web/View/PageComment/Edit.hs", fileContent = "module Web.View.PageComment.Edit where\nimport Web.View.Prelude\n\ndata EditView = EditView { pageComment :: PageComment }\n\ninstance View EditView where\n    html EditView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Edit PageComment</h1>\n        {renderForm pageComment}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"PageComments\" PageCommentsAction\n                , breadcrumbText \"Edit PageComment\"\n                ]\n\nrenderForm :: PageComment -> Html\nrenderForm pageComment = formFor pageComment [hsx|\n    \n    {submitButton}\n\n|]"}+                , AddImport {filePath = "Web/Controller/PageComment.hs", fileContent = "import Web.View.PageComment.Edit"}+                ]++++        it "should build a controller with name \"pageComment\"" do+            let rawControllerName = "pageComment"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let pagination = False+            let builtPlan = ControllerGenerator.buildPlan' schema (makeConfig controllerName modelName applicationName pagination)++            builtPlan `shouldBe`+                [ CreateFile {filePath = "Web/Controller/PageComment.hs", fileContent = "module Web.Controller.PageComment where\n\nimport Web.Controller.Prelude\nimport Web.View.PageComment.Index\nimport Web.View.PageComment.New\nimport Web.View.PageComment.Edit\nimport Web.View.PageComment.Show\n\ninstance Controller PageCommentController where\n    action PageCommentsAction = do\n        pageComment <- query @PageComment |> fetch\n        render IndexView { .. }\n\n    action NewPageCommentAction = do\n        let pageComment = newRecord\n        render NewView { .. }\n\n    action ShowPageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        render ShowView { .. }\n\n    action EditPageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        render EditView { .. }\n\n    action UpdatePageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        pageComment\n            |> buildPageComment\n            |> ifValid \\case\n                Left pageComment -> render EditView { .. }\n                Right pageComment -> do\n                    pageComment <- pageComment |> updateRecord\n                    setSuccessMessage \"PageComment updated\"\n                    redirectTo EditPageCommentAction { .. }\n\n    action CreatePageCommentAction = do\n        let pageComment = newRecord @PageComment\n        pageComment\n            |> buildPageComment\n            |> ifValid \\case\n                Left pageComment -> render NewView { .. } \n                Right pageComment -> do\n                    pageComment <- pageComment |> createRecord\n                    setSuccessMessage \"PageComment created\"\n                    redirectTo PageCommentsAction\n\n    action DeletePageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        deleteRecord pageComment\n        setSuccessMessage \"PageComment deleted\"\n        redirectTo PageCommentsAction\n\nbuildPageComment pageComment = pageComment\n    |> fill @'[]\n"}+                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PageCommentController\n\n"}+                , AppendToFile {filePath = "Web/Types.hs", fileContent = "\ndata PageCommentController\n    = PageCommentsAction\n    | NewPageCommentAction\n    | ShowPageCommentAction { pageCommentId :: !(Id PageComment) }\n    | CreatePageCommentAction\n    | EditPageCommentAction { pageCommentId :: !(Id PageComment) }\n    | UpdatePageCommentAction { pageCommentId :: !(Id PageComment) }\n    | DeletePageCommentAction { pageCommentId :: !(Id PageComment) }\n    deriving (Eq, Show, Data)\n"}+                , AppendToMarker {marker = "-- Controller Imports", filePath = "Web/FrontController.hs", fileContent = "import Web.Controller.PageComment"}+                , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/FrontController.hs", fileContent = "        , parseRoute @PageCommentController"}+                , EnsureDirectory {directory = "Web/View/PageComment"}+                , CreateFile {filePath = "Web/View/PageComment/Index.hs", fileContent = "module Web.View.PageComment.Index where\nimport Web.View.Prelude\n\ndata IndexView = IndexView { pageComment :: [PageComment] }\n\ninstance View IndexView where\n    html IndexView { .. } = [hsx|\n        {breadcrumb}\n\n        <h1>Index<a href={pathTo NewPageCommentAction} class=\"btn btn-primary ms-4\">+ New</a></h1>\n        <div class=\"table-responsive\">\n            <table class=\"table\">\n                <thead>\n                    <tr>\n                        <th>PageComment</th>\n                        <th></th>\n                        <th></th>\n                        <th></th>\n                    </tr>\n                </thead>\n                <tbody>{forEach pageComment renderPageComment}</tbody>\n            </table>\n            \n        </div>\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"PageComments\" PageCommentsAction\n                ]\n\nrenderPageComment :: PageComment -> Html\nrenderPageComment pageComment = [hsx|\n    <tr>\n        <td>{pageComment}</td>\n        <td><a href={ShowPageCommentAction pageComment.id}>Show</a></td>\n        <td><a href={EditPageCommentAction pageComment.id} class=\"text-muted\">Edit</a></td>\n        <td><a href={DeletePageCommentAction pageComment.id} class=\"js-delete text-muted\">Delete</a></td>\n    </tr>\n|]"}+                , AddImport {filePath = "Web/Controller/PageComment.hs", fileContent = "import Web.View.PageComment.Index"}+                , EnsureDirectory {directory = "Web/View/PageComment"}+                , CreateFile {filePath = "Web/View/PageComment/New.hs", fileContent = "module Web.View.PageComment.New where\nimport Web.View.Prelude\n\ndata NewView = NewView { pageComment :: PageComment }\n\ninstance View NewView where\n    html NewView { .. } = [hsx|\n        {breadcrumb}\n        <h1>New PageComment</h1>\n        {renderForm pageComment}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"PageComments\" PageCommentsAction\n                , breadcrumbText \"New PageComment\"\n                ]\n\nrenderForm :: PageComment -> Html\nrenderForm pageComment = formFor pageComment [hsx|\n    \n    {submitButton}\n\n|]"}+                , AddImport {filePath = "Web/Controller/PageComment.hs", fileContent = "import Web.View.PageComment.New"}+                , EnsureDirectory {directory = "Web/View/PageComment"}+                , CreateFile {filePath = "Web/View/PageComment/Show.hs", fileContent = "module Web.View.PageComment.Show where\nimport Web.View.Prelude\n\ndata ShowView = ShowView { pageComment :: PageComment }\n\ninstance View ShowView where\n    html ShowView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Show PageComment</h1>\n        <p>{pageComment}</p>\n\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                            [ breadcrumbLink \"PageComments\" PageCommentsAction\n                            , breadcrumbText \"Show PageComment\"\n                            ]"}+                , AddImport {filePath = "Web/Controller/PageComment.hs", fileContent = "import Web.View.PageComment.Show"}+                , EnsureDirectory {directory = "Web/View/PageComment"}+                , CreateFile {filePath = "Web/View/PageComment/Edit.hs", fileContent = "module Web.View.PageComment.Edit where\nimport Web.View.Prelude\n\ndata EditView = EditView { pageComment :: PageComment }\n\ninstance View EditView where\n    html EditView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Edit PageComment</h1>\n        {renderForm pageComment}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"PageComments\" PageCommentsAction\n                , breadcrumbText \"Edit PageComment\"\n                ]\n\nrenderForm :: PageComment -> Html\nrenderForm pageComment = formFor pageComment [hsx|\n    \n    {submitButton}\n\n|]"}+                , AddImport {filePath = "Web/Controller/PageComment.hs", fileContent = "import Web.View.PageComment.Edit"}+                ]++        it "should build a controller with name \"people\"" do+            let rawControllerName = "people"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let pagination = False+            let builtPlan = ControllerGenerator.buildPlan' schema (makeConfig controllerName modelName applicationName pagination)++            builtPlan `shouldBe`+                [ CreateFile {filePath = "Web/Controller/People.hs", fileContent = "module Web.Controller.People where\n\nimport Web.Controller.Prelude\nimport Web.View.People.Index\nimport Web.View.People.New\nimport Web.View.People.Edit\nimport Web.View.People.Show\n\ninstance Controller PeopleController where\n    action PeopleAction = do\n        people <- query @Person |> fetch\n        render IndexView { .. }\n\n    action NewPersonAction = do\n        let person = newRecord\n        render NewView { .. }\n\n    action ShowPersonAction { personId } = do\n        person <- fetch personId\n        render ShowView { .. }\n\n    action EditPersonAction { personId } = do\n        person <- fetch personId\n        render EditView { .. }\n\n    action UpdatePersonAction { personId } = do\n        person <- fetch personId\n        person\n            |> buildPerson\n            |> ifValid \\case\n                Left person -> render EditView { .. }\n                Right person -> do\n                    person <- person |> updateRecord\n                    setSuccessMessage \"Person updated\"\n                    redirectTo EditPersonAction { .. }\n\n    action CreatePersonAction = do\n        let person = newRecord @Person\n        person\n            |> buildPerson\n            |> ifValid \\case\n                Left person -> render NewView { .. } \n                Right person -> do\n                    person <- person |> createRecord\n                    setSuccessMessage \"Person created\"\n                    redirectTo PeopleAction\n\n    action DeletePersonAction { personId } = do\n        person <- fetch personId\n        deleteRecord person\n        setSuccessMessage \"Person deleted\"\n        redirectTo PeopleAction\n\nbuildPerson person = person\n    |> fill @'[\"name\", \"email\"]\n    |> validateField #name nonEmpty\n    |> validateField #email nonEmpty\n    |> validateField #email isEmail\n"}+                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PeopleController\n\n"}+                , AppendToFile {filePath = "Web/Types.hs", fileContent = "\ndata PeopleController\n    = PeopleAction\n    | NewPersonAction\n    | ShowPersonAction { personId :: !(Id Person) }\n    | CreatePersonAction\n    | EditPersonAction { personId :: !(Id Person) }\n    | UpdatePersonAction { personId :: !(Id Person) }\n    | DeletePersonAction { personId :: !(Id Person) }\n    deriving (Eq, Show, Data)\n"}+                , AppendToMarker {marker = "-- Controller Imports", filePath = "Web/FrontController.hs", fileContent = "import Web.Controller.People"}+                , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/FrontController.hs", fileContent = "        , parseRoute @PeopleController"}+                , EnsureDirectory {directory = "Web/View/People"}+                , CreateFile {filePath = "Web/View/People/Index.hs", fileContent = "module Web.View.People.Index where\nimport Web.View.Prelude\n\ndata IndexView = IndexView { people :: [Person] }\n\ninstance View IndexView where\n    html IndexView { .. } = [hsx|\n        {breadcrumb}\n\n        <h1>Index<a href={pathTo NewPersonAction} class=\"btn btn-primary ms-4\">+ New</a></h1>\n        <div class=\"table-responsive\">\n            <table class=\"table\">\n                <thead>\n                    <tr>\n                        <th>Name</th>\n                        <th>Email</th>\n                        <th></th>\n                        <th></th>\n                        <th></th>\n                    </tr>\n                </thead>\n                <tbody>{forEach people renderPerson}</tbody>\n            </table>\n            \n        </div>\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"People\" PeopleAction\n                ]\n\nrenderPerson :: Person -> Html\nrenderPerson person = [hsx|\n    <tr>\n        <td>{person.name}</td>\n        <td>{person.email}</td>\n        <td><a href={ShowPersonAction person.id}>Show</a></td>\n        <td><a href={EditPersonAction person.id} class=\"text-muted\">Edit</a></td>\n        <td><a href={DeletePersonAction person.id} class=\"js-delete text-muted\">Delete</a></td>\n    </tr>\n|]"}+                , AddImport {filePath = "Web/Controller/People.hs", fileContent = "import Web.View.People.Index"}+                , EnsureDirectory {directory = "Web/View/People"}+                , CreateFile {filePath = "Web/View/People/New.hs", fileContent = "module Web.View.People.New where\nimport Web.View.Prelude\n\ndata NewView = NewView { person :: Person }\n\ninstance View NewView where\n    html NewView { .. } = [hsx|\n        {breadcrumb}\n        <h1>New Person</h1>\n        {renderForm person}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"People\" PeopleAction\n                , breadcrumbText \"New Person\"\n                ]\n\nrenderForm :: Person -> Html\nrenderForm person = formFor person [hsx|\n    {(textField #name)}\n    {(textField #email)}\n    {submitButton}\n\n|]"}+                , AddImport {filePath = "Web/Controller/People.hs", fileContent = "import Web.View.People.New"}+                , EnsureDirectory {directory = "Web/View/People"}+                , CreateFile {filePath = "Web/View/People/Show.hs", fileContent = "module Web.View.People.Show where\nimport Web.View.Prelude\n\ndata ShowView = ShowView { person :: Person }\n\ninstance View ShowView where\n    html ShowView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Show Person</h1>\n        <dl>\n            <dt>Name</dt><dd>{person.name}</dd>\n            <dt>Email</dt><dd>{person.email}</dd>\n        </dl>\n\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                            [ breadcrumbLink \"People\" PeopleAction\n                            , breadcrumbText \"Show Person\"\n                            ]"}+                , AddImport {filePath = "Web/Controller/People.hs", fileContent = "import Web.View.People.Show"}+                , EnsureDirectory {directory = "Web/View/People"}+                , CreateFile {filePath = "Web/View/People/Edit.hs", fileContent = "module Web.View.People.Edit where\nimport Web.View.Prelude\n\ndata EditView = EditView { person :: Person }\n\ninstance View EditView where\n    html EditView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Edit Person</h1>\n        {renderForm person}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"People\" PeopleAction\n                , breadcrumbText \"Edit Person\"\n                ]\n\nrenderForm :: Person -> Html\nrenderForm person = formFor person [hsx|\n    {(textField #name)}\n    {(textField #email)}\n    {submitButton}\n\n|]"}+                , AddImport {filePath = "Web/Controller/People.hs", fileContent = "import Web.View.People.Edit"}+                ]++        it "should generate type-aware validation for a rich schema" do+            let richSchema = [+                        StatementCreateTable (table "projects") {+                            columns = [+                                (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                                , (col "title" PText) { notNull = True }+                                , (col "is_active" PBoolean) { notNull = True }+                                , (col "budget" PInt) { notNull = False }+                                , (col "started_on" PDate) { notNull = False }+                                , (col "contact_email" PText) { notNull = True }+                                , (col "user_id" PUUID) { notNull = True }+                            ]+                            , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                            , constraints = [+                                ForeignKeyConstraint { name = Nothing, columnName = "user_id", referenceTable = "users", referenceColumn = Nothing, onDelete = Nothing }+                              ]+                        }+                        , AddConstraint { tableName = "projects", constraint = UniqueConstraint { name = Nothing, columnNames = ["contact_email"] }, deferrable = Nothing, deferrableType = Nothing }+                    ]+            let rawControllerName = "projects"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let pagination = False+            let builtPlan = ControllerGenerator.buildPlan' richSchema (makeConfig controllerName modelName applicationName pagination)+            let (CreateFile { fileContent = controllerContent }):_ = builtPlan+            -- buildProject should have fill + validations+            (cs controllerContent :: String) `shouldContain` "|> fill @'[\"title\", \"isActive\", \"budget\", \"startedOn\", \"contactEmail\", \"userId\"]"+            (cs controllerContent :: String) `shouldContain` "|> validateField #title nonEmpty"+            (cs controllerContent :: String) `shouldContain` "|> validateField #contactEmail nonEmpty"+            (cs controllerContent :: String) `shouldContain` "|> validateField #contactEmail isEmail"+            (cs controllerContent :: String) `shouldContain` "-- TODO: |> validateIsUnique #contactEmail"+            -- budget is nullable int, should not get nonEmpty+            (cs controllerContent :: String) `shouldNotContain` "validateField #budget nonEmpty"+            -- is_active is boolean, should not get nonEmpty+            (cs controllerContent :: String) `shouldNotContain` "validateField #isActive nonEmpty"++        it "should build a controller with only Index and Show actions" do+            let rawControllerName = "pages"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let config = (makeConfig controllerName modelName applicationName False)+                    { ControllerGenerator.indexActionEnabled = True+                    , ControllerGenerator.newActionEnabled = False+                    , ControllerGenerator.showActionEnabled = True+                    , ControllerGenerator.createActionEnabled = False+                    , ControllerGenerator.editActionEnabled = False+                    , ControllerGenerator.updateActionEnabled = False+                    , ControllerGenerator.deleteActionEnabled = False+                    }+            let builtPlan = ControllerGenerator.buildPlan' schema config++            -- Types.hs should only have Index and Show constructors+            let [AppendToFile { fileContent = typesFileContent }] = builtPlan+                    |> filter (\case AppendToFile { filePath } -> osPathToText filePath == "Web/Types.hs"; _ -> False)+            let typesContent = cs typesFileContent :: String+            typesContent `shouldContain` "PagesAction"+            typesContent `shouldContain` "ShowPageAction"+            typesContent `shouldNotContain` "NewPageAction"+            typesContent `shouldNotContain` "CreatePageAction"+            typesContent `shouldNotContain` "EditPageAction"+            typesContent `shouldNotContain` "UpdatePageAction"+            typesContent `shouldNotContain` "DeletePageAction"++            -- Controller file should only have Index and Show action bodies+            let (CreateFile { fileContent = controllerContent }):_ = builtPlan+            (cs controllerContent :: String) `shouldContain` "action PagesAction"+            (cs controllerContent :: String) `shouldContain` "action ShowPageAction"+            (cs controllerContent :: String) `shouldNotContain` "action NewPageAction"+            (cs controllerContent :: String) `shouldNotContain` "action CreatePageAction"+            (cs controllerContent :: String) `shouldNotContain` "action EditPageAction"+            (cs controllerContent :: String) `shouldNotContain` "action UpdatePageAction"+            (cs controllerContent :: String) `shouldNotContain` "action DeletePageAction"+            -- No buildPage helper since Create/Update are disabled+            (cs controllerContent :: String) `shouldNotContain` "buildPage"+            -- Only Index and Show view imports+            (cs controllerContent :: String) `shouldContain` "import Web.View.Pages.Index"+            (cs controllerContent :: String) `shouldContain` "import Web.View.Pages.Show"+            (cs controllerContent :: String) `shouldNotContain` "import Web.View.Pages.New"+            (cs controllerContent :: String) `shouldNotContain` "import Web.View.Pages.Edit"++            -- Only Index and Show view files should be generated+            let viewFiles = builtPlan+                    |> filter (\case CreateFile { filePath } -> "View" `isInfixOf` osPathToText filePath; _ -> False)+                    |> map (\(CreateFile { filePath }) -> osPathToText filePath)+            viewFiles `shouldBe` ["Web/View/Pages/Index.hs", "Web/View/Pages/Show.hs"]++        it "should not generate Id fields when table doesn't exist in schema" do+            let emptySchema = []+            let rawControllerName = "bars"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let pagination = False+            let builtPlan = ControllerGenerator.buildPlan' emptySchema (makeConfig controllerName modelName applicationName pagination)++            -- Types.hs should not contain barId or Id Bar+            let [AppendToFile { fileContent = typesFileContent }] = builtPlan+                    |> filter (\case AppendToFile { filePath } -> osPathToText filePath == "Web/Types.hs"; _ -> False)+            let typesContent = cs typesFileContent :: String+            typesContent `shouldNotContain` "barId"+            typesContent `shouldNotContain` "Id Bar"+            typesContent `shouldContain` "ShowBarAction\n"+            typesContent `shouldContain` "EditBarAction\n"+            typesContent `shouldContain` "UpdateBarAction\n"+            typesContent `shouldContain` "DeleteBarAction\n"++            -- Controller file should not contain { barId } destructuring or fetch barId+            let (CreateFile { fileContent = controllerContent }):_ = builtPlan+            (cs controllerContent :: String) `shouldNotContain` "barId"+            (cs controllerContent :: String) `shouldNotContain` "fetch barId"
+ Test/IDE/CodeGeneration/JobGenerator.hs view
@@ -0,0 +1,97 @@+{-|+Module: Test.IDE.CodeGeneration.JobGenerator+Copyright: (c) digitally induced GmbH, 2020+-}+module Test.IDE.CodeGeneration.JobGenerator where++import Test.Hspec+import IHP.Prelude+import qualified IHP.IDE.CodeGen.JobGenerator as JobGenerator+import IHP.IDE.CodeGen.Types++tests = do+    describe "Job Generator" do+        it "should build a job with name \"CreateContainerJobs\"" do+            let applicationName = "Web"+            let tableName = "create_container_jobs"+            let modelName = "CreateContainerJob"+            let isFirstJobInApplication = False+            let uuidFunction = "uuid_generate_v4"+            let config = JobGenerator.JobConfig { .. }+            let builtPlan = JobGenerator.buildPlan' config++            builtPlan `shouldBe` [+                  EnsureDirectory {directory = "Web/Job"}+                , AppendToFile {filePath = "Application/Schema.sql", fileContent = "CREATE TABLE create_container_jobs (\n    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,\n    created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n    updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n    status JOB_STATUS DEFAULT 'job_status_not_started' NOT NULL,\n    last_error TEXT DEFAULT NULL,\n    attempts_count INT DEFAULT 0 NOT NULL,\n    locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,\n    locked_by UUID DEFAULT NULL,\n    run_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL\n);\n"}+                , CreateFile {filePath = "Web/Job/CreateContainer.hs", fileContent = "module Web.Job.CreateContainer where\nimport Web.Controller.Prelude\n\ninstance Job CreateContainerJob where\n    perform CreateContainerJob { .. } = do\n        putStrLn \"Hello World!\"\n"}+                , AddImport {filePath = "Web/Worker.hs", fileContent = "import Web.Job.CreateContainer"}+                , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/Worker.hs", fileContent = "        , worker @CreateContainerJob"}+                ]++        it "should build a job with suffix Job even when it's missing in the input" do+            let applicationName = "Web"+            let tableName = "create_container"+            let modelName = "CreateContainer"+            let isFirstJobInApplication = False+            let uuidFunction = "uuid_generate_v4"+            let config = JobGenerator.JobConfig { .. }+            let builtPlan = JobGenerator.buildPlan' config++            builtPlan `shouldBe` [+                  EnsureDirectory {directory = "Web/Job"}+                , AppendToFile {filePath = "Application/Schema.sql", fileContent = "CREATE TABLE create_container_jobs (\n    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,\n    created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n    updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n    status JOB_STATUS DEFAULT 'job_status_not_started' NOT NULL,\n    last_error TEXT DEFAULT NULL,\n    attempts_count INT DEFAULT 0 NOT NULL,\n    locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,\n    locked_by UUID DEFAULT NULL,\n    run_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL\n);\n"}+                , CreateFile {filePath = "Web/Job/CreateContainer.hs", fileContent = "module Web.Job.CreateContainer where\nimport Web.Controller.Prelude\n\ninstance Job CreateContainerJob where\n    perform CreateContainerJob { .. } = do\n        putStrLn \"Hello World!\"\n"}+                , AddImport {filePath = "Web/Worker.hs", fileContent = "import Web.Job.CreateContainer"}+                , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/Worker.hs", fileContent = "        , worker @CreateContainerJob"}+                ]+++        it "should create Web/Worker.hs if it doesn't exist" do+            let applicationName = "Web"+            let tableName = "create_container_jobs"+            let modelName = "CreateContainerJob"+            let isFirstJobInApplication = True+            let uuidFunction = "uuid_generate_v4"+            let config = JobGenerator.JobConfig { .. }+            let builtPlan = JobGenerator.buildPlan' config++            builtPlan `shouldBe` [+                  EnsureDirectory {directory = "Web/Job"}+                , AppendToFile {filePath = "Application/Schema.sql", fileContent = "CREATE TABLE create_container_jobs (\n    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,\n    created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n    updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n    status JOB_STATUS DEFAULT 'job_status_not_started' NOT NULL,\n    last_error TEXT DEFAULT NULL,\n    attempts_count INT DEFAULT 0 NOT NULL,\n    locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,\n    locked_by UUID DEFAULT NULL,\n    run_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL\n);\n"}+                , CreateFile {filePath = "Web/Job/CreateContainer.hs", fileContent = "module Web.Job.CreateContainer where\nimport Web.Controller.Prelude\n\ninstance Job CreateContainerJob where\n    perform CreateContainerJob { .. } = do\n        putStrLn \"Hello World!\"\n"}+                , CreateFile {filePath = "Web/Worker.hs", fileContent = "module Web.Worker where\n\nimport IHP.Prelude\nimport Web.Types\nimport Generated.Types\nimport IHP.Job.Runner\nimport IHP.Job.Types\n\nimport Web.Job.CreateContainer\n\ninstance Worker WebApplication where\n    workers _ =\n        [ worker @CreateContainerJob\n        -- Generator Marker\n        ]\n"}+                ]+++        it "should support other applications" do+            let applicationName = "Admin"+            let tableName = "create_container_jobs"+            let modelName = "CreateContainerJob"+            let isFirstJobInApplication = False+            let uuidFunction = "uuid_generate_v4"+            let config = JobGenerator.JobConfig { .. }+            let builtPlan = JobGenerator.buildPlan' config++            builtPlan `shouldBe` [+                  EnsureDirectory {directory = "Admin/Job"}+                , AppendToFile {filePath = "Application/Schema.sql", fileContent = "CREATE TABLE create_container_jobs (\n    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,\n    created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n    updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n    status JOB_STATUS DEFAULT 'job_status_not_started' NOT NULL,\n    last_error TEXT DEFAULT NULL,\n    attempts_count INT DEFAULT 0 NOT NULL,\n    locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,\n    locked_by UUID DEFAULT NULL,\n    run_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL\n);\n"}+                , CreateFile {filePath = "Admin/Job/CreateContainer.hs", fileContent = "module Admin.Job.CreateContainer where\nimport Admin.Controller.Prelude\n\ninstance Job CreateContainerJob where\n    perform CreateContainerJob { .. } = do\n        putStrLn \"Hello World!\"\n"}+                , AddImport {filePath = "Admin/Worker.hs", fileContent = "import Admin.Job.CreateContainer"}+                , AppendToMarker {marker = "-- Generator Marker", filePath = "Admin/Worker.hs", fileContent = "        , worker @CreateContainerJob"}+                ]++        it "should create appropriate Worker.hs for other applications if it doesn't exist" do+            let applicationName = "Admin"+            let tableName = "create_container_jobs"+            let modelName = "CreateContainerJob"+            let isFirstJobInApplication = True+            let uuidFunction = "uuid_generate_v4"+            let config = JobGenerator.JobConfig { .. }+            let builtPlan = JobGenerator.buildPlan' config++            builtPlan `shouldBe` [+                  EnsureDirectory {directory = "Admin/Job"}+                , AppendToFile {filePath = "Application/Schema.sql", fileContent = "CREATE TABLE create_container_jobs (\n    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,\n    created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n    updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,\n    status JOB_STATUS DEFAULT 'job_status_not_started' NOT NULL,\n    last_error TEXT DEFAULT NULL,\n    attempts_count INT DEFAULT 0 NOT NULL,\n    locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,\n    locked_by UUID DEFAULT NULL,\n    run_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL\n);\n"}+                , CreateFile {filePath = "Admin/Job/CreateContainer.hs", fileContent = "module Admin.Job.CreateContainer where\nimport Admin.Controller.Prelude\n\ninstance Job CreateContainerJob where\n    perform CreateContainerJob { .. } = do\n        putStrLn \"Hello World!\"\n"}+                , CreateFile {filePath = "Admin/Worker.hs", fileContent = "module Admin.Worker where\n\nimport IHP.Prelude\nimport Admin.Types\nimport Generated.Types\nimport IHP.Job.Runner\nimport IHP.Job.Types\n\nimport Admin.Job.CreateContainer\n\ninstance Worker AdminApplication where\n    workers _ =\n        [ worker @CreateContainerJob\n        -- Generator Marker\n        ]\n"}+                ]
+ Test/IDE/CodeGeneration/MailGenerator.hs view
@@ -0,0 +1,38 @@+{-|+Module: Test.IDE.CodeGeneration.MailGenerator+Copyright: (c) digitally induced GmbH, 2020+-}+module Test.IDE.CodeGeneration.MailGenerator where++import Test.Hspec+import IHP.Prelude+import qualified IHP.IDE.CodeGen.MailGenerator as MailGenerator+import IHP.IDE.CodeGen.Types+import IHP.Postgres.Types++++tests = do+    describe "Mail Generator Tests:" do+        let schema = [+                    StatementCreateTable (table "users") {+                        columns = [+                            (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                        ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                        }+                    ]+        it "should build a mail with name \"PurchaseConfirmationMail\"" do+            let mailName = "PurchaseConfirmationMail"+            let rawControllerName = "Users"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let config = MailGenerator.MailConfig { .. }+            let builtPlan = MailGenerator.buildPlan' schema config++            builtPlan `shouldBe` [+                  EnsureDirectory {directory = "Web/Mail/Users"}+                , CreateFile {filePath = "Web/Mail/Users/PurchaseConfirmation.hs", fileContent = "module Web.Mail.Users.PurchaseConfirmation where\nimport Web.View.Prelude\nimport IHP.MailPrelude\n\ndata PurchaseConfirmationMail = PurchaseConfirmationMail { user :: User }\n\ninstance BuildMail PurchaseConfirmationMail where\n    subject = \"Subject\"\n    to PurchaseConfirmationMail { .. } = Address { addressName = Just \"Firstname Lastname\", addressEmail = \"fname.lname@example.com\" }\n    from = \"hi@example.com\"\n    html PurchaseConfirmationMail { .. } = [hsx|\n        Hello World\n    |]\n"}+                , AddImport {filePath = "Web/Controller/Users.hs", fileContent = "import Web.Mail.Users.PurchaseConfirmation"}+                ]
+ Test/IDE/CodeGeneration/MigrationGenerator.hs view
@@ -0,0 +1,1448 @@+{-|+Module: Test.IDE.CodeGeneration.MigrationGenerator+Copyright: (c) digitally induced GmbH, 2021+-}+module Test.IDE.CodeGeneration.MigrationGenerator where++import Test.Hspec+import IHP.Prelude+import IHP.IDE.CodeGen.MigrationGenerator+import Data.String.Interpolate.IsString (i)+import qualified Text.Megaparsec as Megaparsec+import qualified IHP.Postgres.Parser as Parser+import IHP.Postgres.Types++tests = do+    describe "MigrationGenerator" do+        describe "diffSchemas" do+            it "should handle an empty schema" do+                diffSchemas [] [] `shouldBe` []++            it "should handle a new table" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let actualSchema = sql ""++                diffSchemas targetSchema actualSchema `shouldBe` targetSchema++            it "should skip tables that are equals in both schemas" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let actualSchema = targetSchema++                diffSchemas targetSchema actualSchema `shouldBe` []++            it "should handle new columns" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL+                    );+                |]+                let migration = sql [i|ALTER TABLE users ADD COLUMN email TEXT NOT NULL;|]++                diffSchemas targetSchema actualSchema `shouldBe` migration+++            it "should handle multiple new columns" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL+                    );+                |]+                let migration = sql [i|+                    ALTER TABLE users ADD COLUMN name TEXT NOT NULL;+                    ALTER TABLE users ADD COLUMN email TEXT NOT NULL;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should handle deleted columns" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let migration = sql [i|+                    ALTER TABLE users DROP COLUMN email;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration+++            it "should handle renamed columns" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL+                    );+                |]+                let migration = sql [i|ALTER TABLE users RENAME COLUMN name TO full_name;|]++                diffSchemas targetSchema actualSchema `shouldBe` migration+            +            it "should handle UNIQUE constraints added to columns" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT NOT NULL UNIQUE+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT NOT NULL+                    );+                |]+                let migration = sql [i|ALTER TABLE users ADD CONSTRAINT "users_full_name_key" UNIQUE (full_name);|]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should handle changing default values for columns" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT DEFAULT 'new value' NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT DEFAULT 'old value' NOT NULL+                    );+                |]+                let migration = sql [i|ALTER TABLE users ALTER COLUMN full_name SET DEFAULT 'new value';|]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should handle default values added to columns" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT DEFAULT 'value' NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT NOT NULL+                    );+                |]+                let migration = sql [i|ALTER TABLE users ALTER COLUMN full_name SET DEFAULT 'value';|]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should handle default values removed from columns" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT DEFAULT 'value' NOT NULL+                    );+                |]+                let migration = sql [i|ALTER TABLE users ALTER COLUMN full_name DROP DEFAULT;|]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should handle UNIQUE constraints removed from columns" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        full_name TEXT NOT NULL UNIQUE+                    );+                |]+                let migration = sql [i|ALTER TABLE users DROP CONSTRAINT users_full_name_key;|]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should handle new enums" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL+                    );+                    CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy');+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL+                    );+                |]+                let migration = sql [i|+                    CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy');+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should handle new enum values" do+                let targetSchema = sql [i|+                    CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy');+                |]+                let actualSchema = sql [i|+                    CREATE TYPE mood AS ENUM ('sad', 'ok');+                |]+                let migration = sql [i|+                    -- Commit the transaction previously started by IHP+                    COMMIT;+                    ALTER TYPE mood ADD VALUE IF NOT EXISTS 'happy';+                    -- Restart the connection as IHP will also try to run it's own COMMIT+                    BEGIN;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should handle a real world table" do+                let targetSchema = sql [i|+                    CREATE TABLE subscribe_to_convert_kit_tag_jobs (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        status JOB_STATUS DEFAULT 'job_status_not_started' NOT NULL,+                        last_error TEXT DEFAULT NULL,+                        attempts_count INT DEFAULT 0 NOT NULL,+                        locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,+                        locked_by UUID DEFAULT NULL,+                        run_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        user_id UUID NOT NULL,+                        tag_id INT NOT NULL+                    );+                |]++                let actualSchema = sql [i|+                    CREATE TABLE public.subscribe_to_convert_kit_tag_jobs (+                        id uuid DEFAULT public.uuid_generate_v4() NOT NULL,+                        created_at timestamp with time zone DEFAULT now() NOT NULL,+                        updated_at timestamp with time zone DEFAULT now() NOT NULL,+                        status public.job_status DEFAULT 'job_status_not_started'::public.job_status NOT NULL,+                        last_error text,+                        attempts_count integer DEFAULT 0 NOT NULL,+                        locked_at timestamp with time zone,+                        locked_by uuid,+                        run_at timestamp with time zone DEFAULT now() NOT NULL,+                        user_id uuid NOT NULL,+                        tag_id integer NOT NULL+                    );+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []++            it "should not detect unspecified on delete behaviour as a change" do+                let targetSchema = sql [i|+                    ALTER TABLE subscriptions ADD CONSTRAINT subscriptions_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                |]++                let actualSchema = sql [i|+                    ALTER TABLE ONLY public.subscriptions ADD CONSTRAINT subscriptions_ref_user_id FOREIGN KEY (user_id) REFERENCES public.users(id);+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []++            it "should not detect changes on case differences of enums" do+                let targetSchema = sql [i|+                    CREATE TYPE A AS ENUM ();+                |]++                let actualSchema = sql [i|+                    CREATE TYPE a AS ENUM ();+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []+            +            it "should handle a deleted table" do+                let targetSchema = sql ""+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let migration = sql [i|+                    DROP TABLE users;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should handle a deleted enum" do+                let targetSchema = sql ""+                let actualSchema = sql [i|+                    CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy');+                |]+                let migration = sql [i|+                    DROP TYPE mood;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should handle a new indexes" do+                let targetSchema = sql [i|+                    CREATE INDEX users_index ON users (user_name);+                |]+                let actualSchema = sql ""+                let migration = sql [i|+                    CREATE INDEX users_index ON users (user_name);+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration +            +            it "should handle deleted indexes" do+                let targetSchema = sql ""+                let actualSchema = sql [i|+                    CREATE INDEX users_index ON users (user_name);+                |]+                let migration = sql [i|+                    DROP INDEX users_index;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration +            +            it "should handle columns that have been made nullable" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let migration = sql [i|+                    ALTER TABLE users ALTER COLUMN email DROP NOT NULL;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration+            +            it "should handle columns that have been made not nullable" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT+                    );+                |]+                let migration = sql [i|+                    ALTER TABLE users ALTER COLUMN email SET NOT NULL;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration +            +            it "should handle table renames" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE profiles (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let migration = sql [i|+                    ALTER TABLE profiles RENAME TO users;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration +            +            it "should not do a rename if tables are different" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE profiles (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        email TEXT NOT NULL+                    );+                |]+                let migration = sql [i|+                    DROP TABLE profiles;+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL+                    );+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration +            +            it "should handle new foreign keys" do+                let targetSchema = sql [i|+                    ALTER TABLE messages ADD CONSTRAINT messages_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                |]+                let actualSchema = sql ""+                let migration = sql [i|+                    ALTER TABLE messages ADD CONSTRAINT messages_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration+            +            it "should handle new foreign keys" do+                let targetSchema = sql ""+                let actualSchema = sql [i|+                    ALTER TABLE ONLY public.messages ADD CONSTRAINT messages_ref_user_id FOREIGN KEY (user_id) REFERENCES public.users(id);+                |]+                let migration = sql [i|+                    ALTER TABLE messages DROP CONSTRAINT messages_ref_user_id;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration+            +            it "should handle new policies" do+                let targetSchema = sql [i|+                    CREATE POLICY "Users can manage their todos" ON todos USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());+                |]+                let actualSchema = sql ""+                let migration = sql [i|+                    CREATE POLICY "Users can manage their todos" ON todos USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            +            it "should handle deleted policies" do+                let targetSchema = sql ""+                let actualSchema = sql [i|+                    CREATE POLICY "Users can manage their todos" ON todos USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());+                |]+                let migration = sql [i|+                    DROP POLICY "Users can manage their todos" ON todos;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should normalize primary keys" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        email TEXT NOT NULL,+                        password_hash TEXT NOT NULL,+                        locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,+                        failed_login_attempts INT DEFAULT 0 NOT NULL,+                        access_token TEXT DEFAULT NULL+                    );+                    CREATE TABLE posts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        title TEXT NOT NULL,+                        body TEXT NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    --+                    -- PostgreSQL database dump+                    --++                    -- Dumped from database version 14.0 (Debian 14.0-1.pgdg110+1)+                    -- Dumped by pg_dump version 14beta1++                    SET statement_timeout = 0;+                    SET lock_timeout = 0;+                    SET idle_in_transaction_session_timeout = 0;+                    SET client_encoding = 'UTF8';+                    SET standard_conforming_strings = on;+                    SELECT pg_catalog.set_config('search_path', '', false);+                    SET default_toast_compression = 'pglz';+                    SET check_function_bodies = false;+                    SET xmloption = content;+                    SET client_min_messages = warning;+                    SET row_security = off;++                    --+                    -- Name: uuid-ossp; Type: EXTENSION; Schema: -; Owner: -+                    --++                    CREATE EXTENSION IF NOT EXISTS "uuid-ossp" WITH SCHEMA public;+++                    --+                    -- Name: EXTENSION "uuid-ossp"; Type: COMMENT; Schema: -; Owner: -+                    --++                    COMMENT ON EXTENSION "uuid-ossp" IS 'generate universally unique identifiers (UUIDs)';+++                    SET default_tablespace = '';++                    SET default_table_access_method = heap;++                    --+                    -- Name: users; Type: TABLE; Schema: public; Owner: -+                    --++                    CREATE TABLE public.users (+                        id uuid DEFAULT public.uuid_generate_v4() NOT NULL,+                        email text NOT NULL,+                        password_hash text NOT NULL,+                        locked_at timestamp with time zone,+                        failed_login_attempts integer DEFAULT 0 NOT NULL,+                        access_token text+                    );+++                    --+                    -- Name: users users_pkey; Type: CONSTRAINT; Schema: public; Owner: -+                    --++                    ALTER TABLE ONLY public.users+                        ADD CONSTRAINT users_pkey PRIMARY KEY (id);+++                    --+                    -- PostgreSQL database dump complete+                    --++                |]+                let migration = sql [i|+                    CREATE TABLE posts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        title TEXT NOT NULL,+                        body TEXT NOT NULL+                    );+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration+            it "should generate statements in the right order" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        email TEXT NOT NULL,+                        password_hash TEXT NOT NULL,+                        locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,+                        failed_login_attempts INT DEFAULT 0 NOT NULL,+                        access_token TEXT DEFAULT NULL+                    );+                    CREATE TABLE posts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        title TEXT NOT NULL,+                        body TEXT NOT NULL,+                        user_id UUID NOT NULL+                    );+                    CREATE INDEX posts_user_id_index ON posts (user_id);+                    ALTER TABLE posts ADD CONSTRAINT posts_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                |]+                let actualSchema = sql [i|+                    --+                    -- PostgreSQL database dump+                    --++                    -- Dumped from database version 14.0 (Debian 14.0-1.pgdg110+1)+                    -- Dumped by pg_dump version 14beta1++                    SET statement_timeout = 0;+                    SET lock_timeout = 0;+                    SET idle_in_transaction_session_timeout = 0;+                    SET client_encoding = 'UTF8';+                    SET standard_conforming_strings = on;+                    SELECT pg_catalog.set_config('search_path', '', false);+                    SET default_toast_compression = 'pglz';+                    SET check_function_bodies = false;+                    SET xmloption = content;+                    SET client_min_messages = warning;+                    SET row_security = off;++                    --+                    -- Name: uuid-ossp; Type: EXTENSION; Schema: -; Owner: -+                    --++                    CREATE EXTENSION IF NOT EXISTS "uuid-ossp" WITH SCHEMA public;+++                    --+                    -- Name: EXTENSION "uuid-ossp"; Type: COMMENT; Schema: -; Owner: -+                    --++                    COMMENT ON EXTENSION "uuid-ossp" IS 'generate universally unique identifiers (UUIDs)';++                    SET default_tablespace = '';++                    SET default_table_access_method = heap;++                    --+                    -- Name: users; Type: TABLE; Schema: public; Owner: -+                    --++                    CREATE TABLE public.users (+                        id uuid DEFAULT public.uuid_generate_v4() NOT NULL,+                        email text NOT NULL,+                        password_hash text NOT NULL,+                        locked_at timestamp with time zone,+                        failed_login_attempts integer DEFAULT 0 NOT NULL,+                        access_token text+                    );+++                    --+                    -- Name: users users_pkey; Type: CONSTRAINT; Schema: public; Owner: -+                    --++                    ALTER TABLE ONLY public.users+                        ADD CONSTRAINT users_pkey PRIMARY KEY (id);++                |]+                let migration = sql [i|+                    CREATE TABLE posts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        title TEXT NOT NULL,+                        body TEXT NOT NULL,+                        user_id UUID NOT NULL+                    );+                    CREATE INDEX posts_user_id_index ON posts (user_id);+                    ALTER TABLE posts ADD CONSTRAINT posts_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration+++            it "should normalize unique constraints on columns" do+                let targetSchema = sql [i|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        github_user_id INT DEFAULT NULL UNIQUE+                    );+                |]++                let actualSchema = sql [i|+                    CREATE TABLE public.users (+                        id uuid DEFAULT public.uuid_generate_v4() NOT NULL,+                        github_user_id integer+                    );++                    ALTER TABLE ONLY public.users ADD CONSTRAINT users_github_user_id_key UNIQUE (github_user_id);+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []+++            it "should normalize policy definitions" do+                let targetSchema = sql [i|+                    CREATE POLICY "Users can manage their project's migrations" ON migrations USING (EXISTS (SELECT 1 FROM projects WHERE projects.id = migrations.project_id)) WITH CHECK (EXISTS (SELECT 1 FROM projects WHERE projects.id = migrations.project_id));+                |]++                let actualSchema = sql [i|+                    CREATE POLICY "Users can manage their project's migrations" ON public.migrations USING ((EXISTS ( SELECT 1+                       FROM public.projects+                      WHERE (projects.id = migrations.project_id)))) WITH CHECK ((EXISTS ( SELECT 1+                       FROM public.projects+                      WHERE (projects.id = migrations.project_id))));+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []++            it "should normalize check constraints" do+                let targetSchema = sql [i|+                    CREATE TABLE public.a (+                        id uuid DEFAULT public.uuid_generate_v4() NOT NULL+                    );+                    ALTER TABLE a ADD CONSTRAINT contact_email_or_url CHECK (contact_email IS NOT NULL OR source_url IS NOT NULL);+                |]++                let actualSchema = sql [i|+                    CREATE TABLE public.a (+                        id uuid DEFAULT public.uuid_generate_v4() NOT NULL,+                        CONSTRAINT contact_email_or_url CHECK (((contact_email IS NOT NULL) OR (source_url IS NOT NULL)))+                    );+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []++            it "should normalize Bigserials" do+                let targetSchema = sql [i|+                    CREATE TABLE testserial (+                        testcol BIGSERIAL NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE public.testserial (+                        testcol bigint NOT NULL+                    );++                    CREATE SEQUENCE public.testserial_testcol_seq+                        START WITH 1+                        INCREMENT BY 1+                        NO MINVALUE+                        NO MAXVALUE+                        CACHE 1;++                    ALTER SEQUENCE public.testserial_testcol_seq OWNED BY public.testserial.testcol;+                    ALTER TABLE ONLY public.testserial ALTER COLUMN testcol SET DEFAULT nextval('public.testserial_testcol_seq'::regclass);+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []+            +            it "should normalize Serials" do+                let targetSchema = sql [i|+                    CREATE TABLE testserial (+                        testcol SERIAL NOT NULL+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE public.testserial (+                        testcol int NOT NULL+                    );++                    CREATE SEQUENCE public.testserial_testcol_seq+                        START WITH 1+                        INCREMENT BY 1+                        NO MINVALUE+                        NO MAXVALUE+                        CACHE 1;++                    ALTER SEQUENCE public.testserial_testcol_seq OWNED BY public.testserial.testcol;+                    ALTER TABLE ONLY public.testserial ALTER COLUMN testcol SET DEFAULT nextval('public.testserial_testcol_seq'::regclass);+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []++            +            it "should normalize index expressions" do+                let targetSchema = sql [i|+                    CREATE INDEX users_email_index ON users (LOWER(email));+                |]+                let actualSchema = sql [i|+                    CREATE INDEX users_email_index ON public.users USING btree (lower(email));+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []++            it "should not detect a difference between two functions when the only difference is between 'CREATE' and 'CREATE OR REPLACE'" do+                let targetSchema = sql [i|+                    CREATE OR REPLACE FUNCTION notify_did_insert_webrtc_connection() RETURNS TRIGGER AS $$+                    BEGIN+                        PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text);+                        RETURN NEW;+                    END;+                    $$ language plpgsql;+                |]+                let actualSchema = sql [i|+                    CREATE FUNCTION public.notify_did_insert_webrtc_connection() RETURNS trigger+                        LANGUAGE plpgsql+                        AS $$+                    BEGIN+                        PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text);+                        RETURN NEW;+                    END;+                    $$;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []+            +            it "should normalize aliases in policies" do+                let targetSchema = sql [i|+                    CREATE POLICY "Users can see other users in their company" ON users USING (company_id = (SELECT users.company_id FROM users WHERE users.id = ihp_user_id()));+                |]+                let actualSchema = sql [i|+                    CREATE POLICY "Users can see other users in their company" ON public.users USING ((company_id = ( SELECT users_1.company_id+                       FROM public.users users_1+                      WHERE (users_1.id = public.ihp_user_id()))));+                |]++                diffSchemas targetSchema actualSchema `shouldBe` []+            +            it "should handle implicitly deleted indexes and constraints" do+                let targetSchema = sql [i|+                |]+                let actualSchema = sql [i|+                    CREATE TABLE projects (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        user_id UUID NOT NULL+                    );+                    CREATE INDEX projects_name_index ON projects (name);+                    ALTER TABLE projects ADD CONSTRAINT projects_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE CASCADE;+                |]+                let migration = sql [i|+                    DROP TABLE projects;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration+            +            it "should run 'ALTER TYPE .. ADD VALUE ..' outside of a transaction" do+                let targetSchema = sql [i|+                    CREATE TABLE a();+                    CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy');+                    CREATE TABLE b();+                |]+                let actualSchema = sql [i|+                    CREATE TYPE mood AS ENUM ('sad', 'ok');+                |]+                let migration = sql [i|+                    -- Commit the transaction previously started by IHP+                    COMMIT;+                    ALTER TYPE mood ADD VALUE IF NOT EXISTS 'happy';+                    -- Restart the connection as IHP will also try to run it's own COMMIT+                    BEGIN;+                    CREATE TABLE a();+                    CREATE TABLE b();+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should run not generate a default value for a generated column" do+                let targetSchema = sql [i|+                    CREATE TABLE products (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        description TEXT NOT NULL,+                        sku TEXT NOT NULL,+                        text_search TSVECTOR GENERATED ALWAYS AS +                            ( setweight(to_tsvector('english', sku), 'A') ||+                              setweight(to_tsvector('english', name), 'B') ||+                              setweight(to_tsvector('english', description), 'C')+                            ) STORED+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE products (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        description TEXT NOT NULL,+                        sku TEXT NOT NULL+                    );+                |]+                let migration = sql [i|+                    ALTER TABLE products ADD COLUMN text_search TSVECTOR GENERATED ALWAYS AS (setweight(to_tsvector('english', sku), 'A') || setweight(to_tsvector('english', name), 'B') || setweight(to_tsvector('english', description), 'C')) STORED;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should normalize generated columns" do+                let targetSchema = sql [i|+                    CREATE TABLE products (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        name TEXT NOT NULL,+                        description TEXT NOT NULL,+                        sku TEXT NOT NULL,+                        text_search TSVECTOR GENERATED ALWAYS AS +                            ( setweight(to_tsvector('english', sku), 'A') ||+                              setweight(to_tsvector('english', name), 'B') ||+                              setweight(to_tsvector('english', description), 'C')+                            ) STORED+                    );+                |]+                let actualSchema = sql [i|+                    CREATE TABLE public.products (+                        id uuid DEFAULT public.uuid_generate_v4() NOT NULL,+                        name text NOT NULL,+                        description text NOT NULL,+                        sku text NOT NULL,+                        text_search tsvector GENERATED ALWAYS AS (((setweight(to_tsvector('english'::regconfig, sku), 'A'::"char") || setweight(to_tsvector('english'::regconfig, name), 'B'::"char")) || setweight(to_tsvector('english'::regconfig, description), 'C'::"char"))) STORED+                    );+                |]+                let migration = sql [i|+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should not detect changes if the LANGUAGE is in difference casing" do+                let targetSchema = sql [trimming|+                    CREATE FUNCTION ihp_user_id() RETURNS UUID AS $$$$+                        SELECT NULLIF(current_setting('rls.ihp_user_id'), '')::uuid;+                    $$$$ LANGUAGE SQL;++                    CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$$$+                    BEGIN+                        NEW.updated_at = NOW();+                        RETURN NEW;+                    END;+                    $$$$ language plpgsql;+                |]+                let actualSchema = sql [trimming|+                    --+                    -- Name: ihp_user_id(); Type: FUNCTION; Schema: public; Owner: -+                    --++                    CREATE FUNCTION public.ihp_user_id() RETURNS uuid+                        LANGUAGE sql+                        AS $$$$+                        SELECT NULLIF(current_setting('rls.ihp_user_id'), '')::uuid;+                    $$$$;++                    CREATE FUNCTION public.set_updated_at_to_now() RETURNS trigger+                        LANGUAGE plpgsql+                        AS $$$$+                    BEGIN+                        NEW.updated_at = NOW();+                        RETURN NEW;+                    END;+                    $$$$;+                |]+                let migration = sql [i|+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration+            +            it "should not try dropping an index after already droping a column" do+                let targetSchema = sql [trimming|+                    CREATE TABLE tasks (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        title TEXT NOT NULL,+                        updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        user_id UUID DEFAULT ihp_user_id() NOT NULL,+                        updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL+                    );+                    CREATE INDEX tasks_updated_at_index ON tasks (updated_at);+                |]+                let actualSchema = sql [trimming|+                    CREATE TABLE tasks (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        title TEXT NOT NULL,+                        updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        user_id UUID DEFAULT ihp_user_id() NOT NULL,+                        created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL+                    );+                    CREATE INDEX tasks_created_at_index ON tasks (created_at);+                    CREATE INDEX tasks_updated_at_index ON tasks (updated_at);+                |]+                let migration = sql [i|+                    ALTER TABLE tasks DROP COLUMN created_at;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "ignore auto generated 'notify_...' functions" do+                let targetSchema = sql [trimming|+                |]+                let actualSchema = sql [trimming|+                    CREATE FUNCTION public.notify_did_change_todos() RETURNS trigger+                        LANGUAGE plpgsql+                        AS $$$$+                            BEGIN+                                CASE TG_OP+                                WHEN ''UPDATE'' THEN+                                    PERFORM pg_notify(+                                        ''did_change_todos'',+                                        json_build_object(+                                          ''UPDATE'', NEW.id::text,+                                          ''CHANGESET'', (+                                                SELECT json_agg(row_to_json(t))+                                                FROM (+                                                      SELECT pre.key AS "col", post.value AS "new"+                                                      FROM jsonb_each(to_jsonb(OLD)) AS pre+                                                      CROSS JOIN jsonb_each(to_jsonb(NEW)) AS post+                                                      WHERE pre.key = post.key AND pre.value IS DISTINCT FROM post.value+                                                ) t+                                          )+                                        )::text+                                    );+                                WHEN ''DELETE'' THEN+                                    PERFORM pg_notify(+                                        ''did_change_todos'',+                                        (json_build_object(''DELETE'', OLD.id)::text)+                                    );+                                WHEN ''INSERT'' THEN+                                    PERFORM pg_notify(+                                        ''did_change_todos'',+                                        json_build_object(''INSERT'', NEW.id)::text+                                    );+                                END CASE;+                                RETURN new;+                            END;+                        $$$$;+                |]+                let migration = sql [i|+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should normalize unique constraint names with multiple columns" do+                let targetSchema = sql $ cs [plain|+                    ALTER TABLE days ADD UNIQUE (category_id, date);+                |]+                let actualSchema = sql $ cs [plain|+                    ALTER TABLE ONLY public.days ADD CONSTRAINT days_category_id_date_key UNIQUE (category_id, date);+                |]+                let migration = sql [i|+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should not detect changes between functions where only the whitespace is different" do+                let targetSchema = sql $ cs [plain|+CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$+BEGIN+    NEW.updated_at = NOW();+    RETURN NEW;+END;+$$ language PLPGSQL;+                |]+                let actualSchema = sql $ cs [plain|+                    +CREATE FUNCTION public.set_updated_at_to_now() RETURNS trigger+    LANGUAGE plpgsql+    AS $$+    BEGIN+        NEW.updated_at = NOW();+        RETURN NEW;+    END;+    $$;+                |]+                let migration = sql [i|+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should replace functions if the body has changed" do+                let targetSchema = sql $ cs [plain|+CREATE FUNCTION a() RETURNS TRIGGER AS $$+BEGIN+    hello_world();+END;+$$ language PLPGSQL;+                |]+                let actualSchema = sql $ cs [plain|+                    +CREATE FUNCTION public.a() RETURNS trigger+    LANGUAGE plpgsql+    AS $$+    BEGIN+        RETURN NEW;+    END;+    $$;+                |]+                let migration = sql [i|+CREATE OR REPLACE FUNCTION a() RETURNS TRIGGER AS $$BEGIN+    hello_world();+END;$$ language PLPGSQL;|]++                diffSchemas targetSchema actualSchema `shouldBe` migration+            +            it "should normalize qualified identifiers in policy expressions" do+                -- https://github.com/digitallyinduced/ihp/issues/1480+                let targetSchema = sql $ cs [plain|+                    CREATE POLICY "Users can manage servers they have access to" ON servers USING (servers.user_id = ihp_user_id() OR (EXISTS (SELECT 1 FROM public.user_server_access WHERE user_server_access.user_id = ihp_user_id() AND user_server_access.server_id = servers.id)));+                |]+                let actualSchema = sql $ cs [plain|+                    --+                    -- Name: servers Users can manage servers they have access to; Type: POLICY; Schema: public; Owner: -+                    --++                    CREATE POLICY "Users can manage servers they have access to" ON public.servers USING (((user_id = public.ihp_user_id()) OR (EXISTS ( SELECT 1+                       FROM public.user_server_access+                      WHERE ((user_server_access.user_id = public.ihp_user_id()) AND (user_server_access.server_id = servers.id))))));+                |]+                let migration = sql [i|+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should work with IN expressions" do+                let targetSchema = sql $ cs [plain|+CREATE POLICY "Users can read and edit their own record" ON public.users USING ((id IN ( SELECT users_1.id+   FROM public.users users_1+  WHERE ((users_1.id = public.ihp_user_id()) OR (users_1.user_role = 'admin'::text))))) WITH CHECK ((id = public.ihp_user_id()));+                |]+                let actualSchema = sql $ cs [plain|+                |]+                let migration = sql [i|+CREATE POLICY "Users can read and edit their own record" ON public.users USING ((id IN ( SELECT id+   FROM public.users+  WHERE ((id = public.ihp_user_id()) OR (user_role = 'admin'))))) WITH CHECK ((id = public.ihp_user_id()));+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration+            it "should handle indexes with coalesce" do+                -- https://github.com/digitallyinduced/ihp/issues/1451+                let targetSchema = sql "CREATE UNIQUE INDEX user_invite_uniqueness ON user_invites (organization_id, email, coalesce(expires_at, '0001-01-01 01:01:01-04'));"+                let actualSchema = sql ""+                let migration = sql [i|+                    CREATE UNIQUE INDEX user_invite_uniqueness ON user_invites (organization_id, email, coalesce(expires_at, '0001-01-01 01:01:01-04'));+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration ++            it "should handle complex renames" do+                -- See https://github.com/digitallyinduced/thin-backend/issues/66+                let targetSchema = sql $ cs [plain|+                    CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$+                    BEGIN+                        NEW.updated_at = NOW();+                        RETURN NEW;+                    END;+                    $$ language plpgsql;+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        email TEXT NOT NULL,+                        password_hash TEXT NOT NULL,+                        locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,+                        failed_login_attempts INT DEFAULT 0 NOT NULL,+                        access_token TEXT DEFAULT NULL,+                        confirmation_token TEXT DEFAULT NULL,+                        is_confirmed BOOLEAN DEFAULT false NOT NULL+                    );+                    CREATE POLICY "Users can read their own record" ON users USING (id = ihp_user_id()) WITH CHECK (false);+                    ALTER TABLE users ENABLE ROW LEVEL SECURITY;+                    CREATE TABLE artefacts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        user_id UUID DEFAULT ihp_user_id() NOT NULL+                    );+                    CREATE INDEX artefacts_created_at_index ON artefacts (created_at);+                    CREATE TRIGGER update_artefacts_updated_at BEFORE UPDATE ON artefacts FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();+                    CREATE INDEX artefacts_user_id_index ON artefacts (user_id);+                    ALTER TABLE artefacts ADD CONSTRAINT artefacts_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                    ALTER TABLE artefacts ENABLE ROW LEVEL SECURITY;+                    CREATE POLICY "Users can manage their artefacts" ON artefacts USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());+                |]+                let actualSchema = sql $ cs [plain|+                    CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$+                    BEGIN+                        NEW.updated_at = NOW();+                        RETURN NEW;+                    END;+                    $$ language plpgsql;+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        email TEXT NOT NULL,+                        password_hash TEXT NOT NULL,+                        locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,+                        failed_login_attempts INT DEFAULT 0 NOT NULL,+                        access_token TEXT DEFAULT NULL,+                        confirmation_token TEXT DEFAULT NULL,+                        is_confirmed BOOLEAN DEFAULT false NOT NULL+                    );+                    CREATE POLICY "Users can read their own record" ON users USING (id = ihp_user_id()) WITH CHECK (false);+                    ALTER TABLE users ENABLE ROW LEVEL SECURITY;+                    CREATE TABLE media (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        user_id UUID DEFAULT ihp_user_id() NOT NULL+                    );+                    CREATE INDEX media_created_at_index ON media (created_at);+                    CREATE TRIGGER update_media_updated_at BEFORE UPDATE ON media FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();+                    CREATE INDEX media_user_id_index ON media (user_id);+                    ALTER TABLE media ADD CONSTRAINT media_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                    ALTER TABLE media ENABLE ROW LEVEL SECURITY;+                    CREATE POLICY "Users can manage their media" ON media USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());++                |]+                let migration = sql [i|+                    ALTER TABLE media RENAME TO artefacts;+                    +                    DROP INDEX media_created_at_index;+                    DROP TRIGGER update_media_updated_at ON media;+                    DROP INDEX media_user_id_index;++                    ALTER TABLE artefacts DROP CONSTRAINT media_ref_user_id;+                    DROP POLICY "Users can manage their media" ON artefacts;+                    +                    CREATE INDEX artefacts_created_at_index ON artefacts (created_at);+                    CREATE TRIGGER update_artefacts_updated_at BEFORE UPDATE ON artefacts FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();+                    CREATE INDEX artefacts_user_id_index ON artefacts (user_id);+                    ALTER TABLE artefacts ADD CONSTRAINT artefacts_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                    ALTER TABLE artefacts ENABLE ROW LEVEL SECURITY;+                    CREATE POLICY "Users can manage their artefacts" ON artefacts USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration+            +            it "should delete policies when the column is deleted" do+                -- https://github.com/digitallyinduced/ihp/issues/1480+                let targetSchema = sql $ cs [plain|+                    CREATE TABLE artefacts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL+                    );+                    ALTER TABLE artefacts ENABLE ROW LEVEL SECURITY;+                |]+                let actualSchema = sql $ cs [plain|+                    CREATE TABLE artefacts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,+                        user_id UUID DEFAULT ihp_user_id() NOT NULL+                    );+                    ALTER TABLE artefacts ENABLE ROW LEVEL SECURITY;+                    CREATE POLICY "Users can manage their artefacts" ON artefacts USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());+                |]+                let migration = sql [i|+                    ALTER TABLE artefacts DROP COLUMN user_id;+                    DROP POLICY "Users can manage their artefacts" ON artefacts;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should not explicitly delete policies when the table is deleted" do+                -- https://github.com/digitallyinduced/thin-backend/issues/69+                let actualSchema = sql $ cs [plain|+                    CREATE TABLE tests (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        user_id UUID DEFAULT ihp_user_id() NOT NULL+                    );+                    CREATE INDEX tests_user_id_index ON tests (user_id);+                    ALTER TABLE tests ADD CONSTRAINT tests_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                    ALTER TABLE tests ENABLE ROW LEVEL SECURITY;+                    CREATE POLICY "Users can manage their tests" ON tests USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());+                |]+                let targetSchema = []+                let migration = sql [i|+                    DROP TABLE tests;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should ignore the schema_migrations table" do+                let actualSchema = sql $ cs [plain|+                    CREATE TABLE schema_migrations (revision BIGINT NOT NULL UNIQUE);+                |]+                let targetSchema = []+                let migration = []++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should ignore the large_pg_notifications table" do+                let actualSchema = sql $ cs [plain|+                    CREATE UNLOGGED TABLE large_pg_notifications (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        payload TEXT DEFAULT null,+                        created_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL+                    );+                    CREATE INDEX large_pg_notifications_created_at_index ON large_pg_notifications (created_at);+                |]+                let targetSchema = []+                let migration = []++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should not see a diff between those two" do+                -- https://github.com/digitallyinduced/ihp/issues/1628+                let actualSchema = sql $ cs [trimming|+                    CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$$$BEGIN+                        NEW.updated_at = NOW();+                        RETURN NEW;+                    END;$$$$ language PLPGSQL;+                |]+                let targetSchema = sql $ cs [trimming|+                    CREATE FUNCTION public.set_updated_at_to_now() RETURNS trigger+                        LANGUAGE plpgsql+                        AS $$$$BEGIN+                            NEW.updated_at = NOW();+                            RETURN NEW;+                        END;$$$$;+                |]+                let migration = []++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should normalize function body whitespace" do+                -- https://github.com/digitallyinduced/ihp/issues/1628+                let (Just fn) = head $ sql $ cs [trimming|+                    CREATE FUNCTION public.set_updated_at_to_now() RETURNS trigger+                        LANGUAGE plpgsql+                        AS $$$$BEGIN+                            NEW.updated_at = NOW();+                            RETURN NEW;+                        END;$$$$;+                |]++                (normalizeStatement fn) `shouldBe` [(function "set_updated_at_to_now")+                    { functionBody = "BEGIN\n    NEW.updated_at = NOW();\n    RETURN NEW;\nEND;"+                    , language = "PLPGSQL"+                    }]++            it "should delete the updated_at trigger when the updated_at column is deleted" do+                -- https://github.com/digitallyinduced/ihp/issues/1630+                let actualSchema = sql $ cs [plain|+                    CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$+                    BEGIN+                        NEW.updated_at = NOW();+                        RETURN NEW;+                    END;+                    $$ language plpgsql;+                    CREATE TABLE posts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        title TEXT NOT NULL,+                        updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL+                    );+                    CREATE TRIGGER update_posts_updated_at BEFORE UPDATE ON posts FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();+                |]+                let targetSchema = sql $ cs [plain|+                    CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$+                    BEGIN+                        NEW.updated_at = NOW();+                        RETURN NEW;+                    END;+                    $$ language plpgsql;+                    CREATE TABLE posts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        title TEXT NOT NULL+                    );+                |]+                let migration = sql [i|+                    ALTER TABLE posts DROP COLUMN updated_at;+                    DROP TRIGGER update_posts_updated_at ON posts;+                |]++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should ignore did_update_.. triggers by IHP.PGListener" do+                let actualSchema = sql $ cs [plain|+                    CREATE TRIGGER did_update_plans AFTER UPDATE ON public.plans FOR EACH ROW EXECUTE FUNCTION public.notify_did_change_plans();+                    CREATE TRIGGER did_insert_offices AFTER INSERT ON public.offices FOR EACH STATEMENT EXECUTE FUNCTION public.notify_did_change_offices();+                    CREATE TRIGGER did_delete_company_profiles AFTER DELETE ON public.company_profiles FOR EACH STATEMENT EXECUTE FUNCTION public.notify_did_change_company_profiles();+                |]+                let targetSchema = []+                let migration = []++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should ignore ar_did_update_.. triggers by IHP.AutoRefresh" do+                let actualSchema = sql $ cs [plain|+                    CREATE TRIGGER ar_did_update_plans AFTER UPDATE ON public.plans FOR EACH ROW EXECUTE FUNCTION public.notify_did_change_plans();+                    CREATE TRIGGER ar_did_insert_offices AFTER INSERT ON public.offices FOR EACH STATEMENT EXECUTE FUNCTION public.notify_did_change_offices();+                    CREATE TRIGGER ar_did_delete_company_profiles AFTER DELETE ON public.company_profiles FOR EACH STATEMENT EXECUTE FUNCTION public.notify_did_change_company_profiles();+                |]+                let targetSchema = []+                let migration = []++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should deal with truncated identifiers" do+                let actualSchema = sql $ cs [plain|+                    CREATE POLICY "Users can manage the prepare_context_jobs if they can see the C" ON public.prepare_context_jobs USING ((EXISTS ( SELECT 1+                       FROM public.contexts+                      WHERE (contexts.id = prepare_context_jobs.context_id)))) WITH CHECK ((EXISTS ( SELECT 1+                       FROM public.contexts+                      WHERE (contexts.id = prepare_context_jobs.context_id))));+                |]+                let targetSchema = sql $ cs [plain|+                    CREATE POLICY "Users can manage the prepare_context_jobs if they can see the Context" ON prepare_context_jobs USING (EXISTS (SELECT 1 FROM public.contexts WHERE contexts.id = prepare_context_jobs.context_id)) WITH CHECK (EXISTS (SELECT 1 FROM public.contexts WHERE contexts.id = prepare_context_jobs.context_id));+                |]+                let migration = []++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should truncate very long constraint names" do+                let actualSchema = sql $ cs [plain|+                    ALTER TABLE organization_num_employees_ranges ADD CONSTRAINT organization_num_employees_ranges_ref_prospect_search_request_id FOREIGN KEY (prospect_search_request_id) REFERENCES prospect_search_requests (id) ON DELETE NO ACTION;+                |]+                let targetSchema = sql $ cs [plain|+                    ALTER TABLE organization_num_employees_ranges ADD CONSTRAINT organization_num_employees_ranges_ref_prospect_search_request_i FOREIGN KEY (prospect_search_request_id) REFERENCES prospect_search_requests (id) ON DELETE NO ACTION;+                |]+                let migration = []++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should deal with nested SELECT expressions inside a policy" do+                let actualSchema = sql $ cs [plain|+                    CREATE POLICY "Allow users to see their own company" ON public.companies USING ((id = ( SELECT users.company_id+                       FROM public.users+                      WHERE (users.id = public.ihp_user_id())))) WITH CHECK (false);+                |]+                let targetSchema = sql $ cs [plain|+                    CREATE POLICY "Allow users to see their own company" ON companies USING (id = (SELECT company_id FROM users WHERE users.id = ihp_user_id())) WITH CHECK (false);+                |]+                let migration = []++                diffSchemas targetSchema actualSchema `shouldBe` migration+            +            it "should deal with complex nested SELECT expressions inside a policy" do+                -- Tricky part is the `projects.id = ads.project_id` here+                -- It needs to be unwrapped to `id = project_id` correctly+                let actualSchema = sql $ cs [plain|+                    CREATE POLICY "Users can manage ads if they can access the project" ON public.ads USING ((EXISTS ( SELECT projects.id+                       FROM public.projects+                      WHERE (projects.id = ads.project_id)))) WITH CHECK ((EXISTS ( SELECT projects.id+                       FROM public.projects+                      WHERE (projects.id = ads.project_id))));+                |]+                let targetSchema = sql $ cs [plain|+                    CREATE POLICY "Users can manage ads if they can access the project" ON ads USING (EXISTS (SELECT id FROM projects WHERE id = project_id)) WITH CHECK (EXISTS (SELECT id FROM projects WHERE id = project_id));+                |]+                let migration = []++                diffSchemas targetSchema actualSchema `shouldBe` migration++            it "should normalize InArrayExpression in check constraints" do+                -- Ensures normalizeExpression handles InArrayExpression (tuple literals like ('a', 'b'))+                -- This pattern appears more frequently in PostgreSQL 17's pg_dump output+                let targetSchema = sql $ cs [plain|+                    CREATE TABLE posts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        status TEXT NOT NULL+                    );+                    ALTER TABLE posts ADD CONSTRAINT posts_status_check CHECK (status IN ('draft', 'published', 'archived'));+                |]+                let actualSchema = sql $ cs [plain|+                    CREATE TABLE public.posts (+                        id uuid DEFAULT public.uuid_generate_v4() NOT NULL,+                        status text NOT NULL,+                        CONSTRAINT posts_status_check CHECK ((status IN ('draft', 'published', 'archived')))+                    );+                |]+                diffSchemas targetSchema actualSchema `shouldBe` []++sql :: Text -> [Statement]+sql code = case Megaparsec.runParser Parser.parseDDL "" code of+    Left parsingFailed -> error (cs $ Megaparsec.errorBundlePretty parsingFailed)+    Right r -> r
+ Test/IDE/CodeGeneration/ViewGenerator.hs view
@@ -0,0 +1,186 @@+{-|+Module: Test.IDE.CodeGeneration.ViewGenerator+Copyright: (c) digitally induced GmbH, 2020+-}+module Test.IDE.CodeGeneration.ViewGenerator where++import Test.Hspec+import IHP.Prelude+import qualified IHP.IDE.CodeGen.ViewGenerator as ViewGenerator+import IHP.IDE.CodeGen.Types+import IHP.Postgres.Types++++tests = do+    describe "View Generator Tests:" do+        let schema = [+                    StatementCreateTable (table "pages") {+                        columns = [+                            (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                        ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                        }+                    ]+        it "should build a view with name \"EditView\"" do+            let rawViewName = "EditView"+            let viewName = tableNameToViewName rawViewName+            let rawControllerName = "Pages"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let paginationEnabled = False+            let config = ViewGenerator.ViewConfig { .. }+            let builtPlan = ViewGenerator.buildPlan' schema config++            builtPlan `shouldBe`+                [ EnsureDirectory {directory = "Web/View/Pages"},CreateFile {filePath = "Web/View/Pages/Edit.hs", fileContent = "module Web.View.Pages.Edit where\nimport Web.View.Prelude\n\ndata EditView = EditView { page :: Page }\n\ninstance View EditView where\n    html EditView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Edit Page</h1>\n        {renderForm page}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"Pages\" PagesAction\n                , breadcrumbText \"Edit Page\"\n                ]\n\nrenderForm :: Page -> Html\nrenderForm page = formFor page [hsx|\n    \n    {submitButton}\n\n|]"},AddImport {filePath = "Web/Controller/Pages.hs", fileContent = "import Web.View.Pages.Edit"}+                ]++++        it "should build a view with name \"edit_view\"" do+            let rawViewName = "edit_view"+            let viewName = tableNameToViewName rawViewName+            let rawControllerName = "Pages"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let paginationEnabled = False+            let config = ViewGenerator.ViewConfig { .. }+            let builtPlan = ViewGenerator.buildPlan' schema config++            builtPlan `shouldBe`+                [ EnsureDirectory {directory = "Web/View/Pages"},CreateFile {filePath = "Web/View/Pages/Edit.hs", fileContent = "module Web.View.Pages.Edit where\nimport Web.View.Prelude\n\ndata EditView = EditView { page :: Page }\n\ninstance View EditView where\n    html EditView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Edit Page</h1>\n        {renderForm page}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"Pages\" PagesAction\n                , breadcrumbText \"Edit Page\"\n                ]\n\nrenderForm :: Page -> Html\nrenderForm page = formFor page [hsx|\n    \n    {submitButton}\n\n|]"},AddImport {filePath = "Web/Controller/Pages.hs", fileContent = "import Web.View.Pages.Edit"}+                ]+++        it "should build a view with name \"editView\"" do+            let rawViewName = "editView"+            let viewName = tableNameToViewName rawViewName+            let rawControllerName = "Pages"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let paginationEnabled = False+            let config = ViewGenerator.ViewConfig { .. }+            let builtPlan = ViewGenerator.buildPlan' schema config++            builtPlan `shouldBe`+                [ EnsureDirectory {directory = "Web/View/Pages"},CreateFile {filePath = "Web/View/Pages/Edit.hs", fileContent = "module Web.View.Pages.Edit where\nimport Web.View.Prelude\n\ndata EditView = EditView { page :: Page }\n\ninstance View EditView where\n    html EditView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Edit Page</h1>\n        {renderForm page}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"Pages\" PagesAction\n                , breadcrumbText \"Edit Page\"\n                ]\n\nrenderForm :: Page -> Html\nrenderForm page = formFor page [hsx|\n    \n    {submitButton}\n\n|]"},AddImport {filePath = "Web/Controller/Pages.hs", fileContent = "import Web.View.Pages.Edit"}+                ]+++        it "should build a view with name \"Edit\"" do+            let rawViewName = "Edit"+            let viewName = tableNameToViewName rawViewName+            let rawControllerName = "Pages"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let paginationEnabled = False+            let config = ViewGenerator.ViewConfig { .. }+            let builtPlan = ViewGenerator.buildPlan' schema config++            builtPlan `shouldBe`+                [ EnsureDirectory {directory = "Web/View/Pages"},CreateFile {filePath = "Web/View/Pages/Edit.hs", fileContent = "module Web.View.Pages.Edit where\nimport Web.View.Prelude\n\ndata EditView = EditView { page :: Page }\n\ninstance View EditView where\n    html EditView { .. } = [hsx|\n        {breadcrumb}\n        <h1>Edit Page</h1>\n        {renderForm page}\n    |]\n        where\n            breadcrumb = renderBreadcrumb\n                [ breadcrumbLink \"Pages\" PagesAction\n                , breadcrumbText \"Edit Page\"\n                ]\n\nrenderForm :: Page -> Html\nrenderForm page = formFor page [hsx|\n    \n    {submitButton}\n\n|]"},AddImport {filePath = "Web/Controller/Pages.hs", fileContent = "import Web.View.Pages.Edit"}+                ]+++        it "should build a view with name \"Test\"" do+            let rawViewName = "Test"+            let viewName = tableNameToViewName rawViewName+            let rawControllerName = "Pages"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let paginationEnabled = False+            let config = ViewGenerator.ViewConfig { .. }+            let builtPlan = ViewGenerator.buildPlan' schema config++            builtPlan `shouldBe`+                [ EnsureDirectory {directory = "Web/View/Pages"},CreateFile {filePath = "Web/View/Pages/Test.hs", fileContent = "module Web.View.Pages.Test where\nimport Web.View.Prelude\ndata TestView = TestView\n\ninstance View TestView where\n    html TestView { .. } = [hsx|\n        {breadcrumb}\n        <h1>TestView</h1>\n        |]\n            where\n                breadcrumb = renderBreadcrumb\n                                [ breadcrumbLink \"Tests\" PagesAction\n                                , breadcrumbText \"TestView\"\n                                ]"},AddImport {filePath = "Web/Controller/Pages.hs", fileContent = "import Web.View.Pages.Test"}+                ]++        it "should generate type-aware form fields for a rich schema" do+            let richSchema = [+                        StatementCreateTable (table "projects") {+                            columns = [+                                (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                                , (col "title" PText) { notNull = True }+                                , (col "is_active" PBoolean) { notNull = True }+                                , (col "budget" PInt) { notNull = False }+                                , (col "started_on" PDate) { notNull = False }+                                , (col "user_id" PUUID) { notNull = True }+                            ]+                            , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                            , constraints = [+                                ForeignKeyConstraint { name = Nothing, columnName = "user_id", referenceTable = "users", referenceColumn = Nothing, onDelete = Nothing }+                              ]+                        }+                    ]+            let viewName = "NewView"+            let rawControllerName = "projects"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let paginationEnabled = False+            let config = ViewGenerator.ViewConfig { .. }+            let builtPlan = ViewGenerator.buildPlan' richSchema config+            let (EnsureDirectory {}):((CreateFile { fileContent = newViewContent }):_) = builtPlan+            -- Type-aware form fields+            (cs newViewContent :: String) `shouldContain` "{(textField #title)}"+            (cs newViewContent :: String) `shouldContain` "{(checkboxField #isActive)}"+            (cs newViewContent :: String) `shouldContain` "{(numberField #budget)}"+            (cs newViewContent :: String) `shouldContain` "{(dateField #startedOn)}"+            -- FK field should have a TODO comment+            (cs newViewContent :: String) `shouldContain` "{- userId needs to be a selectField -}"++        it "should generate dl-based show view for a rich schema" do+            let richSchema = [+                        StatementCreateTable (table "projects") {+                            columns = [+                                (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                                , (col "title" PText) { notNull = True }+                                , (col "is_active" PBoolean) { notNull = True }+                            ]+                            , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                        }+                    ]+            let viewName = "ShowView"+            let rawControllerName = "projects"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let paginationEnabled = False+            let config = ViewGenerator.ViewConfig { .. }+            let builtPlan = ViewGenerator.buildPlan' richSchema config+            let (EnsureDirectory {}):((CreateFile { fileContent = showViewContent }):_) = builtPlan+            (cs showViewContent :: String) `shouldContain` "<dl>"+            (cs showViewContent :: String) `shouldContain` "<dt>Title</dt><dd>{project.title}</dd>"+            (cs showViewContent :: String) `shouldContain` "<dt>Is Active</dt><dd>{project.isActive}</dd>"++        it "should generate column-based index view for a rich schema" do+            let richSchema = [+                        StatementCreateTable (table "projects") {+                            columns = [+                                (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                                , (col "title" PText) { notNull = True }+                                , (col "is_active" PBoolean) { notNull = True }+                            ]+                            , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                        }+                    ]+            let viewName = "IndexView"+            let rawControllerName = "projects"+            let controllerName = tableNameToControllerName rawControllerName+            let modelName = tableNameToModelName rawControllerName+            let applicationName = "Web"+            let paginationEnabled = False+            let config = ViewGenerator.ViewConfig { .. }+            let builtPlan = ViewGenerator.buildPlan' richSchema config+            let (EnsureDirectory {}):((CreateFile { fileContent = indexViewContent }):_) = builtPlan+            (cs indexViewContent :: String) `shouldContain` "<th>Title</th>"+            (cs indexViewContent :: String) `shouldContain` "<th>Is Active</th>"+            (cs indexViewContent :: String) `shouldContain` "<td>{project.title}</td>"+            (cs indexViewContent :: String) `shouldContain` "<td>{project.isActive}</td>"
+ Test/IDE/SchemaDesigner/CompilerSpec.hs view
@@ -0,0 +1,945 @@+{-|+Module: Test.IDE.SchemaDesigner.CompilerSpec+Copyright: (c) digitally induced GmbH, 2020+-}+module Test.IDE.SchemaDesigner.CompilerSpec where++import Test.Hspec+import IHP.Prelude+import IHP.Postgres.Compiler (compileSql)+import IHP.Postgres.Types+import Test.IDE.SchemaDesigner.ParserSpec (parseSql)++tests = do+    describe "The Schema.sql Compiler" do+        it "should compile an empty CREATE TABLE statement" do+            compileSql [StatementCreateTable (table "users")] `shouldBe` "CREATE TABLE users (\n\n);\n"++        it "should compile a CREATE EXTENSION for the UUID extension" do+            compileSql [CreateExtension { name = "uuid-ossp", ifNotExists = True }] `shouldBe` "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\";\n"++        it "should compile a line comment" do+            compileSql [Comment { content = " Comment value" }] `shouldBe` "-- Comment value\n"++        it "should compile a empty line comments" do+            compileSql [Comment { content = "" }, Comment { content = "" }] `shouldBe` "--\n--\n"++        it "should compile a CREATE TABLE with columns" do+            let sql = cs [plain|CREATE TABLE users (+    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+    firstname TEXT NOT NULL,+    lastname TEXT NOT NULL,+    password_hash TEXT NOT NULL,+    email TEXT NOT NULL,+    company_id UUID NOT NULL,+    picture_url TEXT,+    created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL+);+|]+            let statement = StatementCreateTable (table "users")+                    { columns = [+                        (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                        , (col "firstname" PText) { notNull = True }+                        , (col "lastname" PText) { notNull = True }+                        , (col "password_hash" PText) { notNull = True }+                        , (col "email" PText) { notNull = True }+                        , (col "company_id" PUUID) { notNull = True }+                        , col "picture_url" PText+                        , (col "created_at" PTimestampWithTimezone) { defaultValue = Just (CallExpression "NOW" []), notNull = True }+                        ]+                    , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TABLE with quoted identifiers" do+            compileSql [StatementCreateTable (table "quoted name")] `shouldBe` "CREATE TABLE \"quoted name\" (\n\n);\n"++        it "should compile ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE CASCADE" do+            let statement = AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Just Cascade+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE CASCADE;\n"++        it "should compile ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE SET DEFAULT" do+            let statement = AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Just SetDefault+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE SET DEFAULT;\n"++        it "should compile ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE SET NULL" do+            let statement = AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Just SetNull+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE SET NULL;\n"++        it "should compile ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE RESTRICT" do+            let statement = AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Just Restrict+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE RESTRICT;\n"++        it "should compile ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE NO ACTION" do+            let statement = AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Just NoAction+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE NO ACTION;\n"++        it "should compile ALTER TABLE .. ADD FOREIGN KEY .. (without ON DELETE)" do+            let statement = AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Nothing+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ;\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. CHECK .." do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = CheckConstraint+                        { name = "check_title_length"+                        , checkExpression = NotEqExpression (VarExpression "title") (TextExpression "")+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (title <> '');\n"++        it "should compile a complex ALTER TABLE .. ADD CONSTRAINT .. CHECK .." do+            let statement = AddConstraint+                    { tableName = "properties"+                    , constraint = CheckConstraint+                        { name = "foobar"+                        , checkExpression = OrExpression+                                (AndExpression+                                    (AndExpression+                                        (EqExpression (VarExpression "property_type") (TextExpression "haus_buy"))+                                        (IsExpression (VarExpression "area_garden") (NotExpression (VarExpression "NULL")))+                                    )+                                    (IsExpression (VarExpression "rent_monthly") (VarExpression "NULL"))+                                )++                                (AndExpression+                                    (AndExpression+                                        (EqExpression (VarExpression "property_type") (TextExpression "haus_rent"))+                                        (IsExpression (VarExpression "rent_monthly") (NotExpression (VarExpression "NULL")))+                                    )+                                    (IsExpression (VarExpression "price") (VarExpression "NULL"))+                                )+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE properties ADD CONSTRAINT foobar CHECK ((property_type = 'haus_buy' AND area_garden IS NOT NULL AND rent_monthly IS NULL) OR (property_type = 'haus_rent' AND rent_monthly IS NOT NULL AND price IS NULL));\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. CHECK .. with a <" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = CheckConstraint+                        { name = "check_title_length"+                        , checkExpression = LessThanExpression (CallExpression ("length") [VarExpression "title"]) (VarExpression "20")+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (length(title) < 20);\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. CHECK .. with a <=" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = CheckConstraint+                        { name = "check_title_length"+                        , checkExpression = LessThanOrEqualToExpression (CallExpression ("length") [VarExpression "title"]) (VarExpression "20")+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (length(title) <= 20);\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. CHECK .. with a >" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = CheckConstraint+                        { name = "check_title_length"+                        , checkExpression = GreaterThanExpression (CallExpression ("length") [VarExpression "title"]) (VarExpression "20")+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (length(title) > 20);\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. CHECK .. with a >=" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = CheckConstraint+                        { name = "check_title_length"+                        , checkExpression = GreaterThanOrEqualToExpression (CallExpression ("length") [VarExpression "title"]) (VarExpression "20")+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (length(title) >= 20);\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .." do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            , ExcludeConstraintElement { element = "author", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Nothing+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE (title WITH =, author WITH =);\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. USING BTREE" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            , ExcludeConstraintElement { element = "author", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Just Btree+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE USING BTREE (title WITH =, author WITH =);\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. USING GIST" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            , ExcludeConstraintElement { element = "author", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Just Gist+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE USING GIST (title WITH =, author WITH =);\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. USING GIN" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            , ExcludeConstraintElement { element = "author", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Just Gin+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE USING GIN (title WITH =, author WITH =);\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. WHERE .." do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            , ExcludeConstraintElement { element = "author", operator = "=" }+                            ]+                        , predicate = Just $ EqExpression (VarExpression "title") (TextExpression "why")+                        , indexType = Nothing+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE (title WITH =, author WITH =) WHERE (title = 'why');\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. WHERE .. with various operators" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "i1", operator = "=" }+                            , ExcludeConstraintElement { element = "i2", operator = "<>" }+                            , ExcludeConstraintElement { element = "i3", operator = "!=" }+                            , ExcludeConstraintElement { element = "i4", operator = "AND" }+                            , ExcludeConstraintElement { element = "i5", operator = "OR" }+                            ]+                        , predicate = Just $ EqExpression (VarExpression "title") (TextExpression "why")+                        , indexType = Nothing+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE (i1 WITH =, i2 WITH <>, i3 WITH !=, i4 WITH AND, i5 WITH OR) WHERE (title = 'why');\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. DEFERRABLE" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Nothing+                        }+                    , deferrable = Just True+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE (title WITH =) DEFERRABLE;\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. NOT DEFERRABLE" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Nothing+                        }+                    , deferrable = Just False+                    , deferrableType = Nothing+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE (title WITH =) NOT DEFERRABLE;\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. DEFERRABLE INITIALLY IMMEDIATE" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Nothing+                        }+                    , deferrable = Just True+                    , deferrableType = Just InitiallyImmediate+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE (title WITH =) DEFERRABLE INITIALLY IMMEDIATE;\n"++        it "should compile ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. DEFERRABLE INITIALLY DEFERRED" do+            let statement = AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Nothing+                        }+                    , deferrable = Just True+                    , deferrableType = Just InitiallyDeferred+                    }+            compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE (title WITH =) DEFERRABLE INITIALLY DEFERRED;\n"++        it "should compile a CREATE TABLE with text default value in columns" do+            let sql = cs [plain|CREATE TABLE a (\n    content TEXT DEFAULT 'example text' NOT NULL\n);\n|]+            let statement = StatementCreateTable (table "a")+                    { columns = [+                        (col "content" PText) { defaultValue = Just (TextExpression "example text"), notNull = True }+                        ]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TYPE .. AS ENUM" do+            let sql = cs [plain|CREATE TYPE colors AS ENUM ('yellow', 'red', 'blue');\n|]+            let statement = CreateEnumType+                    { name = "colors"+                    , values = ["yellow", "red", "blue"]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TABLE with (deprecated) NUMERIC, NUMERIC(x), NUMERIC (x,y), VARYING(n) columns" do+            let sql = cs [plain|CREATE TABLE deprecated_variables (\n    a NUMERIC,\n    b NUMERIC(1),\n    c NUMERIC(1,2),\n    d CHARACTER VARYING(10)\n);\n|]+            let statement = StatementCreateTable (table "deprecated_variables")+                    { columns =+                        [ col "a" (PNumeric Nothing Nothing)+                        , col "b" (PNumeric (Just 1) Nothing)+                        , col "c" (PNumeric (Just 1) (Just 2))+                        , col "d" (PVaryingN (Just 10))+                        ]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TABLE statement with a multi-column UNIQUE (a, b) constraint" do+            let sql = cs [plain|CREATE TABLE user_followers (\n    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,\n    user_id UUID NOT NULL,\n    follower_id UUID NOT NULL,\n    UNIQUE(user_id, follower_id)\n);\n|]+            let statement = StatementCreateTable (table "user_followers")+                    { columns =+                        [ (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                        , (col "user_id" PUUID) { notNull = True }+                        , (col "follower_id" PUUID) { notNull = True }+                        ]+                    , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    , constraints = [ UniqueConstraint { name = Nothing, columnNames = [ "user_id", "follower_id" ] } ]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TABLE statement with a serial id" do+            let sql = cs [plain|CREATE TABLE orders (\n    id SERIAL PRIMARY KEY NOT NULL\n);\n|]+            let statement = StatementCreateTable (table "orders")+                    { columns = [ (col "id" PSerial) { notNull = True } ]+                    , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TABLE statement with a bigserial id" do+            let sql = cs [plain|CREATE TABLE orders (\n    id BIGSERIAL PRIMARY KEY NOT NULL\n);\n|]+            let statement = StatementCreateTable (table "orders")+                    { columns = [ (col "id" PBigserial) { notNull = True } ]+                    , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TABLE statement with a composite primary key" do+            let sql = cs [plain|CREATE TABLE "orderTrucks" (\n    order_id BIGSERIAL NOT NULL,\n    truck_id BIGSERIAL NOT NULL,\n    PRIMARY KEY(order_id, truck_id)\n);\n|]+            let statement = StatementCreateTable (table "orderTrucks")+                    { columns =+                        [ (col "order_id" PBigserial) { notNull = True }+                        , (col "truck_id" PBigserial) { notNull = True }+                        ]+                    , primaryKeyConstraint = PrimaryKeyConstraint ["order_id", "truck_id"]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TABLE statement with an array column" do+            let sql = cs [plain|CREATE TABLE array_tests (\n    pay_by_quarter INT[]\n);\n|]+            let statement = StatementCreateTable (table "array_tests")+                    { columns = [ col "pay_by_quarter" (PArray PInt) ]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TABLE statement with an point column" do+            let sql = cs [plain|CREATE TABLE point_tests (\n    pos POINT\n);\n|]+            let statement = StatementCreateTable (table "point_tests")+                    { columns = [ col "pos" PPoint ]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TABLE statement with an polygon column" do+            let sql = cs [plain|CREATE TABLE polygon_tests (\n    poly POLYGON\n);\n|]+            let statement = StatementCreateTable (table "polygon_tests")+                    { columns = [ col "poly" PPolygon ]+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE INDEX statement" do+            let sql = cs [plain|CREATE INDEX users_index ON users (user_name);\n|]+            let statement = CreateIndex+                    { indexName = "users_index"+                    , unique = False+                    , tableName = "users"+                    , columns = [indexCol (VarExpression "user_name")]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }+            compileSql [statement] `shouldBe` sql+        +        it "should escape an index name inside a 'CREATE INDEX' statement" do+            let sql = cs [plain|CREATE INDEX "Some Index" ON "Some Table" ("Some Col");\n|]+            let statement = CreateIndex+                    { indexName = "Some Index"+                    , unique = False+                    , tableName = "Some Table"+                    , columns = [indexCol (VarExpression "Some Col")]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a 'CREATE INDEX .. ON .. USING GIN' statement" do+            let sql = cs [plain|CREATE INDEX users_index ON users USING GIN (user_name);\n|]+            let statement = CreateIndex+                    { indexName = "users_index"+                    , unique = False+                    , tableName = "users"+                    , columns = [indexCol (VarExpression "user_name")]+                    , whereClause = Nothing+                    , indexType = Just Gin+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a 'CREATE INDEX .. ON .. USING BTREE' statement" do+            let sql = cs [plain|CREATE INDEX users_index ON users USING BTREE (user_name);\n|]+            let statement = CreateIndex+                    { indexName = "users_index"+                    , unique = False+                    , tableName = "users"+                    , columns = [indexCol (VarExpression "user_name")]+                    , whereClause = Nothing+                    , indexType = Just Btree+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a 'CREATE INDEX .. ON .. USING GIST' statement" do+            let sql = cs [plain|CREATE INDEX users_index ON users USING GIST (user_name);\n|]+            let statement = CreateIndex+                    { indexName = "users_index"+                    , unique = False+                    , tableName = "users"+                    , columns = [indexCol (VarExpression "user_name")]+                    , whereClause = Nothing+                    , indexType = Just Gist+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE INDEX statement with multiple columns" do+            let sql = cs [plain|CREATE INDEX users_index ON users (user_name, project_id);\n|]+            let statement = CreateIndex+                    { indexName = "users_index"+                    , unique = False+                    , tableName = "users"+                    , columns =+                        [ indexCol (VarExpression "user_name")+                        , indexCol (VarExpression "project_id")+                        ]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE INDEX statement with a LOWER call" do+            let sql = cs [plain|CREATE INDEX users_email_index ON users (LOWER(email));\n|]+            let statement = CreateIndex+                    { indexName = "users_email_index"+                    , unique = False+                    , tableName = "users"+                    , columns = [indexCol (CallExpression "LOWER" [VarExpression "email"])]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE UNIQUE INDEX statement" do+            let sql = cs [plain|CREATE UNIQUE INDEX users_index ON users (user_name);\n|]+            let statement = CreateIndex+                    { indexName = "users_index"+                    , unique = True+                    , tableName = "users"+                    , columns = [indexCol (VarExpression "user_name")]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE INDEX with column order ASC NULLS FIRST statement" do+            let sql = cs [plain|CREATE UNIQUE INDEX users_index ON users (user_name ASC NULLS FIRST);\n|]+            let statement = CreateIndex+                    { indexName = "users_index"+                    , unique = True+                    , tableName = "users"+                    , columns = [IndexColumn { column = VarExpression "user_name", columnOrder = [Asc, NullsFirst]}]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE INDEX with column order DESC NULLS LAST statement" do+            let sql = cs [plain|CREATE UNIQUE INDEX users_index ON users (user_name DESC NULLS LAST);\n|]+            let statement = CreateIndex+                    { indexName = "users_index"+                    , unique = True+                    , tableName = "users"+                    , columns = [IndexColumn { column = VarExpression "user_name", columnOrder = [Desc, NullsLast]}]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }+            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE OR REPLACE FUNCTION ..() RETURNS TRIGGER .." do+            let sql = cs [plain|CREATE OR REPLACE FUNCTION notify_did_insert_webrtc_connection() RETURNS TRIGGER AS $$ BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; $$ language plpgsql;\n|]+            let statement = (function "notify_did_insert_webrtc_connection")+                    { functionBody = " BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; "+                    , orReplace = True+                    }++            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE OR REPLACE FUNCTION ..() RETURNS EVENT_TRIGGER .." do+            let sql = cs [plain|CREATE OR REPLACE FUNCTION a() RETURNS EVENT_TRIGGER AS $$$$ language plpgsql;\n|]+            let statement = (function "a")+                    { orReplace = True+                    , returns = PEventTrigger+                    }++            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE FUNCTION ..() RETURNS TRIGGER .." do+            let sql = cs [plain|CREATE FUNCTION notify_did_insert_webrtc_connection() RETURNS TRIGGER AS $$ BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; $$ language plpgsql;\n|]+            let statement = (function "notify_did_insert_webrtc_connection")+                    { functionBody = " BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; "+                    }++            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE FUNCTION with parameters ..() RETURNS TRIGGER .." do+            let sql = cs [plain|CREATE FUNCTION notify_did_insert_webrtc_connection(param1 TEXT, param2 INT) RETURNS TRIGGER AS $$ BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; $$ language plpgsql;\n|]+            let statement = (function "notify_did_insert_webrtc_connection")+                    { functionArguments = [("param1", PText), ("param2", PInt)]+                    , functionBody = " BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; "+                    }++            compileSql [statement] `shouldBe` sql+++        it "should compile a CREATE FUNCTION with SECURITY DEFINER" do+            let sql = cs [plain|CREATE FUNCTION my_func() RETURNS TRIGGER SECURITY DEFINER AS $$ BEGIN RETURN NEW; END; $$ language plpgsql;\n|]+            let statement = (function "my_func")+                    { functionBody = " BEGIN RETURN NEW; END; "+                    , securityDefiner = True+                    }++            compileSql [statement] `shouldBe` sql++        it "should compile a CREATE TRIGGER .." do+            let sql = cs [plain|CREATE TRIGGER t AFTER INSERT ON x FOR EACH ROW EXECUTE PROCEDURE y();\n|]+            let statement = UnknownStatement { raw = "CREATE TRIGGER t AFTER INSERT ON x FOR EACH ROW EXECUTE PROCEDURE y()"  }+            compileSql [statement] `shouldBe` sql++        it "should compile a decimal default value with a type-cast" do+            let sql = "CREATE TABLE a (\n    electricity_unit_price DOUBLE PRECISION DEFAULT 0.17::DOUBLE PRECISION NOT NULL\n);\n"+            let statement = StatementCreateTable (table "a") { columns = [(col "electricity_unit_price" PDouble) { defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True }] }+            compileSql [statement] `shouldBe` sql++        it "should compile a integer default value" do+            let sql = "CREATE TABLE a (\n    electricity_unit_price INT DEFAULT 0 NOT NULL\n);\n"+            let statement = StatementCreateTable (table "a") { columns = [(col "electricity_unit_price" PInt) { defaultValue = Just (IntExpression 0), notNull = True }] }+            compileSql [statement] `shouldBe` sql++        it "should compile a partial index" do+            let sql = cs [plain|CREATE UNIQUE INDEX unique_source_id ON listings (source, source_id) WHERE source IS NOT NULL AND source_id IS NOT NULL;\n|]+            let index = CreateIndex+                    { indexName = "unique_source_id"+                    , unique = True+                    , tableName = "listings"+                    , columns =+                        [ indexCol (VarExpression "source")+                        , indexCol (VarExpression "source_id")+                        ]+                    , whereClause = Just (+                        AndExpression+                            (IsExpression (VarExpression "source") (NotExpression (VarExpression "NULL")))+                            (IsExpression (VarExpression "source_id") (NotExpression (VarExpression "NULL"))))+                    , indexType = Nothing+                    }+            compileSql [index] `shouldBe` sql++        it "should compile 'ENABLE ROW LEVEL SECURITY' statements" do+            let sql = "ALTER TABLE tasks ENABLE ROW LEVEL SECURITY;\n"+            let statements = [EnableRowLevelSecurity { tableName = "tasks" }]+            compileSql statements `shouldBe` sql++        it "should compile 'ENABLE ROW LEVEL SECURITY' statements with spaces in the table name" do+            let sql = "ALTER TABLE \"users (old)\" ENABLE ROW LEVEL SECURITY;\n"+            let statements = [EnableRowLevelSecurity { tableName = "users (old)" }]+            compileSql statements `shouldBe` sql++        it "should compile 'CREATE POLICY' statements" do+            let sql = "CREATE POLICY \"Users can manage their tasks\" ON tasks USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());\n"+            let p = (policy "Users can manage their tasks" "tasks")+                    { using = Just (+                        EqExpression+                            (VarExpression "user_id")+                            (CallExpression "ihp_user_id" [])+                        )+                    , check = Just (+                        EqExpression+                            (VarExpression "user_id")+                            (CallExpression "ihp_user_id" [])+                        )+                    }+            compileSql [p] `shouldBe` sql++        it "should compile 'CREATE POLICY' statements with a 'ihp_user_id() IS NOT NULL' expression" do+            -- https://github.com/digitallyinduced/ihp/issues/1412+            let sql = "CREATE POLICY \"Users can manage tasks if logged in\" ON tasks USING (ihp_user_id() IS NOT NULL) WITH CHECK (ihp_user_id() IS NOT NULL);\n"+            let p = (policy "Users can manage tasks if logged in" "tasks")+                    { using = Just (+                        IsExpression+                            (CallExpression "ihp_user_id" [])+                            (NotExpression (VarExpression "NULL"))+                        )+                    , check = Just (+                        IsExpression+                            (CallExpression "ihp_user_id" [])+                            (NotExpression (VarExpression "NULL"))+                        )+                    }+            compileSql [p] `shouldBe` sql++        it "should compile 'CREATE POLICY .. FOR SELECT' statements" do+            let sql = "CREATE POLICY \"Messages are public\" ON messages FOR SELECT USING (true);\n"+            let p = CreatePolicy+                    { name = "Messages are public"+                    , action = Just PolicyForSelect+                    , tableName = "messages"+                    , using = Just (VarExpression "true")+                    , check = Nothing+                    }+            compileSql [p] `shouldBe` sql++        it "should use parentheses where needed" do+            -- https://github.com/digitallyinduced/ihp/issues/1087+            let inputSql = cs [plain|ALTER TABLE listings ADD CONSTRAINT source CHECK ((NOT (user_id IS NOT NULL AND agent_id IS NOT NULL)) AND (user_id IS NOT NULL OR agent_id IS NOT NULL));\n|]+            compileSql [parseSql inputSql] `shouldBe` inputSql++        it "should compile 'ALTER TABLE .. DROP COLUMN ..' statements" do+            let sql = "ALTER TABLE tasks DROP COLUMN description;\n"+            let statements = [ DropColumn { tableName = "tasks", columnName = "description" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'DROP TABLE ..' statements" do+            let sql = "DROP TABLE tasks;\n"+            let statements = [ DropTable { tableName = "tasks" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'CREATE SEQUENCE ..' statements" do+            let sql = "CREATE SEQUENCE a;\n"+            let statements = [ CreateSequence { name = "a" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'ALTER TABLE .. RENAME COLUMN .. TO ..' statements" do+            let sql = "ALTER TABLE users RENAME COLUMN name TO full_name;\n"+            let statements = [ RenameColumn { tableName = "users", from = "name", to = "full_name" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'ALTER TABLE .. ADD UNIQUE (..);' statements" do+            let sql = "ALTER TABLE users ADD UNIQUE (full_name);\n"+            let statements = [ AddConstraint { tableName = "users", constraint = UniqueConstraint { name = Nothing, columnNames = ["full_name"] }, deferrable = Nothing, deferrableType = Nothing } ]+            compileSql statements `shouldBe` sql++        it "should compile 'ALTER TABLE .. DROP CONSTRAINT ..;' statements" do+            let sql = "ALTER TABLE users DROP CONSTRAINT users_full_name_key;\n"+            let statements = [ DropConstraint { tableName = "users", constraintName = "users_full_name_key" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'DROP TYPE ..;' statements" do+            let sql = "DROP TYPE colors;\n"+            let statements = [ DropEnumType { name = "colors" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'DROP INDEX ..;' statements" do+            let sql = "DROP INDEX a;\n"+            let statements = [ DropIndex { indexName = "a" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'ALTER TABLE .. ALTER COLUMN .. DROP NOT NULL;' statements" do+            let sql = "ALTER TABLE users ALTER COLUMN email DROP NOT NULL;\n"+            let statements = [ DropNotNull { tableName = "users", columnName = "email" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'ALTER TABLE .. ALTER COLUMN .. SET NOT NULL;' statements" do+            let sql = "ALTER TABLE users ALTER COLUMN email SET NOT NULL;\n"+            let statements = [ SetNotNull { tableName = "users", columnName = "email" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'ALTER TABLE .. ALTER COLUMN .. SET DEFAULT ..;' statements" do+            let sql = "ALTER TABLE users ALTER COLUMN email SET DEFAULT null;\n"+            let statements = [ SetDefaultValue { tableName = "users", columnName = "email", value = VarExpression "null" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'ALTER TABLE .. ALTER COLUMN .. DROP DEFAULT;' statements" do+            let sql = "ALTER TABLE users ALTER COLUMN email DROP DEFAULT;\n"+            let statements = [ DropDefaultValue { tableName = "users", columnName = "email" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'ALTER TABLE .. RENAME TO ..;' statements" do+            let sql = "ALTER TABLE profiles RENAME TO users;\n"+            let statements = [ RenameTable { from = "profiles", to = "users" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'DROP POLICY .. ON ..;' statements" do+            let sql = "DROP POLICY \"Users can manage their todos\" ON todos;\n"+            let statements = [ DropPolicy { tableName = "todos", policyName = "Users can manage their todos" } ]+            compileSql statements `shouldBe` sql++        it "should compile 'CREATE EXTENSION IF NOT EXISTS;' statements with an unqualified name" do+            let sql = "CREATE EXTENSION IF NOT EXISTS fuzzystrmatch;\n"+            let statements = [ CreateExtension { name = "fuzzystrmatch", ifNotExists = True } ]+            compileSql statements `shouldBe` sql++        it "should compile 'CREATE POLICY ..;' statements with an EXISTS condition" do+            let sql = cs [plain|CREATE POLICY "Users can manage their project's migrations" ON migrations USING (EXISTS (SELECT 1 FROM public.projects WHERE projects.id = migrations.project_id)) WITH CHECK (EXISTS (SELECT 1 FROM public.projects WHERE projects.id = migrations.project_id));\n|]+            let statements =+                    [ (policy "Users can manage their project's migrations" "migrations")+                        { using = Just (ExistsExpression (SelectExpression (Select {columns = [IntExpression 1], from = DotExpression (VarExpression "public") "projects", alias = Nothing, whereClause = EqExpression (DotExpression (VarExpression "projects") "id") (DotExpression (VarExpression "migrations") "project_id")})))+                        , check = Just (ExistsExpression (SelectExpression (Select {columns = [IntExpression 1], from = DotExpression (VarExpression "public") "projects", alias = Nothing, whereClause = EqExpression (DotExpression (VarExpression "projects") "id") (DotExpression (VarExpression "migrations") "project_id")})))+                        }+                    ]+            compileSql statements `shouldBe` sql++        it "should compile 'ALTER TYPE .. ADD VALUE ..;' statements" do+            let sql = "ALTER TYPE colors ADD VALUE 'blue';\n"+            let statements = [ AddValueToEnumType { enumName = "colors", newValue = "blue", ifNotExists = False } ]+            compileSql statements `shouldBe` sql++        it "should compile 'CREATE TRIGGER .. AFTER INSERT ON .. FOR EACH ROW EXECUTE ..;' statements" do+            let sql = "CREATE TRIGGER call_test_function_for_new_users AFTER INSERT ON users FOR EACH ROW EXECUTE FUNCTION call_test_function('hello');\n"+            let statements = [ CreateTrigger+                    { name = "call_test_function_for_new_users"+                    , eventWhen = After+                    , event = [TriggerOnInsert]+                    , tableName = "users"+                    , for = ForEachRow+                    , whenCondition = Nothing+                    , functionName = "call_test_function"+                    , arguments = [TextExpression "hello"]+                    } ]+            compileSql statements `shouldBe` sql++        it "should compile 'CREATE TRIGGER .. AFTER INSERT OR UPDATE ON ..' statements" do+            let sql = "CREATE TRIGGER my_trigger AFTER INSERT OR UPDATE ON posts FOR EACH ROW EXECUTE FUNCTION my_function();\n"+            let statements = [ CreateTrigger+                    { name = "my_trigger"+                    , eventWhen = After+                    , event = [TriggerOnInsert, TriggerOnUpdate]+                    , tableName = "posts"+                    , for = ForEachRow+                    , whenCondition = Nothing+                    , functionName = "my_function"+                    , arguments = []+                    } ]+            compileSql statements `shouldBe` sql++        it "should compile 'CREATE EVENT TRIGGER ..' statements" do+            let sql = "CREATE EVENT TRIGGER trigger_update_schema ON ddl_command_end WHEN TAG IN ('CREATE TABLE', 'ALTER TABLE', 'DROP TABLE') EXECUTE FUNCTION update_tables_and_columns();\n"+            let statements = [ CreateEventTrigger+                    { name = "trigger_update_schema"+                    , eventOn = "ddl_command_end"+                    , whenCondition =  Just (InExpression (VarExpression "TAG") (InArrayExpression [TextExpression "CREATE TABLE", TextExpression "ALTER TABLE", TextExpression "DROP TABLE"]))+                    , functionName = "update_tables_and_columns"+                    , arguments = []+                    } ]+            compileSql statements `shouldBe` sql++        it "should compile 'BEGIN;' statements" do+            let sql = "BEGIN;\n"+            let statements = [ Begin ]+            compileSql statements `shouldBe` sql++        it "should compile 'COMMIT;' statements" do+            let sql = "COMMIT;\n"+            let statements = [ Commit ]+            compileSql statements `shouldBe` sql++        it "should compile 'ALTER TABLE .. ALTER COLUMN .. DROP NOT NULL;' statements" do+            let sql = "COMMIT;\n"+            let statements = [ Commit ]+            compileSql statements `shouldBe` sql+        it "should compile 'GENERATED' columns" do+            let sql = [trimming|+                CREATE TABLE products (+                    ts TSVECTOR GENERATED ALWAYS AS (setweight(to_tsvector('english', sku), ('A'::"char")) || setweight(to_tsvector('english', name), 'B') || setweight(to_tsvector('english', description), 'C')) STORED+                );+            |] <> "\n"+            let statements = [+                        StatementCreateTable (table "products")+                            { columns = [+                                (col "ts" PTSVector) { generator = Just $ ColumnGenerator+                                                { generate =+                                                    ConcatenationExpression+                                                        (ConcatenationExpression+                                                            (CallExpression "setweight" [CallExpression "to_tsvector" [TextExpression "english", VarExpression "sku"], TypeCastExpression (TextExpression "A") PSingleChar])+                                                            (CallExpression "setweight" [CallExpression "to_tsvector" [TextExpression "english", VarExpression "name"], TextExpression "B"])+                                                        )+                                                        (CallExpression "setweight" [CallExpression "to_tsvector" [TextExpression "english", VarExpression "description"], TextExpression "C"]), stored = True }+                                    }+                                ]+                            }+                        ]+            compileSql statements `shouldBe` sql+        it "should compile 'DROP FUNCTION ..;' statements" do+            let sql = "DROP FUNCTION my_function;\n"+            let statements = [ DropFunction { functionName = "my_function" } ]+            compileSql statements `shouldBe` sql+        it "should compile 'CREATE UNLOGGED TABLE' statements" do+            let sql = [trimming|+                CREATE UNLOGGED TABLE pg_large_notifications (+                +                );+            |] <> "\n"+            let statements = [+                        StatementCreateTable (table "pg_large_notifications")+                            { unlogged = True, inherits = Nothing+                            }+                        ]+            compileSql statements `shouldBe` sql++        it "should escape policy names with different casing" do+            let sql = [trimming|+                CREATE POLICY "Public" ON plans USING (true) WITH CHECK (false);+            |] <> "\n"+            let statements = [+                        (policy "Public" "plans")+                            { using = Just (VarExpression "true")+                            , check = Just (VarExpression "false")+                            }+                        ]+            compileSql statements `shouldBe` sql
+ Test/IDE/SchemaDesigner/Controller/EnumValuesSpec.hs view
@@ -0,0 +1,22 @@+module Test.IDE.SchemaDesigner.Controller.EnumValuesSpec where++import Test.Hspec+import IHP.Prelude+import IHP.IDE.SchemaDesigner.Controller.EnumValues+import IHP.Postgres.Types++tests :: SpecWith ()+tests = do+    describe "IHP.IDE.SchemaDesigner.Controller.EnumValues" do+        describe "getAllEnumValues" do+            it "should return a list of all enum values" do+                getAllEnumValues [] `shouldBe` []+                getAllEnumValues [ CreateExtension { name ="a", ifNotExists = True } ] `shouldBe` []+                getAllEnumValues [ CreateEnumType { name = "first_enum", values=["a", "b", "c"] }] `shouldBe` ["a", "b", "c"]+                getAllEnumValues+                    [ CreateEnumType {name = "first_enum", values = ["a", "b"]}+                    , CreateExtension {name = "extension", ifNotExists = True}+                    , CreateEnumType {name = "second_enum", values = ["c"]}+                    , CreateEnumType {name = "third_enum", values = []}+                    ]+                    `shouldBe` ["a","b","c"]
+ Test/IDE/SchemaDesigner/Controller/HelperSpec.hs view
@@ -0,0 +1,24 @@+module Test.IDE.SchemaDesigner.Controller.HelperSpec where++import Test.Hspec+import IHP.Prelude+import IHP.IDE.SchemaDesigner.Controller.Helper+import IHP.Postgres.Types++tests :: SpecWith ()+tests = do+    describe "IHP.IDE.SchemaDesigner.Controller.Helper" do+        describe "getAllObjectNames" do+            it "should return a list of all names of tables and enum types" do+                getAllObjectNames [] `shouldBe` []+                getAllObjectNames [ CreateExtension { name ="a", ifNotExists = True } ] `shouldBe` []+                getAllObjectNames [ CreateEnumType { name = "first_enum", values=["a", "b", "c"] }] `shouldBe` ["first_enum"]+                getAllObjectNames [ StatementCreateTable (table "table_name") ]+                    `shouldBe` ["table_name"]+                getAllObjectNames+                    [ CreateEnumType {name = "first_enum", values = ["a", "b"]}+                    , CreateExtension {name = "extension", ifNotExists = True}+                    , StatementCreateTable (table "table_name")+                    , CreateEnumType {name = "second_enum", values = []}+                    ]+                    `shouldBe` ["first_enum","table_name","second_enum"]
+ Test/IDE/SchemaDesigner/Controller/ValidationSpec.hs view
@@ -0,0 +1,33 @@+module Test.IDE.SchemaDesigner.Controller.ValidationSpec where++import Test.Hspec+import IHP.Prelude++import IHP.IDE.SchemaDesigner.Controller.Validation+import IHP.ValidationSupport++tests :: SpecWith ()+tests = do+    describe "IHP.IDE.SchemaDesigner.Controller.Validation" do+        describe "the isUniqueInList validator" do+            it "should handle cases wihout old value" do+                isUniqueInList [] Nothing "hello" `shouldBe` Success+                isUniqueInList ["hi", "bye"] Nothing "hello" `shouldBe` Success+                isUniqueInList ["hi"] Nothing "hi" `shouldSatisfy` isFailure+            it "should handle cases with old value" do+                isUniqueInList ["bye"] (Just "bye") "hello" `shouldBe` Success+                isUniqueInList ["bye", "hi"] (Just "hi") "hi" `shouldBe` Success+                isUniqueInList ["bye", "hi"] (Just "bye") "hi" `shouldSatisfy` isFailure++        describe "the validateNameInSchema validator" do+            it "should reject an empty name" do+                validateNameInSchema "" [] Nothing "" `shouldSatisfy` isFailure+            it "should reject a reserved keyword" do+                validateNameInSchema "" [] Nothing "bigint" `shouldSatisfy` isFailure+                validateNameInSchema "" [] Nothing "where" `shouldSatisfy` isFailure+            it "should reject a new name already in use" do+                validateNameInSchema "" ["used"] Nothing "used" `shouldSatisfy` isFailure+            it "should allow a name already in used if it is the old name" do+                validateNameInSchema "" ["used"] (Just "used") "used" `shouldBe` Success+            it "should allow legal names not already in use" do+                validateNameInSchema "" [] Nothing "new_name" `shouldBe` Success
+ Test/IDE/SchemaDesigner/ParserSpec.hs view
@@ -0,0 +1,1066 @@+{-|+Module: Test.IDE.SchemaDesigner.ParserSpec+Copyright: (c) digitally induced GmbH, 2020+-}+module Test.IDE.SchemaDesigner.ParserSpec where++import Test.Hspec+import IHP.Prelude+import qualified IHP.Postgres.Parser as Parser+import IHP.Postgres.Types+import qualified Text.Megaparsec as Megaparsec+import GHC.IO (evaluate)++tests = do+    describe "The Schema.sql Parser" do+        it "should parse an empty CREATE TABLE statement" do+            parseSql "CREATE TABLE users ();"  `shouldBe` StatementCreateTable (table "users")++        it "should parse an CREATE EXTENSION for the UUID extension" do+            parseSql "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\";" `shouldBe` CreateExtension { name = "uuid-ossp", ifNotExists = True }++        it "should parse an CREATE EXTENSION with schema suffix" do+            parseSql "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\" WITH SCHEMA public;" `shouldBe` CreateExtension { name = "uuid-ossp", ifNotExists = True }++        it "should parse an CREATE EXTENSION without quotes" do+            parseSql "CREATE EXTENSION IF NOT EXISTS fuzzystrmatch WITH SCHEMA public;" `shouldBe` CreateExtension { name = "fuzzystrmatch", ifNotExists = True }++        it "should parse a line comment" do+            parseSql "-- Comment value" `shouldBe` Comment { content = " Comment value" }++        it "should parse an empty comment" do+            parseSqlStatements "--\n--" `shouldBe` [ Comment { content = "" }, Comment { content = "" } ]++        it "should parse a CREATE TABLE with columns" do+            let sql = cs [plain|CREATE TABLE users (+                    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                    firstname TEXT NOT NULL,+                    lastname TEXT NOT NULL,+                    password_hash TEXT NOT NULL,+                    email TEXT NOT NULL,+                    company_id UUID NOT NULL,+                    picture_url TEXT,+                    created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL+                ); |]+            parseSql sql `shouldBe` StatementCreateTable (table "users")+                    { columns = [+                        (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                        , (col "firstname" PText) { notNull = True }+                        , (col "lastname" PText) { notNull = True }+                        , (col "password_hash" PText) { notNull = True }+                        , (col "email" PText) { notNull = True }+                        , (col "company_id" PUUID) { notNull = True }+                        , col "picture_url" PText+                        , (col "created_at" PTimestampWithTimezone) { defaultValue = Just (CallExpression "NOW" []), notNull = True }+                        ]+                    , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    , constraints = []+                    , unlogged = False+                    , inherits = Nothing+                    }++        it "should parse a CREATE TABLE with a generated column" do+            let sql = cs [plain|+                CREATE TABLE products (+                        ts tsvector GENERATED ALWAYS AS (setweight(to_tsvector('english', sku), 'A') || setweight(to_tsvector('english', name), 'B') || setweight(to_tsvector('english', description), 'C')) STORED+                );+            |]+            parseSql sql `shouldBe` StatementCreateTable (table "products")+                    { columns = [+                        (col "ts" PTSVector)+                            { generator = Just $ ColumnGenerator+                                        { generate =+                                            ConcatenationExpression+                                                (ConcatenationExpression+                                                    (CallExpression "setweight" [CallExpression "to_tsvector" [TextExpression "english",VarExpression "sku"],TextExpression "A"])+                                                    (CallExpression "setweight" [CallExpression "to_tsvector" [TextExpression "english",VarExpression "name"],TextExpression "B"])+                                                )+                                                (CallExpression "setweight" [CallExpression "to_tsvector" [TextExpression "english",VarExpression "description"],TextExpression "C"])+                                        , stored = True+                                        }+                            }+                        ]+                    }++        it "should parse a CREATE TABLE with quoted identifiers" do+            parseSql "CREATE TABLE \"quoted name\" ();" `shouldBe` StatementCreateTable (table "quoted name")++        it "should parse a CREATE TABLE with public schema prefix" do+            parseSql "CREATE TABLE public.users ();" `shouldBe` StatementCreateTable (table "users")++        it "should parse ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE CASCADE" do+            parseSql "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE CASCADE;" `shouldBe` AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Just Cascade+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE SET DEFAULT" do+            parseSql "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE SET DEFAULT;" `shouldBe` AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Just SetDefault+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE SET NULL" do+            parseSql "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE SET NULL;" `shouldBe` AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Just SetNull+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE RESTRICT" do+            parseSql "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE RESTRICT;" `shouldBe` AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Just Restrict+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE NO ACTION" do+            parseSql "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE NO ACTION;" `shouldBe` AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Just NoAction+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD FOREIGN KEY .. (without ON DELETE)" do+            parseSql "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id);" `shouldBe` AddConstraint+                    { tableName = "users"+                    , constraint = ForeignKeyConstraint+                        { name = "users_ref_company_id"+                        , columnName = "company_id"+                        , referenceTable = "companies"+                        , referenceColumn = "id"+                        , onDelete = Nothing+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. CHECK .." do+            parseSql "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (title <> '');" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = CheckConstraint+                        { name = "check_title_length"+                        , checkExpression = NotEqExpression (VarExpression "title") (TextExpression "")+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse a complex ALTER TABLE .. ADD CONSTRAINT .. CHECK .." do+            parseSql "ALTER TABLE properties ADD CONSTRAINT foobar CHECK ((property_type = 'haus_buy' AND area_garden IS NOT NULL AND rent_monthly IS NULL) OR (property_type = 'haus_rent' AND rent_monthly IS NOT NULL AND price IS NULL));" `shouldBe` AddConstraint+                    { tableName = "properties"+                    , constraint = CheckConstraint+                        { name = "foobar"+                        , checkExpression = OrExpression+                                (AndExpression+                                    (AndExpression+                                        (EqExpression (VarExpression "property_type") (TextExpression "haus_buy"))+                                        (IsExpression (VarExpression "area_garden") (NotExpression (VarExpression "NULL")))+                                    )+                                    (IsExpression (VarExpression "rent_monthly") (VarExpression "NULL"))+                                )++                                (AndExpression+                                    (AndExpression+                                        (EqExpression (VarExpression "property_type") (TextExpression "haus_rent"))+                                        (IsExpression (VarExpression "rent_monthly") (NotExpression (VarExpression "NULL")))+                                    )+                                    (IsExpression (VarExpression "price") (VarExpression "NULL"))+                                )+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. CHECK .. with a <" do+            parseSql "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (length(title) < 20);" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = CheckConstraint+                        { name = "check_title_length"+                        , checkExpression =+                            LessThanExpression+                                (CallExpression ("length") [VarExpression "title"])+                                (IntExpression 20)+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. CHECK .. with a <=" do+            parseSql "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (length(title) <= 20);" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = CheckConstraint+                        { name = "check_title_length"+                        , checkExpression =+                            LessThanOrEqualToExpression+                                (CallExpression ("length") [VarExpression "title"])+                                (IntExpression 20)+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. CHECK .. with a >" do+            parseSql "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (length(title) > 20);" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = CheckConstraint+                        { name = "check_title_length"+                        , checkExpression =+                            GreaterThanExpression+                                (CallExpression ("length") [VarExpression "title"])+                                (IntExpression 20)+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }+++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. CHECK .. with a >=" do+            parseSql "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (length(title) >= 20);" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = CheckConstraint+                        { name = "check_title_length"+                        , checkExpression =+                            GreaterThanOrEqualToExpression+                                (CallExpression ("length") [VarExpression "title"])+                                (IntExpression 20)+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .." do+            parseSql "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE (title WITH =, author WITH =);" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            , ExcludeConstraintElement { element = "author", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Nothing+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE USING btree .." do+            parseSql "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE USING btree (title WITH =, author WITH =);" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            , ExcludeConstraintElement { element = "author", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Just Btree+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE USING gin .." do+            parseSql "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE USING gin (title WITH =, author WITH =);" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            , ExcludeConstraintElement { element = "author", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Just Gin+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE USING gist .." do+            parseSql "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE USING gist (title WITH =, author WITH =);" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            , ExcludeConstraintElement { element = "author", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Just Gist+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. WHERE .." do+            parseSql "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE (title WITH =, author WITH =) WHERE (title = 'why');" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            , ExcludeConstraintElement { element = "author", operator = "=" }+                            ]+                        , predicate = Just $ EqExpression (VarExpression "title") (TextExpression "why")+                        , indexType = Nothing+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. WHERE .. with various operators" do+            parseSql "ALTER TABLE posts ADD CONSTRAINT unique_title_by_author EXCLUDE (i1 WITH =, i2 WITH <>, i3 WITH !=, i4 WITH AND, i5 WITH OR) WHERE (title = 'why');" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "i1", operator = "=" }+                            , ExcludeConstraintElement { element = "i2", operator = "<>" }+                            , ExcludeConstraintElement { element = "i3", operator = "!=" }+                            , ExcludeConstraintElement { element = "i4", operator = "AND" }+                            , ExcludeConstraintElement { element = "i5", operator = "OR" }+                            ]+                        , predicate = Just $ EqExpression (VarExpression "title") (TextExpression "why")+                        , indexType = Nothing+                        }+                    , deferrable = Nothing+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. DEFERRABLE" do+            parseSql "ALTER TABLE posts ADD CONSTRAINT deferrable_unique_title_by_author EXCLUDE (title WITH =) DEFERRABLE;" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "deferrable_unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Nothing+                        }+                    , deferrable = Just True+                    , deferrableType = Nothing+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. DEFERRABLE INITIALLY IMMEDIATE" do+            parseSql "ALTER TABLE posts ADD CONSTRAINT deferrable_unique_title_by_author EXCLUDE (title WITH =) DEFERRABLE INITIALLY IMMEDIATE;" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "deferrable_unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Nothing+                        }+                    , deferrable = Just True+                    , deferrableType = Just InitiallyImmediate+                    }++        it "should parse ALTER TABLE .. ADD CONSTRAINT .. EXCLUDE .. DEFERRABLE INITIALLY DEFERRED" do+            parseSql "ALTER TABLE posts ADD CONSTRAINT deferrable_unique_title_by_author EXCLUDE (title WITH =) DEFERRABLE INITIALLY DEFERRED;" `shouldBe` AddConstraint+                    { tableName = "posts"+                    , constraint = ExcludeConstraint+                        { name = "deferrable_unique_title_by_author"+                        , excludeElements =+                            [ ExcludeConstraintElement { element = "title", operator = "=" }+                            ]+                        , predicate = Nothing+                        , indexType = Nothing+                        }+                    , deferrable = Just True+                    , deferrableType = Just InitiallyDeferred+                    }++        it "should parse CREATE TYPE .. AS ENUM" do+            parseSql "CREATE TYPE colors AS ENUM ('yellow', 'red', 'green');" `shouldBe` CreateEnumType { name = "colors", values = ["yellow", "red", "green"] }++        it "should parse CREATE TYPE .. AS ENUM with extra whitespace" do+            parseSql "CREATE TYPE Numbers AS ENUM (\n\t'One',\t'Two',\t'Three',\t'Four',\t'Five',\t'Six',\t'Seven',\t'Eight',\t'Nine',\t'Ten'\n);" `shouldBe` CreateEnumType { name = "Numbers", values = ["One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", "Ten"] }++        -- When creating a new Enum Type, it is empty at first.+        -- Throwing an error for empty Enums renders the visual editor inaccessible.+        -- Catching empty Enums results in the "Create Enum" UI button being useless.+        -- Thats why empty Enums will not throw errors.+        it "should parse CREATE TYPE .. AS ENUM without values" do+            parseSql "CREATE TYPE colors AS ENUM ();" `shouldBe` CreateEnumType { name = "colors", values = [] }++        it "should parse ALTER TYPE .. ADD VALUE .." do+            parseSql "ALTER TYPE colors ADD VALUE 'blue';" `shouldBe` AddValueToEnumType { enumName = "colors", newValue = "blue", ifNotExists = False }++        it "should parse ALTER TYPE .. ADD VALUE IF NOT EXISTS .." do+            parseSql "ALTER TYPE colors ADD VALUE IF NOT EXISTS 'blue';" `shouldBe` AddValueToEnumType { enumName = "colors", newValue = "blue", ifNotExists = True }++        it "should parse a CREATE TABLE with INTEGER / INT / INT4 / SMALLINT / INT2 / BIGINT / INT8 columns" do+            parseSql "CREATE TABLE ints (int_a INTEGER, int_b INT, int_c int4, smallint_a SMALLINT, smallint_b INT2, bigint_a BIGINT, bigint_b int8);" `shouldBe` StatementCreateTable (table "ints")+                    { columns =+                        [ col "int_a" PInt+                        , col "int_b" PInt+                        , col "int_c" PInt+                        , col "smallint_a" PSmallInt+                        , col "smallint_b" PSmallInt+                        , col "bigint_a" PBigInt+                        , col "bigint_b" PBigInt+                        ]+                    }++        it "should parse a CREATE TABLE with TIMESTAMP WITH TIMEZONE / TIMESTAMPZ columns" do+            parseSql "CREATE TABLE timestamps (a TIMESTAMP WITH TIME ZONE, b TIMESTAMPZ);" `shouldBe` StatementCreateTable (table "timestamps")+                    { columns =+                        [ col "a" PTimestampWithTimezone+                        , col "b" PTimestampWithTimezone+                        ]+                    }++        it "should parse a CREATE TABLE with BOOLEAN / BOOL columns" do+            parseSql "CREATE TABLE bools (a BOOLEAN, b BOOL);" `shouldBe` StatementCreateTable (table "bools")+                    { columns =+                        [ col "a" PBoolean+                        , col "b" PBoolean+                        ]+                    }++        it "should parse a CREATE TABLE with REAL, FLOAT4, DOUBLE, FLOAT8 columns" do+            parseSql "CREATE TABLE bools (a REAL, b FLOAT4, c DOUBLE PRECISION, d FLOAT8);" `shouldBe` StatementCreateTable (table "bools")+                    { columns =+                        [ col "a" PReal+                        , col "b" PReal+                        , col "c" PDouble+                        , col "d" PDouble+                        ]+                    }++        it "should parse a CREATE TABLE with (deprecated) NUMERIC, NUMERIC(x), NUMERIC (x,y), VARYING(n) columns" do+            parseSql ("CREATE TABLE deprecated_variables (a NUMERIC, b NUMERIC(1), c NUMERIC(1,2), d CHARACTER VARYING(10));") `shouldBe` StatementCreateTable (table "deprecated_variables")+                    { columns =+                        [ col "a" (PNumeric Nothing Nothing)+                        , col "b" (PNumeric (Just 1) Nothing)+                        , col "c" (PNumeric (Just 1) (Just 2))+                        , col "d" (PVaryingN (Just 10))+                        ]+                    }++        it "should parse a CREATE TABLE statement with a multi-column UNIQUE (a, b) constraint" do+            parseSql "CREATE TABLE user_followers (id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, user_id UUID NOT NULL, follower_id UUID NOT NULL, UNIQUE(user_id, follower_id));"  `shouldBe` StatementCreateTable (table "user_followers")+                    { columns =+                        [ (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+                        , (col "user_id" PUUID) { notNull = True }+                        , (col "follower_id" PUUID) { notNull = True }+                        ]+                    , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    , constraints = [ UniqueConstraint { name = Nothing, columnNames = [ "user_id", "follower_id" ] } ]+                    , unlogged = False+                    , inherits = Nothing+                    }++        it "should fail to parse a CREATE TABLE statement with an empty UNIQUE () constraint" do+            (evaluate (parseSql "CREATE TABLE user_followers (id UUID, UNIQUE());")) `shouldThrow` anyException+            pure ()++        it "should parse a CREATE TABLE statement with a multi-column PRIMARY KEY (a, b) constraint" do+            parseSql "CREATE TABLE user_followers (user_id UUID NOT NULL, follower_id UUID NOT NULL, PRIMARY KEY (user_id, follower_id));"  `shouldBe` StatementCreateTable (table "user_followers")+                    { columns =+                        [ (col "user_id" PUUID) { notNull = True }+                        , (col "follower_id" PUUID) { notNull = True }+                        ]+                    , primaryKeyConstraint = PrimaryKeyConstraint [ "user_id", "follower_id" ]+                    }++        it "should fail to parse a CREATE TABLE statement with PRIMARY KEY column and table constraints" do+            (evaluate (parseSql "CREATE TABLE user_followers (id UUID PRIMARY KEY, PRIMARY KEY(id));")) `shouldThrow` anyException+            pure ()++        it "should fail to parse a CREATE TABLE statement with an empty PRIMARY KEY () constraint" do+            (evaluate (parseSql "CREATE TABLE user_followers (id UUID, PRIMARY KEY ());")) `shouldThrow` anyException+            pure ()++        it "should parse a CREATE TABLE statement with a serial id" do+            parseSql "CREATE TABLE orders (\n    id SERIAL PRIMARY KEY NOT NULL\n);\n" `shouldBe` StatementCreateTable (table "orders")+                    { columns = [ (col "id" PSerial) { notNull = True} ]+                    , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    }++        it "should parse a CREATE TABLE statement with a bigserial id" do+            parseSql "CREATE TABLE orders (\n    id BIGSERIAL PRIMARY KEY NOT NULL\n);\n" `shouldBe` StatementCreateTable (table "orders")+                    { columns = [ (col "id" PBigserial) { notNull = True} ]+                    , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    }++        it "should parse a column with NOT NULL before DEFAULT" do+            parseSql "CREATE TABLE tasks (is_completed BOOLEAN NOT NULL DEFAULT false);" `shouldBe` StatementCreateTable (table "tasks")+                    { columns = [ (col "is_completed" PBoolean) { defaultValue = Just (VarExpression "false"), notNull = True } ]+                    }++        it "should parse column modifiers in mixed order" do+            parseSql "CREATE TABLE orders (id UUID PRIMARY KEY DEFAULT uuid_generate_v4() NOT NULL);" `shouldBe` StatementCreateTable (table "orders")+                    { columns = [ (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True } ]+                    , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    }++        it "should parse a CREATE TABLE statement with an array column" do+            parseSql "CREATE TABLE array_tests (\n    pay_by_quarter integer[]\n);\n" `shouldBe` StatementCreateTable (table "array_tests")+                    { columns = [ col "pay_by_quarter" (PArray PInt) ]+                    }++        it "should parse a CREATE TABLE statement with a point column" do+            parseSql "CREATE TABLE points (\n    pos POINT\n);\n" `shouldBe` StatementCreateTable (table "points")+                    { columns = [ col "pos" PPoint ]+                    }++        it "should parse a CREATE TABLE statement with a polygon column" do+            parseSql "CREATE TABLE polygons (\n    poly POLYGON\n);\n" `shouldBe` StatementCreateTable (table "polygons")+                    { columns = [ col "poly" PPolygon ]+                    }++        it "should parse a CREATE INDEX statement" do+            parseSql "CREATE INDEX users_index ON users (user_name);\n" `shouldBe` CreateIndex+                    { indexName = "users_index"+                    , unique = False+                    , tableName = "users"+                    , columns = [indexCol (VarExpression "user_name")]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }++        it "should parse a 'CREATE INDEX .. ON .. USING GIN' statement" do+            parseSql "CREATE INDEX users_index ON users USING GIN (user_name);\n" `shouldBe` CreateIndex+                    { indexName = "users_index"+                    , unique = False+                    , tableName = "users"+                    , columns = [indexCol (VarExpression "user_name")]+                    , whereClause = Nothing+                    , indexType = Just Gin+                    }++        it "should parse a 'CREATE INDEX .. ON .. USING btree' statement" do+            parseSql "CREATE INDEX users_index ON users USING btree (user_name);\n" `shouldBe` CreateIndex+                    { indexName = "users_index"+                    , unique = False+                    , tableName = "users"+                    , columns = [indexCol (VarExpression "user_name")]+                    , whereClause = Nothing+                    , indexType = Just Btree+                    }++        it "should parse a 'CREATE INDEX .. ON .. USING GIST' statement" do+            parseSql "CREATE INDEX users_index ON users USING GIST (user_name);\n" `shouldBe` CreateIndex+                    { indexName = "users_index"+                    , unique = False+                    , tableName = "users"+                    , columns = [indexCol (VarExpression "user_name")]+                    , whereClause = Nothing+                    , indexType = Just Gist+                    }++        it "should parse a CREATE INDEX statement with multiple columns" do+            parseSql "CREATE INDEX users_index ON users (user_name, project_id);\n" `shouldBe` CreateIndex+                    { indexName = "users_index"+                    , unique = False+                    , tableName = "users"+                    , columns =+                        [ indexCol (VarExpression "user_name")+                        , indexCol (VarExpression "project_id")+                        ]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }+        it "should parse a CREATE INDEX statement with a LOWER call" do+            parseSql "CREATE INDEX users_email_index ON users (LOWER(email));\n" `shouldBe` CreateIndex+                    { indexName = "users_email_index"+                    , unique = False+                    , tableName = "users"+                    , columns = [indexCol (CallExpression "LOWER" [VarExpression "email"])]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }+        it "should parse a CREATE UNIQUE INDEX statement" do+            parseSql "CREATE UNIQUE INDEX users_index ON users (user_name);\n" `shouldBe` CreateIndex+                    { indexName = "users_index"+                    , unique = True+                    , tableName = "users"+                    , columns = [indexCol (VarExpression "user_name")]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }++        it "should parse a CREATE INDEX with column order ASC NULLS FIRST statement" do+            parseSql "CREATE UNIQUE INDEX users_index ON users (user_name ASC NULLS FIRST);\n" `shouldBe` CreateIndex+                    { indexName = "users_index"+                    , unique = True+                    , tableName = "users"+                    , columns = [IndexColumn { column = VarExpression "user_name", columnOrder = [Asc, NullsFirst] }]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }++        it "should parse a CREATE INDEX with column order DESC NULLS LAST statement" do+            parseSql "CREATE UNIQUE INDEX users_index ON users (user_name DESC NULLS LAST);\n" `shouldBe` CreateIndex+                    { indexName = "users_index"+                    , unique = True+                    , tableName = "users"+                    , columns = [IndexColumn { column = VarExpression "user_name", columnOrder = [Desc, NullsLast] }]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }++        it "should parse a CREATE INDEX with a coalesce expression" do+            parseSql "CREATE UNIQUE INDEX user_invite_uniqueness ON user_invites (organization_id, email, coalesce(expires_at, '0001-01-01 01:01:01-04'));\n" `shouldBe` CreateIndex+                    { indexName = "user_invite_uniqueness"+                    , unique = True+                    , tableName = "user_invites"+                    , columns =+                            [ indexCol (VarExpression "organization_id")+                            , indexCol (VarExpression "email")+                            , indexCol (CallExpression "coalesce" [VarExpression "expires_at", TextExpression "0001-01-01 01:01:01-04"])+                            ]+                    , whereClause = Nothing+                    , indexType = Nothing+                    }++        it "should parse a CREATE OR REPLACE FUNCTION ..() RETURNS TRIGGER .." do+            parseSql "CREATE OR REPLACE FUNCTION notify_did_insert_webrtc_connection() RETURNS TRIGGER AS $$ BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; $$ language plpgsql;" `shouldBe` (function "notify_did_insert_webrtc_connection")+                    { functionBody = " BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; "+                    , orReplace = True+                    }++        it "should parse a CREATE FUNCTION ..() RETURNS TRIGGER .." do+            parseSql "CREATE FUNCTION notify_did_insert_webrtc_connection() RETURNS TRIGGER AS $$ BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; $$ language plpgsql;" `shouldBe` (function "notify_did_insert_webrtc_connection")+                    { functionBody = " BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; "+                    }++        it "should parse a CREATE FUNCTION with parameters ..() RETURNS TRIGGER .." do+            parseSql "CREATE FUNCTION notify_did_insert_webrtc_connection(param1 INT, param2 TEXT) RETURNS TRIGGER AS $$ BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; $$ language plpgsql;" `shouldBe` (function "notify_did_insert_webrtc_connection")+                    { functionArguments = [("param1", PInt), ("param2", PText)]+                    , functionBody = " BEGIN PERFORM pg_notify('did_insert_webrtc_connection', json_build_object('id', NEW.id, 'floor_id', NEW.floor_id, 'source_user_id', NEW.source_user_id, 'target_user_id', NEW.target_user_id)::text); RETURN NEW; END; "+                    }++        it "should parse CREATE FUNCTION statements that are outputted by pg_dump" do+            let sql = cs [plain|+CREATE FUNCTION public.notify_did_change_projects() RETURNS trigger+    LANGUAGE plpgsql+    AS $$BEGIN+    PERFORM pg_notify('did_change_projects', '');+    RETURN new;END;+$$;+            |]+            parseSql sql `shouldBe` (function "notify_did_change_projects")+                    { functionBody = "BEGIN\n    PERFORM pg_notify('did_change_projects', '');\n    RETURN new;END;\n"+                    }++        it "should parse CREATE FUNCTION statements that returns an event_trigger" do+            let sql = cs [plain|+                CREATE FUNCTION public.a() RETURNS event_trigger+                    LANGUAGE plpgsql+                    AS $$ BEGIN SELECT 1; END; $$;+            |]+            parseSql sql `shouldBe` (function "a")+                    { functionBody = " BEGIN SELECT 1; END; "+                    , returns = PEventTrigger+                    }++        it "should parse a CREATE FUNCTION with SECURITY DEFINER" do+            parseSql "CREATE FUNCTION my_func() RETURNS TRIGGER LANGUAGE plpgsql SECURITY DEFINER AS $$ BEGIN RETURN NEW; END; $$ ;" `shouldBe` (function "my_func")+                    { functionBody = " BEGIN RETURN NEW; END; "+                    , securityDefiner = True+                    }++        it "should parse a decimal default value with a type-cast" do+            let sql = "CREATE TABLE a(electricity_unit_price DOUBLE PRECISION DEFAULT 0.17::double precision NOT NULL);"+            let statements =+                    [ StatementCreateTable (table "a") { columns = [(col "electricity_unit_price" PDouble) { defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True }] }+                    ]+            parseSqlStatements sql `shouldBe` statements++        it "should parse a integer default value" do+            let sql = "CREATE TABLE a(electricity_unit_price INT DEFAULT 0 NOT NULL);"+            let statements =+                    [ StatementCreateTable (table "a") { columns = [(col "electricity_unit_price" PInt) { defaultValue = Just (IntExpression 0), notNull = True }] }+                    ]+            parseSqlStatements sql `shouldBe` statements++        it "should parse a partial index" do+            parseSql "CREATE UNIQUE INDEX unique_source_id ON listings (source, source_id) WHERE source IS NOT NULL AND source_id IS NOT NULL;" `shouldBe` CreateIndex+                    { indexName = "unique_source_id"+                    , unique = True+                    , tableName = "listings"+                    , columns =+                        [ indexCol (VarExpression "source")+                        , indexCol (VarExpression "source_id")+                        ]+                    , whereClause = Just (+                        AndExpression+                            (IsExpression (VarExpression "source") (NotExpression (VarExpression "NULL")))+                            (IsExpression (VarExpression "source_id") (NotExpression (VarExpression "NULL"))))+                    , indexType = Nothing+                    }++        it "should parse 'ENABLE ROW LEVEL SECURITY' statements" do+            parseSql "ALTER TABLE tasks ENABLE ROW LEVEL SECURITY;" `shouldBe` EnableRowLevelSecurity { tableName = "tasks" }++        it "should parse 'CREATE POLICY' statements" do+            parseSql "CREATE POLICY \"Users can manage their tasks\" ON tasks USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());" `shouldBe`+                    (policy "Users can manage their tasks" "tasks")+                    { using = Just (+                        EqExpression+                            (VarExpression "user_id")+                            (CallExpression "ihp_user_id" [])+                        )+                    , check = Just (+                        EqExpression+                            (VarExpression "user_id")+                            (CallExpression "ihp_user_id" [])+                        )+                    }+        it "should parse 'ALTER TABLE .. ADD COLUMN' statements" do+            parseSql "ALTER TABLE a ADD COLUMN b INT NOT NULL;" `shouldBe` AddColumn { tableName = "a", column = (col "b" PInt) { notNull = True } }++        it "should parse 'ALTER TABLE .. DROP COLUMN ..' statements" do+            parseSql "ALTER TABLE tasks DROP COLUMN description;" `shouldBe` DropColumn { tableName = "tasks", columnName = "description" }++        it "should parse 'ALTER TABLE .. RENAME COLUMN .. TO ..' statements" do+            parseSql "ALTER TABLE users RENAME COLUMN name TO full_name;" `shouldBe` RenameColumn { tableName = "users", from = "name", to = "full_name" }++        it "should parse 'DROP TABLE ..' statements" do+            parseSql "DROP TABLE tasks;" `shouldBe` DropTable { tableName = "tasks" }++        it "should parse 'DROP TYPE ..' statements" do+            parseSql "DROP TYPE colors;" `shouldBe` DropEnumType { name = "colors" }++        it "should parse 'ALTER TABLE .. DROP CONSTRAINT ..' statements" do+            parseSql "ALTER TABLE tasks DROP CONSTRAINT tasks_title_key;" `shouldBe` DropConstraint { tableName = "tasks", constraintName = "tasks_title_key" }++        it "should parse 'CREATE SEQUENCE ..' statements" do+            parseSql "CREATE SEQUENCE a;" `shouldBe` CreateSequence { name = "a" }++        it "should parse 'CREATE SEQUENCE ..' statements with qualified name" do+            parseSql "CREATE SEQUENCE public.a;" `shouldBe` CreateSequence { name = "a" }++        it "should parse 'CREATE SEQUENCE .. AS .. START WITH .. INCREMENT BY .. NO MINVALUE NO MAXVALUE CACHE ..;'" do+            let sql = [trimming|+                CREATE SEQUENCE public.a+                    AS integer+                    START WITH 1+                    INCREMENT BY 1+                    NO MINVALUE+                    NO MAXVALUE+                    CACHE 1;+            |]+            parseSql sql `shouldBe` CreateSequence { name = "a" }++        it "should parse 'SET' statements" do+            parseSql "SET statement_timeout = 0;" `shouldBe` Set { name = "statement_timeout", value = IntExpression 0 }+            parseSql "SET client_encoding = 'UTF8';" `shouldBe` Set { name = "client_encoding", value = TextExpression "UTF8" }++        it "should parse 'SELECT' statements" do+            parseSql "SELECT pg_catalog.set_config('search_path', '', false);" `shouldBe` SelectStatement { query = "pg_catalog.set_config('search_path', '', false)" }+        it "should parse 'COMMENT' statements" do+            parseSql "COMMENT ON EXTENSION \"uuid-ossp\" IS 'generate universally unique identifiers (UUIDs)';" `shouldBe` Comment { content = "ON EXTENSION \"uuid-ossp\" IS 'generate universally unique identifiers (UUIDs)'" }++        it "should parse a column with a default value that has a qualified function call" do+            let sql = cs [plain|+                CREATE TABLE a(id UUID DEFAULT public.uuid_generate_v4() NOT NULL);+            |]+            let statement = StatementCreateTable (table "a") { columns = [(col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }] }+            parseSql sql `shouldBe` statement+++        it "should parse character varying type casts" do+            let sql = cs [plain|+                CREATE TABLE a (+                    a character varying(510) DEFAULT NULL::character varying+                );+            |]+            let statement = StatementCreateTable (table "a")+                    { columns = [ (col "a" (PVaryingN (Just 510)))+                            { defaultValue = Just (TypeCastExpression (VarExpression "NULL") (PVaryingN Nothing))+                            }+                        ]+                    }+            parseSql sql `shouldBe` statement++        it "should parse empty binary strings" do+            let sql = cs [plain|+                CREATE TABLE a (+                    a bytea DEFAULT '\\x'::bytea NOT NULL+                );+            |]+            let statement = StatementCreateTable (table "a")+                    { columns = [ (col "a" PBinary)+                            { defaultValue = Just (TypeCastExpression (TextExpression "") PBinary)+                            , notNull = True+                            }+                        ]+                    }+            parseSql sql `shouldBe` statement+        it "should parse a pg_dump header" do+            let sql = cs [plain|+--+-- PostgreSQL database dump+--++-- Dumped from database version 13.3+-- Dumped by pg_dump version 13.3++SET statement_timeout = 0;+SET lock_timeout = 0;+SET idle_in_transaction_session_timeout = 0;+SET client_encoding = 'UTF8';+SET standard_conforming_strings = on;+SELECT pg_catalog.set_config('search_path', '', false);+SET check_function_bodies = false;+SET xmloption = content;+SET client_min_messages = warning;+SET row_security = off;++--+-- Name: uuid-ossp; Type: EXTENSION; Schema: -; Owner: -+--++CREATE EXTENSION IF NOT EXISTS "uuid-ossp" WITH SCHEMA public;+++--+-- Name: EXTENSION "uuid-ossp"; Type: COMMENT; Schema: -; Owner: -+--++COMMENT ON EXTENSION "uuid-ossp" IS 'generate universally unique identifiers (UUIDs)';+++            |]++            let statements =+                    [ Comment {content = ""}+                    , Comment {content = " PostgreSQL database dump"}+                    , Comment {content = ""}+                    , Comment {content = " Dumped from database version 13.3"}+                    , Comment {content = " Dumped by pg_dump version 13.3"}+                    , Set {name = "statement_timeout", value = IntExpression 0}+                    , Set {name = "lock_timeout", value = IntExpression 0}+                    , Set {name = "idle_in_transaction_session_timeout", value = IntExpression 0}+                    , Set {name = "client_encoding", value = TextExpression "UTF8"}+                    , Set {name = "standard_conforming_strings", value = VarExpression "on"}+                    , SelectStatement {query = "pg_catalog.set_config('search_path', '', false)"}+                    , Set {name = "check_function_bodies", value = VarExpression "false"}+                    , Set {name = "xmloption", value = VarExpression "content"}+                    , Set {name = "client_min_messages", value = VarExpression "warning"}+                    , Set {name = "row_security", value = VarExpression "off"}+                    , Comment {content = ""}+                    , Comment {content = " Name: uuid-ossp; Type: EXTENSION; Schema: -; Owner: -"}+                    , Comment {content = ""}+                    , CreateExtension {name = "uuid-ossp", ifNotExists = True}+                    , Comment {content = ""}+                    , Comment {content = " Name: EXTENSION \"uuid-ossp\"; Type: COMMENT; Schema: -; Owner: -"}+                    , Comment {content = ""}+                    , Comment {content = "ON EXTENSION \"uuid-ossp\" IS 'generate universally unique identifiers (UUIDs)'"}+                    ]+            parseSqlStatements sql `shouldBe` statements++        it "should parse 'DROP INDEX ..' statements" do+            parseSql "DROP INDEX a;" `shouldBe` DropIndex { indexName = "a" }++        it "should parse 'ALTER TABLE .. ALTER COLUMN .. DROP NOT NULL' statements" do+            parseSql "ALTER TABLE a ALTER COLUMN b DROP NOT NULL;" `shouldBe` DropNotNull { tableName = "a", columnName = "b" }++        it "should parse 'ALTER TABLE .. ALTER COLUMN .. SET NOT NULL' statements" do+            parseSql "ALTER TABLE a ALTER COLUMN b SET NOT NULL;" `shouldBe` SetNotNull { tableName = "a", columnName = "b" }++        it "should parse 'ALTER TABLE .. ALTER COLUMN .. SET DEFAULT ..' statements" do+            parseSql "ALTER TABLE a ALTER COLUMN b SET DEFAULT null;" `shouldBe` SetDefaultValue { tableName = "a", columnName = "b", value = VarExpression "null" }++        it "should parse 'ALTER TABLE .. ALTER COLUMN .. DROP DEFAULT' statements" do+            parseSql "ALTER TABLE a ALTER COLUMN b DROP DEFAULT;" `shouldBe` DropDefaultValue { tableName = "a", columnName = "b" }++        it "should parse 'ALTER TABLE .. RENAME TO ..' statements" do+            parseSql "ALTER TABLE profiles RENAME TO users;" `shouldBe` RenameTable { from = "profiles", to = "users" }++        it "should parse 'DROP POLICY .. ON ..' statements" do+            parseSql "DROP POLICY \"Users can manage their todos\" ON todos;" `shouldBe` DropPolicy { tableName = "todos", policyName = "Users can manage their todos" }++        it "should parse 'CREATE POLICY .. FOR SELECT' statements" do+            let sql = cs [plain|CREATE POLICY "Messages are public" ON messages FOR SELECT USING (true);|]+            parseSql sql `shouldBe` CreatePolicy+                    { name = "Messages are public"+                    , action = Just PolicyForSelect+                    , tableName = "messages"+                    , using = Just (VarExpression "true")+                    , check = Nothing+                    }++        it "should parse policies with an EXISTS condition" do+            let sql = cs [plain|CREATE POLICY "Users can manage their project's migrations" ON migrations USING (EXISTS (SELECT 1 FROM projects WHERE id = project_id)) WITH CHECK (EXISTS (SELECT 1 FROM projects WHERE id = project_id));|]+            parseSql sql `shouldBe`+                    (policy "Users can manage their project's migrations" "migrations")+                    { using = Just (ExistsExpression (SelectExpression (Select {columns = [IntExpression 1], from = VarExpression "projects", alias = Nothing, whereClause = EqExpression (VarExpression "id") (VarExpression "project_id")})))+                    , check = Just (ExistsExpression (SelectExpression (Select {columns = [IntExpression 1], from = VarExpression "projects", alias = Nothing, whereClause = EqExpression (VarExpression "id") (VarExpression "project_id")})))+                    }++        it "should parse policies with an EXISTS condition and a qualified table name" do+            let sql = cs [plain|CREATE POLICY "Users can manage their project's migrations" ON migrations USING (EXISTS (SELECT 1 FROM public.projects WHERE projects.id = migrations.project_id)) WITH CHECK (EXISTS (SELECT 1 FROM public.projects WHERE projects.id = migrations.project_id));|]+            parseSql sql `shouldBe`+                    (policy "Users can manage their project's migrations" "migrations")+                    { using = Just (ExistsExpression (SelectExpression (Select {columns = [IntExpression 1], from = DotExpression (VarExpression "public") "projects", alias = Nothing, whereClause = EqExpression (DotExpression (VarExpression "projects") "id") (DotExpression (VarExpression "migrations") "project_id")})))+                    , check = Just (ExistsExpression (SelectExpression (Select {columns = [IntExpression 1], from = DotExpression (VarExpression "public") "projects", alias = Nothing, whereClause = EqExpression (DotExpression (VarExpression "projects") "id") (DotExpression (VarExpression "migrations") "project_id")})))+                    }++        it "should parse a call expression with multiple arguments" do+            let sql = cs [plain|ALTER TABLE a ADD CONSTRAINT source CHECK (num_nonnulls(a, b, c) = 1);|]+            parseSql sql `shouldBe`  AddConstraint+                { tableName = "a"+                , constraint = CheckConstraint+                    { name = Just "source"+                    , checkExpression = EqExpression (CallExpression "num_nonnulls" [VarExpression "a",VarExpression "b",VarExpression "c"]) (IntExpression 1)+                    }+                , deferrable = Nothing+                , deferrableType = Nothing+                }++        it "should parse 'CREATE TRIGGER .. AFTER INSERT ON .. FOR EACH ROW EXECUTE ..;' statements" do+            parseSql "CREATE TRIGGER call_test_function_for_new_users AFTER INSERT ON public.users FOR EACH ROW EXECUTE FUNCTION call_test_function('hello');" `shouldBe` CreateTrigger+                    { name = "call_test_function_for_new_users"+                    , eventWhen = After+                    , event = [TriggerOnInsert]+                    , tableName = "users"+                    , for = ForEachRow+                    , whenCondition = Nothing+                    , functionName = "call_test_function"+                    , arguments = [TextExpression "hello"]+                    }++        it "should parse 'CREATE TRIGGER .. AFTER INSERT OR UPDATE ON ..' statements" do+            parseSql "CREATE TRIGGER my_trigger AFTER INSERT OR UPDATE ON public.posts FOR EACH ROW EXECUTE FUNCTION my_function();" `shouldBe` CreateTrigger+                    { name = "my_trigger"+                    , eventWhen = After+                    , event = [TriggerOnInsert, TriggerOnUpdate]+                    , tableName = "posts"+                    , for = ForEachRow+                    , whenCondition = Nothing+                    , functionName = "my_function"+                    , arguments = []+                    }++        it "should parse 'CREATE EVENT TRIGGER ..' statements" do+            let sql = cs [plain|+                CREATE EVENT TRIGGER trigger_update_schema+                ON ddl_command_end+                WHEN TAG IN ('CREATE TABLE', 'ALTER TABLE', 'DROP TABLE')+                EXECUTE FUNCTION update_tables_and_columns();+            |]+            parseSql sql `shouldBe` CreateEventTrigger+                    { name = "trigger_update_schema"+                    , eventOn = "ddl_command_end"+                    , whenCondition =  Just (InExpression (VarExpression "TAG") (InArrayExpression [TextExpression "CREATE TABLE", TextExpression "ALTER TABLE", TextExpression "DROP TABLE"]))+                    , functionName = "update_tables_and_columns"+                    , arguments = []+                    }++        it "should parse 'ALTER SEQUENCE ..' statements" do+            let sql = cs [plain|ALTER SEQUENCE public.a OWNED BY public.b.serial_number;|]+            parseSql sql `shouldBe` UnknownStatement { raw = "ALTER SEQUENCE public.a OWNED BY public.b.serial_number" }++        it "should parse positive IntExpression's" do+            parseExpression "1" `shouldBe` (IntExpression 1)++        it "should parse negative IntExpression's" do+            parseExpression "-1" `shouldBe` (IntExpression (-1))++        it "should parse positive DoubleExpression's" do+            parseExpression "1.337" `shouldBe` (DoubleExpression 1.337)++        it "should parse negative DoubleExpression's" do+            parseExpression "-1.337" `shouldBe` (DoubleExpression (-1.337))++        it "should parse lower-cased SELECT expressions" do+            parseExpression "(select company_id from users where id = ihp_user_id())" `shouldBe` SelectExpression (Select {columns = [VarExpression "company_id"], from = VarExpression "users", alias = Nothing, whereClause = EqExpression (VarExpression "id") (CallExpression "ihp_user_id" [])})++        it "should parse policies with an alias in the USING expression" do+            let sql = cs [plain|+                CREATE POLICY "Users can see other users in their company" ON public.users USING ((company_id = ( SELECT users_1.company_id+                   FROM public.users users_1+                  WHERE (users_1.id = public.ihp_user_id()))));+            |]+            parseSql sql `shouldBe`+                    (policy "Users can see other users in their company" "users")+                    { using = Just (EqExpression (VarExpression "company_id") (SelectExpression (Select {columns = [DotExpression (VarExpression "users_1") "company_id"], from = DotExpression (VarExpression "public") "users", alias = Just "users_1", whereClause = EqExpression (DotExpression (VarExpression "users_1") "id") (CallExpression "ihp_user_id" [])})))+                    }++        it "should parse 'BEGIN' statements" do+            let sql = cs [plain|BEGIN;|]+            parseSql sql `shouldBe` Begin++        it "should parse 'COMMIT' statements" do+            let sql = cs [plain|COMMIT;|]+            parseSql sql `shouldBe` Commit+        +        it "should parse 'DROP FUNCTION ..' statements" do+            let sql = cs [plain|DROP FUNCTION my_function;|]+            parseSql sql `shouldBe` DropFunction { functionName = "my_function" }+        +        it "should parse 'CREATE TABLE ..' statements when the table name starts with public" do+            let sql = cs [plain|CREATE TABLE public_variables (id UUID);|]+            parseSql sql `shouldBe` StatementCreateTable (table "public_variables") { columns = [col "id" PUUID] }++        it "should parse an 'CREATE UNLOGGED TABLE' statement" do+            parseSql "CREATE UNLOGGED TABLE pg_large_notifications ();"  `shouldBe` StatementCreateTable (table "pg_large_notifications") { unlogged = True }++        it "should ignore restrict lines" do+            let sql = [trimming|+                \restrict LjgPjBgHVdXUE0a19ZenYCd3Zs2dsdUxghYk15OGwb4zzkNflnbsZ4rQo7Eqm5G+                \unrestrict LjgPjBgHVdXUE0a19ZenYCd3Zs2dsdUxghYk15OGwb4zzkNflnbsZ4rQo7Eqm5G+            |]+            parseSqlStatements sql `shouldBe` [Comment { content = "" }, Comment { content = "" }]++parseSql :: Text -> Statement+parseSql sql = let [statement] = parseSqlStatements sql in statement++parseSqlStatements :: Text -> [Statement]+parseSqlStatements sql =+    case Megaparsec.runParser Parser.parseDDL "input" sql of+            Left parserError -> error (cs $ Megaparsec.errorBundlePretty parserError) -- For better error reporting in hspec+            Right statements -> statements++parseExpression :: Text -> Expression+parseExpression sql =+    case Megaparsec.runParser Parser.expression "input" sql of+            Left parserError -> error (cs $ Megaparsec.errorBundlePretty parserError) -- For better error reporting in hspec+            Right expression -> expression
+ Test/IDE/SchemaDesigner/SchemaOperationsSpec.hs view
@@ -0,0 +1,499 @@+module Test.IDE.SchemaDesigner.SchemaOperationsSpec where++import Test.Hspec+import IHP.Prelude+import IHP.Postgres.Types+import qualified IHP.IDE.SchemaDesigner.SchemaOperations as SchemaOperations+import qualified IHP.Postgres.Parser as Parser+import qualified Text.Megaparsec as Megaparsec++tests = do+    describe "IHP.IDE.SchemaDesigner.SchemaOperations" do+        let tableA = StatementCreateTable (table "a")+        let tableB = StatementCreateTable (table "b")+        let enumA = CreateEnumType { name = "enumA", values = [] }+        let enumB = CreateEnumType { name = "enumB", values = [] }+        let comment = Comment { content = "comment" }+        describe "addEnum" do+            it "should prepend the enum" do+                let inputSchema = [tableA, tableB]+                let expectedSchema = [enumA, tableA, tableB ]++                (SchemaOperations.addEnum "enumA" inputSchema) `shouldBe` expectedSchema++            it "should prepend the enum, but after existing enums" do++                let inputSchema = [enumA, tableA]+                let expectedSchema = [enumA, enumB, tableA]++                (SchemaOperations.addEnum "enumB" inputSchema) `shouldBe` expectedSchema+            +            it "should deal with the empty case" do+                let inputSchema = []+                let expectedSchema = [enumA]++                (SchemaOperations.addEnum "enumA" inputSchema) `shouldBe` expectedSchema++            it "should ignore comments" do+                let inputSchema = [comment, enumA, tableA]+                let expectedSchema = [comment, enumA, enumB, tableA]++                (SchemaOperations.addEnum "enumB" inputSchema) `shouldBe` expectedSchema++        describe "enableRowLevelSecurity" do+            it "should enable row level security if not enabled yet" do+                let inputSchema = [tableA]+                let expectedSchema = [tableA, EnableRowLevelSecurity { tableName = "a"} ]++                (SchemaOperations.enableRowLevelSecurity "a" inputSchema) `shouldBe` expectedSchema+            +            it "should not do anything if already enabled" do+                let inputSchema = [tableA, EnableRowLevelSecurity { tableName = "a"} ]+                let expectedSchema = [tableA, EnableRowLevelSecurity { tableName = "a"} ]++                (SchemaOperations.enableRowLevelSecurity "a" inputSchema) `shouldBe` expectedSchema+        +        describe "disableRowLevelSecurity" do+            it "should disable row level security if enabled" do+                let inputSchema = [tableA, EnableRowLevelSecurity { tableName = "a"}]+                let expectedSchema = [tableA]++                (SchemaOperations.disableRowLevelSecurity "a" inputSchema) `shouldBe` expectedSchema+            +            it "should not do anything if the row level security is not enabled" do+                let inputSchema = [tableA]+                let expectedSchema = [tableA]++                (SchemaOperations.disableRowLevelSecurity "a" inputSchema) `shouldBe` expectedSchema+        +        describe "disableRowLevelSecurityIfNoPolicies" do+            it "should disable row level security if there's no policy" do+                let inputSchema = [tableA, EnableRowLevelSecurity { tableName = "a"}]+                let expectedSchema = [tableA]++                (SchemaOperations.disableRowLevelSecurityIfNoPolicies "a" inputSchema) `shouldBe` expectedSchema+            +            it "should not do anything if the row level security is not enabled" do+                let inputSchema = [tableA]++                (SchemaOperations.disableRowLevelSecurityIfNoPolicies "a" inputSchema) `shouldBe` inputSchema+            +            it "should not do anything if there's a policy" do+                let p = policy "p" "a"+                let inputSchema = [tableA, EnableRowLevelSecurity { tableName = "a"}, p]++                (SchemaOperations.disableRowLevelSecurityIfNoPolicies "a" inputSchema) `shouldBe` inputSchema++        describe "deleteTable" do+            it "delete a table with all it's indices, constraints, policies, enable RLS statements, triggers" do+                let inputSchema = parseSqlStatements [trimming|+                    CREATE TABLE users ();+                    CREATE TABLE tasks ();+                    CREATE INDEX tasks_user_id_index ON tasks (user_id);+                    ALTER TABLE tasks ADD CONSTRAINT tasks_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                    CREATE POLICY "Users can manage their tasks" ON tasks USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());+                    ALTER TABLE tasks ENABLE ROW LEVEL SECURITY;+                    CREATE TRIGGER update_tasks_updated_at BEFORE UPDATE ON tasks FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();+                |]+                let outputSchema = parseSqlStatements [trimming|+                    CREATE TABLE users ();+                |]++                SchemaOperations.deleteTable "tasks" inputSchema `shouldBe` outputSchema++        describe "suggestPolicy" do+            it "should suggest a policy if a user_id column exists" do+                let postsTable = StatementCreateTable (table "posts")+                                { columns =+                                    [ (col "user_id" PUUID) { notNull = True }+                                    ]+                                }+                let schema = [postsTable]+                let expectedPolicy = (policy "Users can manage their posts" "posts")+                        { using = Just (EqExpression (VarExpression "user_id") (CallExpression "ihp_user_id" []))+                        , check = Just (EqExpression (VarExpression "user_id") (CallExpression "ihp_user_id" []))+                        }++                SchemaOperations.suggestPolicy schema postsTable `shouldBe` expectedPolicy++            it "should suggest an empty policy if no user_id column exists" do+                let postsTable = StatementCreateTable (table "posts")+                                { columns =+                                    [ (col "title" PText) { notNull = True }+                                    ]+                                }+                let schema = [postsTable]+                let expectedPolicy = policy "" "posts"++                SchemaOperations.suggestPolicy schema postsTable `shouldBe` expectedPolicy++            it "should suggest a policy if it can find a one hop path to a user_id column" do+                let tasksTable = StatementCreateTable (table "tasks")+                                { columns =+                                    [ (col "task_list_id" PUUID) { notNull = True }+                                    ]+                                }+                let taskListsTable = StatementCreateTable (table "task_lists")+                                { columns =+                                    [ (col "user_id" PUUID) { notNull = True }+                                    ]+                                }+                let schema =+                            [ tasksTable+                            , taskListsTable+                            , AddConstraint { tableName = "tasks", constraint = ForeignKeyConstraint { name = "tasks_ref_task_lists", columnName = "task_list_id", referenceTable = "task_lists", referenceColumn = Nothing, onDelete = Nothing }, deferrable = Nothing, deferrableType = Nothing }+                            ]+                let expectedPolicy = (policy "Users can manage the tasks if they can see the TaskList" "tasks")+                        { using = Just (ExistsExpression (SelectExpression (Select {columns = [IntExpression 1], from = DotExpression (VarExpression "public") "task_lists", alias = Nothing, whereClause = EqExpression (DotExpression (VarExpression "task_lists") "id") (DotExpression (VarExpression "tasks") "task_list_id")})))+                        , check = Just (ExistsExpression (SelectExpression (Select {columns = [IntExpression 1], from = DotExpression (VarExpression "public") "task_lists", alias = Nothing, whereClause = EqExpression (DotExpression (VarExpression "task_lists") "id") (DotExpression (VarExpression "tasks") "task_list_id")})))+                        }++                SchemaOperations.suggestPolicy schema tasksTable `shouldBe` expectedPolicy+        describe "addColumn" do+            it "should add an index if withIndex = true" do+                let inputSchema = [tableA]++                let tableAWithCreatedAt = StatementCreateTable (table "a")+                            { columns = [+                                    (col "created_at" PTimestampWithTimezone) { defaultValue = Just (CallExpression "NOW" []), notNull = True }+                            ]+                            }+                let index = CreateIndex { indexName = "a_created_at_index", unique = False, tableName = "a", columns = [indexCol (VarExpression "created_at")], whereClause = Nothing, indexType = Nothing }++                let expectedSchema = [tableAWithCreatedAt, index]++                let options = SchemaOperations.AddColumnOptions+                        { tableName = "a"+                        , columnName = "created_at"+                        , columnType = PTimestampWithTimezone+                        , defaultValue = Just (CallExpression "NOW" [])+                        , isArray = False+                        , allowNull = False+                        , isUnique = False+                        , isReference = False+                        , referenceTable = Nothing+                        , primaryKey = False+                        , withIndex = True+                        , autoPolicy = False+                        }++                (SchemaOperations.addColumn options inputSchema) `shouldBe` expectedSchema+            +            it "should add a trigger to updated_at columns" do+                let inputSchema = [tableA]++                let tableAWithCreatedAt = StatementCreateTable (table "a")+                            { columns = [+                                    (col "updated_at" PTimestampWithTimezone) { defaultValue = Just (CallExpression "NOW" []), notNull = True }+                            ]+                            }++                let setUpdatedAtFn = (function "set_updated_at_to_now")+                            { functionBody = "\nBEGIN\n    NEW.updated_at = NOW();\n    RETURN NEW;\nEND;\n"+                            }+                let trigger = CreateTrigger+                            { name = "update_a_updated_at"+                            , eventWhen = Before+                            , event = [TriggerOnUpdate]+                            , tableName = "a"+                            , for = ForEachRow+                            , whenCondition = Nothing+                            , functionName = "set_updated_at_to_now"+                            , arguments = []+                            }++                let expectedSchema = [setUpdatedAtFn, tableAWithCreatedAt, trigger]+                +                let options = SchemaOperations.AddColumnOptions+                        { tableName = "a"+                        , columnName = "updated_at"+                        , columnType = PTimestampWithTimezone+                        , defaultValue = Just (CallExpression "NOW" [])+                        , isArray = False+                        , allowNull = False+                        , isUnique = False+                        , isReference = False+                        , referenceTable = Nothing+                        , primaryKey = False+                        , withIndex = False+                        , autoPolicy = False+                        }++                (SchemaOperations.addColumn options inputSchema) `shouldBe` expectedSchema+            +            it "should add a policy if autoPolicy = true" do+                let inputSchema = [tableA]++                let tableAWithCreatedAt = StatementCreateTable (table "a")+                            { columns = [+                                    (col "user_id" PUUID) { notNull = True }+                            ]+                            }++                let index = CreateIndex+                        { indexName = "a_user_id_index"+                        , unique = False+                        , tableName = "a"+                        , columns = [indexCol (VarExpression "user_id")]+                        , whereClause = Nothing+                        , indexType = Nothing+                        }+                let constraint = AddConstraint+                        { tableName = "a"+                        , constraint = ForeignKeyConstraint { name = Just "a_ref_user_id", columnName = "user_id", referenceTable = "users", referenceColumn = Just "id", onDelete = Just NoAction }+                        , deferrable = Nothing+                        , deferrableType = Nothing+                        }+                let enableRLS = EnableRowLevelSecurity { tableName = "a" }+                let p = (policy "Users can manage their a" "a")+                        { using = Just (EqExpression (VarExpression "user_id") (CallExpression "ihp_user_id" []))+                        , check = Just (EqExpression (VarExpression "user_id") (CallExpression "ihp_user_id" []))+                        }++                let expectedSchema = [tableAWithCreatedAt, index, constraint, enableRLS, p]+                +                let options = SchemaOperations.AddColumnOptions+                        { tableName = "a"+                        , columnName = "user_id"+                        , columnType = PUUID+                        , defaultValue = Nothing+                        , isArray = False+                        , allowNull = False+                        , isUnique = False+                        , isReference = True+                        , referenceTable = Just "users"+                        , primaryKey = False+                        , withIndex = False+                        , autoPolicy = True+                        }++                (SchemaOperations.addColumn options inputSchema) `shouldBe` expectedSchema++        describe "deleteColumn" do+            it "should delete an referenced index" do+                let tableAWithCreatedAt = StatementCreateTable (table "a")+                            { columns = [+                                    (col "created_at" PTimestampWithTimezone) { defaultValue = Just (CallExpression "NOW" []), notNull = True }+                            ]+                            }+                let index = CreateIndex { indexName = "a_created_at_index", unique = False, tableName = "a", columns = [indexCol (VarExpression "created_at")], whereClause = Nothing, indexType = Nothing }++                let inputSchema = [tableAWithCreatedAt, index]+                let expectedSchema = [tableA]+                +                let options = SchemaOperations.DeleteColumnOptions+                        { tableName = "a"+                        , columnName = "created_at"+                        , columnId = 0+                        }++                (SchemaOperations.deleteColumn options inputSchema) `shouldBe` expectedSchema+            +            it "should delete a updated_at trigger" do+                let tableAWithCreatedAt = StatementCreateTable (table "a")+                            { columns = [+                                    (col "updated_at" PTimestampWithTimezone) { defaultValue = Just (CallExpression "NOW" []), notNull = True }+                            ]+                            }++                let setUpdatedAtFn = (function "set_updated_at_to_now")+                            { functionBody = "\nBEGIN\n    NEW.updated_at = NOW();\n    RETURN NEW;\nEND;\n"+                            }+                let trigger = CreateTrigger+                            { name = "update_a_updated_at"+                            , eventWhen = Before+                            , event = [TriggerOnUpdate]+                            , tableName = "a"+                            , for = ForEachRow+                            , whenCondition = Nothing+                            , functionName = "set_updated_at_to_now"+                            , arguments = []+                            }++                let inputSchema = [setUpdatedAtFn, tableAWithCreatedAt, trigger]+                let expectedSchema = [setUpdatedAtFn, tableA]+                +                let options = SchemaOperations.DeleteColumnOptions+                        { tableName = "a"+                        , columnName = "updated_at"+                        , columnId = 0+                        }++                (SchemaOperations.deleteColumn options inputSchema) `shouldBe` expectedSchema+            +            it "should delete an referenced policy" do+                let tableAWithUserId = StatementCreateTable (table "a")+                            { columns = [+                                    (col "user_id" PUUID) { defaultValue = Just (CallExpression "ihp_user_id" []), notNull = True }+                            ]+                            }+                let p = (policy "a_policy" "a") { using = Just (EqExpression (VarExpression "user_id") (CallExpression "ihp_user_id" [])) }++                let inputSchema = [tableAWithUserId, p]+                let expectedSchema = [tableA]+                +                let options = SchemaOperations.DeleteColumnOptions+                        { tableName = "a"+                        , columnName = "user_id"+                        , columnId = 0+                        }++                (SchemaOperations.deleteColumn options inputSchema) `shouldBe` expectedSchema+        describe "update" do+            it "update a column's name, type, default value and not null" do+                let tableAWithCreatedAt = StatementCreateTable (table "a")+                            { columns = [+                                    (col "updated_at" PTimestampWithTimezone) { defaultValue = Just (CallExpression "NOW" []), notNull = True }+                            ]+                            }++                let tableAWithUpdatedColumn = StatementCreateTable (table "a")+                            { columns = [+                                    col "created_at2" PText+                            ]+                            }++                let inputSchema = [tableAWithCreatedAt]+                let expectedSchema = [tableAWithUpdatedColumn]+                +                let options = SchemaOperations.UpdateColumnOptions+                        { tableName = "a"+                        , columnName = "created_at2"+                        , columnType = PText+                        , defaultValue = Nothing+                        , isArray = False+                        , allowNull = True+                        , isUnique = False+                        , primaryKey = False+                        , columnId = 0+                        }++                (SchemaOperations.updateColumn options inputSchema) `shouldBe` expectedSchema+            it "updates a primary key" do+                let tableWithPK = StatementCreateTable (table "a")+                            { columns = [+                                    (col "id2" PUUID) { notNull = True }+                            ]+                            , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                            }++                let tableWithoutPK = StatementCreateTable (table "a")+                            { columns = [+                                    (col "id" PUUID) { notNull = True }+                            ]+                            }++                let inputSchema = [tableWithoutPK]+                let expectedSchema = [tableWithPK]+                +                let options = SchemaOperations.UpdateColumnOptions+                        { tableName = "a"+                        , columnName = "id2"+                        , columnType = PUUID+                        , defaultValue = Nothing+                        , isArray = False+                        , allowNull = False+                        , isUnique = False+                        , primaryKey = True+                        , columnId = 0+                        }++                (SchemaOperations.updateColumn options inputSchema) `shouldBe` expectedSchema+            it "updates referenced foreign key constraints" do+                let tasksTable = StatementCreateTable (table "tasks")+                                { columns =+                                    [ (col "task_list_id" PUUID) { notNull = True }+                                    ]+                                }+                let taskListsTable = StatementCreateTable (table "task_lists")+                                { columns =+                                    [ (col "user_id" PUUID) { notNull = True }+                                    ]+                                }+                let inputSchema =+                            [ tasksTable+                            , taskListsTable+                            , AddConstraint { tableName = "tasks", constraint = ForeignKeyConstraint { name = "tasks_ref_task_lists", columnName = "task_list_id", referenceTable = "task_lists", referenceColumn = Nothing, onDelete = Nothing }, deferrable = Nothing, deferrableType = Nothing }+                            ]++                let tasksTable' = StatementCreateTable (table "tasks")+                                { columns =+                                    [ (col "list_id" PUUID) { notNull = True }+                                    ]+                                }+                let expectedSchema =+                            [ tasksTable'+                            , taskListsTable+                            , AddConstraint { tableName = "tasks", constraint = ForeignKeyConstraint { name = "tasks_ref_task_lists", columnName = "list_id", referenceTable = "task_lists", referenceColumn = Nothing, onDelete = Nothing }, deferrable = Nothing, deferrableType = Nothing }+                            ]+                +                let options = SchemaOperations.UpdateColumnOptions+                        { tableName = "tasks"+                        , columnName = "list_id"+                        , columnType = PUUID+                        , defaultValue = Nothing+                        , isArray = False+                        , allowNull = False+                        , isUnique = False+                        , primaryKey = False+                        , columnId = 0+                        }++                (SchemaOperations.updateColumn options inputSchema) `shouldBe` expectedSchema+            it "update a column's indexes" do+                let tableAWithCreatedAt = StatementCreateTable (table "a")+                            { columns = [+                                    (col "updated_at" PTimestampWithTimezone) { defaultValue = Just (CallExpression "NOW" []), notNull = True }+                            ]+                            }+                let index = CreateIndex { indexName = "a_updated_at_index", unique = False, tableName = "a", columns = [indexCol (VarExpression "updated_at")], whereClause = Nothing, indexType = Nothing }++                let tableAWithUpdatedColumn = StatementCreateTable (table "a")+                            { columns = [+                                    col "created_at" PText+                            ]+                            }+                let indexUpdated = CreateIndex { indexName = "a_created_at_index", unique = False, tableName = "a", columns = [indexCol (VarExpression "created_at")], whereClause = Nothing, indexType = Nothing }++                let inputSchema = [tableAWithCreatedAt, index]+                let expectedSchema = [tableAWithUpdatedColumn, indexUpdated]+                +                let options = SchemaOperations.UpdateColumnOptions+                        { tableName = "a"+                        , columnName = "created_at"+                        , columnType = PText+                        , defaultValue = Nothing+                        , isArray = False+                        , allowNull = True+                        , isUnique = False+                        , primaryKey = False+                        , columnId = 0+                        }++                (SchemaOperations.updateColumn options inputSchema) `shouldBe` expectedSchema+        describe "updateTable" do+            it "renames a table with all it's indices, constraints, policies, enable RLS statements, triggers" do+                let inputSchema = parseSqlStatements [trimming|+                    CREATE TABLE tasks ();+                    CREATE INDEX tasks_user_id_index ON tasks (user_id);+                    ALTER TABLE tasks ADD CONSTRAINT tasks_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                    CREATE POLICY "Users can manage their tasks" ON tasks USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());+                    ALTER TABLE tasks ENABLE ROW LEVEL SECURITY;+                    CREATE TRIGGER update_tasks_updated_at BEFORE UPDATE ON tasks FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();+                |]+                let outputSchema = parseSqlStatements [trimming|+                    CREATE TABLE todos ();+                    CREATE INDEX todos_user_id_index ON todos (user_id);+                    ALTER TABLE todos ADD CONSTRAINT todos_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                    CREATE POLICY "Users can manage their todos" ON todos USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());+                    ALTER TABLE todos ENABLE ROW LEVEL SECURITY;+                    CREATE TRIGGER update_todos_updated_at BEFORE UPDATE ON todos FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();+                |]++                SchemaOperations.updateTable 0 "todos" inputSchema `shouldBe` outputSchema++parseSqlStatements :: Text -> [Statement]+parseSqlStatements sql =+    case Megaparsec.runParser Parser.parseDDL "input" sql of+            Left parserError -> error (cs $ Megaparsec.errorBundlePretty parserError) -- For better error reporting in hspec+            Right statements -> statements
+ Test/Main.hs view
@@ -0,0 +1,38 @@+module Main where++import Test.Hspec+import IHP.Prelude++import qualified Test.IDE.SchemaDesigner.CompilerSpec+import qualified Test.IDE.SchemaDesigner.ParserSpec+import qualified Test.IDE.SchemaDesigner.Controller.EnumValuesSpec+import qualified Test.IDE.SchemaDesigner.Controller.HelperSpec+import qualified Test.IDE.SchemaDesigner.Controller.ValidationSpec+import qualified Test.IDE.SchemaDesigner.SchemaOperationsSpec+import qualified Test.IDE.CodeGeneration.ControllerGenerator+import qualified Test.IDE.CodeGeneration.ViewGenerator+import qualified Test.IDE.CodeGeneration.MailGenerator+import qualified Test.IDE.CodeGeneration.JobGenerator+import qualified Test.IDE.CodeGeneration.MigrationGenerator+import qualified Test.SchemaCompilerSpec+import qualified Test.IDE.ToolServer.MiddlewareSpec+import qualified Test.IDE.Logs.ControllerSpec+import qualified Test.ServerSpec++main :: IO ()+main = hspec do+    Test.IDE.SchemaDesigner.CompilerSpec.tests+    Test.IDE.SchemaDesigner.ParserSpec.tests+    Test.IDE.SchemaDesigner.Controller.EnumValuesSpec.tests+    Test.IDE.SchemaDesigner.Controller.HelperSpec.tests+    Test.IDE.SchemaDesigner.Controller.ValidationSpec.tests+    Test.IDE.CodeGeneration.ControllerGenerator.tests+    Test.IDE.CodeGeneration.ViewGenerator.tests+    Test.IDE.CodeGeneration.MailGenerator.tests+    Test.IDE.CodeGeneration.JobGenerator.tests+    Test.IDE.SchemaDesigner.SchemaOperationsSpec.tests+    Test.IDE.CodeGeneration.MigrationGenerator.tests+    Test.SchemaCompilerSpec.tests+    Test.IDE.ToolServer.MiddlewareSpec.tests+    Test.IDE.Logs.ControllerSpec.tests+    Test.ServerSpec.tests
+ Test/SchemaCompilerSpec.hs view
@@ -0,0 +1,1339 @@+{-|+Module: Test.SchemaCompilerSpec+Copyright: (c) digitally induced GmbH, 2020+-}+module Test.SchemaCompilerSpec where++import Test.Hspec+import IHP.Prelude+import IHP.SchemaCompiler+import IHP.Postgres.Types+import qualified Data.Text as Text+import Test.IDE.SchemaDesigner.ParserSpec (parseSqlStatements)++tests = do+    describe "SchemaCompiler" do+        describe "compileEnumDataDefinitions" do+            it "should deal with enum values that have spaces" do+                let statement = CreateEnumType { name = "mood", values = ["happy", "very happy", "sad", "very sad"] }+                let output = compileStatementPreview [statement] statement |> Text.strip++                output `shouldBe` [trimming|+                    data Mood = Happy | VeryHappy | Sad | VerySad deriving (Eq, Show, Read, Enum, Bounded, Ord)+                    instance FromField Mood where+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "happy") = pure Happy+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "very happy") = pure VeryHappy+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "sad") = pure Sad+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "very sad") = pure VerySad+                        fromField field (Just value) = returnError ConversionFailed field ("Unexpected value for enum value. Got: " <> Data.String.Conversions.cs value)+                        fromField field Nothing = returnError UnexpectedNull field "Unexpected null for enum value"+                    instance Default Mood where def = Happy+                    instance ToField Mood where+                        toField Happy = toField ("happy" :: Text)+                        toField VeryHappy = toField ("very happy" :: Text)+                        toField Sad = toField ("sad" :: Text)+                        toField VerySad = toField ("very sad" :: Text)+                    instance InputValue Mood where+                        inputValue Happy = "happy" :: Text+                        inputValue VeryHappy = "very happy" :: Text+                        inputValue Sad = "sad" :: Text+                        inputValue VerySad = "very sad" :: Text+                    instance DeepSeq.NFData Mood where rnf a = seq a ()+                    instance IHP.Controller.Param.ParamReader Mood where readParameter = IHP.Controller.Param.enumParamReader; readParameterJSON = IHP.Controller.Param.enumParamReaderJSON+                    textToEnumMoodMap :: HashMap.HashMap Text Mood+                    textToEnumMoodMap = HashMap.fromList [("happy", Happy), ("very happy", VeryHappy), ("sad", Sad), ("very sad", VerySad)]+                    textToEnumMood :: Text -> Maybe Mood+                    textToEnumMood t = HashMap.lookup t textToEnumMoodMap+                    instance Hasql.Implicits.Encoders.DefaultParamEncoder Mood where+                        defaultParam = Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "mood" inputValue)+                    instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe Mood) where+                        defaultParam = Hasql.Encoders.nullable (Hasql.Encoders.enum (Just "public") "mood" inputValue)+                    instance Hasql.Implicits.Encoders.DefaultParamEncoder [Mood] where+                        defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "mood" inputValue)+                    instance Mapping.IsScalar Mood where+                        encoder = Hasql.Encoders.enum (Just "public") "mood" inputValue+                        decoder = Hasql.Decoders.enum (Just "public") "mood" textToEnumMood+                |]+            it "should deal with enums that have no values" do+                -- https://github.com/digitallyinduced/ihp/issues/1026+                -- Empty enums typically happen when an enum was just created in the schema designer and no value has been added yet by the user+                let statement = CreateEnumType { name = "mood", values = [] }+                let output = compileStatementPreview [statement] statement |> Text.strip++                -- We don't generate anything when no values are defined as there's nothing you could do with the enum yet+                -- An empty data declaration is not really useful in this case+                output `shouldBe` mempty+            it "should not pluralize values" do+                -- See https://github.com/digitallyinduced/ihp/issues/767+                let statement = CreateEnumType { name = "Province", values = ["Alberta", "BritishColumbia", "Saskatchewan", "Manitoba", "Ontario", "Quebec", "NovaScotia", "NewBrunswick", "PrinceEdwardIsland", "NewfoundlandAndLabrador"] }+                let output = compileStatementPreview [statement] statement |> Text.strip++                output `shouldBe` [trimming|+                    data Province = Alberta | Britishcolumbia | Saskatchewan | Manitoba | Ontario | Quebec | Novascotia | Newbrunswick | Princeedwardisland | Newfoundlandandlabrador deriving (Eq, Show, Read, Enum, Bounded, Ord)+                    instance FromField Province where+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Alberta") = pure Alberta+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "BritishColumbia") = pure Britishcolumbia+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Saskatchewan") = pure Saskatchewan+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Manitoba") = pure Manitoba+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Ontario") = pure Ontario+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Quebec") = pure Quebec+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "NovaScotia") = pure Novascotia+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "NewBrunswick") = pure Newbrunswick+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "PrinceEdwardIsland") = pure Princeedwardisland+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "NewfoundlandAndLabrador") = pure Newfoundlandandlabrador+                        fromField field (Just value) = returnError ConversionFailed field ("Unexpected value for enum value. Got: " <> Data.String.Conversions.cs value)+                        fromField field Nothing = returnError UnexpectedNull field "Unexpected null for enum value"+                    instance Default Province where def = Alberta+                    instance ToField Province where+                        toField Alberta = toField ("Alberta" :: Text)+                        toField Britishcolumbia = toField ("BritishColumbia" :: Text)+                        toField Saskatchewan = toField ("Saskatchewan" :: Text)+                        toField Manitoba = toField ("Manitoba" :: Text)+                        toField Ontario = toField ("Ontario" :: Text)+                        toField Quebec = toField ("Quebec" :: Text)+                        toField Novascotia = toField ("NovaScotia" :: Text)+                        toField Newbrunswick = toField ("NewBrunswick" :: Text)+                        toField Princeedwardisland = toField ("PrinceEdwardIsland" :: Text)+                        toField Newfoundlandandlabrador = toField ("NewfoundlandAndLabrador" :: Text)+                    instance InputValue Province where+                        inputValue Alberta = "Alberta" :: Text+                        inputValue Britishcolumbia = "BritishColumbia" :: Text+                        inputValue Saskatchewan = "Saskatchewan" :: Text+                        inputValue Manitoba = "Manitoba" :: Text+                        inputValue Ontario = "Ontario" :: Text+                        inputValue Quebec = "Quebec" :: Text+                        inputValue Novascotia = "NovaScotia" :: Text+                        inputValue Newbrunswick = "NewBrunswick" :: Text+                        inputValue Princeedwardisland = "PrinceEdwardIsland" :: Text+                        inputValue Newfoundlandandlabrador = "NewfoundlandAndLabrador" :: Text+                    instance DeepSeq.NFData Province where rnf a = seq a ()+                    instance IHP.Controller.Param.ParamReader Province where readParameter = IHP.Controller.Param.enumParamReader; readParameterJSON = IHP.Controller.Param.enumParamReaderJSON+                    textToEnumProvinceMap :: HashMap.HashMap Text Province+                    textToEnumProvinceMap = HashMap.fromList [("Alberta", Alberta), ("BritishColumbia", Britishcolumbia), ("Saskatchewan", Saskatchewan), ("Manitoba", Manitoba), ("Ontario", Ontario), ("Quebec", Quebec), ("NovaScotia", Novascotia), ("NewBrunswick", Newbrunswick), ("PrinceEdwardIsland", Princeedwardisland), ("NewfoundlandAndLabrador", Newfoundlandandlabrador)]+                    textToEnumProvince :: Text -> Maybe Province+                    textToEnumProvince t = HashMap.lookup t textToEnumProvinceMap+                    instance Hasql.Implicits.Encoders.DefaultParamEncoder Province where+                        defaultParam = Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "province" inputValue)+                    instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe Province) where+                        defaultParam = Hasql.Encoders.nullable (Hasql.Encoders.enum (Just "public") "province" inputValue)+                    instance Hasql.Implicits.Encoders.DefaultParamEncoder [Province] where+                        defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "province" inputValue)+                    instance Mapping.IsScalar Province where+                        encoder = Hasql.Encoders.enum (Just "public") "province" inputValue+                        decoder = Hasql.Decoders.enum (Just "public") "province" textToEnumProvince+                |]+            it "should deal with duplicate enum values" do+                let enum1 = CreateEnumType { name = "property_type", values = ["APARTMENT", "HOUSE"] }+                let enum2 = CreateEnumType { name = "apartment_type", values = ["LOFT", "APARTMENT"] }+                let output = compileStatementPreview [enum1, enum2] enum1 |> Text.strip++                output `shouldBe` [trimming|+                    data PropertyType = PropertyTypeApartment | House deriving (Eq, Show, Read, Enum, Bounded, Ord)+                    instance FromField PropertyType where+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "APARTMENT") = pure PropertyTypeApartment+                        fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "HOUSE") = pure House+                        fromField field (Just value) = returnError ConversionFailed field ("Unexpected value for enum value. Got: " <> Data.String.Conversions.cs value)+                        fromField field Nothing = returnError UnexpectedNull field "Unexpected null for enum value"+                    instance Default PropertyType where def = PropertyTypeApartment+                    instance ToField PropertyType where+                        toField PropertyTypeApartment = toField ("APARTMENT" :: Text)+                        toField House = toField ("HOUSE" :: Text)+                    instance InputValue PropertyType where+                        inputValue PropertyTypeApartment = "APARTMENT" :: Text+                        inputValue House = "HOUSE" :: Text+                    instance DeepSeq.NFData PropertyType where rnf a = seq a ()+                    instance IHP.Controller.Param.ParamReader PropertyType where readParameter = IHP.Controller.Param.enumParamReader; readParameterJSON = IHP.Controller.Param.enumParamReaderJSON+                    textToEnumPropertyTypeMap :: HashMap.HashMap Text PropertyType+                    textToEnumPropertyTypeMap = HashMap.fromList [("APARTMENT", PropertyTypeApartment), ("HOUSE", House)]+                    textToEnumPropertyType :: Text -> Maybe PropertyType+                    textToEnumPropertyType t = HashMap.lookup t textToEnumPropertyTypeMap+                    instance Hasql.Implicits.Encoders.DefaultParamEncoder PropertyType where+                        defaultParam = Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "property_type" inputValue)+                    instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe PropertyType) where+                        defaultParam = Hasql.Encoders.nullable (Hasql.Encoders.enum (Just "public") "property_type" inputValue)+                    instance Hasql.Implicits.Encoders.DefaultParamEncoder [PropertyType] where+                        defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "property_type" inputValue)+                    instance Mapping.IsScalar PropertyType where+                        encoder = Hasql.Encoders.enum (Just "public") "property_type" inputValue+                        decoder = Hasql.Decoders.enum (Just "public") "property_type" textToEnumPropertyType+                |]+        describe "compileCreate" do+            let statement = StatementCreateTable $ (table "users") {+                    columns = [ col "id" PUUID ],+                    primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                }+            let compileOutput = compileStatementPreview [statement] statement |> Text.strip++            it "should compile CanCreate instance with sqlQuery" $ \statement -> do+                getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming|+                    instance CanCreate Generated.ActualTypes.User where+                        create = createUser+                        createMany = createManyUser+                        createRecordDiscardResult = createRecordDiscardResultUser+                    |]+            it "should compile CanUpdate instance with sqlQuery" $ \statement -> do+                getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming|+                    instance CanUpdate Generated.ActualTypes.User where+                        updateRecord = updateRecordUser+                        updateRecordDiscardResult = updateRecordDiscardResultUser+                    |]++            it "should compile CanUpdate instance with an array type with an explicit cast" do+                let statement = StatementCreateTable $ (table "users") {+                    columns = [ (col "id" PUUID) { notNull = True, isUnique = True }, col "ids" (PArray PUUID)],+                    primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                }+                let compileOutput = compileStatementPreview [statement] statement |> Text.strip++                getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming|+                    instance CanUpdate Generated.ActualTypes.User where+                        updateRecord = updateRecordUser+                        updateRecordDiscardResult = updateRecordDiscardResultUser+                    |]+            it "should deal with double default values" do+                let statement = StatementCreateTable (table "users")+                        { columns =+                            [ (col "id" PUUID) { notNull = True, isUnique = True }+                            , col "ids" (PArray PUUID)+                            , (col "electricity_unit_price" PDouble) { defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True }+                            ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                        }+                let compileOutput = compileStatementPreview [statement] statement |> Text.strip++                compileOutput `shouldBe` [trimming|+                    data User' = User {id :: (Id' "users"), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show)++                    type instance PrimaryKey "users" = UUID++                    type User = User'++                    type instance GetTableName (User') = "users"+                    type instance GetModelByTableName "users" = User++                    instance Default (Id' "users") where def = Id def++                    instance IHP.ModelSupport.Table (User') where+                        tableName = "users"+                        columnNames = ["id","ids","electricity_unit_price"]+                        primaryKeyColumnNames = ["id"]+++                    instance InputValue Generated.ActualTypes.User where inputValue = IHP.ModelSupport.recordToInputValue++                    instance FromRow Generated.ActualTypes.User where+                        fromRow = do+                            id <- field+                            ids <- field+                            electricityUnitPrice <- field+                            let theRecord = Generated.ActualTypes.User id ids electricityUnitPrice def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }+                            pure theRecord++                    instance FromRowHasql Generated.ActualTypes.User where+                        hasqlRowDecoder = Generated.Statements.RowDecoderUser.rowDecoder++                    type instance GetModelName (User') = "User"++                    instance CanCreate Generated.ActualTypes.User where+                        create = createUser+                        createMany = createManyUser+                        createRecordDiscardResult = createRecordDiscardResultUser++                    createUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User+                    createUser model = do+                        let pool = ?modelContext.hasqlPool+                        let touched = model.meta.touchedFields+                        sqlStatementHasql pool model (Generated.Statements.CreateUser.statement touched)++                    createManyUser :: (?modelContext :: ModelContext) => [Generated.ActualTypes.User] -> IO [Generated.ActualTypes.User]+                    createManyUser [] = pure []+                    createManyUser models = do+                        let pool = ?modelContext.hasqlPool+                        sqlStatementHasql pool models (Generated.Statements.CreateManyUser.statement (List.length models))++                    createRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()+                    createRecordDiscardResultUser model = do+                        let pool = ?modelContext.hasqlPool+                        let touched = model.meta.touchedFields+                        sqlStatementHasql pool model (Generated.Statements.CreateUser.discardResultStatement touched)++                    instance CanUpdate Generated.ActualTypes.User where+                        updateRecord = updateRecordUser+                        updateRecordDiscardResult = updateRecordDiscardResultUser++                    updateRecordUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User+                    updateRecordUser model = do+                        let touched = model.meta.touchedFields+                        if touched == 0 then pure model else do+                            let pool = ?modelContext.hasqlPool+                            sqlStatementHasql pool model (Generated.Statements.UpdateUser.statement touched)++                    updateRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()+                    updateRecordDiscardResultUser model = do+                        let touched = model.meta.touchedFields+                        unless (touched == 0) $ do+                            let pool = ?modelContext.hasqlPool+                            sqlStatementHasql pool model (Generated.Statements.UpdateUser.discardResultStatement touched)++                    instance Record Generated.ActualTypes.User where+                        {-# INLINE newRecord #-}+                        newRecord = Generated.ActualTypes.User def def 0.17  def+++                    instance QueryBuilder.FilterPrimaryKey "users" where+                        filterWhereId id builder =+                            builder |> QueryBuilder.filterWhere (#id, id)+                        {-# INLINE filterWhereId #-}++                    instance FieldBit "id" (User') where fieldBit = 1+                    instance FieldBit "ids" (User') where fieldBit = 2+                    instance FieldBit "electricityUnitPrice" (User') where fieldBit = 4+                |]+            it "should deal with integer default values for double columns" do+                let statement = StatementCreateTable (table "users")+                        { columns =+                            [ (col "id" PUUID) { notNull = True, isUnique = True }+                            , col "ids" (PArray PUUID)+                            , (col "electricity_unit_price" PDouble) { defaultValue = Just (IntExpression 0), notNull = True }+                            ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                        }+                let compileOutput = compileStatementPreview [statement] statement |> Text.strip++                compileOutput `shouldBe` [trimming|+                    data User' = User {id :: (Id' "users"), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show)++                    type instance PrimaryKey "users" = UUID++                    type User = User'++                    type instance GetTableName (User') = "users"+                    type instance GetModelByTableName "users" = User++                    instance Default (Id' "users") where def = Id def++                    instance IHP.ModelSupport.Table (User') where+                        tableName = "users"+                        columnNames = ["id","ids","electricity_unit_price"]+                        primaryKeyColumnNames = ["id"]+++                    instance InputValue Generated.ActualTypes.User where inputValue = IHP.ModelSupport.recordToInputValue++                    instance FromRow Generated.ActualTypes.User where+                        fromRow = do+                            id <- field+                            ids <- field+                            electricityUnitPrice <- field+                            let theRecord = Generated.ActualTypes.User id ids electricityUnitPrice def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }+                            pure theRecord++                    instance FromRowHasql Generated.ActualTypes.User where+                        hasqlRowDecoder = Generated.Statements.RowDecoderUser.rowDecoder++                    type instance GetModelName (User') = "User"++                    instance CanCreate Generated.ActualTypes.User where+                        create = createUser+                        createMany = createManyUser+                        createRecordDiscardResult = createRecordDiscardResultUser++                    createUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User+                    createUser model = do+                        let pool = ?modelContext.hasqlPool+                        let touched = model.meta.touchedFields+                        sqlStatementHasql pool model (Generated.Statements.CreateUser.statement touched)++                    createManyUser :: (?modelContext :: ModelContext) => [Generated.ActualTypes.User] -> IO [Generated.ActualTypes.User]+                    createManyUser [] = pure []+                    createManyUser models = do+                        let pool = ?modelContext.hasqlPool+                        sqlStatementHasql pool models (Generated.Statements.CreateManyUser.statement (List.length models))++                    createRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()+                    createRecordDiscardResultUser model = do+                        let pool = ?modelContext.hasqlPool+                        let touched = model.meta.touchedFields+                        sqlStatementHasql pool model (Generated.Statements.CreateUser.discardResultStatement touched)++                    instance CanUpdate Generated.ActualTypes.User where+                        updateRecord = updateRecordUser+                        updateRecordDiscardResult = updateRecordDiscardResultUser++                    updateRecordUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User+                    updateRecordUser model = do+                        let touched = model.meta.touchedFields+                        if touched == 0 then pure model else do+                            let pool = ?modelContext.hasqlPool+                            sqlStatementHasql pool model (Generated.Statements.UpdateUser.statement touched)++                    updateRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()+                    updateRecordDiscardResultUser model = do+                        let touched = model.meta.touchedFields+                        unless (touched == 0) $ do+                            let pool = ?modelContext.hasqlPool+                            sqlStatementHasql pool model (Generated.Statements.UpdateUser.discardResultStatement touched)++                    instance Record Generated.ActualTypes.User where+                        {-# INLINE newRecord #-}+                        newRecord = Generated.ActualTypes.User def def 0  def+++                    instance QueryBuilder.FilterPrimaryKey "users" where+                        filterWhereId id builder =+                            builder |> QueryBuilder.filterWhere (#id, id)+                        {-# INLINE filterWhereId #-}++                    instance FieldBit "id" (User') where fieldBit = 1+                    instance FieldBit "ids" (User') where fieldBit = 2+                    instance FieldBit "electricityUnitPrice" (User') where fieldBit = 4+                |]+            it "should not touch GENERATED columns" do+                let statement = StatementCreateTable (table "users")+                        { columns =+                            [ (col "id" PUUID) { notNull = True, isUnique = True }+                            , (col "ts" PTSVector) { notNull = True, generator = Just (ColumnGenerator { generate = VarExpression "someResult", stored = False }) }+                            ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                        }+                let compileOutput = compileStatementPreview [statement] statement |> Text.strip++                compileOutput `shouldBe` [trimming|+                    data User' = User {id :: (Id' "users"), ts :: (Maybe Tsvector), meta :: MetaBag} deriving (Eq, Show)++                    type instance PrimaryKey "users" = UUID++                    type User = User'++                    type instance GetTableName (User') = "users"+                    type instance GetModelByTableName "users" = User++                    instance Default (Id' "users") where def = Id def++                    instance IHP.ModelSupport.Table (User') where+                        tableName = "users"+                        columnNames = ["id","ts"]+                        primaryKeyColumnNames = ["id"]+++                    instance InputValue Generated.ActualTypes.User where inputValue = IHP.ModelSupport.recordToInputValue++                    instance FromRow Generated.ActualTypes.User where+                        fromRow = do+                            id <- field+                            ts <- field+                            let theRecord = Generated.ActualTypes.User id ts def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }+                            pure theRecord++                    instance FromRowHasql Generated.ActualTypes.User where+                        hasqlRowDecoder = Generated.Statements.RowDecoderUser.rowDecoder++                    type instance GetModelName (User') = "User"++                    instance CanCreate Generated.ActualTypes.User where+                        create = createUser+                        createMany = createManyUser+                        createRecordDiscardResult = createRecordDiscardResultUser++                    createUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User+                    createUser model = do+                        let pool = ?modelContext.hasqlPool+                        sqlStatementHasql pool model Generated.Statements.CreateUser.statement++                    createManyUser :: (?modelContext :: ModelContext) => [Generated.ActualTypes.User] -> IO [Generated.ActualTypes.User]+                    createManyUser [] = pure []+                    createManyUser models = do+                        let pool = ?modelContext.hasqlPool+                        sqlStatementHasql pool models (Generated.Statements.CreateManyUser.statement (List.length models))++                    createRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()+                    createRecordDiscardResultUser model = do+                        let pool = ?modelContext.hasqlPool+                        sqlStatementHasql pool model Generated.Statements.CreateUser.discardResultStatement++                    instance CanUpdate Generated.ActualTypes.User where+                        updateRecord = updateRecordUser+                        updateRecordDiscardResult = updateRecordDiscardResultUser++                    updateRecordUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User+                    updateRecordUser model = do+                        let touched = model.meta.touchedFields+                        if touched == 0 then pure model else do+                            let pool = ?modelContext.hasqlPool+                            sqlStatementHasql pool model (Generated.Statements.UpdateUser.statement touched)++                    updateRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()+                    updateRecordDiscardResultUser model = do+                        let touched = model.meta.touchedFields+                        unless (touched == 0) $ do+                            let pool = ?modelContext.hasqlPool+                            sqlStatementHasql pool model (Generated.Statements.UpdateUser.discardResultStatement touched)++                    instance Record Generated.ActualTypes.User where+                        {-# INLINE newRecord #-}+                        newRecord = Generated.ActualTypes.User def def  def+++                    instance QueryBuilder.FilterPrimaryKey "users" where+                        filterWhereId id builder =+                            builder |> QueryBuilder.filterWhere (#id, id)+                        {-# INLINE filterWhereId #-}++                    instance FieldBit "id" (User') where fieldBit = 1+                    instance FieldBit "ts" (User') where fieldBit = 2+                |]+            it "should handle tablets with generated columns" do+                let statement = StatementCreateTable CreateTable+                        { name = "posts"+                        , columns =+                            [ (col "id" PUUID) { notNull = True, isUnique = True }+                            , (col "title" PText) { notNull = True }+                            , (col "body" PText) { notNull = True }+                            , (col "body_index_col" PTSVector) { generator = Just (ColumnGenerator { generate = CallExpression "to_tsvector" [TextExpression "english", CallExpression "coalesce" [VarExpression "body", TextExpression ""]], stored = True }) }+                            ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                        , constraints = []+                        , unlogged = False+                        , inherits = Nothing+                        }+                let compileOutput = compileStatementPreview [statement] statement |> Text.strip++                -- The key point: RETURNING clause should include body_index_col even though it's generated+                getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming|+                    instance CanCreate Generated.ActualTypes.Post where+                        create = createPost+                        createMany = createManyPost+                        createRecordDiscardResult = createRecordDiscardResultPost+                    |]++                getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming|+                    instance CanUpdate Generated.ActualTypes.Post where+                        updateRecord = updateRecordPost+                        updateRecordDiscardResult = updateRecordDiscardResultPost+                    |]+            it "should deal with multiple has many relationships to the same table" do+                let statements = parseSqlStatements [trimming|+                    CREATE TABLE landing_pages (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL+                    );+                    CREATE TABLE paragraph_ctas (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        landing_page_id UUID NOT NULL,+                        to_landing_page_id UUID NOT NULL+                    );+                    ALTER TABLE paragraph_ctas ADD CONSTRAINT paragraph_ctas_ref_landing_page_id FOREIGN KEY (landing_page_id) REFERENCES landing_pages (id) ON DELETE NO ACTION;+                    ALTER TABLE paragraph_ctas ADD CONSTRAINT paragraph_ctas_ref_to_landing_page_id FOREIGN KEY (to_landing_page_id) REFERENCES landing_pages (id) ON DELETE NO ACTION;+                |]+                let+                    isTargetTable :: Statement -> Bool+                    isTargetTable (StatementCreateTable CreateTable { name }) = name == "landing_pages"+                    isTargetTable otherwise = False+                let (Just statement) = find isTargetTable statements+                let compileOutput = compileStatementPreview statements statement |> Text.strip++                compileOutput `shouldBe` [trimming|+                    data LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages = LandingPage {id :: (Id' "landing_pages"), paragraphCtasLandingPages :: paragraphCtasLandingPages, paragraphCtasToLandingPages :: paragraphCtasToLandingPages, meta :: MetaBag} deriving (Eq, Show)++                    type instance PrimaryKey "landing_pages" = UUID+                    +                    type LandingPage = LandingPage' (QueryBuilder.QueryBuilder "paragraph_ctas") (QueryBuilder.QueryBuilder "paragraph_ctas")++                    type instance GetTableName (LandingPage' _ _) = "landing_pages"+                    type instance GetModelByTableName "landing_pages" = LandingPage++                    instance Default (Id' "landing_pages") where def = Id def++                    instance IHP.ModelSupport.Table (LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages) where+                        tableName = "landing_pages"+                        columnNames = ["id"]+                        primaryKeyColumnNames = ["id"]+++                    instance InputValue Generated.ActualTypes.LandingPage where inputValue = IHP.ModelSupport.recordToInputValue++                    instance FromRow Generated.ActualTypes.LandingPage where+                        fromRow = do+                            id <- field+                            let theRecord = Generated.ActualTypes.LandingPage id (QueryBuilder.filterWhere (#landingPageId, id) (QueryBuilder.query @ParagraphCta)) (QueryBuilder.filterWhere (#toLandingPageId, id) (QueryBuilder.query @ParagraphCta)) def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }+                            pure theRecord++                    instance FromRowHasql Generated.ActualTypes.LandingPage where+                        hasqlRowDecoder = Generated.Statements.RowDecoderLandingPage.rowDecoder++                    type instance GetModelName (LandingPage' _ _) = "LandingPage"++                    instance CanCreate Generated.ActualTypes.LandingPage where+                        create = createLandingPage+                        createMany = createManyLandingPage+                        createRecordDiscardResult = createRecordDiscardResultLandingPage++                    createLandingPage :: (?modelContext :: ModelContext) => Generated.ActualTypes.LandingPage -> IO Generated.ActualTypes.LandingPage+                    createLandingPage model = do+                        let pool = ?modelContext.hasqlPool+                        let touched = model.meta.touchedFields+                        sqlStatementHasql pool model (Generated.Statements.CreateLandingPage.statement touched)++                    createManyLandingPage :: (?modelContext :: ModelContext) => [Generated.ActualTypes.LandingPage] -> IO [Generated.ActualTypes.LandingPage]+                    createManyLandingPage [] = pure []+                    createManyLandingPage models = do+                        let pool = ?modelContext.hasqlPool+                        sqlStatementHasql pool models (Generated.Statements.CreateManyLandingPage.statement (List.length models))++                    createRecordDiscardResultLandingPage :: (?modelContext :: ModelContext) => Generated.ActualTypes.LandingPage -> IO ()+                    createRecordDiscardResultLandingPage model = do+                        let pool = ?modelContext.hasqlPool+                        let touched = model.meta.touchedFields+                        sqlStatementHasql pool model (Generated.Statements.CreateLandingPage.discardResultStatement touched)++                    instance CanUpdate Generated.ActualTypes.LandingPage where+                        updateRecord = updateRecordLandingPage+                        updateRecordDiscardResult = updateRecordDiscardResultLandingPage++                    updateRecordLandingPage :: (?modelContext :: ModelContext) => Generated.ActualTypes.LandingPage -> IO Generated.ActualTypes.LandingPage+                    updateRecordLandingPage model = do+                        let touched = model.meta.touchedFields+                        if touched == 0 then pure model else do+                            let pool = ?modelContext.hasqlPool+                            sqlStatementHasql pool model (Generated.Statements.UpdateLandingPage.statement touched)++                    updateRecordDiscardResultLandingPage :: (?modelContext :: ModelContext) => Generated.ActualTypes.LandingPage -> IO ()+                    updateRecordDiscardResultLandingPage model = do+                        let touched = model.meta.touchedFields+                        unless (touched == 0) $ do+                            let pool = ?modelContext.hasqlPool+                            sqlStatementHasql pool model (Generated.Statements.UpdateLandingPage.discardResultStatement touched)++                    instance Record Generated.ActualTypes.LandingPage where+                        {-# INLINE newRecord #-}+                        newRecord = Generated.ActualTypes.LandingPage def def def def+++                    instance QueryBuilder.FilterPrimaryKey "landing_pages" where+                        filterWhereId id builder =+                            builder |> QueryBuilder.filterWhere (#id, id)+                        {-# INLINE filterWhereId #-}++                    instance FieldBit "id" (LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages) where fieldBit = 1+                |]+            it "should not use DEFAULT for array columns" do+                let statement = StatementCreateTable (table "users")+                        { columns =+                            [ (col "id" PUUID) { notNull = True, isUnique = True }+                            , (col "keywords" (PArray PText)) { defaultValue = Just (VarExpression "NULL") }+                            ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                        }+                let compileOutput = compileStatementPreview [statement] statement |> Text.strip++                getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming|+                    instance CanCreate Generated.ActualTypes.User where+                        create = createUser+                        createMany = createManyUser+                        createRecordDiscardResult = createRecordDiscardResultUser+                    |]+        describe "compileStatementPreview for table with arbitrarily named primary key" do+            let statements = parseSqlStatements [trimming|+                CREATE TABLE things (+                    thing_arbitrary_ident UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL+                );+                CREATE TABLE others (+                    other_arbitrary_ident UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                    thing_ref UUID NOT NULL+                );+                ALTER TABLE others ADD CONSTRAINT other_thing_refs FOREIGN KEY (thing_ref) REFERENCES things (thing_arbitrary_ident) ON DELETE NO ACTION;+            |]+            let+                isTargetTable :: Statement -> Bool+                isTargetTable (StatementCreateTable CreateTable { name }) = name == "things"+                isTargetTable otherwise = False+            let (Just statement) = find isTargetTable statements+            let compileOutput = compileStatementPreview statements statement |> Text.strip+        +            it "should compile CanCreate instance with sqlQuery" $ \statement -> do+                getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming|+                    instance CanCreate Generated.ActualTypes.Thing where+                        create = createThing+                        createMany = createManyThing+                        createRecordDiscardResult = createRecordDiscardResultThing+                    |]+            it "should compile CanUpdate instance with sqlQuery" $ \statement -> do+                getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming|+                    instance CanUpdate Generated.ActualTypes.Thing where+                        updateRecord = updateRecordThing+                        updateRecordDiscardResult = updateRecordDiscardResultThing+                    |]+            it "should compile FromRow instance" $ \statement -> do+                getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming|+                    instance FromRow Generated.ActualTypes.Thing where+                        fromRow = do+                            thingArbitraryIdent <- field+                            let theRecord = Generated.ActualTypes.Thing thingArbitraryIdent (QueryBuilder.filterWhere (#thingRef, thingArbitraryIdent) (QueryBuilder.query @Other)) def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }+                            pure theRecord+                    |]+            it "should compile Table instance" $ \statement -> do+                getInstanceDecl "IHP.ModelSupport.Table" compileOutput `shouldBe` [trimming|+                    instance IHP.ModelSupport.Table (Thing' others) where+                        tableName = "things"+                        columnNames = ["thing_arbitrary_ident"]+                        primaryKeyColumnNames = ["thing_arbitrary_ident"]++                    |]+            it "should compile QueryBuilder.FilterPrimaryKey instance" $ \statement -> do+                getInstanceDecl "QueryBuilder.FilterPrimaryKey" compileOutput `shouldBe` [trimming|+                    instance QueryBuilder.FilterPrimaryKey "things" where+                        filterWhereId thingArbitraryIdent builder =+                            builder |> QueryBuilder.filterWhere (#thingArbitraryIdent, thingArbitraryIdent)+                        {-# INLINE filterWhereId #-}+                    |]+        describe "compileStatementPreview for table with composite primary key" do+            let statements = parseSqlStatements [trimming|+                CREATE TABLE bits (+                    bit_arbitrary_ident UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL+                );+                CREATE TABLE parts (+                    part_arbitrary_ident UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL+                );+                CREATE TABLE bit_part_refs (+                    bit_ref UUID NOT NULL,+                    part_ref UUID NOT NULL,+                    PRIMARY KEY(bit_ref, part_ref)+                );+                ALTER TABLE bit_part_refs ADD CONSTRAINT bit_part_bit_refs FOREIGN KEY (bit_ref) REFERENCES bits (bit_arbitrary_ident) ON DELETE NO ACTION;+                ALTER TABLE bit_part_refs ADD CONSTRAINT bit_part_part_refs FOREIGN KEY (part_ref) REFERENCES parts (part_arbitrary_ident) ON DELETE NO ACTION;+            |]+            let+                isNamedTable :: Text -> Statement -> Bool+                isNamedTable targetName (StatementCreateTable CreateTable { name }) = name == targetName+                isNamedTable _ _ = False+            let (Just statement) = find (isNamedTable "bit_part_refs") statements+            let compileOutput = compileStatementPreview statements statement |> Text.strip+        +            it "should compile CanCreate instance with sqlQuery" $ \statement -> do+                getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming|+                    instance CanCreate Generated.ActualTypes.BitPartRef where+                        create = createBitPartRef+                        createMany = createManyBitPartRef+                        createRecordDiscardResult = createRecordDiscardResultBitPartRef+                    |]+            it "should compile CanUpdate instance with sqlQuery" $ \statement -> do+                getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming|+                    instance CanUpdate Generated.ActualTypes.BitPartRef where+                        updateRecord = updateRecordBitPartRef+                        updateRecordDiscardResult = updateRecordDiscardResultBitPartRef+                    |]+            it "should compile FromRow instance" $ \statement -> do+                getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming|+                    instance FromRow Generated.ActualTypes.BitPartRef where+                        fromRow = do+                            bitRef <- field+                            partRef <- field+                            let theRecord = Generated.ActualTypes.BitPartRef bitRef partRef def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }+                            pure theRecord+                    |]+            it "should compile Table instance" $ \statement -> do+                getInstanceDecl "IHP.ModelSupport.Table" compileOutput `shouldBe` [trimming|+                    instance IHP.ModelSupport.Table (BitPartRef' bitRef partRef) where+                        tableName = "bit_part_refs"+                        columnNames = ["bit_ref","part_ref"]+                        primaryKeyColumnNames = ["bit_ref","part_ref"]++                    |]+            it "should compile FromRow instance of table that references part of a composite key" $ \statement -> do+                let (Just statement) = find (isNamedTable "parts") statements+                let compileOutput = compileStatementPreview statements statement |> Text.strip+                getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming|+                    instance FromRow Generated.ActualTypes.Part where+                        fromRow = do+                            partArbitraryIdent <- field+                            let theRecord = Generated.ActualTypes.Part partArbitraryIdent (QueryBuilder.filterWhere (#partRef, partArbitraryIdent) (QueryBuilder.query @BitPartRef)) def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }+                            pure theRecord+                    |]+            it "should compile QueryBuilder.FilterPrimaryKey instance" $ \statement -> do+                getInstanceDecl "QueryBuilder.FilterPrimaryKey" compileOutput `shouldBe` [trimming|+                    instance QueryBuilder.FilterPrimaryKey "bit_part_refs" where+                        filterWhereId (Id (bitRef, partRef)) builder =+                            builder |> QueryBuilder.filterWhere (#bitRef, bitRef) |> QueryBuilder.filterWhere (#partRef, partRef)+                        {-# INLINE filterWhereId #-}+                    |]+        describe "compileFilterPrimaryKeyInstance" do+            it "should compile FilterPrimaryKey instance when primary key is called id" do+                let statement = StatementCreateTable $ (table "things") {+                        columns = [ (col "id" PUUID) { notNull = True, isUnique = True } ],+                        primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                    }+                let compileOutput = compileStatementPreview [statement] statement |> Text.strip+                +                getInstanceDecl "QueryBuilder.FilterPrimaryKey" compileOutput `shouldBe` [trimming|+                    instance QueryBuilder.FilterPrimaryKey "things" where+                        filterWhereId id builder =+                            builder |> QueryBuilder.filterWhere (#id, id)+                        {-# INLINE filterWhereId #-}+                    |]++        describe "needsHasFieldId" do+            let+                isNamedTable :: Text -> Statement -> Bool+                isNamedTable targetName (StatementCreateTable CreateTable { name }) = name == targetName+                isNamedTable _ _ = False+            it "should not generate HasField id for composite PK table with an id column" do+                let statements = parseSqlStatements [trimming|+                    CREATE TABLE ideas_votes (+                        id INT NOT NULL,+                        idea_id UUID NOT NULL,+                        parent_id UUID NOT NULL,+                        PRIMARY KEY(idea_id, parent_id)+                    );+                |]+                let (Just statement) = find (isNamedTable "ideas_votes") statements+                let compileOutput = compileStatementPreview statements statement |> Text.strip++                -- Should NOT contain a generated HasField "id" instance since the table has a column named "id"+                compileOutput `shouldNotSatisfy` (Text.isInfixOf "instance HasField \"id\"")++            it "should not generate HasField id for single non-id PK table with an id column" do+                let statements = parseSqlStatements [trimming|+                    CREATE TABLE things (+                        id INT NOT NULL,+                        code TEXT PRIMARY KEY NOT NULL+                    );+                |]+                let (Just statement) = find (isNamedTable "things") statements+                let compileOutput = compileStatementPreview statements statement |> Text.strip++                -- Should NOT contain a generated HasField "id" instance since the table has a column named "id"+                compileOutput `shouldNotSatisfy` (Text.isInfixOf "instance HasField \"id\"")++            it "should generate HasField id for composite PK table without an id column" do+                let statements = parseSqlStatements [trimming|+                    CREATE TABLE bit_part_refs (+                        bit_ref UUID NOT NULL,+                        part_ref UUID NOT NULL,+                        PRIMARY KEY(bit_ref, part_ref)+                    );+                |]+                let (Just statement) = find (isNamedTable "bit_part_refs") statements+                let compileOutput = compileStatementPreview statements statement |> Text.strip++                -- Should contain a generated HasField "id" instance for the composite PK+                compileOutput `shouldSatisfy` (Text.isInfixOf "instance HasField \"id\"")++        describe "FK referencing non-PK column" do+            it "should not generate type parameters or Include instances for non-PK FK columns" do+                let statements = parseSqlStatements [trimming|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        email TEXT NOT NULL UNIQUE+                    );+                    CREATE TABLE logins (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        user_email TEXT NOT NULL+                    );+                    ALTER TABLE logins ADD CONSTRAINT logins_ref_user_email FOREIGN KEY (user_email) REFERENCES users (email) ON DELETE NO ACTION;+                |]+                let+                    isTargetTable :: Text -> Statement -> Bool+                    isTargetTable targetName (StatementCreateTable CreateTable { name }) = name == targetName+                    isTargetTable _ _ = False+                let (Just loginStatement) = find (isTargetTable "logins") statements+                let compileOutput = compileStatementPreview statements loginStatement |> Text.strip++                -- userEmail should be Text (not Id' "users"), and no type parameter for it+                compileOutput `shouldSatisfy` ("userEmail :: Text" `Text.isInfixOf`)+                -- Should NOT have Include instance for userEmail (since it's not a PK-based FK)+                compileOutput `shouldSatisfy` (not . ("Include \"userEmail\"" `Text.isInfixOf`))++            it "should not generate has-many QueryBuilder field on the referenced table for non-PK FK" do+                let statements = parseSqlStatements [trimming|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        email TEXT NOT NULL UNIQUE+                    );+                    CREATE TABLE logins (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        user_email TEXT NOT NULL+                    );+                    ALTER TABLE logins ADD CONSTRAINT logins_ref_user_email FOREIGN KEY (user_email) REFERENCES users (email) ON DELETE NO ACTION;+                |]+                let+                    isTargetTable :: Text -> Statement -> Bool+                    isTargetTable targetName (StatementCreateTable CreateTable { name }) = name == targetName+                    isTargetTable _ _ = False+                let (Just userStatement) = find (isTargetTable "users") statements+                let compileOutput = compileStatementPreview statements userStatement |> Text.strip++                -- Users table should NOT have a has-many logins Include instance+                compileOutput `shouldSatisfy` (not . ("Include \"logins\"" `Text.isInfixOf`))++        describe "simple mode (compileRelationSupport = False)" do+            let simpleOptions = previewCompilerOptions { compileRelationSupport = False }+            it "should produce no type parameters and no QueryBuilder fields for a table with FK and has-many relations" do+                let statements = parseSqlStatements [trimming|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL+                    );+                    CREATE TABLE posts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        title TEXT NOT NULL,+                        user_id UUID NOT NULL+                    );+                    CREATE TABLE comments (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        post_id UUID NOT NULL,+                        body TEXT NOT NULL+                    );+                    ALTER TABLE posts ADD CONSTRAINT posts_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                    ALTER TABLE comments ADD CONSTRAINT comments_ref_post_id FOREIGN KEY (post_id) REFERENCES posts (id) ON DELETE NO ACTION;+                |]+                let+                    isTargetTable :: Text -> Statement -> Bool+                    isTargetTable targetName (StatementCreateTable CreateTable { name }) = name == targetName+                    isTargetTable _ _ = False+                let (Just postStatement) = find (isTargetTable "posts") statements+                let compileOutput = compileStatementPreviewWith simpleOptions statements postStatement |> Text.strip++                -- data Post' has no type parameters, no QueryBuilder field, and userId has concrete type+                compileOutput `shouldBe` [trimming|+                    data Post' = Post {id :: (Id' "posts"), title :: Text, userId :: (Id' "users"), meta :: MetaBag} deriving (Eq, Show)++                    type instance PrimaryKey "posts" = UUID++                    type Post = Post'++                    type instance GetTableName (Post') = "posts"+                    type instance GetModelByTableName "posts" = Post++                    instance Default (Id' "posts") where def = Id def++                    instance IHP.ModelSupport.Table (Post') where+                        tableName = "posts"+                        columnNames = ["id","title","user_id"]+                        primaryKeyColumnNames = ["id"]+++                    instance InputValue Generated.ActualTypes.Post where inputValue = IHP.ModelSupport.recordToInputValue++                    instance FromRow Generated.ActualTypes.Post where+                        fromRow = do+                            id <- field+                            title <- field+                            userId <- field+                            let theRecord = Generated.ActualTypes.Post id title userId def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }+                            pure theRecord++                    instance FromRowHasql Generated.ActualTypes.Post where+                        hasqlRowDecoder = Generated.Statements.RowDecoderPost.rowDecoder++                    type instance GetModelName (Post') = "Post"++                    instance CanCreate Generated.ActualTypes.Post where+                        create = createPost+                        createMany = createManyPost+                        createRecordDiscardResult = createRecordDiscardResultPost++                    createPost :: (?modelContext :: ModelContext) => Generated.ActualTypes.Post -> IO Generated.ActualTypes.Post+                    createPost model = do+                        let pool = ?modelContext.hasqlPool+                        let touched = model.meta.touchedFields+                        sqlStatementHasql pool model (Generated.Statements.CreatePost.statement touched)++                    createManyPost :: (?modelContext :: ModelContext) => [Generated.ActualTypes.Post] -> IO [Generated.ActualTypes.Post]+                    createManyPost [] = pure []+                    createManyPost models = do+                        let pool = ?modelContext.hasqlPool+                        sqlStatementHasql pool models (Generated.Statements.CreateManyPost.statement (List.length models))++                    createRecordDiscardResultPost :: (?modelContext :: ModelContext) => Generated.ActualTypes.Post -> IO ()+                    createRecordDiscardResultPost model = do+                        let pool = ?modelContext.hasqlPool+                        let touched = model.meta.touchedFields+                        sqlStatementHasql pool model (Generated.Statements.CreatePost.discardResultStatement touched)++                    instance CanUpdate Generated.ActualTypes.Post where+                        updateRecord = updateRecordPost+                        updateRecordDiscardResult = updateRecordDiscardResultPost++                    updateRecordPost :: (?modelContext :: ModelContext) => Generated.ActualTypes.Post -> IO Generated.ActualTypes.Post+                    updateRecordPost model = do+                        let touched = model.meta.touchedFields+                        if touched == 0 then pure model else do+                            let pool = ?modelContext.hasqlPool+                            sqlStatementHasql pool model (Generated.Statements.UpdatePost.statement touched)++                    updateRecordDiscardResultPost :: (?modelContext :: ModelContext) => Generated.ActualTypes.Post -> IO ()+                    updateRecordDiscardResultPost model = do+                        let touched = model.meta.touchedFields+                        unless (touched == 0) $ do+                            let pool = ?modelContext.hasqlPool+                            sqlStatementHasql pool model (Generated.Statements.UpdatePost.discardResultStatement touched)++                    instance Record Generated.ActualTypes.Post where+                        {-# INLINE newRecord #-}+                        newRecord = Generated.ActualTypes.Post def def def  def+++                    instance QueryBuilder.FilterPrimaryKey "posts" where+                        filterWhereId id builder =+                            builder |> QueryBuilder.filterWhere (#id, id)+                        {-# INLINE filterWhereId #-}++                    instance FieldBit "id" (Post') where fieldBit = 1+                    instance FieldBit "title" (Post') where fieldBit = 2+                    instance FieldBit "userId" (Post') where fieldBit = 4+                |]+            it "should produce no type parameters for a table that is referenced by other tables" do+                let statements = parseSqlStatements [trimming|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL+                    );+                    CREATE TABLE posts (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        user_id UUID NOT NULL+                    );+                    ALTER TABLE posts ADD CONSTRAINT posts_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+                |]+                let+                    isTargetTable :: Text -> Statement -> Bool+                    isTargetTable targetName (StatementCreateTable CreateTable { name }) = name == targetName+                    isTargetTable _ _ = False+                let (Just userStatement) = find (isTargetTable "users") statements+                let compileOutput = compileStatementPreviewWith simpleOptions statements userStatement |> Text.strip++                -- User has no has-many posts field, no type parameters+                getInstanceDecl "Record" compileOutput `shouldBe` [trimming|+                    instance Record Generated.ActualTypes.User where+                        {-# INLINE newRecord #-}+                        newRecord = Generated.ActualTypes.User def  def+                |]++            it "should use the referenced column's type when FK points to a non-PK column" do+                let statements = parseSqlStatements [trimming|+                    CREATE TABLE users (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        email TEXT NOT NULL UNIQUE+                    );+                    CREATE TABLE logins (+                        id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                        user_email TEXT NOT NULL+                    );+                    ALTER TABLE logins ADD CONSTRAINT logins_ref_user_email FOREIGN KEY (user_email) REFERENCES users (email) ON DELETE NO ACTION;+                |]+                let+                    isTargetTable :: Text -> Statement -> Bool+                    isTargetTable targetName (StatementCreateTable CreateTable { name }) = name == targetName+                    isTargetTable _ _ = False+                let (Just loginStatement) = find (isTargetTable "logins") statements+                let compileOutput = compileStatementPreviewWith simpleOptions statements loginStatement |> Text.strip++                -- userEmail should be Text, not Id' "users"+                compileOutput `shouldSatisfy` ("userEmail :: Text" `Text.isInfixOf`)++        describe "statement module content" do+            let statements =+                    [ StatementCreateTable CreateTable+                        { name = "posts"+                        , columns =+                            [ (col "id" PUUID) { notNull = True, isUnique = True }+                            , (col "title" PText) { notNull = True }+                            , (col "body" PText) { notNull = True }+                            ]+                        , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                        , constraints = []+                        , unlogged = False+                        , inherits = Nothing+                        }+                    ]+            let [StatementCreateTable theTable] = statements+            let ?schema = Schema statements+            let ?compilerOptions = fullCompileOptions++            it "should generate correct RowDecoder statement module" do+                let output = compileRowDecoderModule theTable+                getStatementBody output `shouldBe` [trimming|+                    rowDecoder :: Decoders.Row Generated.ActualTypes.Post+                    rowDecoder = do+                        id <- Decoders.column (Decoders.nonNullable Mapping.decoder)+                        title <- Decoders.column (Decoders.nonNullable Decoders.text)+                        body <- Decoders.column (Decoders.nonNullable Decoders.text)+                        pure (let theRecord = Generated.ActualTypes.Post id title body def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) } in theRecord)+                    |]++            it "should generate nonNullable decoder for PRIMARY KEY column even without explicit NOT NULL (#2531)" do+                let bugStatements =+                        [ StatementCreateTable CreateTable+                            { name = "bars"+                            , columns =+                                [ (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []) }+                                , (col "ticker" PText) { notNull = True }+                                , (col "date" PDate) { notNull = True }+                                ]+                            , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                            , constraints = []+                            , unlogged = False+                            , inherits = Nothing+                            }+                        ]+                let [StatementCreateTable bugTable] = bugStatements+                let ?schema = Schema bugStatements+                let output = compileRowDecoderModule bugTable+                getStatementBody output `shouldBe` [trimming|+                    rowDecoder :: Decoders.Row Generated.ActualTypes.Bar+                    rowDecoder = do+                        id <- Decoders.column (Decoders.nonNullable Mapping.decoder)+                        ticker <- Decoders.column (Decoders.nonNullable Decoders.text)+                        date <- Decoders.column (Decoders.nonNullable Decoders.date)+                        pure (let theRecord = Generated.ActualTypes.Bar id ticker date def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) } in theRecord)+                    |]++            it "should generate correct Create statement module" do+                let output = compileCreateStatement theTable+                getStatementBody output `shouldBe` [trimming|+                    statement :: Statement.Statement Generated.ActualTypes.Post Generated.ActualTypes.Post+                    statement = Statement.preparable sqlReturningResult encoder decoder++                    discardResultStatement :: Statement.Statement Generated.ActualTypes.Post ()+                    discardResultStatement = Statement.preparable sqlDiscardResult encoder Decoders.noResult++                    sql :: Bool -> Text+                    sql returning = "INSERT INTO posts (id, title, body) VALUES ($$1, $$2, $$3)"+                        <> if returning then " RETURNING id, title, body" else ""++                    sqlReturningResult :: Text+                    sqlReturningResult = sql True++                    sqlDiscardResult :: Text+                    sqlDiscardResult = sql False++                    encoder :: Encoders.Params Generated.ActualTypes.Post+                    encoder =+                            mconcat+                                [ (.id) >$$< Encoders.param (Encoders.nonNullable Mapping.encoder)+                                , (.title) >$$< Encoders.param (Encoders.nonNullable Encoders.text)+                                , (.body) >$$< Encoders.param (Encoders.nonNullable Encoders.text)+                                ]++                    decoder :: Decoders.Result Generated.ActualTypes.Post+                    decoder = Decoders.singleRow RowDecoder.rowDecoder+                    |]++            it "should generate correct Update statement module" do+                let output = compileUpdateStatement theTable+                getStatementBody output `shouldBe` [trimming|+                    statement :: Integer -> Statement.Statement Generated.ActualTypes.Post Generated.ActualTypes.Post+                    statement touchedFields = Statement.preparable (sql touchedFields True) (encoder touchedFields) decoder++                    discardResultStatement :: Integer -> Statement.Statement Generated.ActualTypes.Post ()+                    discardResultStatement touchedFields = Statement.preparable (sql touchedFields False) (encoder touchedFields) Decoders.noResult++                    sql :: Integer -> Bool -> Text+                    sql touchedFields returning =+                        let setEntries = catMaybes+                                [ if testBit touchedFields 1 then Just "title" else Nothing+                                , if testBit touchedFields 2 then Just "body" else Nothing+                                ]+                            setClauses = [col <> " = $$" <> Text.pack (show i) | (i, col) <- zip [1..] setEntries]+                            pkIdx = length setEntries + 1+                            whereClause = \startIdx -> "id" <> " = $$" <> Text.pack (show startIdx)+                            returningClause = if returning then " RETURNING id, title, body" else ""+                        in "UPDATE posts SET " <> Text.intercalate ", " setClauses <> " WHERE " <> whereClause pkIdx <> returningClause+++                    encoder :: Integer -> Encoders.Params Generated.ActualTypes.Post+                    encoder touchedFields = mconcat (catMaybes+                        [ if testBit touchedFields 1 then Just ((.title) >$$< Encoders.param (Encoders.nonNullable Encoders.text)) else Nothing+                        , if testBit touchedFields 2 then Just ((.body) >$$< Encoders.param (Encoders.nonNullable Encoders.text)) else Nothing+                        ])+                        <> ((.id) >$$< Encoders.param (Encoders.nonNullable Mapping.encoder))+++                    decoder :: Decoders.Result Generated.ActualTypes.Post+                    decoder = Decoders.singleRow RowDecoder.rowDecoder+                    |]++            it "should generate correct FetchById statement module" do+                let output = compileFetchByIdStatement theTable+                getStatementBody output `shouldBe` [trimming|+                    statement :: Statement.Statement (Id' "posts") (Maybe Generated.ActualTypes.Post)+                    statement = Statement.preparable sql encoder decoder++                    sql :: Text+                    sql = "SELECT id, title, body FROM posts WHERE id = $$1 LIMIT 1"++                    encoder :: Encoders.Params (Id' "posts")+                    encoder = Encoders.param (Encoders.nonNullable Mapping.encoder)++                    decoder :: Decoders.Result (Maybe Generated.ActualTypes.Post)+                    decoder = Decoders.rowMaybe RowDecoder.rowDecoder+                    |]++            it "should generate correct CreateMany statement module" do+                let output = compileCreateManyStatement theTable+                getStatementBody output `shouldBe` [trimming|+                    statement :: Int -> Statement.Statement [Generated.ActualTypes.Post] [Generated.ActualTypes.Post]+                    statement count = Statement.unpreparable (sql count) (encoder count) decoder++                    sql :: Int -> Text+                    sql count = "INSERT INTO posts (id, title, body) VALUES "+                        <> Text.intercalate ", " [valueGroup (i * 3) | i <- [0..count - 1]]+                        <> " RETURNING id, title, body"+                      where+                        valueGroup offset = "(" <> Text.intercalate ", " ["$$" <> Text.pack (show (offset + j)) | j <- [1..3]] <> ")"++                    encoder :: Int -> Encoders.Params [Generated.ActualTypes.Post]+                    encoder count = mconcat [contramap (!! i) singleEncoder | i <- [0..count - 1]]++                    singleEncoder :: Encoders.Params Generated.ActualTypes.Post+                    singleEncoder =+                            mconcat+                                [ (.id) >$$< Encoders.param (Encoders.nonNullable Mapping.encoder)+                                , (.title) >$$< Encoders.param (Encoders.nonNullable Encoders.text)+                                , (.body) >$$< Encoders.param (Encoders.nonNullable Encoders.text)+                                ]++                    decoder :: Decoders.Result [Generated.ActualTypes.Post]+                    decoder = Decoders.rowList RowDecoder.rowDecoder+                    |]++            it "should use correct bit indices for columns in Update" do+                let snakeStatements =+                        [ StatementCreateTable CreateTable+                            { name = "blog_posts"+                            , columns =+                                [ (col "id" PUUID) { notNull = True, isUnique = True }+                                , (col "post_title" PText) { notNull = True }+                                ]+                            , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                            , constraints = []+                            , unlogged = False+                            , inherits = Nothing+                            }+                        ]+                let [StatementCreateTable snakeTable] = snakeStatements+                let ?schema = Schema snakeStatements+                let output = compileUpdateStatement snakeTable+                -- post_title is at index 1 in the columns list, so testBit should use 1+                output `shouldSatisfy` Text.isInfixOf "testBit touchedFields 1"++            it "should generate correct dynamic Create statement module with DEFAULT columns" do+                let defaultStatements =+                        [ StatementCreateTable CreateTable+                            { name = "posts"+                            , columns =+                                [ (col "id" PUUID) { notNull = True, isUnique = True, defaultValue = Just (CallExpression "uuid_generate_v4" []) }+                                , (col "title" PText) { notNull = True }+                                , (col "created_at" PTimestampWithTimezone) { notNull = True, defaultValue = Just (CallExpression "now" []) }+                                ]+                            , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+                            , constraints = []+                            , unlogged = False+                            , inherits = Nothing+                            }+                        ]+                let [StatementCreateTable defaultTable] = defaultStatements+                let ?schema = Schema defaultStatements+                let output = compileCreateStatement defaultTable+                getStatementBody output `shouldBe` [trimming|+                    statement :: Integer -> Statement.Statement Generated.ActualTypes.Post Generated.ActualTypes.Post+                    statement touchedFields = Statement.preparable (sql touchedFields True) (encoder touchedFields) decoder++                    discardResultStatement :: Integer -> Statement.Statement Generated.ActualTypes.Post ()+                    discardResultStatement touchedFields = Statement.preparable (sql touchedFields False) (encoder touchedFields) Decoders.noResult++                    sql :: Integer -> Bool -> Text+                    sql touchedFields returning =+                        let entries = catMaybes+                                [ if testBit touchedFields 0 then Just "id" else Nothing+                                , Just "title"+                                , if testBit touchedFields 2 then Just "created_at" else Nothing+                                ]+                            columns = Text.intercalate ", " entries+                            placeholders = Text.intercalate ", " ["$$" <> Text.pack (show i) | i <- [1 .. length entries]]+                            returningClause = if returning then " RETURNING id, title, created_at" else ""+                        in if null entries+                            then "INSERT INTO posts DEFAULT VALUES" <> returningClause+                            else "INSERT INTO posts (" <> columns <> ") VALUES (" <> placeholders <> ")" <> returningClause+++                    encoder :: Integer -> Encoders.Params Generated.ActualTypes.Post+                    encoder touchedFields = mconcat $$ catMaybes+                        [ if testBit touchedFields 0 then Just ((.id) >$$< Encoders.param (Encoders.nonNullable Mapping.encoder)) else Nothing+                        , Just ((.title) >$$< Encoders.param (Encoders.nonNullable Encoders.text))+                        , if testBit touchedFields 2 then Just ((.createdAt) >$$< Encoders.param (Encoders.nonNullable Encoders.timestamptz)) else Nothing+                        ]+++                    decoder :: Decoders.Result Generated.ActualTypes.Post+                    decoder = Decoders.singleRow RowDecoder.rowDecoder+                    |]++        describe "table inheritance (INHERITS)" do+            let statements = parseSqlStatements [trimming|+                CREATE TABLE posts (+                    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                    title TEXT NOT NULL,+                    body TEXT NOT NULL+                );+                CREATE TABLE post_revisions (+                    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+                    revision_content TEXT NOT NULL+                ) INHERITS (posts);+            |]+            let+                isNamedTable :: Text -> Statement -> Bool+                isNamedTable targetName (StatementCreateTable CreateTable { name }) = name == targetName+                isNamedTable _ _ = False+            let (Just childStatement) = find (isNamedTable "post_revisions") statements+            let compileOutput = compileStatementPreview statements childStatement |> Text.strip++            it "should include inherited columns in FromRow instance" do+                getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming|+                    instance FromRow Generated.ActualTypes.PostRevision where+                        fromRow = do+                            id <- field+                            revisionContent <- field+                            title <- field+                            body <- field+                            let theRecord = Generated.ActualTypes.PostRevision id revisionContent title body def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }+                            pure theRecord+                    |]++            it "should include inherited columns in Table instance" do+                getInstanceDecl "IHP.ModelSupport.Table" compileOutput `shouldBe` [trimming|+                    instance IHP.ModelSupport.Table (PostRevision') where+                        tableName = "post_revisions"+                        columnNames = ["id","revision_content","title","body"]+                        primaryKeyColumnNames = ["id"]++                    |]++            it "should include inherited columns in Record instance" do+                getInstanceDecl "Record" compileOutput `shouldBe` [trimming|+                    instance Record Generated.ActualTypes.PostRevision where+                        {-# INLINE newRecord #-}+                        newRecord = Generated.ActualTypes.PostRevision def def def def  def+                    |]++-- | Extract the body of a statement module (everything after the import block)+getStatementBody :: Text -> Text+getStatementBody full =+    Text.splitOn "\n" full+        |> dropWhile (\line -> "import " `isPrefixOf` line || isEmpty line || "-- " `isPrefixOf` line || "{-#" `isPrefixOf` line || "module " `isPrefixOf` line)+        |> Text.unlines+        |> Text.strip++getInstanceDecl :: Text -> Text -> Text+getInstanceDecl instanceName full =+    Text.splitOn "\n" full+        |> findInstanceDecl+        |> takeInstanceDecl+        |> Text.unlines+        |> Text.strip+    where+        findInstanceDecl (line:rest)+            | ("instance " <> instanceName) `isPrefixOf` line = line : rest+            | otherwise = findInstanceDecl rest+        findInstanceDecl [] = error ("didn't find instance declaration of " <> instanceName)++        takeInstanceDecl (line:rest)+            | isEmpty line = []+            | otherwise = line : takeInstanceDecl rest+        takeInstanceDecl [] = [] -- EOF reached
+ Test/ServerSpec.hs view
@@ -0,0 +1,89 @@+module Test.ServerSpec where++import IHP.Prelude+import Test.Hspec+import Network.Wai+import Network.Wai.Test+import Network.HTTP.Types++import IHP.Static (staticRouteShortcut)+import Network.Wai.Middleware.AssetPath (assetPathMiddleware, assetPath)++-- | A simple WAI app that responds with the pathInfo and rawPathInfo it received+echoApp :: Application+echoApp request respond = respond $ responseLBS status200 []+    (cs (tshow request.pathInfo <> "|" <> cs request.rawPathInfo :: Text))++-- | A fallback app that always responds with "fallback"+fallbackApp :: Application+fallbackApp _request respond = respond $ responseLBS status200 [] "fallback"++makeRequest :: ByteString -> [Text] -> Request+makeRequest rawPath segments = defaultRequest+    { rawPathInfo = rawPath+    , pathInfo = segments+    }++tests :: Spec+tests = do+    describe "staticRouteShortcut" $ do+        it "routes /static/* requests to the static app with prefix stripped" $ do+            let app = staticRouteShortcut echoApp fallbackApp+            let request = makeRequest "/static/app.css" ["static", "app.css"]+            response <- runSession (request' request) app+            let body = cs (simpleBody response) :: Text+            body `shouldBe` "[\"app.css\"]|/app.css"++        it "routes /static/ nested paths with prefix stripped" $ do+            let app = staticRouteShortcut echoApp fallbackApp+            let request = makeRequest "/static/vendor/bootstrap.css" ["static", "vendor", "bootstrap.css"]+            response <- runSession (request' request) app+            let body = cs (simpleBody response) :: Text+            body `shouldBe` "[\"vendor\",\"bootstrap.css\"]|/vendor/bootstrap.css"++        it "routes /static/ root to the static app with empty path" $ do+            let app = staticRouteShortcut echoApp fallbackApp+            let request = makeRequest "/static/" ["static", ""]+            response <- runSession (request' request) app+            let body = cs (simpleBody response) :: Text+            body `shouldBe` "[\"\"]|/"++        it "routes non-static requests to the fallback app" $ do+            let app = staticRouteShortcut echoApp fallbackApp+            let request = makeRequest "/Users" ["Users"]+            response <- runSession (request' request) app+            simpleBody response `shouldBe` "fallback"++        it "routes root requests to the fallback app" $ do+            let app = staticRouteShortcut echoApp fallbackApp+            let request = makeRequest "/" [""]+            response <- runSession (request' request) app+            simpleBody response `shouldBe` "fallback"++        it "does not match /staticx or similar prefixes" $ do+            let app = staticRouteShortcut echoApp fallbackApp+            let request = makeRequest "/staticx/app.css" ["staticx", "app.css"]+            response <- runSession (request' request) app+            simpleBody response `shouldBe` "fallback"++    describe "assetPath with /static/ prefix" $ do+        it "generates /static/-prefixed paths when middleware is applied" $ do+            let middleware = assetPathMiddleware "abc123" Nothing+            let innerApp req respond = do+                    let result = assetPath req "/app.css"+                    respond $ responseLBS status200 [] (cs result)+            let app = middleware innerApp+            response <- runSession (request' defaultRequest) app+            cs (simpleBody response) `shouldBe` ("/static/app.css?v=abc123" :: String)++        it "skips /static/ prefix when base URL is specified" $ do+            let middleware = assetPathMiddleware "abc123" (Just "https://cdn.example.com")+            let innerApp req respond = do+                    let result = assetPath req "/app.js"+                    respond $ responseLBS status200 [] (cs result)+            let app = middleware innerApp+            response <- runSession (request' defaultRequest) app+            cs (simpleBody response) `shouldBe` ("https://cdn.example.com/app.js?v=abc123" :: String)++request' :: Request -> Session SResponse+request' = srequest . flip SRequest ""
+ changelog.md view
@@ -0,0 +1,25 @@+# Changelog for `ihp-ide`++## v1.5.0++- Add PostgreSQL table inheritance (`INHERITS`) support in Schema Designer+- Add PostgreSQL 18 support with UUIDv7 as default UUID function+- Support multiple trigger events (INSERT OR UPDATE, etc.)+- Add `SECURITY DEFINER` support for SQL functions+- Enable Hoogle by default with auto-start and IDE sidebar link+- Allow deselecting actions in the controller generator+- Add app selector to Generate Controller from schema designer+- Improve IDE logs viewer with devenv service log tabs+- Add persistent socket for seamless app restarts+- Migrate IDE Data Controller from postgresql-simple to hasql+- Migrate Bootstrap 4 to Bootstrap 5 (CSS classes, data attributes, jQuery 4.0)+- Upgrade Bootstrap 5.2.1 to 5.3.8+- Fix Schema Designer layout issues, column visibility, and context menu width+- Fix IDE Data Editor foreign key dropdown, tooltip positioning, boolean display+- Fix app crash detection with persistent socket+- Fix lazy IO crash in FileWatcher+- Fix devenv up Ctrl+C leaving GHCi/web server running as orphan processes+- Remove compile-time `+RTS` flags (were incompatible with Hackage)+- Replace snippet codegen with hasql statement modules+- Improve code generators with type-aware scaffolding+- Use `OsPath` instead of `FilePath`
data/lib/IHP/Makefile.dist view
@@ -7,6 +7,9 @@ MAKEFLAGS += --warn-undefined-variables MAKEFLAGS += --no-builtin-rules +PSQL_ARGS = "$$DATABASE_URL"+PG_DUMP_ARGS = "$$DATABASE_URL"+ GHC_EXTENSIONS= GHC_EXTENSIONS+= -XGHC2021 GHC_EXTENSIONS+= -XOverloadedStrings@@ -96,46 +99,43 @@ 	build/bin/RunProdServer  postgres: ## Starts the postgresql server-	@if [ -s build/db/state/postmaster.pid ]; then echo "Postgres is already running."; else echo "Starting postgres"; postgres -D build/db/state -k $$PWD/build/db -c "listen_addresses="; fi+	@echo "Postgres is managed by devenv. Use 'devenv up' to start all services including postgres."  psql: ## Connects to the running postgresql server-	@psql -h $$PWD/build/db -d app+	@psql $(PSQL_ARGS)  db: Application/Schema.sql Application/Fixtures.sql ## Creates a new database with the current Schema and imports Fixtures.sql-	(echo "drop schema public cascade; create schema public;" | psql -h $${PWD}/build/db -d app) && \-	psql -v ON_ERROR_STOP=1 -h $${PWD}/build/db -d app < "$${IHP_LIB}/IHPSchema.sql" && \-	psql -v ON_ERROR_STOP=1 -h $${PWD}/build/db -d app < Application/Schema.sql && \-	psql -v ON_ERROR_STOP=1 -h $${PWD}/build/db -d app < Application/Fixtures.sql+	(echo "drop schema public cascade; create schema public;" | psql $(PSQL_ARGS)) && \+	psql -v ON_ERROR_STOP=1 $(PSQL_ARGS) < "$${IHP_LIB}/IHPSchema.sql" && \+	psql -v ON_ERROR_STOP=1 $(PSQL_ARGS) < Application/Schema.sql && \+	psql -v ON_ERROR_STOP=1 $(PSQL_ARGS) < Application/Fixtures.sql  dumpdb: dump_db ## Saves the current database state into the Fixtures.sql dump_db: ## Saves the current database state into the Fixtures.sql-	pg_dump -a --inserts --column-inserts --disable-triggers -h $$PWD/build/db app | sed -e '/^--/d' > Application/Fixtures.sql+	pg_dump -a --inserts --column-inserts --disable-triggers $(PG_DUMP_ARGS) | sed -e '/^--/d' > Application/Fixtures.sql  sql_dump:  ## Saves the current database state, so it can dumped into an SQL file `make sql_dump > dump.sql`-	@pg_dump --no-owner --no-acl -h $$PWD/build/db app | sed -e '/^--/d'+	@pg_dump --no-owner --no-acl $(PG_DUMP_ARGS) | sed -e '/^--/d'  build/Generated/Types.hs: Application/Schema.sql ## Rebuilds generated types 	mkdir -p build/Generated 	build-generated-code -build/bin/RunUnoptimizedProdServer: Main.hs build/bin static/prod.js static/prod.css build/Generated/Types.hs ## Quickly does a production build (all compiler optimizations disabled)-	mkdir -p build/RunUnoptimizedProdServer-	ghc -O0 ${GHC_OPTIONS} $< -o $@ -odir build/RunUnoptimizedProdServer -hidir build/RunUnoptimizedProdServer-	chmod +x $<-	rm -f build/bin/RunProdServer-	ln -s `basename $@` build/bin/RunProdServer+build/bin/RunUnoptimizedProdServer: ## Deprecated: Use 'nix build .#unoptimized-prod-server' instead+	@echo "WARNING: This target is deprecated and may not work correctly."+	@echo "Please use 'nix build .#unoptimized-prod-server' instead."+	@echo "See https://ihp.digitallyinduced.com/Guide/deployment.html for more information."+	@exit 1 -build/bin/RunOptimizedProdServer: Main.hs build/bin static/prod.js static/prod.css build/Generated/Types.hs ## Full production build with all ghc optimizations (takes a while)-	mkdir -p build/RunOptimizedProdServer-	ghc -O${OPTIMIZATION_LEVEL} ${GHC_OPTIONS} ${PROD_GHC_OPTIONS} $< -o $@ -odir build/RunOptimizedProdServer -hidir build/RunOptimizedProdServer-	chmod +x $<-	rm -f build/bin/RunProdServer-	ln -s `basename $@` build/bin/RunProdServer+build/bin/RunOptimizedProdServer: ## Deprecated: Use 'nix build .#optimized-prod-server' instead+	@echo "WARNING: This target is deprecated and may not work correctly."+	@echo "Please use 'nix build .#optimized-prod-server' instead."+	@echo "See https://ihp.digitallyinduced.com/Guide/deployment.html for more information."+	@exit 1  clean: ## Resets all build and temporary files 	rm -rf build/bin 	rm -rf IHP/IHP/static/node_modules-	rm -rf build/db  static/prod.js: $(JS_FILES) ## Builds the production js bundle 	awk -v RS='\0' '{print "(function (window, document, undefined) {"; print; print "\n})(window, document);";}' $(JS_FILES) > $@@@ -152,15 +152,12 @@ help: ## This help page 	@grep -h -E '^[a-zA-Z_///-\.]+:.*?## .*$$' $(MAKEFILE_LIST) | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' -build/bin/Script/%: build/Script/Main/%.hs-	mkdir -p build/bin/Script-	# If RunOptimizedProdServer is compiled, likely we have object files with O2 in the build directory, so we're making an optimized script-	# Otherwise we're doing a unoptimized compile as it's much faster-	if [[ -f "build/bin/RunOptimizedProdServer" ]]; then \-		ghc -O${OPTIMIZATION_LEVEL} ${GHC_OPTIONS} ${PROD_GHC_OPTIONS} $< -o $@ -odir build/RunOptimizedProdServer -hidir build/RunOptimizedProdServer; \-	else \-		ghc -O0 ${GHC_OPTIONS} $< -o $@ -odir build/RunUnoptimizedProdServer -hidir build/RunUnoptimizedProdServer; \-	fi+build/bin/Script/%: ## Deprecated: Use 'nix build' instead+	@echo "WARNING: This target is deprecated and may not work correctly."+	@echo "Please use 'nix build .#optimized-prod-server' or 'nix build .#unoptimized-prod-server' instead."+	@echo "Script binaries will be available in result/bin/"+	@echo "See https://ihp.digitallyinduced.com/Guide/deployment.html for more information."+	@exit 1  build/Script/Main/%.hs: Application/Script/%.hs 	mkdir -p build/Script/Main@@ -170,15 +167,19 @@ 	echo "import Application.Script.$* (run)" >> $@ 	echo "main = runScript Config.config run" >> $@ -build/bin/RunJobs: build/RunJobs.hs ## Builds an unoptimized binary for running the job workers-	mkdir -p build/bin-	ghc -O0 -main-is 'RunJobs.main' ${GHC_OPTIONS} $< -o $@ -odir build/RunUnoptimizedProdServer -hidir build/RunUnoptimizedProdServer # We use object files by build/bin/RunUnoptimizedProdServer here to speed up compilation during deployments+build/bin/RunJobs: ## Deprecated: Use 'nix build' instead+	@echo "WARNING: This target is deprecated and may not work correctly."+	@echo "Please use 'nix build .#optimized-prod-server' or 'nix build .#unoptimized-prod-server' instead."+	@echo "The RunJobs binary will be available in result/bin/RunJobs"+	@echo "See https://ihp.digitallyinduced.com/Guide/deployment.html for more information."+	@exit 1 -build/bin/RunJobsOptimized: build/RunJobs.hs ## Builds an optimized binary for running the job workers, symlinks it to build/bin/RunJobs-	mkdir -p build/bin-	ghc -O${OPTIMIZATION_LEVEL} -main-is 'RunJobs.main' ${GHC_OPTIONS} ${PROD_GHC_OPTIONS} $< -o $@ -odir build/RunOptimizedProdServer -hidir build/RunOptimizedProdServer # We use object files by build/bin/RunOptimizedProdServer here to speed up compilation during deployments-	rm -f build/bin/RunJobs-	ln -s `basename $@` build/bin/RunJobs+build/bin/RunJobsOptimized: ## Deprecated: Use 'nix build .#optimized-prod-server' instead+	@echo "WARNING: This target is deprecated and may not work correctly."+	@echo "Please use 'nix build .#optimized-prod-server' instead."+	@echo "The RunJobs binary will be available in result/bin/RunJobs"+	@echo "See https://ihp.digitallyinduced.com/Guide/deployment.html for more information."+	@exit 1  build/RunJobs.hs: build/Generated/Types.hs 	echo "module RunJobs (main) where" > $@@@ -197,5 +198,9 @@ # https://github.com/digitallyinduced/ihp/issues/776 console: ghci ## Start IHP console, alias for 'make ghci' -prepare-optimized-nix-build: ## Sets the 'enabled = true' flags in default.nix, so that a 'nix-build' makes optimized binaries-	sed -i '' 's/haskellDeps/optimized = true;\n        haskellDeps/g' default.nix+prepare-optimized-nix-build: ## Deprecated: Use 'nix build .#optimized-prod-server' instead+	@echo "WARNING: This target is deprecated and no longer needed."+	@echo "Please use 'nix build .#optimized-prod-server' for optimized builds."+	@echo "Or use 'nix build .#unoptimized-prod-server' for faster, unoptimized builds."+	@echo "See https://ihp.digitallyinduced.com/Guide/deployment.html for more information."+	@exit 1
data/lib/IHP/applicationGhciConfig view
@@ -1,7 +1,6 @@ :set prompt "\ESC[38;5;208m\STXIHP>\ESC[m\STX " :set -i. :set -iIHP/ihp-hsx-:set -iIHP/ihp-postgresql-simple-extra :set -iConfig :set -ibuild :set -iIHP@@ -41,6 +40,7 @@ :set -XFunctionalDependencies :set -package ihp :set -fbyte-code+:set -j :set -Wno-partial-type-signatures :set -XPartialTypeSignatures :set -XStandaloneDeriving
data/static/IDE/data-hovercard.js view
@@ -2,49 +2,52 @@     initDataHoverCard(); }); -function initDataHoverCard() {-    $('td[data-foreign-key-column]').each(function () {-        var element = this;+// Dispose hovercards before Turbolinks replaces the page to prevent orphaned tooltip elements+document.addEventListener('turbolinks:before-render', function () {+    document.querySelectorAll('td[data-foreign-key-column]').forEach(function (el) {+        var existing = bootstrap.Tooltip.getInstance(el);+        if (existing) existing.dispose();+    });+}); -        $(element).tooltip({+function initDataHoverCard() {+    document.querySelectorAll('td[data-foreign-key-column]').forEach(function (element) {+        var bsTooltip = new bootstrap.Tooltip(element, {             title: "Loading",             html: true,             placement: 'left',-            template: '<div class="tooltip foreign-key-hovercard" role="tooltip"><div class="arrow"></div><div class="tooltip-inner"></div></div>',-            boundary: 'window'+            container: 'body',+            popperConfig: { strategy: 'fixed' },+            template: '<div class="tooltip foreign-key-hovercard" role="tooltip"><div class="tooltip-arrow"></div><div class="tooltip-inner"></div></div>'         });          var hoverCard = null;          // When the `_id` column doesn't have a foreign key constraint         // E.g. it's a stripe_customer_id column, then we get a 404 error-        // by the server. In that case we just dispose the tooltip in `updateConte`+        // by the server. In that case we just dispose the tooltip         var isError = false;          function updateContent() {-            const tooltipId = element.getAttribute('aria-describedby');-            const tooltipEl = document.getElementById(tooltipId);+            var tooltipEl = bsTooltip.tip;              if (!tooltipEl) {                 return;             }             if (isError) {-                $(element).tooltip('dispose');+                bsTooltip.dispose();                 return;             }-            const tooltipInner = tooltipEl.querySelector('.tooltip-inner');+            var tooltipInner = tooltipEl.querySelector('.tooltip-inner');              tooltipInner.innerHTML = hoverCard;--            $(element).attr('title', hoverCard)-            $(element).tooltip('update');-            $(element).tooltip('_fixTitle');+            bsTooltip.update();         } -        $(element).on('show.bs.tooltip', async function () {+        element.addEventListener('show.bs.tooltip', async function () {             var url = element.dataset.foreignKeyColumn;             if (!hoverCard) {-                hoverCard = fetch(url, { credentials: 'include' }).then(res => {+                hoverCard = fetch(url, { credentials: 'include' }).then(function (res) {                     if (!res.ok) {                         console.log('ERROR');                         isError = true;@@ -57,10 +60,10 @@                 updateContent();             }         });-        $(element).on('shown.bs.tooltip', async function () {-            if (!(hoverCard instanceof Promise) && !element.getAttribute('title')) {+        element.addEventListener('shown.bs.tooltip', async function () {+            if (typeof hoverCard === 'string') {                 updateContent();             }-        })-    })+        });+    }); }
data/static/IDE/form.css view
@@ -57,29 +57,22 @@     background-color: hsl(192deg 100% 26% / 50%) !important; } -.custom-control-label::before {+.form-check-input {     background-color: #002b36;     border: 1px solid hsl(192deg 100% 30% / 50%); } -.custom-checkbox .custom-control-input:checked~.custom-control-label::after {-    top: 1px;-}--.custom-control-input:checked~.custom-control-label::before {-    background-color:#519f98;+.form-check-input:checked {+    background-color: #519f98;     border-color: #519f98; } -.custom-control-input:focus~.custom-control-label::before {+.form-check-input:focus {     box-shadow: none !important;-}--.custom-control-input:focus:not(:checked)~.custom-control-label::before {     border-color: #519f98; } -.custom-control-label {+.form-check-label {     user-select: none;     -webkit-user-select: none; }
data/static/IDE/ihp-help.js view
@@ -1,11 +1,14 @@-$(function () {-    $('#nav-help').popover({+document.addEventListener('turbolinks:load', function () {+    var navHelp = document.getElementById('nav-help');+    if (!navHelp) return;++    new bootstrap.Popover(navHelp, {         container: '#content',         html: true,         content: document.getElementById('help-content').innerHTML,     }); -    document.getElementById('nav-help').addEventListener('click', event => {+    navHelp.addEventListener('click', function (event) {         event.preventDefault();-    })-})+    });+});
data/static/IDE/ihp-schemadesigner.js view
@@ -49,14 +49,18 @@             $('#typeSelector').val('DATE').trigger('change');         }     });-    $('.select2').select2({ tags: true });-    $('.select2-simple').select2();+    var $modal = $('.modal');+    var select2Options = $modal.length ? { tags: true, dropdownParent: $modal } : { tags: true };+    var select2SimpleOptions = $modal.length ? { dropdownParent: $modal } : {};+    $('.select2').select2(select2Options);+    $('.select2-simple').select2(select2SimpleOptions);     $('#typeSelector').change(function () {         switch (this.value) {             case "UUID":                 if ($('div[data-attribute="' + $("#colName").val() +'"]').length == 0) {+                    var defaultUuidFn = document.body.getAttribute('data-default-uuid-function') || 'uuid_generate_v4()';                     $('#defaultSelector').empty()-                    .append(new Option("uuid_generate_v4()", 'uuid_generate_v4()', true, true))+                    .append(new Option(defaultUuidFn, defaultUuidFn, true, true))                     .append(new Option("no default", "", false, false))                     .trigger('change');                 } else {@@ -186,7 +190,14 @@ }  function initTooltip() {-    $('[data-toggle="tooltip"]').tooltip('dispose').tooltip({ container: 'body'});+    // Remove any orphaned tooltip elements left over from Turbolinks/morphdom transitions+    document.querySelectorAll('body > .tooltip').forEach(function (el) { el.remove(); });++    document.querySelectorAll('[data-bs-toggle="tooltip"]').forEach(function (el) {+        var existing = bootstrap.Tooltip.getInstance(el);+        if (existing) existing.dispose();+        new bootstrap.Tooltip(el, { container: 'body', popperConfig: { strategy: 'fixed' } });+    }); }  document.addEventListener('turbolinks:load', initSchemaDesigner);@@ -195,6 +206,14 @@ document.addEventListener('turbolinks:load', initTooltip); document.addEventListener('turbolinks:load', initDataEditorForeignKeyAutocomplete); +// Dispose all tooltips before Turbolinks replaces the page to prevent orphaned tooltip elements+document.addEventListener('turbolinks:before-render', function () {+    document.querySelectorAll('[data-bs-toggle="tooltip"]').forEach(function (el) {+        var existing = bootstrap.Tooltip.getInstance(el);+        if (existing) existing.dispose();+    });+});+ function initQueryAce() {     var editorEl = document.getElementById('queryInput');     if (!editorEl) return;@@ -248,7 +267,7 @@ function setSqlMode(id, sqlMode) {     var inputField = document.getElementById(id + "-input");     if (sqlMode) {-        inputField.className = "form-control text-monospace text-secondary bg-light"+        inputField.className = "form-control font-monospace text-secondary bg-light"     } else {         inputField.className = "form-control";     }@@ -269,7 +288,7 @@         inputField.className = "d-none";         inputField.name = id + "-inactive";         hiddenField.name = id + "-inactive";-        altField.className = "form-control text-monospace text-secondary bg-light";+        altField.className = "form-control font-monospace text-secondary bg-light";         altField.name = id;         checkBoxContainer.className = "d-none";         @@ -336,18 +355,25 @@ function initDataEditorForeignKeyAutocomplete() {     const elements = document.querySelectorAll('.form-control.is-foreign-key-column'); +    var $modal = $('.modal');     for (const element of elements) {-        $(element).select2({+        var options = {             ajax: {                 url: element.dataset.selectUrl,-                processResults: data => ({ results: data }),+                processResults: data => ({+                    results: data.map(row => {+                        row._originalKeys = Object.keys(row);+                        return row;+                    })+                }),                 cache: true             },             templateResult: row => {                 const result = document.createElement('div');                 result.classList.add('record'); -                for (const key in row) {+                const keys = row._originalKeys || Object.keys(row);+                for (const key of keys) {                     const keyValueContainer = document.createElement('span');                     keyValueContainer.classList.add('key-value-container'); @@ -378,6 +404,8 @@                 return row.id;             },             placeholder:' Search ...'-        })+        };+        if ($modal.length) options.dropdownParent = $modal;+        $(element).select2(options);     } }
data/static/IDE/ihp-toolserver-layout.css view
@@ -184,6 +184,7 @@ .context-menu-open {     display: block;     position: fixed;+    width: fit-content; }  /* slightly transparent fallback */@@ -227,8 +228,16 @@ .data-rows-table {     font-size: 14px;     width: 100%;+    table-layout: fixed; } +.data-rows-table td {+    max-width: 300px;+    overflow: hidden;+    text-overflow: ellipsis;+    white-space: nowrap;+}+ .data-rows-table [data-fieldname$="id"] { font-size: 8px } .data-rows-table [data-fieldname="created_at"] { font-size: 8px } .data-rows-table [data-fieldname="password_hash"] { font-size: 8px }@@ -284,7 +293,7 @@     color: #fdf6e3; } -.border, .border-left, .border-bottom, .border-right, .border-top {+.border, .border-start, .border-bottom, .border-end, .border-top {     border-color: #0A4151 !important; } @@ -296,7 +305,7 @@     border-bottom: 1px solid #0A4151 } -.modal-header .close {+.modal-header .btn-close {     color: hsl(192deg 100% 30% / 50%);     transition: all 0.2s; }@@ -392,6 +401,6 @@     background-color: hsl(193deg 80% 6%); } -.bs-popover-auto[x-placement^=right]>.arrow::after, .bs-popover-right>.arrow::after {+.bs-popover-auto[data-popper-placement^="right"]>.popover-arrow::after, .bs-popover-end>.popover-arrow::after {     border-right-color: #0B5163; }
data/static/IDE/schema-designer.css view
@@ -110,6 +110,7 @@ }  .column-selector .column td {+	color: white;     padding-top: 0px;     padding-bottom: 0px;     font-size: 10px;@@ -150,7 +151,7 @@  #editor {     min-height: 800px;-    background-color: #33555E#33555E+    background-color: #33555E; }  .row-form {@@ -178,8 +179,9 @@     margin-bottom: 200px; /* Make sure the context menu has a bit of space, see https://github.com/digitallyinduced/ihp/issues/895 */ } -.index .index-name, .policy .policy-name {+.index .index-name, .policy .policy-name, .policy-expression {     padding-left: 8px;+    color: inherit; }  .policy-expression small {@@ -206,6 +208,11 @@     background-color: #063642; } +.column-selector .table {+    --bs-table-bg: transparent;+    --bs-table-hover-bg: hsla(192, 81%, 26%, 0.25);+}+ .object {     color: #E5EAEB;     transition: all 0.1s;@@ -239,6 +246,10 @@     color:  #fff; } +.column-selector a.text-body {+    color: inherit !important;+}+ .column-selector .column {     color: #FFFFFF; }@@ -252,12 +263,18 @@ #schema-designer-viewer {     margin-bottom: 0;     flex-grow: 1;+    flex-wrap: nowrap;+    overflow: hidden; }  .object-selector, .column-selector {     min-height: 0 !important; } +.object-selector {+    min-width: 0;+}+ .migration-status-visible .column-selector {     padding-bottom: 100px; }@@ -294,20 +311,20 @@     font-size: 12px; } -#column-options .custom-control {+#column-options .form-check {     display: flex;     justify-content: center;     align-items: center; } -#column-options .custom-control-label::before {-    top: 1px;-}- #editor .code-editor-container {     min-height: 800px; } +.modal-body {+    overflow: visible;+}+ .select2-results__option span.key {     opacity: 0.5;     margin-right: 12px;@@ -332,26 +349,36 @@ }  #migration-status-container {-    position: absolute;-    bottom: 20px;-    left: 0;-    right: 0;+    position: sticky;+    bottom: 0;+    z-index: 10;+    width: 100%; }  #migration-status-container > .alert {+    --bs-alert-bg: #0A4151;+    --bs-alert-color: hsla(196, 13%, 90%, 1);+    --bs-alert-border-color: #0A4151;+    --bs-alert-padding-x: 16px;+    --bs-alert-padding-y: 8px;+    --bs-alert-margin-bottom: 0;     max-width: 800px;     margin-left: auto;     margin-right: auto;+    margin-bottom: 0;     font-size: 14px;-    padding-top: 8px;-    padding-bottom: 8px;-    padding-left: 16px !important;-    padding-right: 16px !important;-    border: 2px solid #0B5163;+    padding: 8px 16px;+    border: 1px solid hsla(192, 81%, 26%, 0.4);+    border-radius: 6px;     background-color: #0A4151;+    color: hsla(196, 13%, 90%, 1); }  #migration-status-container .btn.btn-dark {+    --bs-btn-bg: #002B37;+    --bs-btn-border-color: hsla(192, 81%, 26%, 0.8);+    --bs-btn-hover-bg: #003a4a;+    --bs-btn-hover-border-color: hsla(192, 81%, 26%, 1);     background-color: #002B37;     border: 1px solid hsla(192, 81%, 26%, 0.8); }
data/static/IDE/table.css view
@@ -9,7 +9,19 @@ }  .table {-    color:  #fff;+    --bs-table-bg: transparent;+    --bs-table-color: #fff;+    --bs-table-hover-bg: hsla(192, 81%, 26%, 0.25);+    color: #fff;+}++/* Override Bootstrap's .table>:not(caption)>*>* which resets color on cells */+.table > :not(caption) > * > * {+    color: inherit;+}++.table td, .table th {+    border-bottom: 0; }  .table td a {
data/static/IDE/toolserver-logs.css view
@@ -1,41 +1,62 @@ #logs {-    background-color: hsla(192, 81%, 3%, 1);+    background-color: #0a1628;     height: 100%;     display: flex;+    flex-direction: column;+}++#logs .logs-tab-bar {+    display: flex;     flex-direction: row;+    gap: 0;+    padding: 0 1rem;+    background-color: #0d1b30;+    border-bottom: 1px solid #1e2d45;+    flex-shrink: 0; } -#logs pre {-    color: hsla(196, 13%, 90%, 1);-    padding-left: 2rem;-    padding-right: 4rem;-    padding-top: 80px;-    padding-bottom: 8rem;-    margin-bottom: 0;-    font-size: 11px;+#logs .logs-tab {+    padding: 0.6rem 1rem;+    color: #8899aa;+    font-weight: 500;+    font-size: 12px;+    text-decoration: none;+    border-bottom: 2px solid transparent;+    transition: color 0.15s, border-color 0.15s; } -#logs pre:empty {-    display: none;+#logs .logs-tab:hover {+    color: #c8d6e5; } -#logs .logs-navigation {-    height: 100%;-    display: flex;-    flex-direction: column;;-    padding-top: 80px;+#logs .logs-tab.active {+    color: #e8f0fe;+    border-bottom-color: #4d9fff; } -#logs .logs-navigation a {-    padding-left: 2rem;-    padding-right: 1rem;-    padding-bottom: 1rem;-    color: #fdf6e3;-    font-weight: 400;-    font-size: 11px;-    opacity: 0.5;+#logs .logs-output {+    flex: 1;+    overflow-y: auto;+    padding: 1rem 2rem 4rem; } -#logs .logs-navigation a.active {-    opacity: 1;+#logs .logs-output pre {+    color: #c8d6e5;+    margin-bottom: 0;+    font-family: 'SF Mono', Menlo, Monaco, 'Cascadia Code', monospace;+    font-size: 12px;+    line-height: 1.5;+    white-space: pre-wrap;+    word-wrap: break-word;+    background: transparent;+    border: none;+    padding: 0;+}++#logs .logs-output pre:empty {+    display: none;+}++#logs .logs-output pre.stderr {+    color: #f0883e; }
data/static/IDE/tooltip.css view
@@ -12,7 +12,7 @@      box-shadow: 0 1rem 3rem rgba(0,0,0,.175)!important; }-.tooltip .arrow {+.tooltip .tooltip-arrow {     display: none; }
− exe/IHP/CLI/BuildGeneratedCode.hs 
@@ -1,14 +0,0 @@-{-|-Module: IHP.CLI.BuildGeneratedCode-Description:  Provides the @build-generated-code@ command which generates the Generated.Types module-Copyright: (c) digitally induced GmbH, 2020--}-module Main where--import IHP.Prelude-import IHP.SchemaCompiler-import Main.Utf8 (withUtf8)--main :: IO ()-main = withUtf8 do-    compile
exe/IHP/CLI/DeleteController.hs view
@@ -1,7 +1,7 @@ module Main where  import IHP.Prelude-import qualified System.Directory as Directory+import qualified System.Directory.OsPath as Directory import qualified System.Posix.Env.ByteString as Posix import IHP.IDE.CodeGen.ControllerGenerator import IHP.IDE.CodeGen.Controller (undoPlan)@@ -22,8 +22,7 @@         _ -> usage  deleteController applicationName controllerName = do-    let paginationEnabled = False-    planOrError <- buildPlan applicationName controllerName paginationEnabled+    planOrError <- buildPlan controllerName defaultControllerConfig { applicationName }     case planOrError of         Left error -> putStrLn error         Right plan -> undoPlan $ reverse plan
exe/IHP/CLI/NewApplication.hs view
@@ -1,7 +1,7 @@ module Main where  import IHP.Prelude-import qualified System.Directory as Directory+import qualified System.Directory.OsPath as Directory import qualified System.Posix.Env.ByteString as Posix import IHP.IDE.CodeGen.ApplicationGenerator import IHP.IDE.CodeGen.Controller (executePlan)
exe/IHP/CLI/NewController.hs view
@@ -1,7 +1,7 @@ module Main where  import IHP.Prelude-import qualified System.Directory as Directory+import qualified System.Directory.OsPath as Directory import qualified System.Posix.Env.ByteString as Posix import IHP.IDE.CodeGen.ControllerGenerator import IHP.IDE.CodeGen.Controller (executePlan)@@ -17,6 +17,7 @@         Just "" -> usage         Just appAndControllerName -> do             generateController appAndControllerName+        Nothing -> usage  usage :: IO () usage = putStrLn "Usage: new-controller RESOURCE_NAME"@@ -29,15 +30,14 @@      generateController :: Text -> IO () generateController appAndControllerName = do-    let paginationEnabled = False     case Text.splitOn "." appAndControllerName of         [controllerName] -> do-            planOrError <- buildPlan controllerName "Web" paginationEnabled+            planOrError <- buildPlan controllerName defaultControllerConfig             case planOrError of                 Left error -> putStrLn error                 Right plan -> executePlan plan         [applicationName, controllerName] -> do-            planOrError <- buildPlan controllerName applicationName paginationEnabled+            planOrError <- buildPlan controllerName defaultControllerConfig { applicationName }             case planOrError of                 Left error -> putStrLn error                 Right plan -> executePlan plan
exe/IHP/CLI/NewMigration.hs view
@@ -2,7 +2,7 @@  import IHP.Prelude import qualified System.Posix.Env.ByteString as Posix-import qualified System.Directory as Directory+import qualified System.Directory.OsPath as Directory import IHP.IDE.ToolServer.Helper.Controller (openEditor) import qualified IHP.IDE.CodeGen.MigrationGenerator as MigrationGenerator import IHP.IDE.CodeGen.Controller (executePlan)
exe/IHP/IDE/DevServer.hs view
@@ -4,10 +4,7 @@ import qualified System.Process as Process import IHP.HaskellSupport import qualified Data.ByteString.Char8 as ByteString-import Control.Concurrent (myThreadId, threadDelay)-import System.Exit-import System.Posix.Signals-+import Control.Concurrent (threadDelay) import IHP.IDE.Types import IHP.IDE.Postgres import IHP.IDE.StatusServer@@ -30,28 +27,34 @@ import qualified Control.Concurrent.Chan.Unagi as Queue import IHP.IDE.FileWatcher import qualified System.Environment as Env-import qualified System.Directory as Directory+import qualified System.Directory.OsPath as Directory import qualified Control.Exception.Safe as Exception import qualified Data.ByteString.Builder as ByteString import qualified Network.Socket as Socket+import qualified System.IO as IO+import System.OsPath (OsPath, encodeUtf, decodeUtf) + mainInParentDirectory :: IO () mainInParentDirectory = do     cwd <- Directory.getCurrentDirectory-    mainInProjectDirectory (cwd <> "/../")+    cwdStr <- decodeUtf cwd+    projectDir <- encodeUtf (cwdStr <> "/../")+    mainInProjectDirectory projectDir -mainInProjectDirectory :: FilePath -> IO ()+mainInProjectDirectory :: OsPath -> IO () mainInProjectDirectory projectDir = do     cwd <- Directory.getCurrentDirectory+    cwdStr <- decodeUtf cwd      withCurrentWorkingDirectory projectDir do-        Env.setEnv "IHP_LIB" (cwd <> "/ihp-ide/lib/IHP")-        Env.setEnv "TOOLSERVER_STATIC" (cwd <> "/ihp-ide/lib/IHP/static")-        Env.setEnv "IHP_STATIC" (cwd <> "/lib/IHP/static")+        Env.setEnv "IHP_LIB" (cwdStr <> "/ihp-ide/lib/IHP")+        Env.setEnv "TOOLSERVER_STATIC" (cwdStr <> "/ihp-ide/lib/IHP/static")+        Env.setEnv "IHP_STATIC" (cwdStr <> "/lib/IHP/static")          mainWithOptions True -withCurrentWorkingDirectory :: FilePath -> IO result -> IO result+withCurrentWorkingDirectory :: OsPath -> IO result -> IO result withCurrentWorkingDirectory workingDirectory callback = do     cwd <- Directory.getCurrentDirectory     Exception.bracket_@@ -64,19 +67,29 @@  mainWithOptions :: Bool -> IO () mainWithOptions wrapWithDirenv = withUtf8 do+    -- https://github.com/digitallyinduced/ihp/issues/2134+    -- devenv will redirect the standard handles to a pipe, causing block buffering by default+    -- We need to override this so that `putStrLn` etc. works as expected+    IO.hSetBuffering IO.stdout IO.LineBuffering+    IO.hSetBuffering IO.stderr IO.LineBuffering+     databaseNeedsMigration <- newIORef False     portConfig <- findAvailablePortConfig-    ensureUserIsNotRoot      -- Start the dev server in Debug mode by setting the env var DEBUG=1     -- Like: $ DEBUG=1 devenv up     isDebugMode <- EnvVar.envOrDefault "DEBUG" False +    -- Create a persistent listening socket for the app port+    -- This socket is shared between the status server and the app,+    -- ensuring seamless transitions during app restarts (no connection refused errors)+    appSocket <- createListeningSocket portConfig.appPort+     bracket (Log.newLogger def) (\logger -> logger.cleanup) \logger -> do         (ghciInChan, ghciOutChan) <- Queue.newChan         liveReloadClients <- newIORef mempty         lastSchemaCompilerError <- newIORef Nothing-        let ?context = Context { portConfig, isDebugMode, logger, ghciInChan, ghciOutChan, wrapWithDirenv, liveReloadClients, lastSchemaCompilerError }+        let ?context = Context { portConfig, isDebugMode, logger, ghciInChan, ghciOutChan, wrapWithDirenv, liveReloadClients, lastSchemaCompilerError, appSocket }          -- Print IHP Version when in debug mode         when isDebugMode (Log.debug ("IHP Version: " <> Version.ihpVersion))@@ -84,41 +97,37 @@         ghciIsLoadingVar <- newIORef False         reloadGhciVar :: MVar () <- newEmptyMVar -        withBuiltinOrDevenvPostgres \databaseIsReady postgresStandardOutput postgresErrorOutput -> do-            withStatusServer ghciIsLoadingVar \startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients -> do-                -- Compile Schema before loading the app-                tryCompileSchema reloadGhciVar startStatusServer-                -                let toolServerApplication = ToolServerApplication-                        { postgresStandardOutput-                        , postgresErrorOutput-                        , appStandardOutput = statusServerStandardOutput-                        , appErrorOutput = statusServerErrorOutput-                        , appPort = portConfig.appPort-                        , databaseNeedsMigration-                        }+        withStatusServer ghciIsLoadingVar \startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients -> do+            -- Compile Schema before loading the app+            tryCompileSchema reloadGhciVar startStatusServer +            let toolServerApplication = ToolServerApplication+                    { appStandardOutput = statusServerStandardOutput+                    , appErrorOutput = statusServerErrorOutput+                    , appPort = portConfig.appPort+                    , databaseNeedsMigration+                    } -                void $ runConcurrently $ (,,,,,,)-                        <$> Concurrently (updateDatabaseIsOutdated databaseNeedsMigration databaseIsReady)-                        <*> Concurrently (runToolServer toolServerApplication liveReloadClients)-                        <*> Concurrently (consumeGhciOutput statusServerStandardOutput statusServerErrorOutput statusServerClients)-                        <*> Concurrently Telemetry.reportTelemetry-                        <*> Concurrently (runFileWatcherWithDebounce (fileWatcherParams liveReloadClients databaseNeedsMigration databaseIsReady reloadGhciVar startStatusServer))-                        <*> Concurrently (runAppGhci ghciIsLoadingVar startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients reloadGhciVar) -            pure ()+            void $ runConcurrently $ (,,,,,)+                    <$> Concurrently (updateDatabaseIsOutdated databaseNeedsMigration)+                    <*> Concurrently (runToolServer toolServerApplication liveReloadClients)+                    <*> Concurrently (consumeGhciOutput statusServerStandardOutput statusServerErrorOutput statusServerClients)+                    <*> Concurrently Telemetry.reportTelemetry+                    <*> Concurrently (runFileWatcherWithDebounce (fileWatcherParams liveReloadClients databaseNeedsMigration reloadGhciVar startStatusServer))+                    <*> Concurrently (runAppGhci ghciIsLoadingVar startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients reloadGhciVar) -fileWatcherParams liveReloadClients databaseNeedsMigration databaseIsReady reloadGhciVar startStatusServer =+fileWatcherParams liveReloadClients databaseNeedsMigration reloadGhciVar startStatusServer =     FileWatcherParams-        { onHaskellFileChanged = putMVar reloadGhciVar ()-        , onSchemaChanged = concurrently_ (tryCompileSchema reloadGhciVar startStatusServer) (updateDatabaseIsOutdated databaseNeedsMigration databaseIsReady)+        { onHaskellFileChanged = do+            -- Use tryPutMVar to avoid blocking if a reload is already pending.+            -- This handles the case where multiple file changes happen in quick succession.+            void $ tryPutMVar reloadGhciVar ()+        , onSchemaChanged = do+            concurrently_ (tryCompileSchema reloadGhciVar startStatusServer) (updateDatabaseIsOutdated databaseNeedsMigration)         , onAssetChanged = notifyAssetChange liveReloadClients         } -isUsingDevenv :: IO Bool-isUsingDevenv = EnvVar.envOrDefault "IHP_DEVENV" False- ghciArguments :: [String] ghciArguments =     [ "-threaded"@@ -128,35 +137,20 @@     , "-package-env -" -- Do not load `~/.ghc/arch-os-version/environments/name file`, global packages interfere with our packages     , "-ignore-dot-ghci" -- Ignore the global ~/.ghc/ghci.conf That file sometimes causes trouble (specifically `:set +c +s`)     , "-ghci-script", ".ghci" -- Because the previous line ignored default ghci config file locations, we have to manual load our .ghci-    , "+RTS", "-A128m", "-n2m", "-H2m", "--nonmoving-gc", "-N"+    , "+RTS", "-A64m", "-n4m", "-H256m", "--nonmoving-gc", "-Iw60", "-N4"     ]  withGHCI :: (?context :: Context) => (Handle -> Handle -> Handle -> Process.ProcessHandle -> IO a) -> IO a withGHCI callback = do-    let params = (procDirenvAware "ghci" ghciArguments)+    baseParams <- procDirenvAware "ghci" ghciArguments+    let params = baseParams             { Process.std_in = Process.CreatePipe             , Process.std_out = Process.CreatePipe             , Process.std_err = Process.CreatePipe-            , Process.create_group = True             }      Process.withCreateProcess params \(Just input) (Just output) (Just error) processHandle -> callback input output error processHandle --- | Exit with an error if running as the root user------ When the dev server starts the postgres server, it will fail if run as root:------ > initdb: cannot be run as root------ This is a bit hard to debug, therefore we proactively fail early when run as root----ensureUserIsNotRoot :: IO ()-ensureUserIsNotRoot = do-    username <- EnvVar.envOrDefault "USERNAME" ("" :: ByteString)-    when (username == "root") do-        ByteString.hPutStrLn stderr "Cannot be run as root: The IHP dev server cannot be run with the root user because we cannot start the postgres server with a root user.\n\nPlease run this with a normal user.\nIf you need help, join the IHP Slack: https://ihp.digitallyinduced.com/Slack"-        exitFailure- initGHCICommands =      [ -- The app is loaded by loading .ghci, which then loads applicationGhciConfig, which triggers a ':l Main.hs'      ":set prompt \"\"" -- Disable the prompt as this caused output such as '[38;5;208mIHP>[m Ser[v3e8r; 5s;t2a0r8tmedI' instead of 'Server started'@@ -165,7 +159,6 @@  runAppGhci :: (?context :: Context) => IORef Bool -> MVar () -> MVar (MVar ()) -> IORef [ByteString] -> IORef [ByteString] -> Clients -> MVar () -> IO () runAppGhci ghciIsLoadingVar startStatusServer stopStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients reloadGhciVar = do-    let isDebugMode = ?context.isDebugMode     -- The app is using the `PORT` env variable for its web server     let appPort :: Int = fromIntegral ?context.portConfig.appPort     Env.setEnv "PORT" (show appPort)@@ -176,50 +169,82 @@             callback      let processResult inputHandle outputHandle errorHandle processHandle result = do-            hasSchemaCompilerError <- isJust <$> readIORef ?context.lastSchemaCompilerError-            -- This branch blocks until .hs file change happens+            -- Handle the result of GHCi compilation, then wait for the next file change             case result of-                Left failed -> takeMVar reloadGhciVar-                Right _ | hasSchemaCompilerError -> takeMVar reloadGhciVar+                Left failed -> do+                    writeIORef ghciIsLoadingVar False+                    -- Clear any stale reload signals to prevent rapid retry loops.+                    -- This can happen when schema compilation fails and generates+                    -- invalid files, triggering multiple file watcher events.+                    void $ tryTakeMVar reloadGhciVar+                    -- Wait for the next file change before retrying+                    takeMVar reloadGhciVar                 Right loaded -> do-                    withoutStatusServer do-                        withRunningApp ?context.portConfig.appPort inputHandle outputHandle errorHandle processHandle receiveAppOutput do+                    -- Check for schema error fresh here to avoid race condition with tryCompileSchema.+                    -- The schema compiler runs concurrently and may have set an error after GHCi loaded.+                    hasSchemaCompilerError <- isJust <$> readIORef ?context.lastSchemaCompilerError+                    writeIORef ghciIsLoadingVar False+                    if hasSchemaCompilerError+                        then do+                            -- Don't start the app if there's a schema error - wait for fix                             takeMVar reloadGhciVar---                    pure ()-            +                        else do+                            -- Clear any stale reload signal (e.g. from tryCompileSchema triggering+                            -- a reload after recovering from a previous schema error)+                            void $ tryTakeMVar reloadGhciVar+                            -- Catch any exceptions from withRunningApp (e.g., startup timeout)+                            -- so we can return to the status server gracefully+                            result <- Exception.tryAny $ withoutStatusServer do+                                withRunningApp ?context.portConfig.appPort inputHandle outputHandle errorHandle processHandle receiveAppOutput \appCrashed -> do+                                    -- App is running, wait for next file change or app crash+                                    race_ (takeMVar reloadGhciVar) (takeMVar appCrashed)+                            case result of+                                Left ex -> do+                                    -- App startup failed, wait for a reload signal before trying again+                                    takeMVar reloadGhciVar+                                Right () -> pure ()              writeIORef ghciIsLoadingVar True-            +             -- Clear logs in web ui             clearStatusServer statusServerStandardOutput statusServerErrorOutput statusServerClients              result <- refresh inputHandle outputHandle errorHandle receiveAppOutput-            +             -- reload app             notifyHaskellChange ?context.liveReloadClients              processResult inputHandle outputHandle errorHandle processHandle result -         withGHCI \inputHandle outputHandle errorHandle processHandle -> do         writeIORef ghciIsLoadingVar True         withLoadedApp inputHandle outputHandle errorHandle receiveAppOutput \result -> do             processResult inputHandle outputHandle errorHandle processHandle result +-- | Read lines from a handle, accumulating output and classifying each line.+--+-- Races against @stopVar@ being filled — when the MVar is readable, reading stops.+readHandleLines+    :: MVar a                   -- ^ Race against this (stop when filled)+    -> MVar ByteString.Builder  -- ^ Output accumulator+    -> Handle                   -- ^ Handle to read from+    -> (ByteString -> IO ())    -- ^ Log callback+    -> (ByteString -> IO ())    -- ^ Line classifier/action+    -> IO ()+readHandleLines stopVar outputVar handle logLine onMatch = race_ (readMVar stopVar) $ forever do+    line <- ByteString.hGetLine handle+    modifyMVar_ outputVar (\builder -> pure (builder <> "\n" <> ByteString.byteString line))+    logLine line+    onMatch line+ withLoadedApp :: (?context :: Context) => Handle -> Handle -> Handle -> (OutputLine -> IO ()) -> ((Either LByteString LByteString) -> IO a) -> IO a withLoadedApp inputHandle outputHandle errorHandle logLine callback = do     outputVar :: MVar ByteString.Builder <- newMVar ""     resultVar :: MVar Bool <- newEmptyMVar-    let readHandle handle logLine = race_ (readMVar resultVar) $ forever do-            line <- ByteString.hGetLine handle-            modifyMVar_ outputVar (\builder -> pure (builder <> "\n" <> ByteString.byteString line))-            logLine line-            case line of-                line | "Failed," `isInfixOf` line -> putMVar resultVar False-                line | "modules loaded." `isInfixOf` line -> putMVar resultVar True-                _ -> pure ()+    let onMatch line = case line of+            line | "Failed," `isInfixOf` line -> putMVar resultVar False+            line | "modules loaded." `isInfixOf` line -> putMVar resultVar True+            _ -> pure ()      let main = do             sendGhciCommands inputHandle initGHCICommands@@ -236,69 +261,70 @@      (result, _, _) <- runConcurrently $ (,,)         <$> Concurrently main-        <*> Concurrently (readHandle outputHandle (\line -> logLine (StandardOutput line)))-        <*> Concurrently (readHandle errorHandle (\line -> logLine (ErrorOutput line)))+        <*> Concurrently (readHandleLines resultVar outputVar outputHandle (\line -> logLine (StandardOutput line)) onMatch)+        <*> Concurrently (readHandleLines resultVar outputVar errorHandle (\line -> logLine (ErrorOutput line)) onMatch)      pure result -withRunningApp :: (?context :: Context) => Socket.PortNumber -> Handle -> Handle -> Handle -> Process.ProcessHandle -> (OutputLine -> IO ()) -> (IO a) -> IO a+withRunningApp :: (?context :: Context) => Socket.PortNumber -> Handle -> Handle -> Handle -> Process.ProcessHandle -> (OutputLine -> IO ()) -> (MVar () -> IO a) -> IO a withRunningApp appPort inputHandle outputHandle errorHandle processHandle logLine callback = do     outputVar :: MVar ByteString.Builder <- newMVar ""     serverStarted :: MVar () <- newEmptyMVar     serverStopped :: MVar () <- newEmptyMVar-    let readHandle handle logLine = race_-                (readMVar serverStopped)-                (forever do-                    line <- ByteString.hGetLine handle-                    modifyMVar_ outputVar (\builder -> pure (builder <> "\n" <> ByteString.byteString line))-                    logLine line-                    case line of-                        line | "Server started" `isInfixOf` line -> putMVar serverStarted ()-                        _ -> pure ()-                )+    appCrashed :: MVar () <- newEmptyMVar+    let onMatch line = case line of+            line | "Server started" `isInfixOf` line -> putMVar serverStarted ()+            line | "[[IHP_APP_CRASHED]]" `isInfixOf` line -> void $ tryPutMVar appCrashed ()+            _ -> pure ()      let startApp = do+            -- Pass the socket file descriptor to the app so it can accept connections+            -- on the same socket without rebinding the port.+            -- Note: GHCi is a child process with its own FD table, so the app closing+            -- its copy of the FD won't affect RunDevServer's copy.+            socketFd <- Socket.unsafeFdSocket ?context.appSocket+            sendGhciCommand inputHandle $ "System.Environment.setEnv \"IHP_SOCKET_FD\" \"" <> cs (show socketFd) <> "\""             sendGhciCommand inputHandle "stopVar :: ClassyPrelude.MVar () <- ClassyPrelude.newEmptyMVar"-            sendGhciCommand inputHandle "app <- ClassyPrelude.async (ClassyPrelude.race_ (ClassyPrelude.takeMVar stopVar) (main `ClassyPrelude.catch` \\(e :: SomeException) -> IHP.Prelude.putStrLn (tshow e)))"+            sendGhciCommand inputHandle "app <- ClassyPrelude.async (ClassyPrelude.race_ (ClassyPrelude.takeMVar stopVar) (main `ClassyPrelude.catch` \\(e :: SomeException) -> IHP.Prelude.putStrLn (tshow e) >> IHP.Prelude.putStrLn \"[[IHP_APP_CRASHED]]\"))"     let stopApp = do             sendGhciCommand inputHandle "ClassyPrelude.putMVar stopVar ()"             sendGhciCommand inputHandle "ClassyPrelude.cancel app"-            waitForPortAvailable appPort+            -- Give GHCi a moment to process the stop commands before signaling completion+            -- This prevents the status server from starting while the app is still running+            threadDelay 100000 -- 100ms+            -- No need to wait for port availability - we use a persistent socket             putMVar serverStopped () +    let waitForServerStart = do+            -- Wait up to 60 seconds for "Server started" message+            -- If the app crashes during startup, "Server started" will never be printed+            maybeStarted <- timeout (60 * 1000000) (takeMVar serverStarted)+            case maybeStarted of+                Just () -> callback appCrashed+                Nothing -> do+                    logLine (ErrorOutput "App startup timed out after 60 seconds. Check for runtime errors above.")+                    -- Throw exception to trigger bracket cleanup and return to status server+                    Exception.throwString "App startup timeout"+     (result, _, _) <- runConcurrently $ (,,)-        <$> Concurrently (Exception.bracket_ startApp stopApp (do takeMVar serverStarted; callback))-        <*> Concurrently (readHandle outputHandle (\line -> logLine (StandardOutput line)))-        <*> Concurrently (readHandle errorHandle (\line -> logLine (ErrorOutput line)))+        <$> Concurrently (Exception.bracket_ startApp stopApp waitForServerStart)+        <*> Concurrently (readHandleLines serverStopped outputVar outputHandle (\line -> logLine (StandardOutput line)) onMatch)+        <*> Concurrently (readHandleLines serverStopped outputVar errorHandle (\line -> logLine (ErrorOutput line)) onMatch)      pure result -waitForPortAvailable :: Socket.PortNumber -> IO ()-waitForPortAvailable port = do-    isAvailable <- isPortAvailable port-    unless isAvailable do-        putStrLn "waitForPortAvailable: wait"-        threadDelay 100000-        waitForPortAvailable port- refresh :: (?context :: Context) => Handle -> Handle -> Handle -> (OutputLine -> IO ()) -> IO (Either LByteString LByteString) refresh inputHandle outputHandle errorHandle logOutput = do     outputVar :: MVar ByteString.Builder <- newMVar ""     resultVar :: MVar Bool <- newEmptyMVar-    let readHandle handle logLine = race_-                (readMVar resultVar)-                (forever do-                    line <- ByteString.hGetLine handle-                    modifyMVar_ outputVar (\builder -> pure (builder <> "\n" <> ByteString.byteString line))-                    logLine line-                    case line of-                        line | "Failed," `isInfixOf` line -> putMVar resultVar False-                        line | "modules loaded." `isInfixOf` line -> putMVar resultVar True-                        line | "cannot find object file for module" `isInfixOf` line -> do-                            -- https://gitlab.haskell.org/ghc/ghc/-/issues/11596-                            sendGhciCommand inputHandle ":l"-                        _ -> pure ()-                )+    let onMatch line = case line of+            line | "Failed," `isInfixOf` line -> putMVar resultVar False+            -- Match both "modules loaded." (initial) and "modules reloaded." (after :r)+            line | "modules loaded." `isInfixOf` line || "modules reloaded." `isInfixOf` line -> putMVar resultVar True+            line | "cannot find object file for module" `isInfixOf` line -> do+                -- https://gitlab.haskell.org/ghc/ghc/-/issues/11596+                sendGhciCommand inputHandle ":l"+            _ -> pure ()      let main = do             sendGhciCommand inputHandle ":r"@@ -312,8 +338,8 @@      (result, _, _) <- runConcurrently $ (,,)         <$> Concurrently main-        <*> Concurrently (readHandle outputHandle (\line -> logOutput (StandardOutput line)))-        <*> Concurrently (readHandle errorHandle (\line -> logOutput (ErrorOutput line)))+        <*> Concurrently (readHandleLines resultVar outputVar outputHandle (\line -> logOutput (StandardOutput line)) onMatch)+        <*> Concurrently (readHandleLines resultVar outputVar errorHandle (\line -> logOutput (ErrorOutput line)) onMatch)      pure result @@ -330,10 +356,10 @@     diff <- MigrationGenerator.diffAppDatabase True databaseUrl     pure (not (isEmpty diff)) -updateDatabaseIsOutdated :: (?context :: Context) => IORef Bool -> MVar () -> IO ()-updateDatabaseIsOutdated databaseNeedsMigrationRef databaseIsReady = do+updateDatabaseIsOutdated :: (?context :: Context) => IORef Bool -> IO ()+updateDatabaseIsOutdated databaseNeedsMigrationRef = do     result <- Exception.tryAny do-            readMVar databaseIsReady+            waitPostgres             databaseNeedsMigration <- checkDatabaseIsOutdated             writeIORef databaseNeedsMigrationRef databaseNeedsMigration @@ -344,7 +370,7 @@ tryCompileSchema :: (?context :: Context) => MVar () -> MVar () -> IO () tryCompileSchema reloadGhciVar startStatusServer = do     result <- Exception.tryAny SchemaCompiler.compile-    +     case result of         Left exception -> do             Log.error (tshow exception)@@ -358,4 +384,6 @@             previouslyHadSchemaError <- isJust <$> readIORef ?context.lastSchemaCompilerError             writeIORef ?context.lastSchemaCompilerError Nothing -            when previouslyHadSchemaError (putMVar reloadGhciVar ())+            -- Use tryPutMVar to avoid double trigger if file watcher already triggered reload+            -- This triggers a reload only if recovering from a previous schema error+            when previouslyHadSchemaError $ void $ tryPutMVar reloadGhciVar ()
ihp-ide.cabal view
@@ -1,9 +1,10 @@ cabal-version:       2.2 name:                ihp-ide-version:             1.4.0+version:             1.5.0 synopsis:            Dev tools for IHP description:         The Integrated Haskell Platform is a full stack framework focused on rapid application development while striving for robust code quality. license:             MIT+license-file:        LICENSE author:              digitally induced GmbH maintainer:          hello@digitallyinduced.com homepage:            https://ihp.digitallyinduced.com/@@ -13,6 +14,7 @@ stability:           Stable tested-with:         GHC == 9.8.4 build-type:          Simple+extra-source-files:  changelog.md data-dir: data data-files:       lib/IHP/Makefile.dist@@ -38,7 +40,8 @@             , classy-prelude             , mono-traversable             , transformers-            , directory+            , directory >= 1.3.8.0+            , filepath >= 1.5             , string-conversions             , warp             , wai@@ -47,15 +50,14 @@             , wai-extra             , inflections             , text-            , postgresql-simple             , wai-app-static             , wai-util             , bytestring             , network-uri             , uri-encode             , aeson-            , wai-session-            , wai-session-clientsession+            , wai-session-maybe+            , wai-session-clientsession-deferred             , clientsession             , vault             , data-default@@ -76,11 +78,11 @@             , websockets             , wai-websockets             , wreq-            , parser-combinators             , neat-interpolation             , unagi-chan             , with-utf8             , ihp-hsx+            , ihp-postgres-parser             -- Used for 'Control.Debounce' in 'IHP.IDE.FileWatcher'             , auto-update             , base16-bytestring@@ -88,6 +90,11 @@             , http-types             , safe-exceptions             , countable-inflections+            , ihp-migrate+            , hasql+            , hasql-pool+            , hasql-dynamic-statements+            , hasql-implicits     default-extensions:         OverloadedStrings         , NoImplicitPrelude@@ -111,15 +118,15 @@     if flag(FastBuild)         ghc-options:             -threaded-            +RTS -A256m -n4m -H512m -qg -N -RTS              -Wunused-imports             -Wunused-foralls-            -Wmissing-fields+            -Werror=missing-fields             -Winaccessible-code             -Wmissed-specialisations             -Wall-missed-specialisations             -Wno-ambiguous-fields+            -Werror=incomplete-patterns     else         ghc-options:             -fstatic-argument-transformation@@ -129,19 +136,21 @@              -Wunused-imports             -Wunused-foralls-            -Wmissing-fields+            -Werror=missing-fields             -Winaccessible-code             -Wmissed-specialisations             -Wall-missed-specialisations             -fspecialise-aggressively             -Wno-ambiguous-fields+            -Werror=incomplete-patterns  library     import: shared-properties     hs-source-dirs: .-    build-depends: ihp+    build-depends: ihp, ihp-log, ihp-modal, wai-request-params, ihp-schema-compiler     exposed-modules:-          IHP.IDE.SchemaDesigner.Controller.Columns+          IHP.IDE.Prelude+        , IHP.IDE.SchemaDesigner.Controller.Columns         , IHP.IDE.SchemaDesigner.Controller.EnumValues         , IHP.IDE.SchemaDesigner.Controller.Enums         , IHP.IDE.SchemaDesigner.Controller.Helper@@ -194,6 +203,7 @@         , IHP.IDE.CodeGen.View.NewMigration         , IHP.IDE.Logs.View.Logs         , IHP.IDE.Logs.Controller+        , IHP.IDE.Logs.ServiceLog         , IHP.IDE.CodeGen.View.NewMail         , IHP.IDE.ToolServer         , IHP.IDE.ToolServer.Helper.Controller@@ -208,6 +218,7 @@         , IHP.IDE.CodeGen.ControllerGenerator         , IHP.IDE.CodeGen.ScriptGenerator         , IHP.IDE.CodeGen.Types+        , IHP.IDE.CodeGen.DefaultUuidFunction         , IHP.IDE.CodeGen.ViewGenerator         , IHP.IDE.CodeGen.JobGenerator         , IHP.IDE.CodeGen.View.NewJob@@ -218,26 +229,29 @@         , IHP.IDE.PortConfig         , IHP.IDE.Postgres         , IHP.IDE.StatusServer-        , IHP.SchemaCompiler         , IHP.IDE.SchemaDesigner.Compiler-        , IHP.IDE.SchemaDesigner.Parser         , IHP.IDE.SchemaDesigner.Types         , IHP.Telemetry         , IHP.Version-        , IHP.Test.Database     autogen-modules: Paths_ihp_ide     other-modules: Paths_ihp_ide  executable RunDevServer     import: shared-properties-    build-depends: ihp, ihp-ide+    build-depends: ihp, ihp-log, ihp-ide, ihp-schema-compiler     hs-source-dirs: exe     main-is: IHP/IDE/DevServer.hs+    ghc-options: -rtsopts=all     if flag(FastBuild)         ghc-options:             -threaded-            +RTS -A512m -n4m -H512m -G3 -qg -N -RTS+            -with-rtsopts=-A512m+            -with-rtsopts=-N+            -with-rtsopts=-n4m+            -with-rtsopts=--nonmoving-gc+            -with-rtsopts=-Iw60             -Wno-ambiguous-fields+            -Werror=incomplete-patterns     else         ghc-options:             -fconstraint-solver-iterations=100@@ -256,8 +270,9 @@             -with-rtsopts=-N             -with-rtsopts=-n4m             -with-rtsopts=--nonmoving-gc-            +RTS -A256m -n4m -H512m -G3 -qg -N -RTS+            -with-rtsopts=-Iw60             -Wno-ambiguous-fields+            -Werror=incomplete-patterns     autogen-modules: Paths_ihp_ide     other-modules: Paths_ihp_ide @@ -267,12 +282,6 @@     hs-source-dirs: exe     main-is: IHP/CLI/NewApplication.hs -executable build-generated-code-    import: shared-properties-    build-depends: ihp, ihp-ide-    hs-source-dirs: exe-    main-is: IHP/CLI/BuildGeneratedCode.hs- executable new-controller     import: shared-properties     build-depends: ihp, ihp-ide@@ -314,3 +323,24 @@ source-repository head     type:     git     location: https://github.com/digitallyinduced/ihp++test-suite tests+    import: shared-properties+    type: exitcode-stdio-1.0+    main-is: Test/Main.hs+    hs-source-dirs: .+    build-depends: ihp, ihp-log, ihp-modal, ihp-schema-compiler, hspec, wai-request-params, wai-asset-path+    other-modules:+        Test.IDE.SchemaDesigner.CompilerSpec+        Test.IDE.SchemaDesigner.ParserSpec+        Test.IDE.SchemaDesigner.Controller.EnumValuesSpec+        Test.IDE.SchemaDesigner.Controller.HelperSpec+        Test.IDE.SchemaDesigner.Controller.ValidationSpec+        Test.IDE.CodeGeneration.ControllerGenerator+        Test.IDE.CodeGeneration.ViewGenerator+        Test.IDE.CodeGeneration.MailGenerator+        Test.IDE.CodeGeneration.JobGenerator+        Test.IDE.SchemaDesigner.SchemaOperationsSpec+        Test.IDE.CodeGeneration.MigrationGenerator+        Test.SchemaCompilerSpec+        Test.ServerSpec