module IHP.IDE.Data.Controller where import IHP.ControllerPrelude import IHP.IDE.ToolServer.Types import IHP.IDE.Data.View.ShowDatabase import IHP.IDE.Data.View.ShowTableRows import IHP.IDE.Data.View.ShowQuery import IHP.IDE.Data.View.NewRow import IHP.IDE.Data.View.EditRow 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 Data.Text as T import qualified Data.ByteString.Builder instance Controller DataController where action ShowDatabaseAction = do connection <- connectToAppDb tableNames <- fetchTableNames connection PG.close connection case headMay tableNames of Just tableName -> jumpToAction ShowTableRowsAction { tableName } Nothing -> render ShowDatabaseView { .. } 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 render ShowTableRowsView { .. } action NewQueryAction = do let queryText = "" let queryResult = Nothing 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) PG.close connection render ShowQueryView { .. } action DeleteEntryAction { primaryKey, tableName } = do connection <- connectToAppDb tableNames <- fetchTableNames connection primaryKeyFields <- tablePrimaryKeyFields connection 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 redirectTo ShowTableRowsAction { .. } action NewRowAction { tableName } = do connection <- connectToAppDb tableNames <- fetchTableNames connection rows :: [[DynamicField]] <- fetchRows connection tableName tableCols <- fetchTableCols connection tableName PG.close connection 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 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 let targetPrimaryKeyValues = T.splitOn "---" targetPrimaryKey values <- fetchRow connection (cs tableName) targetPrimaryKeyValues let (Just rowValues) = head values PG.close connection render EditRowView { .. } action UpdateRowAction = do let tableName = param "tableName" connection <- connectToAppDb tableNames <- fetchTableNames connection tableCols <- fetchTableCols connection tableName primaryKeyFields <- tablePrimaryKeyFields 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 columns :: [Text] = map (\col -> cs (col.columnName)) tableCols let primaryKeyValues = map (\pkey -> "'" <> (param @Text (cs pkey <> "-pk")) <> "'") primaryKeyFields 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 redirectTo ShowTableRowsAction { .. } action EditRowValueAction { tableName, targetName, id } = do connection <- connectToAppDb tableNames <- fetchTableNames connection rows :: [[DynamicField]] <- fetchRows connection 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 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 redirectTo ShowTableRowsAction { .. } action DeleteTableRowsAction { tableName } = do connection <- connectToAppDb let query = "TRUNCATE TABLE " <> tableName PG.execute_ connection (PG.Query . cs $! query) PG.close connection 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 PG.close connection 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) foreignKeyInfo <- fetchForeignKeyInfo connection 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 hovercardData of Just (record, foreignTableName) -> render ShowForeignKeyHoverCardView { record, foreignTableName } Nothing -> renderNotFound connectToAppDb :: (?context :: ControllerContext) => IO PG.Connection connectToAppDb = PG.connectPostgreSQL ?context.frameworkConfig.databaseUrl 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) 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) 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 instance PG.FromField DynamicField where fromField field fieldValue = pure DynamicField { .. } where fieldName = fromMaybe "" (PG.name field) instance PG.FromRow ColumnDefinition where fromRow = ColumnDefinition <$> PG.field <*> PG.field <*> PG.field <*> PG.field 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 fetchRows :: FromRow r => PG.Connection -> Text -> IO [r] fetchRows connection tableName = do pkFields <- tablePrimaryKeyFields connection tableName let query = "SELECT * FROM " <> tableName <> (if null pkFields then "" else " ORDER BY " <> intercalate ", " pkFields ) PG.query_ connection (PG.Query . cs $! query) 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 PG.query_ connection (PG.Query . cs $! query) tableLength :: PG.Connection -> Text -> IO Int tableLength connection tableName = do [Only count] <- PG.query connection "SELECT COUNT(*) FROM ?" [PG.Identifier tableName] pure count -- 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)) updateValues list = map (\elem -> fst elem <> " = " <> snd elem) list 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 case result of [(foreignTableName, foreignColumnName)] -> pure $ Just (foreignTableName, foreignColumnName) otherwise -> pure $ Nothing instance {-# OVERLAPS #-} ToJSON [DynamicField] where toJSON fields = object (map (\DynamicField { fieldName, fieldValue } -> (cs fieldName) .= (fieldValueToJSON fieldValue)) fields) where fieldValueToJSON (Just bs) = toJSON ((cs bs) :: Text) fieldValueToJSON Nothing = toJSON Null toEncoding fields = pairs $ foldl' (<>) mempty (encodedFields) where encodedFields = (map (\DynamicField { fieldName, fieldValue } -> (cs fieldName) .= (fieldValueToJSON fieldValue)) fields) fieldValueToJSON (Just bs) = toJSON ((cs bs) :: Text) fieldValueToJSON Nothing = toJSON Null