{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module UpsertWhere where
import PgInit
import Data.Time
import Database.Persist.Postgresql
share
[mkPersist sqlSettings, mkMigrate "upsertWhereMigrate"]
[persistLowerCase|
Item
name Text sqltype=varchar(80)
description Text
price Double Maybe
quantity Int Maybe
UniqueName name
deriving Eq Show Ord
ItemMigOnly
name Text
price Double
quantity Int
UniqueNameMigOnly name
createdAt UTCTime MigrationOnly default=CURRENT_TIMESTAMP
|]
wipe :: IO ()
wipe = runConnAssert $ do
deleteWhere ([] :: [Filter Item])
deleteWhere ([] :: [Filter ItemMigOnly])
itDb
:: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ()))
itDb msg action = it msg $ runConnAssert $ void action
specs :: Spec
specs = describe "UpsertWhere" $ do
let
item1 = Item "item1" "" (Just 3) Nothing
item2 = Item "item2" "hello world" Nothing (Just 2)
items = [item1, item2]
describe "upsertWhere" $ before_ wipe $ do
itDb "inserts appropriately" $ do
upsertWhere item1 [ItemDescription =. "i am item 1"] []
Just item <- fmap entityVal <$> getBy (UniqueName "item1")
item `shouldBe` item1
itDb "performs only updates given if record already exists" $ do
let
newDescription = "I am a new description"
insert_ item1
upsertWhere
(Item "item1" "i am an inserted description" (Just 1) (Just 2))
[ItemDescription =. newDescription]
[]
Just item <- fmap entityVal <$> getBy (UniqueName "item1")
item `shouldBe` item1{itemDescription = newDescription}
itDb "inserts with MigrationOnly fields (#1330)" $ do
upsertWhere
(ItemMigOnly "foobar" 20 1)
[ItemMigOnlyPrice +=. 2]
[]
describe "upsertManyWhere" $ do
itDb "inserts fresh records" $ do
insertMany_ items
let
newItem = Item "item3" "fresh" Nothing Nothing
upsertManyWhere
(newItem : items)
[copyField ItemDescription]
[]
[]
dbItems <- map entityVal <$> selectList [] []
dbItems `shouldMatchList` (newItem : items)
itDb "updates existing records" $ do
let
postUpdate =
map (\i -> i{itemQuantity = fmap (+ 1) (itemQuantity i)}) items
insertMany_ items
upsertManyWhere
items
[]
[ItemQuantity +=. Just 1]
[]
dbItems <- fmap entityVal <$> selectList [] []
dbItems `shouldMatchList` postUpdate
itDb "only copies passing values" $ do
insertMany_ items
let
newItems =
map
(\i -> i{itemQuantity = Just 0, itemPrice = fmap (* 2) (itemPrice i)})
items
postUpdate = map (\i -> i{itemPrice = fmap (* 2) (itemPrice i)}) items
upsertManyWhere
newItems
[ copyUnlessEq ItemQuantity (Just 0)
, copyField ItemPrice
]
[]
[]
dbItems <- fmap entityVal <$> selectList [] []
dbItems `shouldMatchList` postUpdate
itDb "inserts without modifying existing records if no updates specified" $ do
let
newItem = Item "item3" "hi friends!" Nothing Nothing
insertMany_ items
upsertManyWhere
(newItem : items)
[]
[]
[]
dbItems <- fmap entityVal <$> selectList [] []
dbItems `shouldMatchList` (newItem : items)
itDb
"inserts without modifying existing records if no updates specified and there's a filter with True condition"
$ do
let
newItem = Item "item3" "hi friends!" Nothing Nothing
insertMany_ items
upsertManyWhere
(newItem : items)
[]
[]
[ItemDescription ==. "hi friends!"]
dbItems <- fmap entityVal <$> selectList [] []
dbItems `shouldMatchList` (newItem : items)
itDb
"inserts without updating existing records if there are updates specified but there's a filter with a False condition"
$ do
let
newItem = Item "item3" "hi friends!" Nothing Nothing
insertMany_ items
upsertManyWhere
(newItem : items)
[]
[ItemQuantity +=. Just 1]
[ItemDescription ==. "hi friends!"]
dbItems <- fmap entityVal <$> selectList [] []
dbItems `shouldMatchList` (newItem : items)
itDb
"inserts new records but does not update existing records if there are updates specified but the modification condition is False"
$ do
let
newItem = Item "item3" "hi friends!" Nothing Nothing
insertMany_ items
upsertManyWhere
(newItem : items)
[]
[ItemQuantity +=. Just 1]
[excludeNotEqualToOriginal ItemDescription]
dbItems <- fmap entityVal <$> selectList [] []
dbItems `shouldMatchList` (newItem : items)
itDb
"inserts new records and updates existing records if there are updates specified and the modification condition is True (because it's empty)"
$ do
let
newItem = Item "item3" "hello world" Nothing Nothing
postUpdate = map (\i -> i{itemQuantity = fmap (+ 1) (itemQuantity i)}) items
insertMany_ items
upsertManyWhere
(newItem : items)
[]
[ItemQuantity +=. Just 1]
[]
dbItems <- fmap entityVal <$> selectList [] []
dbItems `shouldMatchList` (newItem : postUpdate)
itDb
"inserts new records and updates existing records if there are updates specified and the modification filter condition is triggered"
$ do
let
newItem = Item "item3" "hi friends!" Nothing Nothing
postUpdate = map (\i -> i{itemQuantity = fmap (+ 1) (itemQuantity i)}) items
insertMany_ items
upsertManyWhere
(newItem : items)
[ copyUnlessEq ItemDescription "hi friends!"
, copyField ItemPrice
]
[ItemQuantity +=. Just 1]
[ItemDescription !=. "bye friends!"]
dbItems <- fmap entityVal <$> selectList [] []
dbItems `shouldMatchList` (newItem : postUpdate)
itDb
"inserts an item and doesn't apply the update if the filter condition is triggered"
$ do
let
newItem = Item "item3" "hello world" Nothing Nothing
insertMany_ items
upsertManyWhere
(newItem : items)
[]
[ItemQuantity +=. Just 1]
[excludeNotEqualToOriginal ItemDescription]
dbItems <- fmap entityVal <$> selectList [] []
dbItems `shouldMatchList` (newItem : items)