From 54c3561a68deab50d2ef175d02badb253fbbde8d Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Thu, 18 Apr 2024 10:00:48 +0200 Subject: [PATCH] Added updateRecordDiscardResult --- IHP/ModelSupport.hs | 17 +++++++++++++++++ IHP/Prelude.hs | 2 +- IHP/SchemaCompiler.hs | 5 +++++ Test/SchemaCompilerSpec.hs | 16 ++++++++++++++++ 4 files changed, 39 insertions(+), 1 deletion(-) diff --git a/IHP/ModelSupport.hs b/IHP/ModelSupport.hs index 485fe43c6..89b301813 100644 --- a/IHP/ModelSupport.hs +++ b/IHP/ModelSupport.hs @@ -106,6 +106,12 @@ class CanCreate a where class CanUpdate a where updateRecord :: (?modelContext :: ModelContext) => a -> IO a + -- | Like 'updateRecord' but doesn't return the updated record + updateRecordDiscardResult :: (?modelContext :: ModelContext) => a -> IO () + updateRecordDiscardResult record = do + _ <- updateRecord record + pure () + {-# INLINE createRecord #-} createRecord :: (?modelContext :: ModelContext, CanCreate model) => model -> IO model createRecord = create @@ -411,6 +417,17 @@ sqlExec theQuery theParameters = do theParameters {-# INLINABLE sqlExec #-} +-- | Runs a sql statement (like a CREATE statement), but doesn't return any result +-- +-- __Example:__ +-- +-- > sqlExecDiscardResult "CREATE TABLE users ()" () +sqlExecDiscardResult :: (?modelContext :: ModelContext, PG.ToRow q) => Query -> q -> IO () +sqlExecDiscardResult theQuery theParameters = do + _ <- sqlExec theQuery theParameters + pure () +{-# INLINABLE sqlExecDiscardResult #-} + -- | Wraps the query with Row level security boilerplate, if a row level security context was provided -- -- __Example:__ diff --git a/IHP/Prelude.hs b/IHP/Prelude.hs index 28693f1fe..aa158e8e5 100644 --- a/IHP/Prelude.hs +++ b/IHP/Prelude.hs @@ -67,7 +67,7 @@ import GHC.OverloadedLabels import Data.Data (Data) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import IHP.NameSupport -import IHP.ModelSupport (ModelContext (..), CanUpdate, NormalizeModel, Id, GetTableName, GetModelName, updateRecord, createRecord, deleteRecord, MetaBag (..)) +import IHP.ModelSupport (ModelContext (..), CanUpdate, NormalizeModel, Id, GetTableName, GetModelName, updateRecord, updateRecordDiscardResult, createRecord, deleteRecord, MetaBag (..)) import Data.TMap (TMap) import Database.PostgreSQL.Simple (FromRow) import Data.IORef diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs index 9f14b198c..77c9a1adc 100644 --- a/IHP/SchemaCompiler.hs +++ b/IHP/SchemaCompiler.hs @@ -598,6 +598,11 @@ compileUpdate table@(CreateTable { name, columns }) = "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| diff --git a/Test/SchemaCompilerSpec.hs b/Test/SchemaCompilerSpec.hs index 3df0555d3..00b370814 100644 --- a/Test/SchemaCompilerSpec.hs +++ b/Test/SchemaCompilerSpec.hs @@ -143,6 +143,8 @@ tests = do instance CanUpdate User where updateRecord model = do sqlQuerySingleRow "UPDATE users SET id = ? WHERE id = ? RETURNING id" ((fieldWithUpdate #id model, model.id)) + updateRecordDiscardResult model = do + sqlExecDiscardResult "UPDATE users SET id = ? WHERE id = ?" ((fieldWithUpdate #id model, model.id)) |] it "should compile CanUpdate instance with an array type with an explicit cast" do @@ -159,6 +161,8 @@ tests = do instance CanUpdate User where updateRecord model = do sqlQuerySingleRow "UPDATE users SET id = ?, ids = ? :: UUID[] WHERE id = ? RETURNING id, ids" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, model.id)) + updateRecordDiscardResult model = do + sqlExecDiscardResult "UPDATE users SET id = ?, ids = ? :: UUID[] WHERE id = ?" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, model.id)) |] it "should deal with double default values" do let statement = StatementCreateTable CreateTable @@ -219,6 +223,8 @@ tests = do instance CanUpdate User where updateRecord model = do sqlQuerySingleRow "UPDATE users SET id = ?, ids = ? :: UUID[], electricity_unit_price = ? WHERE id = ? RETURNING id, ids, electricity_unit_price" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, fieldWithUpdate #electricityUnitPrice model, model.id)) + updateRecordDiscardResult model = do + sqlExecDiscardResult "UPDATE users SET id = ?, ids = ? :: UUID[], electricity_unit_price = ? WHERE id = ?" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, fieldWithUpdate #electricityUnitPrice model, model.id)) instance Record User where {-# INLINE newRecord #-} @@ -289,6 +295,8 @@ tests = do instance CanUpdate User where updateRecord model = do sqlQuerySingleRow "UPDATE users SET id = ?, ids = ? :: UUID[], electricity_unit_price = ? WHERE id = ? RETURNING id, ids, electricity_unit_price" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, fieldWithUpdate #electricityUnitPrice model, model.id)) + updateRecordDiscardResult model = do + sqlExecDiscardResult "UPDATE users SET id = ?, ids = ? :: UUID[], electricity_unit_price = ? WHERE id = ?" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, fieldWithUpdate #electricityUnitPrice model, model.id)) instance Record User where {-# INLINE newRecord #-} @@ -358,6 +366,8 @@ tests = do instance CanUpdate User where updateRecord model = do sqlQuerySingleRow "UPDATE users SET id = ? WHERE id = ? RETURNING id" ((fieldWithUpdate #id model, model.id)) + updateRecordDiscardResult model = do + sqlExecDiscardResult "UPDATE users SET id = ? WHERE id = ?" ((fieldWithUpdate #id model, model.id)) instance Record User where {-# INLINE newRecord #-} @@ -435,6 +445,8 @@ tests = do instance CanUpdate LandingPage where updateRecord model = do sqlQuerySingleRow "UPDATE landing_pages SET id = ? WHERE id = ? RETURNING id" ((fieldWithUpdate #id model, model.id)) + updateRecordDiscardResult model = do + sqlExecDiscardResult "UPDATE landing_pages SET id = ? WHERE id = ?" ((fieldWithUpdate #id model, model.id)) instance Record LandingPage where {-# INLINE newRecord #-} @@ -479,6 +491,8 @@ tests = do instance CanUpdate Thing where updateRecord model = do sqlQuerySingleRow "UPDATE things SET thing_arbitrary_ident = ? WHERE thing_arbitrary_ident = ? RETURNING thing_arbitrary_ident" ((fieldWithUpdate #thingArbitraryIdent model, model.thingArbitraryIdent)) + updateRecordDiscardResult model = do + sqlExecDiscardResult "UPDATE things SET thing_arbitrary_ident = ? WHERE thing_arbitrary_ident = ?" ((fieldWithUpdate #thingArbitraryIdent model, model.thingArbitraryIdent)) |] it "should compile FromRow instance" $ \statement -> do getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming| @@ -543,6 +557,8 @@ tests = do instance CanUpdate BitPartRef where updateRecord model = do sqlQuerySingleRow "UPDATE bit_part_refs SET bit_ref = ?, part_ref = ? WHERE (bit_ref, part_ref) = (?, ?) RETURNING bit_ref, part_ref" ((fieldWithUpdate #bitRef model, fieldWithUpdate #partRef model, model.bitRef, model.partRef)) + updateRecordDiscardResult model = do + sqlExecDiscardResult "UPDATE bit_part_refs SET bit_ref = ?, part_ref = ? WHERE (bit_ref, part_ref) = (?, ?)" ((fieldWithUpdate #bitRef model, fieldWithUpdate #partRef model, model.bitRef, model.partRef)) |] it "should compile FromRow instance" $ \statement -> do getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming|