beam-large-records-0.1.3: test/Test/Record/Beam/Tutorial2.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 #-}
{-# LANGUAGE OverloadedLabels #-}
{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-unused-top-binds #-}
module Test.Record.Beam.Tutorial2 (
tests
-- * Exported for the benefit of follow-up tutorials
, AddressT(..)
, Address
, PrimaryKey(..)
) where
import Data.Functor.Const
import Data.Int
import Data.Kind
import Data.Text (Text)
import Database.Beam
import Database.Beam.Schema.Tables
import Optics.Core ((&), (^.), (%~), (%), (.~), coerced)
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as Text
import qualified Database.SQLite.Simple as SQLite
import qualified GHC.Generics as GHC
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, testCase, assertEqual)
import Test.Record.Beam.Tutorial1 hiding (tests)
import Test.Record.Beam.Util.SQLite
{-------------------------------------------------------------------------------
New table: with a foreign key
-------------------------------------------------------------------------------}
{-# ANN type AddressT largeRecord #-}
data AddressT (f :: Type -> Type) = Address {
addressId :: C f Int32
, addressLine1 :: C f Text
, addressLine2 :: C f (Maybe Text)
, addressCity :: C f Text
, addressState :: C f Text
, addressZip :: C f Text
, addressForUser :: PrimaryKey UserT f
}
deriving (Show, Eq)
deriving anyclass (Beamable)
type Address = AddressT Identity
instance Table AddressT where
data PrimaryKey AddressT f = AddressId (Columnar f Int32)
deriving stock (GHC.Generic)
deriving anyclass (Beamable)
primaryKey addr = AddressId $ addr ^. #addressId
deriving instance Show (Columnar f Int32) => Show (PrimaryKey AddressT f)
deriving instance Eq (Columnar f Int32) => Eq (PrimaryKey AddressT f)
exampleAddress :: Address
exampleAddress = Address {
addressId = 1
, addressLine1 = "street"
, addressLine2 = Nothing
, addressCity = "city"
, addressState = "state"
, addressZip = "zip"
, addressForUser = UserId "a@b.c"
}
{-------------------------------------------------------------------------------
Version 2 of the DB
-------------------------------------------------------------------------------}
{-# ANN type ShoppingCart2Db largeRecord #-}
data ShoppingCart2Db (f :: Type -> Type) = ShoppingCart2Db {
shoppingCart2Users :: f (TableEntity UserT)
, shoppingCart2UserAddresses :: f (TableEntity AddressT)
}
deriving (Show, Eq)
instance Database be ShoppingCart2Db
shoppingCart2Db :: forall be. DatabaseSettings be ShoppingCart2Db
shoppingCart2Db = defaultDbSettings `withDbModification`
(dbModification & #shoppingCart2UserAddresses .~
(setEntityName "addresses"
<> modifyTableFields
(tableModification & #addressLine1 .~ fieldNamed "address1"
& #addressLine2 .~ fieldNamed "address2")))
{-------------------------------------------------------------------------------
Tests proper
-------------------------------------------------------------------------------}
tests :: TestTree
tests = testGroup "Test.Record.Beam.Tutorial2" [
testCase "defaultDbSettings" test_tutorial2_defaultDbSettings
, testCase "tableLenses" test_tableLenses
, testCase "dbLenses" test_dbLenses
, testCase "SQL" test_SQL
]
test_tutorial2_defaultDbSettings :: Assertion
test_tutorial2_defaultDbSettings =
assertEqual "" expected shoppingCart2Db
where
expected :: DatabaseSettings be ShoppingCart2Db
expected = ShoppingCart2Db {
shoppingCart2Users = DatabaseEntity $ DatabaseTable {
dbTableSchema = Nothing
, dbTableOrigName = "shoppingCart2Users"
, dbTableCurrentName = "cart2_users"
, dbTableSettings = User {
userEmail = TableField {_fieldPath = NE.fromList ["userEmail"] , _fieldName = "email"}
, userFirstName = TableField {_fieldPath = NE.fromList ["userFirstName"] , _fieldName = "first_name"}
, userLastName = TableField {_fieldPath = NE.fromList ["userLastName"] , _fieldName = "last_name"}
, userPassword = TableField {_fieldPath = NE.fromList ["userPassword"] , _fieldName = "password"}
}
}
, shoppingCart2UserAddresses = DatabaseEntity $ DatabaseTable {
dbTableSchema = Nothing
, dbTableOrigName = "shoppingCart2UserAddresses"
, dbTableCurrentName = "addresses"
, dbTableSettings = Address {
addressId = TableField {_fieldPath = NE.fromList ["addressId"] , _fieldName = "id"}
, addressLine1 = TableField {_fieldPath = NE.fromList ["addressLine1"] , _fieldName = "address1"}
, addressLine2 = TableField {_fieldPath = NE.fromList ["addressLine2"] , _fieldName = "address2"}
, addressCity = TableField {_fieldPath = NE.fromList ["addressCity"] , _fieldName = "city"}
, addressState = TableField {_fieldPath = NE.fromList ["addressState"] , _fieldName = "state"}
, addressZip = TableField {_fieldPath = NE.fromList ["addressZip"] , _fieldName = "zip"}
, addressForUser = UserId $ TableField {
_fieldPath = NE.fromList ["addressForUser", "userEmail"]
, _fieldName = "for_user__email"
}
}
}
}
test_tableLenses :: Assertion
test_tableLenses = do
assertEqual "get" expectedGet $
exampleAddress ^. #addressId
assertEqual "set" expectedSet $
exampleAddress & #addressForUser % coerced %~ Text.toUpper
where
expectedGet :: Int32
expectedGet = 1
expectedSet :: Address
expectedSet = exampleAddress & #addressForUser .~ UserId "A@B.C"
test_dbLenses :: Assertion
test_dbLenses = do
assertEqual "get" expectedGet $
exampleDb ^. #shoppingCart2Users
assertEqual "set" expectedSet $
exampleDb & #shoppingCart2UserAddresses %~ (\(Const n) -> Const (n + 1))
where
expectedGet :: Const Int a
expectedGet = Const 1
exampleDb, expectedSet :: ShoppingCart2Db (Const Int)
exampleDb = ShoppingCart2Db {
shoppingCart2Users = Const 1
, shoppingCart2UserAddresses = Const 2
}
expectedSet = exampleDb & #shoppingCart2UserAddresses .~ Const 3
test_SQL :: Assertion
test_SQL = runInMemory $ \conn -> do
liftIO $ SQLite.execute_ conn $
"CREATE TABLE cart2_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, address1 VARCHAR NOT NULL, address2 VARCHAR, city VARCHAR NOT NULL, state VARCHAR NOT NULL, zip VARCHAR NOT NULL, for_user__email VARCHAR NOT NULL );"
runInsert $ insert (shoppingCart2Db ^. #shoppingCart2Users) $
insertValues [ james, betty, sam ]
runInsert $ insert (shoppingCart2Db ^. #shoppingCart2UserAddresses) $
insertExpressions addresses
-- Straight-forward SELECT
-- (Checks that primary keys have been assigned correctly)
addressesActual <-
runSelectReturningList $
select (all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses))
liftIO $ assertEqual "addresses"
addressesExpected
addressesActual
-- Simple JOIN
usersAndRelatedAddressesActual <-
runSelectReturningList $ select $ do
user <- all_ (shoppingCart2Db ^. #shoppingCart2Users)
address <- all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses)
guard_ (address ^. #addressForUser % coerced ==. user ^. #userEmail)
return (user, address)
liftIO $ assertEqual "usersAndRelatedAddresses"
usersAndRelatedAddressesExpected
usersAndRelatedAddressesActual
-- Alternative way to write the same JOIN
usersAndRelatedAddressesUsingReferences <-
runSelectReturningList $ select $ do
user <- all_ (shoppingCart2Db ^. #shoppingCart2Users)
address <- all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses)
guard_ ((address ^. #addressForUser) `references_` user)
pure (user, address)
liftIO $ assertEqual "usersAndRelatedAddressesUsingReferences"
usersAndRelatedAddressesExpected
usersAndRelatedAddressesUsingReferences
-- Using ON
usersAndRelatedAddressesUsingRelated <-
runSelectReturningList $ select $ do
address <- all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses)
user <- related_ (shoppingCart2Db ^. #shoppingCart2Users) (address ^. #addressForUser)
pure (user, address)
liftIO $ assertEqual "usersAndRelatedAddressesUsingRelated"
usersAndRelatedAddressesExpected
usersAndRelatedAddressesUsingRelated
-- WHERE on a foreign key
bettysAddresses <-
runSelectReturningList $ select $ do
address <- all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses)
guard_ (address ^. #addressForUser ==. val_ bettyId)
pure address
liftIO $ assertEqual "bettysAddresses"
[addr2, addr3]
bettysAddresses
-- Simple UPDATE
runUpdate $ save (shoppingCart2Db ^. #shoppingCart2Users) $
james & #userPassword .~ superSecure
[james'] <- runSelectReturningList $
lookup_ (shoppingCart2Db ^. #shoppingCart2Users) jamesId
liftIO $ assertEqual "James' new password"
superSecure
(james' ^. #userPassword)
-- More granular UPDATE
runUpdate $ update (shoppingCart2Db ^. #shoppingCart2UserAddresses)
(\address -> mconcat [
address ^. #addressCity <-. val_ "Sugarville"
, address ^. #addressZip <-. val_ "12345"
]
)
(\address ->
address ^. #addressCity ==. val_ "Sugarland"
&&. address ^. #addressState ==. val_ "TX"
)
updatedAddresses <- runSelectReturningList $
select $ all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses)
liftIO $ assertEqual "updatedAddresses"
[addr1, addr2, addr3']
updatedAddresses
-- DELETE
runDelete $ delete (shoppingCart2Db ^. #shoppingCart2UserAddresses)
(\address ->
address ^. #addressCity ==. "Houston"
&&. (address ^. #addressForUser) `references_` val_ betty
)
afterDelete <- runSelectReturningList $
select $ all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses)
liftIO $ assertEqual "afterDelete"
[addr1, addr3']
afterDelete
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"
jamesId, bettyId :: UserId
jamesId = UserId "james@example.com"
bettyId = UserId "betty@example.com"
-- The tutorial uses @pk@ directly, rather than @val . pk@.
-- This is possible if we make @james@ and co polymorphic
--
-- > james :: UserT (QExpr Sqlite s)
--
-- We can do that (because of a 'IsString' instance for 'QExpr', but then we
-- get into trouble in @addr1@ and co.
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))
]
addr1, addr2, addr3, addr3' :: Address
addr1 = Address 1 "123 Little Street" Nothing "Boston" "MA" "12345" (pk james)
addr2 = Address 2 "222 Main Street" (Just "Ste 1") "Houston" "TX" "8888" (pk betty)
addr3 = Address 3 "9999 Residence Ave" Nothing "Sugarland" "TX" "8989" (pk betty)
addr3' = Address 3 "9999 Residence Ave" Nothing "Sugarville" "TX" "12345" (pk betty)
addressesExpected :: [Address]
addressesExpected = [
addr1
, addr2
, addr3
]
usersAndRelatedAddressesExpected :: [(User, Address)]
usersAndRelatedAddressesExpected = [
(james, addr1)
, (betty, addr2)
, (betty, addr3)
]
superSecure :: Text
superSecure = "52a516ca6df436828d9c0d26e31ef704"