Added updateRecordDiscardResult

digitallyinduced · Apr 18, 2024 · 54c3561 · 54c3561
1 parent ab4ecd0
commit 54c3561
Show file tree

Hide file tree

Showing 4 changed files with 39 additions and 1 deletion.
diff --git 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
@@ -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
@@ -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
@@ -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|