From cedc79d9e5cc2a99ef08f96aa3b6bd9b55d87184 Mon Sep 17 00:00:00 2001 From: Jose Duran Date: Mon, 21 Oct 2019 15:28:45 -0500 Subject: [PATCH 1/9] add insertSelectWithConflict to allow insert with conflict resolution --- src/Database/Esqueleto/PostgreSQL.hs | 98 ++++++++++++++++++++++++---- 1 file changed, 84 insertions(+), 14 deletions(-) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index cbbf7887e..99e93dd30 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings - , GADTs, CPP + , GADTs, CPP, Rank2Types + , ScopedTypeVariables #-} -- | This module contain PostgreSQL-specific functions. -- @@ -20,6 +21,8 @@ module Database.Esqueleto.PostgreSQL , random_ , upsert , upsertBy + , insertSelectWithConflict + , insertSelectWithConflictCount -- * Internal , unsafeSqlAggregateFunction ) where @@ -33,15 +36,18 @@ import Database.Esqueleto.Internal.Language hiding (random_) import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) import Database.Esqueleto.Internal.Sql import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..), - UnexpectedCaseError(..), SetClause) + UnexpectedCaseError(..), SetClause, Ident(..), + uncommas) import Database.Persist.Class (OnlyOneUniqueKey) import Data.List.NonEmpty ( NonEmpty( (:|) ) ) +import Data.Int (Int64) +import Data.Proxy (Proxy(..)) import Control.Arrow ((***), first) import Control.Exception (Exception, throw, throwIO) +import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..)) import qualified Control.Monad.Trans.Reader as R - -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. -- @@ -203,14 +209,78 @@ upsertBy uniqueKey record updates = do updatesText conn = first builderToText $ renderUpdates conn updates handler conn f = fmap head $ uncurry rawSql $ (***) (f entDef (uDef :| [])) addVals $ updatesText conn - renderUpdates :: SqlBackend - -> [SqlExpr (Update val)] - -> (TLB.Builder, [PersistValue]) - renderUpdates conn = uncommas' . concatMap renderUpdate - where - mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])] - mk (ERaw _ f) = [f info] - mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME - renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])] - renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused - info = (projectBackend conn, initialIdentState) \ No newline at end of file + +-- | Render postgres updates to be use in a SET clause. +renderUpdates :: (BackendCompatible SqlBackend backend) => + backend + -> [SqlExpr (Update val)] + -> (TLB.Builder, [PersistValue]) +renderUpdates conn = uncommas' . concatMap renderUpdate + where + mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])] + mk (ERaw _ f) = [f info] + mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME + renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])] + renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused + info = (projectBackend conn, initialIdentState) + +-- | Inserts into a table the results of a query similar to 'insertSelect' but allows +-- to update values that violate a constraint during insertions. +-- +-- Example of usage: +-- +-- @ +-- insertSelectWithConflict +-- (SomeFooUnique undefined) +-- (from $ \b -> +-- return $ Foo <# (b ^. BarNum) +-- ) +-- (\current excluded -> +-- [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)] +-- ) +-- @ +-- +-- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, +-- the conflicting value is updated to the current plus the excluded. +insertSelectWithConflict :: (MonadIO m, PersistEntity val) => + Unique val + -- ^ Uniqueness constraint, this is used just to get the name of the postgres constraint, the value(s) is(are) never used, so if you have a unique "MyUnique 0", "MyUnique undefined" will work as well. + -> SqlQuery (SqlExpr (Insertion val)) + -- ^ Insert query. + -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) + -- ^ A list of updates to be applied in case of the constraint being violated. The expression takes the current and excluded value to produce the updates. + -> SqlWriteT m () +insertSelectWithConflict unique query = void . insertSelectWithConflictCount unique query + +-- | Same as 'insertSelectWithConflict' but returns the number of rows affected. +insertSelectWithConflictCount :: forall val m. (MonadIO m, PersistEntity val) => + Unique val + -> SqlQuery (SqlExpr (Insertion val)) + -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) + -> SqlWriteT m Int64 +insertSelectWithConflictCount unique query conflictQuery = do + conn <- R.ask + uncurry rawExecuteCount $ + combine + (toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query)) + (conflict conn) + where + proxy :: Proxy val + proxy = Proxy + combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2) + entExcluded = EEntity $ I "excluded" + tableName = unDBName . entityDB . entityDef + entCurrent = EEntity $ I (tableName proxy) + -- there must be a better way to get the constrain name from a unique, make this not a list search + uniqueDef = head . filter ((==) (persistUniqueToFieldNames unique) . uniqueFields) . entityUniques . entityDef $ proxy + constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef + renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue]) + renderedUpdates conn = renderUpdates conn (conflictQuery entCurrent entExcluded) + conflict conn = (foldr1 mappend [ + TLB.fromText "ON CONFLICT ON CONSTRAINT \"", + constraint, + TLB.fromText "\" DO UPDATE SET ", + updatesTLB + ],values) + where + (updatesTLB,values) = renderedUpdates conn \ No newline at end of file From 1b517226660774304aab8dfed380819eff29fc87 Mon Sep 17 00:00:00 2001 From: Jose Duran Date: Mon, 21 Oct 2019 23:52:23 -0500 Subject: [PATCH 2/9] insertSelectWithConflictCount does nothing when no updates given and add tests --- src/Database/Esqueleto/PostgreSQL.hs | 11 ++++--- test/Common/Test.hs | 1 + test/PostgreSQL/Test.hs | 45 ++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 4 deletions(-) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 99e93dd30..b0aac8bc1 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -267,6 +267,7 @@ insertSelectWithConflictCount unique query conflictQuery = do where proxy :: Proxy val proxy = Proxy + updates = conflictQuery entCurrent entExcluded combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2) entExcluded = EEntity $ I "excluded" tableName = unDBName . entityDB . entityDef @@ -275,12 +276,14 @@ insertSelectWithConflictCount unique query conflictQuery = do uniqueDef = head . filter ((==) (persistUniqueToFieldNames unique) . uniqueFields) . entityUniques . entityDef $ proxy constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue]) - renderedUpdates conn = renderUpdates conn (conflictQuery entCurrent entExcluded) - conflict conn = (foldr1 mappend [ + renderedUpdates conn = renderUpdates conn updates + conflict conn = (foldr1 mappend ([ TLB.fromText "ON CONFLICT ON CONSTRAINT \"", constraint, - TLB.fromText "\" DO UPDATE SET ", + TLB.fromText "\" DO " + ] ++ if null updates then [TLB.fromText "NOTHING"] else [ + TLB.fromText "UPDATE SET ", updatesTLB - ],values) + ]),values) where (updatesTLB,values) = renderedUpdates conn \ No newline at end of file diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 9c6d36734..4f55d1b0f 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -52,6 +52,7 @@ module Common.Test , Circle (..) , Numbers (..) , OneUnique(..) + , Unique(..) ) where import Control.Monad (forM_, replicateM, replicateM_, void) diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 407cb4119..05ac19b22 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -978,6 +978,50 @@ testUpsert = u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"] liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} +testInsertSelectWithConflict :: Spec +testInsertSelectWithConflict = + describe "insertSelectWithConflict test" $ do + it "Should do Nothing when no updates set" $ run $ do + _ <- insert p1 + _ <- insert p2 + _ <- insert p3 + n1 <- EP.insertSelectWithConflictCount (UniqueValue undefined) ( + from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) + ) + (\current excluded -> []) + uniques1 <- select $ from $ \u -> return u + n2 <- EP.insertSelectWithConflictCount (UniqueValue undefined) ( + from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) + ) + (\current excluded -> []) + uniques2 <- select $ from $ \u -> return u + liftIO $ n1 `shouldBe` 3 + liftIO $ n2 `shouldBe` 0 + let test = map (OneUnique "test" . personFavNum) [p1,p2,p3] + liftIO $ map entityVal uniques1 `shouldBe` test + liftIO $ map entityVal uniques2 `shouldBe` test + it "Should update a value if given an update on conflict" $ run $ do + _ <- insert p1 + _ <- insert p2 + _ <- insert p3 + -- Note, have to sum 4 so that the update does not conflicts again with another row. + n1 <- EP.insertSelectWithConflictCount (UniqueValue undefined) ( + from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) + ) + (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) + uniques1 <- select $ from $ \u -> return u + n2 <- EP.insertSelectWithConflictCount (UniqueValue undefined) ( + from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) + ) + (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) + uniques2 <- select $ from $ \u -> return u + liftIO $ n1 `shouldBe` 3 + liftIO $ n2 `shouldBe` 3 + let test = map (OneUnique "test" . personFavNum) [p1,p2,p3] + test2 = map (OneUnique "test" . (+4) . (*2) . personFavNum) [p1,p2,p3] + liftIO $ map entityVal uniques1 `shouldBe` test + liftIO $ map entityVal uniques2 `shouldBe` test2 + type JSONValue = Maybe (JSONB A.Value) createSaneSQL :: (PersistField a) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> IO () @@ -1051,6 +1095,7 @@ main = do testPostgresqlTextFunctions testInsertUniqueViolation testUpsert + testInsertSelectWithConflict describe "PostgreSQL JSON tests" $ do -- NOTE: We only clean the table once, so we -- can use its contents across all JSON tests From f0cbbc69c8461f90cfd81cdbea38b589b72a0a00 Mon Sep 17 00:00:00 2001 From: Jose Duran Date: Thu, 24 Oct 2019 13:41:45 -0500 Subject: [PATCH 3/9] no longer require undefined for insertSelectWithConflict --- src/Database/Esqueleto/PostgreSQL.hs | 66 ++++++++++++++++++++++++---- test/PostgreSQL/Test.hs | 8 ++-- 2 files changed, 61 insertions(+), 13 deletions(-) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index b0aac8bc1..994449f7a 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -2,7 +2,9 @@ {-# LANGUAGE OverloadedStrings , GADTs, CPP, Rank2Types , ScopedTypeVariables + , FlexibleInstances #-} + {-# LANGUAGE TypeFamilies #-} -- | This module contain PostgreSQL-specific functions. -- -- /Since: 2.2.8/ @@ -25,6 +27,7 @@ module Database.Esqueleto.PostgreSQL , insertSelectWithConflictCount -- * Internal , unsafeSqlAggregateFunction + , toUniqueDef ) where #if __GLASGOW_HASKELL__ < 804 @@ -205,7 +208,7 @@ upsertBy uniqueKey record updates = do where addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey entDef = entityDef (Just record) - uDef = head $ filter ((==) (persistUniqueToFieldNames uniqueKey) . uniqueFields) $ entityUniques entDef + uDef = toUniqueDef uniqueKey updatesText conn = first builderToText $ renderUpdates conn updates handler conn f = fmap head $ uncurry rawSql $ (***) (f entDef (uDef :| [])) addVals $ updatesText conn @@ -224,14 +227,52 @@ renderUpdates conn = uncommas' . concatMap renderUpdate renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused info = (projectBackend conn, initialIdentState) +type family KnowResult a where + KnowResult (i -> o) = KnowResult o + KnowResult a = a + +class FinalResult a where + finalR :: a -> KnowResult a + +instance FinalResult (Unique val) where + finalR = id + +instance (FinalResult b) => FinalResult (a -> b) where + finalR f = finalR (f undefined) + +toUniqueDef :: forall a val. (KnowResult a ~ (Unique val), PersistEntity val,FinalResult a) => + a -> UniqueDef +toUniqueDef uniqueConstructor = uniqueDef + where + proxy :: Proxy val + proxy = Proxy + unique :: Unique val + unique = finalR uniqueConstructor + -- there must be a better way to get the constrain name from a unique, make this not a list search + filterF = (==) (persistUniqueToFieldNames unique) . uniqueFields + uniqueDef = head . filter filterF . entityUniques . entityDef $ proxy + -- | Inserts into a table the results of a query similar to 'insertSelect' but allows -- to update values that violate a constraint during insertions. -- -- Example of usage: -- -- @ +-- share [ mkPersist sqlSettings +-- , mkDeleteCascade sqlSettings +-- , mkMigrate "migrate" +-- ] [persistLowerCase| +-- Bar +-- num Int +-- deriving Eq Show +-- Foo +-- num Int +-- UniqueFoo num +-- deriving Eq Show +-- |] +-- -- insertSelectWithConflict --- (SomeFooUnique undefined) +-- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work -- (from $ \b -> -- return $ Foo <# (b ^. BarNum) -- ) @@ -242,9 +283,13 @@ renderUpdates conn = uncommas' . concatMap renderUpdate -- -- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, -- the conflicting value is updated to the current plus the excluded. -insertSelectWithConflict :: (MonadIO m, PersistEntity val) => - Unique val - -- ^ Uniqueness constraint, this is used just to get the name of the postgres constraint, the value(s) is(are) never used, so if you have a unique "MyUnique 0", "MyUnique undefined" will work as well. +insertSelectWithConflict :: forall a m val. ( + FinalResult a, + KnowResult a ~ (Unique val), + MonadIO m, + PersistEntity val) => + a + -- ^ Unique constructor or a unique, this is used just to get the name of the postgres constraint, the value(s) is(are) never used, so if you have a unique "MyUnique 0", "MyUnique undefined" would work as well. -> SqlQuery (SqlExpr (Insertion val)) -- ^ Insert query. -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) @@ -253,8 +298,12 @@ insertSelectWithConflict :: (MonadIO m, PersistEntity val) => insertSelectWithConflict unique query = void . insertSelectWithConflictCount unique query -- | Same as 'insertSelectWithConflict' but returns the number of rows affected. -insertSelectWithConflictCount :: forall val m. (MonadIO m, PersistEntity val) => - Unique val +insertSelectWithConflictCount :: forall a val m. ( + FinalResult a, + KnowResult a ~ (Unique val), + MonadIO m, + PersistEntity val) => + a -> SqlQuery (SqlExpr (Insertion val)) -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) -> SqlWriteT m Int64 @@ -272,8 +321,7 @@ insertSelectWithConflictCount unique query conflictQuery = do entExcluded = EEntity $ I "excluded" tableName = unDBName . entityDB . entityDef entCurrent = EEntity $ I (tableName proxy) - -- there must be a better way to get the constrain name from a unique, make this not a list search - uniqueDef = head . filter ((==) (persistUniqueToFieldNames unique) . uniqueFields) . entityUniques . entityDef $ proxy + uniqueDef = toUniqueDef unique constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue]) renderedUpdates conn = renderUpdates conn updates diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 05ac19b22..4ef69c4e4 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -985,12 +985,12 @@ testInsertSelectWithConflict = _ <- insert p1 _ <- insert p2 _ <- insert p3 - n1 <- EP.insertSelectWithConflictCount (UniqueValue undefined) ( + n1 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> []) uniques1 <- select $ from $ \u -> return u - n2 <- EP.insertSelectWithConflictCount (UniqueValue undefined) ( + n2 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> []) @@ -1005,12 +1005,12 @@ testInsertSelectWithConflict = _ <- insert p2 _ <- insert p3 -- Note, have to sum 4 so that the update does not conflicts again with another row. - n1 <- EP.insertSelectWithConflictCount (UniqueValue undefined) ( + n1 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) uniques1 <- select $ from $ \u -> return u - n2 <- EP.insertSelectWithConflictCount (UniqueValue undefined) ( + n2 <- EP.insertSelectWithConflictCount UniqueValue ( from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) ) (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) From 236e5b0b6dd26dd95db13a1d3da0208fb6163347 Mon Sep 17 00:00:00 2001 From: Jose Duran Date: Mon, 28 Oct 2019 11:49:35 -0500 Subject: [PATCH 4/9] Update src/Database/Esqueleto/PostgreSQL.hs Co-Authored-By: Matt Parsons --- src/Database/Esqueleto/PostgreSQL.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 994449f7a..fc4349d6c 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -214,6 +214,8 @@ upsertBy uniqueKey record updates = do (***) (f entDef (uDef :| [])) addVals $ updatesText conn -- | Render postgres updates to be use in a SET clause. +-- +-- @since 3.1.3 renderUpdates :: (BackendCompatible SqlBackend backend) => backend -> [SqlExpr (Update val)] @@ -334,4 +336,4 @@ insertSelectWithConflictCount unique query conflictQuery = do updatesTLB ]),values) where - (updatesTLB,values) = renderedUpdates conn \ No newline at end of file + (updatesTLB,values) = renderedUpdates conn From 1c7d4599d241ea4fe110c20b0b31def259d8e73b Mon Sep 17 00:00:00 2001 From: Jose Duran Date: Mon, 28 Oct 2019 11:50:02 -0500 Subject: [PATCH 5/9] Update src/Database/Esqueleto/PostgreSQL.hs Co-Authored-By: Matt Parsons --- src/Database/Esqueleto/PostgreSQL.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index fc4349d6c..eef9127b8 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -285,6 +285,8 @@ toUniqueDef uniqueConstructor = uniqueDef -- -- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, -- the conflicting value is updated to the current plus the excluded. +-- +-- @since 3.1.3 insertSelectWithConflict :: forall a m val. ( FinalResult a, KnowResult a ~ (Unique val), From 6414a122b3089192213285e5513e147f2acbb9c1 Mon Sep 17 00:00:00 2001 From: Jose Duran Date: Mon, 28 Oct 2019 11:50:13 -0500 Subject: [PATCH 6/9] Update src/Database/Esqueleto/PostgreSQL.hs Co-Authored-By: Matt Parsons --- src/Database/Esqueleto/PostgreSQL.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index eef9127b8..166d7eada 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -302,6 +302,8 @@ insertSelectWithConflict :: forall a m val. ( insertSelectWithConflict unique query = void . insertSelectWithConflictCount unique query -- | Same as 'insertSelectWithConflict' but returns the number of rows affected. +-- +-- @since 3.1.3 insertSelectWithConflictCount :: forall a val m. ( FinalResult a, KnowResult a ~ (Unique val), From e62d350636bc4b7f6a416b5ab5e1bb98dcfd3c9c Mon Sep 17 00:00:00 2001 From: Jose Duran Date: Mon, 28 Oct 2019 11:52:16 -0500 Subject: [PATCH 7/9] Update src/Database/Esqueleto/PostgreSQL.hs Co-Authored-By: Matt Parsons --- src/Database/Esqueleto/PostgreSQL.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 166d7eada..002f51c19 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -242,6 +242,11 @@ instance FinalResult (Unique val) where instance (FinalResult b) => FinalResult (a -> b) where finalR f = finalR (f undefined) +-- | Convert a constructor for a 'Unique' key on a record to the 'UniqueDef' that defines it. You +-- can supply just the constructor itself, or a value of the type - the library is capable of figuring +-- it out from there. +-- +-- @since 3.1.3 toUniqueDef :: forall a val. (KnowResult a ~ (Unique val), PersistEntity val,FinalResult a) => a -> UniqueDef toUniqueDef uniqueConstructor = uniqueDef From 2cb98e95adf40582f2c75eaa294158017f85a0f9 Mon Sep 17 00:00:00 2001 From: Jose Duran Date: Mon, 28 Oct 2019 12:20:41 -0500 Subject: [PATCH 8/9] Move non postgres related functions out of postgres module to internal. --- src/Database/Esqueleto/Internal/Internal.hs | 48 +++++++++++++++++++ src/Database/Esqueleto/PostgreSQL.hs | 52 +-------------------- 2 files changed, 50 insertions(+), 50 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index d6d165b4c..5ba734d60 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -887,6 +887,54 @@ instance ( ToSomeValues a toSomeValues c ++ toSomeValues d ++ toSomeValues e ++ toSomeValues f ++ toSomeValues g ++ toSomeValues h +type family KnowResult a where + KnowResult (i -> o) = KnowResult o + KnowResult a = a + +-- | A class for constructors or function which result type is known. +-- +-- @since 3.1.3 +class FinalResult a where + finalR :: a -> KnowResult a + +instance FinalResult (Unique val) where + finalR = id + +instance (FinalResult b) => FinalResult (a -> b) where + finalR f = finalR (f undefined) + +-- | Convert a constructor for a 'Unique' key on a record to the 'UniqueDef' that defines it. You +-- can supply just the constructor itself, or a value of the type - the library is capable of figuring +-- it out from there. +-- +-- @since 3.1.3 +toUniqueDef :: forall a val. (KnowResult a ~ (Unique val), PersistEntity val,FinalResult a) => + a -> UniqueDef +toUniqueDef uniqueConstructor = uniqueDef + where + proxy :: Proxy val + proxy = Proxy + unique :: Unique val + unique = finalR uniqueConstructor + -- there must be a better way to get the constrain name from a unique, make this not a list search + filterF = (==) (persistUniqueToFieldNames unique) . uniqueFields + uniqueDef = head . filter filterF . entityUniques . entityDef $ proxy + +-- | Render updates to be use in a SET clause for a given sql backend. +-- +-- @since 3.1.3 +renderUpdates :: (BackendCompatible SqlBackend backend) => + backend + -> [SqlExpr (Update val)] + -> (TLB.Builder, [PersistValue]) +renderUpdates conn = uncommas' . concatMap renderUpdate + where + mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])] + mk (ERaw _ f) = [f info] + mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME + renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])] + renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused + info = (projectBackend conn, initialIdentState) -- | Data type that represents an @INNER JOIN@ (see 'LeftOuterJoin' for an example). data InnerJoin a b = a `InnerJoin` b diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 002f51c19..8f70fb2d4 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -2,9 +2,7 @@ {-# LANGUAGE OverloadedStrings , GADTs, CPP, Rank2Types , ScopedTypeVariables - , FlexibleInstances #-} - {-# LANGUAGE TypeFamilies #-} -- | This module contain PostgreSQL-specific functions. -- -- /Since: 2.2.8/ @@ -27,7 +25,6 @@ module Database.Esqueleto.PostgreSQL , insertSelectWithConflictCount -- * Internal , unsafeSqlAggregateFunction - , toUniqueDef ) where #if __GLASGOW_HASKELL__ < 804 @@ -40,7 +37,8 @@ import Database.Esqueleto.Internal.PersistentImport hiding (upsert, up import Database.Esqueleto.Internal.Sql import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..), UnexpectedCaseError(..), SetClause, Ident(..), - uncommas) + uncommas, FinalResult(..), toUniqueDef, + KnowResult, renderUpdates) import Database.Persist.Class (OnlyOneUniqueKey) import Data.List.NonEmpty ( NonEmpty( (:|) ) ) import Data.Int (Int64) @@ -213,52 +211,6 @@ upsertBy uniqueKey record updates = do handler conn f = fmap head $ uncurry rawSql $ (***) (f entDef (uDef :| [])) addVals $ updatesText conn --- | Render postgres updates to be use in a SET clause. --- --- @since 3.1.3 -renderUpdates :: (BackendCompatible SqlBackend backend) => - backend - -> [SqlExpr (Update val)] - -> (TLB.Builder, [PersistValue]) -renderUpdates conn = uncommas' . concatMap renderUpdate - where - mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])] - mk (ERaw _ f) = [f info] - mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME - renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])] - renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused - info = (projectBackend conn, initialIdentState) - -type family KnowResult a where - KnowResult (i -> o) = KnowResult o - KnowResult a = a - -class FinalResult a where - finalR :: a -> KnowResult a - -instance FinalResult (Unique val) where - finalR = id - -instance (FinalResult b) => FinalResult (a -> b) where - finalR f = finalR (f undefined) - --- | Convert a constructor for a 'Unique' key on a record to the 'UniqueDef' that defines it. You --- can supply just the constructor itself, or a value of the type - the library is capable of figuring --- it out from there. --- --- @since 3.1.3 -toUniqueDef :: forall a val. (KnowResult a ~ (Unique val), PersistEntity val,FinalResult a) => - a -> UniqueDef -toUniqueDef uniqueConstructor = uniqueDef - where - proxy :: Proxy val - proxy = Proxy - unique :: Unique val - unique = finalR uniqueConstructor - -- there must be a better way to get the constrain name from a unique, make this not a list search - filterF = (==) (persistUniqueToFieldNames unique) . uniqueFields - uniqueDef = head . filter filterF . entityUniques . entityDef $ proxy - -- | Inserts into a table the results of a query similar to 'insertSelect' but allows -- to update values that violate a constraint during insertions. -- From ff3b5d5186fdfff43278cbb457bfdd39f9fe3549 Mon Sep 17 00:00:00 2001 From: Jose Duran Date: Mon, 28 Oct 2019 12:26:35 -0500 Subject: [PATCH 9/9] add entry to changelog --- changelog.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/changelog.md b/changelog.md index d0b74adc6..98d620aaf 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +Unreleased (3.1.3) +======== + +- @JoseD92 + - [#155](https://github.com/bitemyapp/esqueleto/pull/149): Added `insertSelectWithConflict` postgres function. + Unreleased (3.1.1) ========