beam-large-records-0.1.1: test/Test/Record/Beam/Tutorial3.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}
-- For lens derivation
-- {-# LANGUAGE ImpredicativeTypes #-}
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-unused-top-binds #-}
module Test.Record.Beam.Tutorial3 (tests) where
import Prelude hiding (product)
import Data.Int
import Data.Kind
import Data.Text (Text)
import Data.Time
import Database.Beam hiding (countAll_)
import Database.Beam.Backend.SQL
import Database.Beam.Sqlite
import Lens.Micro
import qualified Data.Text as T
import qualified Database.SQLite.Simple as SQLite
import qualified GHC.Generics as GHC
import Test.Tasty
import Test.Tasty.HUnit
import Data.Record.Beam ()
import Test.Record.Beam.Tutorial1 hiding (tests)
import Test.Record.Beam.Tutorial2 hiding (tests)
import Test.Record.Beam.Util.Compat
import Test.Record.Beam.Util.SQLite
{-------------------------------------------------------------------------------
New table: Product
This does not introduce a new beam features.
-------------------------------------------------------------------------------}
{-# ANN type ProductT largeRecord #-}
data ProductT (f :: Type -> Type) = Product {
productId :: C f Int32
, productTitle :: C f Text
, productDescription :: C f Text
, productPrice :: C f Int32 {- Price in cents -}
}
deriving (Show, Eq)
deriving anyclass (Beamable)
instance Table ProductT where
data PrimaryKey ProductT f = ProductId (Columnar f Int32)
deriving stock (GHC.Generic)
deriving anyclass (Beamable)
primaryKey p = ProductId p.productId
deriving instance Show (Columnar f Int32) => Show (PrimaryKey ProductT f)
deriving instance Eq (Columnar f Int32) => Eq (PrimaryKey ProductT f)
type Product = ProductT Identity
{-------------------------------------------------------------------------------
New table: Order
This introduces the use of 'Nullable' (as well as the use of a
custom datatype for a column).
-------------------------------------------------------------------------------}
data ShippingCarrier = USPS | FedEx | UPS | DHL
deriving (Show, Read, Eq, Ord, Enum)
instance HasSqlValueSyntax be String => HasSqlValueSyntax be ShippingCarrier where
sqlValueSyntax = autoSqlValueSyntax
instance FromBackendRow Sqlite ShippingCarrier where
fromBackendRow = read . T.unpack <$> fromBackendRow
{-# ANN type OrderT largeRecord #-}
data OrderT (f :: Type -> Type) = Order {
orderId :: Columnar f Int32
, orderDate :: Columnar f LocalTime
, orderForUser :: PrimaryKey UserT f
, orderShipToAddress :: PrimaryKey AddressT f
, orderShippingInfo :: PrimaryKey ShippingInfoT (Nullable f)
}
deriving (Show, Eq)
deriving anyclass (Beamable)
{-# ANN type ShippingInfoT largeRecord #-}
data ShippingInfoT (f :: Type -> Type) = ShippingInfo {
shippingInfoId :: Columnar f Int32
, shippingInfoCarrier :: Columnar f ShippingCarrier
, shippingInfoTrackingNumber :: Columnar f Text
}
deriving (Show, Eq)
deriving anyclass (Beamable)
instance Table OrderT where
data PrimaryKey OrderT f = OrderId (Columnar f Int32)
deriving stock (GHC.Generic)
deriving anyclass (Beamable)
primaryKey o = OrderId o.orderId
instance Table ShippingInfoT where
data PrimaryKey ShippingInfoT f = ShippingInfoId (Columnar f Int32)
deriving stock (GHC.Generic)
deriving anyclass (Beamable)
primaryKey s = ShippingInfoId s.shippingInfoId
deriving instance Show (Columnar f Int32) => Show (PrimaryKey OrderT f)
deriving instance Eq (Columnar f Int32) => Eq (PrimaryKey OrderT f)
deriving instance Show (Columnar f Int32) => Show (PrimaryKey ShippingInfoT f)
deriving instance Eq (Columnar f Int32) => Eq (PrimaryKey ShippingInfoT f)
type Order = OrderT Identity
type ShippingInfo = ShippingInfoT Identity
{-------------------------------------------------------------------------------
New table: 'LineItem' (many-to-many relation)
-------------------------------------------------------------------------------}
{-# ANN type LineItemT largeRecord #-}
data LineItemT (f :: Type -> Type) = LineItem {
lineItemInOrder :: PrimaryKey OrderT f
, lineItemForProduct :: PrimaryKey ProductT f
, lineItemQuantity :: Columnar f Int32
}
deriving (Show, Eq)
deriving anyclass (Beamable)
type LineItem = LineItemT Identity
instance Table LineItemT where
data PrimaryKey LineItemT f =
LineItemId (PrimaryKey OrderT f) (PrimaryKey ProductT f)
deriving stock (GHC.Generic)
deriving anyclass (Beamable)
primaryKey l = LineItemId l.lineItemInOrder l.lineItemForProduct
{-------------------------------------------------------------------------------
Version 3 of the DB
-------------------------------------------------------------------------------}
{-# ANN type ShoppingCart3Db largeRecord #-}
data ShoppingCart3Db (f :: Type -> Type) = ShoppingCart3Db {
shoppingCart3Users :: f (TableEntity UserT)
, shoppingCart3UserAddresses :: f (TableEntity AddressT)
, shoppingCart3Products :: f (TableEntity ProductT)
, shoppingCart3Orders :: f (TableEntity OrderT)
, shoppingCart3ShippingInfos :: f (TableEntity ShippingInfoT)
, shoppingCart3LineItems :: f (TableEntity LineItemT)
}
instance Database be ShoppingCart3Db
{-------------------------------------------------------------------------------
DB settings
-------------------------------------------------------------------------------}
shoppingCart3Db :: DatabaseSettings be ShoppingCart3Db
shoppingCart3Db = defaultDbSettings `withDbModification`
dbModification{shoppingCart3UserAddresses =
setEntityName "addresses"
<> modifyTableFields tableModification{addressLine1 = "address1"
,addressLine2 = "address2"
}
, shoppingCart3Products =
setEntityName "products"
, shoppingCart3Orders =
setEntityName "orders"
<> modifyTableFields tableModification{orderShippingInfo = ShippingInfoId "shipping_info__id"}
, shoppingCart3ShippingInfos =
setEntityName "shipping_info"
<> modifyTableFields tableModification{shippingInfoId = "id"
,shippingInfoCarrier = "carrier"
,shippingInfoTrackingNumber = "tracking_number"
}
, shoppingCart3LineItems =
setEntityName "line_items"
}
{-------------------------------------------------------------------------------
Lenses
-------------------------------------------------------------------------------}
lensesLineItemT :: LineItemT (Lenses LineItemT f)
lensesProductT :: ProductT (Lenses ProductT f)
lensesOrderT :: OrderT (Lenses OrderT f)
lensesLineItemT = tableLenses
lensesProductT = tableLenses
lensesOrderT = tableLenses
lensesShoppingCart3 :: ShoppingCart3Db (TableLens f ShoppingCart3Db)
lensesShoppingCart3 = dbLenses
xlineItemInOrder :: Lens' (LineItemT f) (C f Int32)
xlineItemInOrder = case lensesLineItemT.lineItemInOrder of OrderId (LensFor l) -> l
xlineItemForProduct :: Lens' (LineItemT f) (C f Int32)
xlineItemForProduct = case lensesLineItemT.lineItemForProduct of ProductId (LensFor l) -> l
xlineItemQuantity :: Lens' (LineItemT f) (C f Int32)
xlineItemQuantity = case lensesLineItemT.lineItemQuantity of LensFor l -> l
xproductId :: Lens' (ProductT f) (C f Int32)
xproductId = case lensesProductT.productId of LensFor l -> l
xproductTitle :: Lens' (ProductT f) (C f Text)
xproductTitle = case lensesProductT.productTitle of LensFor l -> l
xproductDescription :: Lens' (ProductT f) (C f Text)
xproductDescription = case lensesProductT.productDescription of LensFor l -> l
xproductPrice :: Lens' (ProductT f) (C f Int32)
xproductPrice = case lensesProductT.productPrice of LensFor l -> l
xorderId :: Lens' (OrderT f) (C f Int32)
xorderId = case lensesOrderT.orderId of LensFor l -> l
xorderDate :: Lens' (OrderT f) (C f LocalTime)
xorderDate = case lensesOrderT.orderDate of LensFor l -> l
xorderForUser :: Lens' (OrderT f) (C f Text)
xorderForUser = case lensesOrderT.orderForUser of UserId (LensFor l) -> l
xorderShipToAddress :: Lens' (OrderT f) (C f Int32)
xorderShipToAddress = case lensesOrderT.orderShipToAddress of AddressId (LensFor l) -> l
xorderShippingInfo :: Lens' (OrderT f) (C f (Maybe Int32))
xorderShippingInfo = case lensesOrderT.orderShippingInfo of ShippingInfoId (LensFor l) -> l
xshoppingCart3Users :: Lens' (ShoppingCart3Db f) (f (TableEntity UserT))
xshoppingCart3Users = case lensesShoppingCart3.shoppingCart3Users of TableLens x -> x
xshoppingCart3UserAddresses :: Lens' (ShoppingCart3Db f) (f (TableEntity AddressT))
xshoppingCart3UserAddresses = case lensesShoppingCart3.shoppingCart3UserAddresses of TableLens x -> x
xshoppingCart3Products :: Lens' (ShoppingCart3Db f) (f (TableEntity ProductT))
xshoppingCart3Products = case lensesShoppingCart3.shoppingCart3Products of TableLens x -> x
xshoppingCart3Orders :: Lens' (ShoppingCart3Db f) (f (TableEntity OrderT))
xshoppingCart3Orders = case lensesShoppingCart3.shoppingCart3Orders of TableLens x -> x
xshoppingCart3ShippingInfos :: Lens' (ShoppingCart3Db f) (f (TableEntity ShippingInfoT))
xshoppingCart3ShippingInfos = case lensesShoppingCart3.shoppingCart3ShippingInfos of TableLens x -> x
xshoppingCart3LineItems :: Lens' (ShoppingCart3Db f) (f (TableEntity LineItemT))
xshoppingCart3LineItems = case lensesShoppingCart3.shoppingCart3LineItems of TableLens x -> x
-- | Lens from 'Order' to the primary key of the shipping info
--
-- Note that nullability translates to 'Maybe'.
shippingInfo :: Lens' Order (Maybe Int32)
shippingInfo = xorderShippingInfo
{-------------------------------------------------------------------------------
Tests proper
-------------------------------------------------------------------------------}
tests :: TestTree
tests = testGroup "Test.Record.Beam.Tutorial3" [
testCase "lensToNullableField" test_lensToNullableField
, testCase "SQL" test_SQL
]
test_lensToNullableField :: Assertion
test_lensToNullableField = do
now <- zonedTimeToLocalTime <$> getZonedTime
assertEqual "Just" (Just 3) (exampleOrder1 now ^. shippingInfo)
assertEqual "Nothing" Nothing (exampleOrder2 now ^. shippingInfo)
assertEqual "set" (exampleOrder1 now) $
(exampleOrder2 now) & shippingInfo .~ Just 3
where
exampleOrder1, exampleOrder2 :: LocalTime -> Order
exampleOrder1 now = Order {
orderId = 1
, orderDate = now
, orderForUser = UserId "a@b.c"
, orderShipToAddress = AddressId 1
, orderShippingInfo = ShippingInfoId (Just 3)
}
exampleOrder2 now = Order {
orderId = 1
, orderDate = now
, orderForUser = UserId "a@b.c"
, orderShipToAddress = AddressId 1
, orderShippingInfo = ShippingInfoId Nothing
}
test_SQL :: Assertion
test_SQL = runInMemory $ \conn -> do
liftIO $ SQLite.execute_ conn $
"CREATE TABLE cart3_users (email VARCHAR NOT NULL, first_name VARCHAR NOT NULL, last_name VARCHAR NOT NULL, password VARCHAR NOT NULL, PRIMARY KEY( email ));"
liftIO $ SQLite.execute_ conn $
"CREATE TABLE addresses ( id INTEGER PRIMARY KEY AUTOINCREMENT, address1 VARCHAR NOT NULL, address2 VARCHAR, city VARCHAR NOT NULL, state VARCHAR NOT NULL, zip VARCHAR NOT NULL, for_user__email VARCHAR NOT NULL );"
liftIO $ SQLite.execute_ conn $
"CREATE TABLE products ( id INTEGER PRIMARY KEY AUTOINCREMENT, title VARCHAR NOT NULL, description VARCHAR NOT NULL, price INT NOT NULL );"
liftIO $ SQLite.execute_ conn $
"CREATE TABLE orders ( id INTEGER PRIMARY KEY AUTOINCREMENT, date TIMESTAMP NOT NULL, for_user__email VARCHAR NOT NULL, ship_to_address__id INT NOT NULL, shipping_info__id INT);"
liftIO $ SQLite.execute_ conn $
"CREATE TABLE shipping_info ( id INTEGER PRIMARY KEY AUTOINCREMENT, carrier VARCHAR NOT NULL, tracking_number VARCHAR NOT NULL);"
liftIO $ SQLite.execute_ conn $
"CREATE TABLE line_items (item_in_order__id INTEGER NOT NULL, item_for_product__id INTEGER NOT NULL, item_quantity INTEGER NOT NULL)"
(jamesAddress1, bettyAddress1, _bettyAddress2, redBall, mathTextbook, introToHaskell, _suitcase) <- do
runInsert $ insert (shoppingCart3Db ^. xshoppingCart3Users) $
insertValues users
[jamesAddress1, bettyAddress1, bettyAddress2] <-
runInsertReturningList $
insertReturning (shoppingCart3Db ^. xshoppingCart3UserAddresses) $
insertExpressions addresses
[redBall, mathTextbook, introToHaskell, suitcase] <-
runInsertReturningList $
insertReturning (shoppingCart3Db ^. xshoppingCart3Products) $
insertExpressions products
pure ( jamesAddress1, bettyAddress1, bettyAddress2, redBall, mathTextbook, introToHaskell, suitcase )
-- Check autoincrement field
liftIO $ assertEqual "jamesAddress1" addr1 jamesAddress1
-- Marshalling custom types
bettyShippingInfo <- do
[bettyShippingInfo] <-
runInsertReturningList $
insertReturning (shoppingCart3Db ^. xshoppingCart3ShippingInfos) $
insertExpressions [
ShippingInfo default_ (val_ USPS) (val_ "12345790ABCDEFGHI")
]
pure bettyShippingInfo
liftIO $ assertEqual "bettyShippingInfo" info1 bettyShippingInfo
-- Timestamps
now <- liftIO $ zonedTimeToLocalTime <$> getZonedTime
[jamesOrder1, bettyOrder1, jamesOrder2] <-
runInsertReturningList $
insertReturning (shoppingCart3Db ^. xshoppingCart3Orders) $
insertExpressions [
Order default_ currentTimestamp_ (val_ (pk james)) (val_ (pk jamesAddress1)) nothing_
, Order default_ currentTimestamp_ (val_ (pk betty)) (val_ (pk bettyAddress1)) (just_ (val_ (pk bettyShippingInfo)))
, Order default_ currentTimestamp_ (val_ (pk james)) (val_ (pk jamesAddress1)) nothing_
]
-- Less than one second should have passed in between us taking a timestamp
-- and sqlite actually creating the row
liftIO $ assertBool "timestamp" $
nominalDiffTimeToSeconds ((jamesOrder1 ^. xorderDate) `diffLocalTime` now) < 1
-- Create line items
let lineItems :: [LineItem]
lineItems = [
LineItem (pk jamesOrder1) (pk redBall) 10
, LineItem (pk jamesOrder1) (pk mathTextbook) 1
, LineItem (pk jamesOrder1) (pk introToHaskell) 4
, LineItem (pk bettyOrder1) (pk mathTextbook) 3
, LineItem (pk bettyOrder1) (pk introToHaskell) 3
, LineItem (pk jamesOrder2) (pk mathTextbook) 1
]
runInsert $ insert (shoppingCart3Db ^. xshoppingCart3LineItems) $
insertValues lineItems
-- LEFT JOIN: Users and orders
usersAndOrders <-
runSelectReturningList $
select $ do
user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) (\order -> order.orderForUser `references_` user)
pure (user, order)
let expectedUsersAndOrders :: [(User, Maybe Order)]
expectedUsersAndOrders = [
(james, Just jamesOrder1)
, (james, Just jamesOrder2)
, (betty, Just bettyOrder1)
, (sam, Nothing)
]
liftIO $ assertEqual "usersAndOrders" expectedUsersAndOrders usersAndOrders
-- LEFT JOIN: Users without any orders
usersWithNoOrders <-
runSelectReturningList $
select $ do
user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) (\order -> order.orderForUser `references_` user)
guard_ (isNothing_ order)
pure user
liftIO $ assertEqual "usersWithNoOrders" [sam] usersWithNoOrders
-- Alternative way to get users with no orders
usersWithNoOrders' <-
runSelectReturningList $
select $ do
user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
guard_ (not_ (exists_ (filter_ (\order -> order.orderForUser `references_` user) (all_ (shoppingCart3Db ^. xshoppingCart3Orders)))))
pure user
liftIO $ assertEqual "usersWithNoOrders'" [sam] usersWithNoOrders'
-- Aggregates
ordersWithCostOrdered <-
runSelectReturningList $
select $ orderBy_ (\(_order, total) -> desc_ total)
$ aggregate_ (\(order, lineItem, product) ->
(group_ order, sum_ (lineItem ^. xlineItemQuantity * product ^. xproductPrice)))
$ do
lineItem <- all_ (shoppingCart3Db ^. xshoppingCart3LineItems)
order <- related_ (shoppingCart3Db ^. xshoppingCart3Orders) lineItem.lineItemInOrder
product <- related_ (shoppingCart3Db ^. xshoppingCart3Products) lineItem.lineItemForProduct
pure (order, lineItem, product)
let totalJamesOrder1, totalJamesOrder2, totalBettyOrder1 :: Int32
totalJamesOrder1 = 10 * redBall.productPrice
+ 1 * mathTextbook.productPrice
+ 4 * introToHaskell.productPrice
totalJamesOrder2 = 1 * mathTextbook.productPrice
totalBettyOrder1 = 3 * mathTextbook.productPrice
+ 3 * introToHaskell.productPrice
expectedOrdersWithCostOrdered :: [(Order, Maybe Int32)]
expectedOrdersWithCostOrdered = [
(jamesOrder1, Just totalJamesOrder1)
, (bettyOrder1, Just totalBettyOrder1)
, (jamesOrder2, Just totalJamesOrder2)
]
liftIO $ assertEqual "ordersWithCostOrdered" expectedOrdersWithCostOrdered ordersWithCostOrdered
-- LEFT JOIN: Using 'maybe_'
allUsersAndTotals <-
runSelectReturningList $
select $ orderBy_ (\(_user, total) -> desc_ total)
$ aggregate_ (\(user, lineItem, product) ->
(group_ user, sum_ (maybe_ 0 id lineItem.lineItemQuantity * maybe_ 0 id (product ^. xproductPrice))))
$ do
user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders))
(\order -> order.orderForUser `references_` user)
lineItem <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3LineItems))
(\lineItem -> maybe_ (val_ False) (\order' -> lineItem.lineItemInOrder `references_` order') order)
product <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Products))
(\product -> maybe_ (val_ False) (\lineItem' -> lineItem'.lineItemForProduct `references_` product) lineItem)
pure (user, lineItem, product)
-- Bug in beam? Original tutorial (without LR) has same problem.
-- <https://github.com/haskell-beam/beam/issues/580>
let expectedAllUsersAndTotals :: [(User, Maybe Int32)]
expectedAllUsersAndTotals = [
(betty, Just totalBettyOrder1)
, (james, Just 0) -- TODO: Should be (totalJamesOrder1 + totalJamesOrder2))
, (sam, Just 0)
]
liftIO $ assertEqual "allUsersAndTotals" expectedAllUsersAndTotals allUsersAndTotals
-- LEFT JOIN: Using 'leftJoin_''
allUsersAndTotals2 <-
runSelectReturningList $
select $ orderBy_ (\(_user, total) -> desc_ total)
$ aggregate_ (\(user, lineItem, product) ->
(group_ user, sum_ (maybe_ 0 id lineItem.lineItemQuantity * maybe_ 0 id (product ^. xproductPrice))))
$ do
user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders))
(\order -> order.orderForUser `references_` user)
lineItem <- leftJoin_' (all_ (shoppingCart3Db ^. xshoppingCart3LineItems))
(\lineItem -> just_ lineItem.lineItemInOrder ==?. pk order)
product <- leftJoin_' (all_ (shoppingCart3Db ^. xshoppingCart3Products))
(\product -> lineItem.lineItemForProduct ==?. just_ (pk product))
pure (user, lineItem, product)
let expectedAllUsersAndTotals2 :: [(User, Maybe Int32)]
expectedAllUsersAndTotals2 = [
(james, Just (totalJamesOrder1 + totalJamesOrder2))
, (betty, Just totalBettyOrder1)
, (sam, Just 0)
]
liftIO $ assertEqual "allUsersAndTotals2" expectedAllUsersAndTotals2 allUsersAndTotals2
-- Dealing with nullable foreign keys
allUnshippedOrders <-
runSelectReturningList $
select $ filter_ (\info -> isNothing_ info.orderShippingInfo)
$ all_ (shoppingCart3Db ^. xshoppingCart3Orders)
let expectedAllUnshippedOrders :: [Order]
expectedAllUnshippedOrders = [jamesOrder1, jamesOrder2]
liftIO $ assertEqual "allUnshippedOrders" expectedAllUnshippedOrders allUnshippedOrders
-- .. in combination with aggregation
shippingInformationByUser <-
runSelectReturningList $
select $ aggregate_ (\(user, order) ->
let ShippingInfoId siId = order.orderShippingInfo
in ( group_ user
, as_ @Int32 $ count_ (as_ @(Maybe Int32) (maybe_ (just_ 1) (\_ -> nothing_) siId))
, as_ @Int32 $ count_ siId
))
$ do
user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) (\order -> order.orderForUser `references_` user)
pure (user, order)
let expectedShippingInformationByUser :: [(User, Int32, Int32)]
expectedShippingInformationByUser = [
(betty, 0, 1)
, (james, 2, 0)
, (sam, 1, 0) -- Incorrect value (expected problem, mentioned in tutorial)
]
liftIO $ assertEqual "shippingInformationByUser"
expectedShippingInformationByUser
shippingInformationByUser
-- Using implicit subselects
shippingInformationByUser' <-
runSelectReturningList $
select $ do
forUser <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
(email, unshippedCount) <-
aggregate_ (\(email, _order) -> (group_ email, countAll_)) $
do user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders))
(\order -> order.orderForUser `references_` user &&. isNothing_ order.orderShippingInfo)
pure (pk user, order)
guard_ (email `references_` forUser)
(email', shippedCount) <-
aggregate_ (\(email', _order) -> (group_ email', countAll_)) $
do user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders))
(\order -> order.orderForUser `references_` user &&. isJust_ order.orderShippingInfo)
pure (pk user, order)
guard_ (email' `references_` forUser)
pure (forUser, unshippedCount, shippedCount)
-- TODO: These numbers make no sense
-- <https://github.com/haskell-beam/beam/issues/580>
let expectedShippingInformationByUser' :: [(User, Int32, Int32)]
expectedShippingInformationByUser' = [
(betty, 1, 1)
, (james, 2, 1)
, (sam, 1, 1)
]
liftIO $ assertEqual "shippingInformationByUser'"
expectedShippingInformationByUser'
shippingInformationByUser'
-- Alternative formulation: using explicit subselects
shippingInformationByUser'' <-
runSelectReturningList $
select $
do forUser <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
(email, unshippedCount) <-
subselect_ $
aggregate_ (\(email, _order) -> (group_ email, countAll_)) $
do user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders))
(\order -> order.orderForUser `references_` user &&. isNothing_ order.orderShippingInfo)
pure (pk user, order)
guard_ (email `references_` forUser)
(email', shippedCount) <-
subselect_ $
aggregate_ (\(email', _order) -> (group_ email', countAll_)) $
do user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)
order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders))
(\order -> order.orderForUser `references_` user &&. isJust_ order.orderShippingInfo)
pure (pk user, order)
guard_ (email' `references_` forUser)
pure (forUser, unshippedCount, shippedCount)
liftIO $ assertEqual "shippingInformationByUser''"
expectedShippingInformationByUser'
shippingInformationByUser''
where
james, betty, sam :: User
james = User "james@example.com" "James" "Smith" "b4cc344d25a2efe540adbf2678e2304c"
betty = User "betty@example.com" "Betty" "Jones" "82b054bd83ffad9b6cf8bdb98ce3cc2f"
sam = User "sam@example.com" "Sam" "Taylor" "332532dcfaa1cbf61e2a266bd723612c"
users :: [User]
users = [james, betty, sam]
addresses :: [AddressT (QExpr Sqlite s)]
addresses = [
Address default_ (val_ "123 Little Street") (val_ Nothing) (val_ "Boston") (val_ "MA") (val_ "12345") (val_ (pk james))
, Address default_ (val_ "222 Main Street") (val_ (Just "Ste 1")) (val_ "Houston") (val_ "TX") (val_ "8888") (val_ (pk betty))
, Address default_ (val_ "9999 Residence Ave") (val_ Nothing) (val_ "Sugarland") (val_ "TX") (val_ "8989") (val_ (pk betty))
]
products :: [ProductT (QExpr Sqlite s)]
products = [
Product default_ (val_ "Red Ball") (val_ "A bright red, very spherical ball") (val_ 1000)
, Product default_ (val_ "Math Textbook") (val_ "Contains a lot of important math theorems and formulae") (val_ 2500)
, Product default_ (val_ "Intro to Haskell") (val_ "Learn the best programming language in the world") (val_ 3000)
, Product default_ (val_ "Suitcase") "A hard durable suitcase" 15000
]
addr1 :: Address
addr1 = Address 1 "123 Little Street" Nothing "Boston" "MA" "12345" (pk james)
info1 :: ShippingInfo
info1 = ShippingInfo 1 USPS "12345790ABCDEFGHI"