esqueleto-3.6.0.0: test/Common/Record.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- Tests for `Database.Esqueleto.Record`.
module Common.Record (testDeriveEsqueletoRecord) where
import Common.Test.Import hiding (from, on)
import Data.List (sortOn)
import Database.Esqueleto.Experimental
import Database.Esqueleto.Record
( DeriveEsqueletoRecordSettings(..)
, defaultDeriveEsqueletoRecordSettings
, deriveEsqueletoRecord
, deriveEsqueletoRecordWith
)
import GHC.Records
data MyRecord =
MyRecord
{ myName :: Text
, myAge :: Maybe Int
, myUser :: Entity User
, myAddress :: Maybe (Entity Address)
}
deriving (Show, Eq)
$(deriveEsqueletoRecord ''MyRecord)
myRecordQuery :: SqlQuery SqlMyRecord
myRecordQuery = do
user :& address <- from $
table @User
`leftJoin`
table @Address
`on` (do \(user :& address) -> user ^. #address ==. address ?. #id)
pure
SqlMyRecord
{ myName = castString $ user ^. #name
, myAge = val $ Just 10
, myUser = user
, myAddress = address
}
data MyNestedRecord = MyNestedRecord
{ myName :: Text
, myRecord :: MyRecord
, myMaybeRecord :: Maybe MyRecord
}
deriving (Show, Eq)
data MyNestedMaybeRecord = MyNestedMaybeRecord
{myNestedRecord :: Maybe MyRecord}
deriving (Show, Eq)
$(deriveEsqueletoRecord ''MyNestedRecord)
$(deriveEsqueletoRecord ''MyNestedMaybeRecord)
myNestedRecordQuery :: SqlQuery SqlMyNestedRecord
myNestedRecordQuery = do
user :& address <-
from $
table @User
`leftJoin` table @Address
`on` (do \(user :& address) -> user ^. #address ==. address ?. #id)
pure
SqlMyNestedRecord
{ myName = castString $ user ^. #name
, myRecord =
SqlMyRecord
{ myName = castString $ user ^. #name
, myAge = val $ Just 10
, myUser = user
, myAddress = address
}
, myMaybeRecord =
SqlMaybeMyRecord
{ myName = castString $ user ^. #name
, myAge = val $ Just 10
, myUser = toMaybe user
, myAddress = address
}
}
myNestedMaybeRecordQuery :: SqlQuery SqlMyNestedMaybeRecord
myNestedMaybeRecordQuery = do
user :& address <-
from $
table @User
`leftJoin` table @Address
`on` (do \(user :& address) -> user ^. #address ==. address ?. #id)
pure
SqlMyNestedMaybeRecord
{
myNestedRecord =
SqlMaybeMyRecord
{ myName = castString $ user ^. #name
, myAge = val $ Just 10
, myUser = toMaybe user
, myAddress = address
}
}
data MyModifiedRecord =
MyModifiedRecord
{ myModifiedName :: Text
, myModifiedAge :: Maybe Int
, myModifiedUser :: Entity User
, myModifiedAddress :: Maybe (Entity Address)
}
deriving (Show, Eq)
$(deriveEsqueletoRecordWith (defaultDeriveEsqueletoRecordSettings
{ sqlNameModifier = (++ "Sql")
, sqlFieldModifier = (++ "Sql")
})
''MyModifiedRecord)
myModifiedRecordQuery :: SqlQuery MyModifiedRecordSql
myModifiedRecordQuery = do
user :& address <- from $
table @User
`leftJoin`
table @Address
`on` (do \(user :& address) -> user ^. #address ==. address ?. #id)
pure
MyModifiedRecordSql
{ myModifiedNameSql = castString $ user ^. #name
, myModifiedAgeSql = val $ Just 10
, myModifiedUserSql = user
, myModifiedAddressSql = address
}
mySubselectRecordQuery :: SqlQuery (SqlExpr (Maybe (Entity Address)))
mySubselectRecordQuery = do
_ :& record <- from $
table @User
`leftJoin`
myRecordQuery
`on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" record ?. #id)
pure $ getField @"myAddress" record
testDeriveEsqueletoRecord :: SpecDb
testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do
let setup :: MonadIO m => SqlPersistT m ()
setup = do
_ <- insert $ User { userAddress = Nothing, userName = "Rebecca" }
addr <- insert $ Address { addressAddress = "30-50 Feral Hogs Rd" }
_ <- insert $ User { userAddress = Just addr, userName = "Some Guy" }
pure ()
itDb "can select records" $ do
setup
records <- select myRecordQuery
let sortedRecords = sortOn (\MyRecord {myName} -> myName) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case MyRecord { myName = "Rebecca"
, myAge = Just 10
, myUser = Entity _ User { userAddress = Nothing
, userName = "Rebecca"
}
, myAddress = Nothing
} -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case MyRecord { myName = "Some Guy"
, myAge = Just 10
, myUser = Entity _ User { userAddress = Just addr1
, userName = "Some Guy"
}
, myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})
} -> addr1 == addr2 -- The keys should match.
_ -> False)
itDb "can select nested records" $ do
setup
records <- select myNestedRecordQuery
let sortedRecords = sortOn (\MyNestedRecord {myName} -> myName) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case MyNestedRecord
{ myName = "Rebecca"
, myRecord =
MyRecord { myName = "Rebecca"
, myAge = Just 10
, myUser = Entity _ User { userAddress = Nothing
, userName = "Rebecca"
}
, myAddress = Nothing
}
} -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case MyNestedRecord
{ myName = "Some Guy"
, myRecord =
MyRecord { myName = "Some Guy"
, myAge = Just 10
, myUser = Entity _ User { userAddress = Just addr1
, userName = "Some Guy"
}
, myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})
}
} -> addr1 == addr2 -- The keys should match.
_ -> False)
itDb "can select nested maybe records" $ do
setup
records <- select myNestedMaybeRecordQuery
let sortedRecords = sortOn (\MyNestedMaybeRecord {myNestedRecord} -> case myNestedRecord of
Just r -> getField @"myName" r
Nothing -> "No name"
) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case MyNestedMaybeRecord
{
myNestedRecord = Just
MyRecord { myName = "Rebecca"
, myAge = Just 10
, myUser = Entity _ User { userAddress = Nothing
, userName = "Rebecca"
}
, myAddress = Nothing
}
} -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case MyNestedMaybeRecord
{
myNestedRecord = Just
MyRecord { myName = "Some Guy"
, myAge = Just 10
, myUser = Entity _ User { userAddress = Just addr1
, userName = "Some Guy"
}
, myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})
}
} -> addr1 == addr2 -- The keys should match.
_ -> False)
itDb "can select nested nothing records" $ do
setup
records <- select $ do
user :& address <-
from $ table @User `leftJoin` table @Address `on` (do \(_ :& _) -> val False)
pure
SqlMyNestedMaybeRecord
{
myNestedRecord =
SqlMaybeMyRecord
{ myName = val Nothing
, myAge = val Nothing
, myUser = toMaybe user
, myAddress = address
}
}
liftIO $ records `shouldBe`
[MyNestedMaybeRecord { myNestedRecord = Nothing }, MyNestedMaybeRecord { myNestedRecord = Nothing}]
itDb "can left join on nested maybed records" $ do
setup
records <- select $ do
from
( table @User
`leftJoin` myNestedMaybeRecordQuery
`on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myNestedRecord" record) ?. #id)
)
let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case (_ :& Just (MyNestedMaybeRecord
{
myNestedRecord = Just
MyRecord { myName = "Rebecca",
myAddress = Nothing
}
}
)) -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case ( _ :& Just (MyNestedMaybeRecord
{ myNestedRecord = Just
MyRecord { myName = "Some Guy"
, myAddress = (Just (Entity _ Address {addressAddress = "30-50 Feral Hogs Rd"}))
}
}
)) -> True
_ -> False)
itDb "can left join on nothing nested records" $ do
setup
records <- select $ do
from (table @User `leftJoin` myNestedMaybeRecordQuery `on` (do \(_ :& _) -> val False))
let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case (_ :& Nothing) -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case (_ :& Nothing) -> True
_ -> False)
itDb "can be used in a CTE" $ do
setup
records <- select $ do
recordCTE <- with myRecordQuery
record <- from recordCTE
pure record
let sortedRecords = sortOn (\MyRecord {myName} -> myName) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case MyRecord { myName = "Rebecca"
, myAge = Just 10
, myUser = Entity _ User { userAddress = Nothing
, userName = "Rebecca"
}
, myAddress = Nothing
} -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case MyRecord { myName = "Some Guy"
, myAge = Just 10
, myUser = Entity _ User { userAddress = Just addr1
, userName = "Some Guy"
}
, myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})
} -> addr1 == addr2 -- The keys should match.
_ -> False)
itDb "can select user-modified records" $ do
setup
records <- select myModifiedRecordQuery
let sortedRecords = sortOn (\MyModifiedRecord {myModifiedName} -> myModifiedName) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case MyModifiedRecord
{ myModifiedName = "Rebecca"
, myModifiedAge = Just 10
, myModifiedUser = Entity _ User { userAddress = Nothing
, userName = "Rebecca"
}
, myModifiedAddress = Nothing
} -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case MyModifiedRecord
{ myModifiedName = "Some Guy"
, myModifiedAge = Just 10
, myModifiedUser = Entity _ User { userAddress = Just addr1
, userName = "Some Guy"
}
, myModifiedAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})
} -> addr1 == addr2 -- The keys should match.
_ -> False)
itDb "can left join on records" $ do
setup
records <- select $ do
from
( table @User
`leftJoin` myRecordQuery `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" record ?. #id)
)
let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case (_ :& Just (MyRecord {myName = "Rebecca", myAddress = Nothing})) -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case ( _ :& Just ( MyRecord { myName = "Some Guy"
, myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}))
}
)) -> True
_ -> False)
itDb "can handle joins on records with Nothing" $ do
setup
records <- select $ do
from
( table @User
`leftJoin` myRecordQuery `on` (do \(user :& record) -> user ^. #address ==. getField @"myAddress" record ?. #id)
)
let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case (_ :& Nothing) -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case ( _ :& Just ( MyRecord { myName = "Some Guy"
, myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}))
}
)) -> True
_ -> False)
itDb "can left join on nested records" $ do
setup
records <- select $ do
from
( table @User
`leftJoin` myNestedRecordQuery
`on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myRecord" record) ?. #id)
)
let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case (_ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case ( _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy"
, myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}))
}
})) -> True
_ -> False)
itDb "can handle multiple left joins on the same record" $ do
setup
records <- select $ do
from
( table @User
`leftJoin` myNestedRecordQuery
`on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myRecord" record) ?. #id)
`leftJoin` myNestedRecordQuery
`on` (do \(user :& record1 :& record2) -> getField @"myUser" (getField @"myRecord" record1) ?. #id !=. getField @"myUser" (getField @"myRecord" record2) ?. #id)
)
let sortedRecords = sortOn (\(Entity _ user :& _ :& _) -> getField @"userName" user) records
liftIO $ sortedRecords !! 0
`shouldSatisfy`
(\case ( _ :& _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy"
, myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}))
}
})) -> True
_ -> False)
liftIO $ sortedRecords !! 1
`shouldSatisfy`
(\case (_ :& _ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True
_ -> False)