beam-postgres.org

Beam with postgres - tutorial 1

trying to follow beam’s tutorial 1, but for postgres instead of sqlite3.

stack setup

Add this snippet to the packages section of stack.yaml

- location:
    git: https://github.com/tathougies/beam.git
    commit: 3b9015c06cb5b4179f42ec3c203d45d8f328d8c5
  extra-dep: true
  subdirs:
    - beam-core
    - beam-migrate
    - beam-postgres

This just fetches the repository at that commit and builds it

cabal setup

Add these dependencies to the cabal file

beam-core,
beam-postgres,
postgresql-simple,
text

language pragmas

{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}

imports

import           Data.Text                  (Text)
import           Database.Beam              as B
import           Database.Beam.Postgres
import           Database.PostgreSQL.Simple

We need the beam-postgres backend, along with what comes with beam-core. One thing to note is that the postgres backend supplies it’s own insert and runInsert, so we qualify beam-core to use those two functions without ambiguity.

getting the connection to the database

Get the connection to your database via PostgreSQL.Simple.connectPostgreSQL

let conn = connectPostgreSQL "dbName=shoppingcart1"

We will use this connection to pass to our functions doing database stuff we will define later.

We need the pragma

{-# LANGUAGE OverloadedStrings #-}

for this to work

defining a table

data UserT f = User
  { _userEmail     :: Columnar f Text
  , _userFirstName :: Columnar f Text
  , _userLastName  :: Columnar f Text
  , _userPassword  :: Columnar f Text
  } deriving (Generic)

Using some defaults of beam, this will make calls to columns with names

email
first_name
last_name
password

You can change these, if you like, see the models section

The pragma {-# LANGUAGE DeriveGeneric #-} is necessary for compilation.

Just like in the sqlite tutorial, Columnar Identity a is equivalent to a. Given that,

type User = UserT Identity

means that the User type looks just like a record type.

data User = User
  { _userEmail     :: Text
  , _userFirstName :: Text
  , _userLastName  :: Text
  , _userPassword  :: Text
  } deriving (Generic)

That is why UserT has the data constructor User.

PrimaryKey type

type UserId = PrimaryKey UserT Identity

user id, that in the actual database is email.

Letting beam know about our table

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies      #-}

instance Beamable UserT
instance Beamable (PrimaryKey UserT)

instance Table UserT where
  data PrimaryKey UserT f = UserId (Columnar f Text) deriving Generic
  primaryKey = UserId . _userEmail

The last two instance definitions need each other and won’t compile on their own.

letting beam know about our database

data ShoppingCartDb f = ShoppingCartDb
  { _shoppingCartUsers :: f (TableEntity UserT)
  } deriving (Generic)

instance Database ShoppingCartDb

shoppingCartDb :: DatabaseSettings be ShoppingCartDb
shoppingCartDb = defaultDbSettings

Again, per conventions, this will look at the database with a table called cart_users. Again, this can be changed as well. The database isn’t named to any convention, connect to it as above – this just defines the tables in the database we connect to. UserT defines the columns in the table.

shoppingCartDb is a handle we will use to get at our tables. You can do that with lenses if you set that up, or through regular record syntax.

database operations

all users at the top level

It would be nice to do this at the top level, since a bunch of these functions are using all users. Additionally everytime we query on users, we query on them all first.

allUsers = all_ (_shoppingCartUsers shoppingCartDb)

But I am getting this error and idk why

Couldn't match type ‘Database.Beam.Backend.SQL.SQL92.Sql92FromExpressionSyntax
                              (Database.Beam.Backend.SQL.SQL92.Sql92SelectTableFromSyntax
                                 (Database.Beam.Backend.SQL.SQL92.Sql92SelectSelectTableSyntax
                                    select0))’
                      with ‘Database.Beam.Backend.SQL.SQL92.Sql92SelectTableExpressionSyntax
                              (Database.Beam.Backend.SQL.SQL92.Sql92SelectSelectTableSyntax
                                 select0)’
         arising from a use of ‘all_’
       The type variable ‘select0’ is ambiguous
     • In the expression: all_ (_shoppingCartUsers shoppingCartDb)
       In an equation for ‘allUsers’:
           allUsers = all_ (_shoppingCartUsers shoppingCartDb)
     • Relevant bindings include
         allUsers :: Q select0
                       ShoppingCartDb
                       s
                       (UserT
                          (QExpr
                             (Database.Beam.Backend.SQL.SQL92.Sql92SelectTableExpressionSyntax
                                (Database.Beam.Backend.SQL.SQL92.Sql92SelectSelectTableSyntax
                                   select0))
                             s))

If I use some type holes and fill in the blank, I can concretize a type and it typechecks!

allUsers :: Q PgSelectSyntax ShoppingCartDb s (UserT (QExpr PgExpressionSyntax s))
allUsers = all_ (_shoppingCartUsers shoppingCartDb)

You need to import Database.Beam.Postgres for the type signature to work.

inserting into the database

insertvals :: Connection -> IO ()
insertvals conn =
  withDatabaseDebug putStrLn conn $ B.runInsert $
    B.insert (_shoppingCartUsers shoppingCartDb) $
    insertValues [ User "james@example.com" "James" "Smith" "b4cc344d25a2efe540adbf2678e2304c" {- james -}
                 , User "betty@example.com" "Betty" "Jones" "82b054bd83ffad9b6cf8bdb98ce3cc2f" {- betty -}
                 , User "james@pallo.com" "James" "Pallo" "b4cc344d25a2efe540adbf2678e2304c" {- james -}
                 , User "betty@sims.com" "Betty" "Sims" "82b054bd83ffad9b6cf8bdb98ce3cc2f" {- betty -}
                 , User "james@oreily.com" "James" "O'Reily" "b4cc344d25a2efe540adbf2678e2304c" {- james -}
                 , User "sam@sophitz.com" "Sam" "Sophitz" "332532dcfaa1cbf61e2a266bd723612c" {- sam -}
                 , User "sam@jely.com" "Sam" "Jely" "332532dcfaa1cbf61e2a266bd723612c" {- sam -}
                 , User "sam@example.com" "Sam" "Taylor" "332532dcfaa1cbf61e2a266bd723612c" {- sam -}
                 ]

Need to use B.insert and B.runInsert because the postgres backend has it’s own version of this function and this avoids the ambiguity the compiler complains about.

The sqlite backend doesn’t have these functions defined, so the tutorial for that doesn’t need to worry about it.

selecting users

selectusers :: Connection -> IO ()
selectusers conn =
  withDatabaseDebug putStrLn conn $ do
    users <- runSelectReturningList $ select allUsers
    mapM_ (liftIO . putStrLn . show) users

We will need an instance of show for User, and for that we need the pragma {-# LANGUAGE StandaloneDeriving #-}.

deriving instance Show User

sorting with order by

sortByFirstName :: Connection -> IO ()
sortByFirstName conn =
  withDatabaseDebug putStrLn conn $ do
    users <- runSelectReturningList $ select sortUsersByFirstName
    mapM_ (liftIO . putStrLn . show) users
  where
    sortUsersByFirstName = orderBy_ (\u -> (asc_ (_userFirstName u), desc_ (_userLastName u))) allUsers

bounding results with limit_ and offset_

boundedquery :: Connection -> IO ()
boundedquery conn =
  withDatabaseDebug putStrLn conn $ do
    users <- runSelectReturningList $ select boundedQuery
    mapM_ (liftIO . putStrLn . show) users
  where
    boundedQuery = limit_ 1 $ offset_ 1 $ orderBy_ (asc_ . _userFirstName) $ allUsers

counting with aggregate_

usercount :: Connection -> IO ()
usercount conn =
  withDatabaseDebug putStrLn conn $ do
    Just c <- runSelectReturningOne $ select userCount
    liftIO $ putStrLn ("We have " ++ show c ++ " users in the database")
  where
    userCount = aggregate_ (\u -> as_ @Int countAll_) allUsers

numusersbyname :: Connection -> IO ()
numusersbyname conn =
  withDatabaseDebug putStrLn conn $ do
    countedByName <- runSelectReturningList $ select numberOfUsersByName
    mapM_ (liftIO . putStrLn . show) countedByName
  where
    numberOfUsersByName = aggregate_ (\u -> (group_ (_userFirstName u), as_ @Int countAll_)) allUsers

You will need the pragma {-# LANGUAGE TypeApplications #-} for the

as_ @Int count

expressions.

Beam with postgres - tutorial 2

Adding a related address table

This is basically the same as UserT, but it contains a reference to a UserT table, and has an auto incremented id addressId.

data AddressT f = Address
  { _addressId :: C f (Auto Int)
  , _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 (Generic)

type Address = AddressT Identity
type AddressId = PrimaryKey AddressT Identity

deriving instance Show UserId
deriving instance Show Address

instance Beamable AddressT
instance Beamable (PrimaryKey AddressT)

instance Table AddressT where
    data PrimaryKey AddressT f = AddressId (Columnar f (Auto Int)) deriving Generic
    primaryKey = AddressId . _addressId

Need the show instances for UserId and Adress when printing things out. Other than that, it is just like UserT.

redefining the database type for this new table

data ShoppingCartDb f = ShoppingCartDb
  { _shoppingCartUsers :: f (TableEntity UserT)
  , _shoppingCartUserAddresses :: f (TableEntity AddressT)
  } deriving (Generic)

This will have beam operate on a table addresses. Again, this can be modified if necessary.

tables with lenses

Address (LensFor addressId)    (LensFor addressLine1)
        (LensFor addressLine2) (LensFor addressCity)
        (LensFor addressState) (LensFor addressZip)
        (UserId (LensFor addressForUserId)) =
        tableLenses

User (LensFor userEmail)    (LensFor userFirstName)
     (LensFor userLastName) (LensFor userPassword) =
     tableLenses

databases with lenses

ShoppingCartDb (TableLens shoppingCartUsers)
               (TableLens shoppingCartUserAddresses) =
               dbLenses

all addresses

Much like allUsers, except here we are using the lenses we defined.

import Control.Lens

allAddresses :: Q PgSelectSyntax ShoppingCartDb s (AddressT (QExpr PgExpressionSyntax s))
allAddresses = all_ (shoppingCartDb ^. shoppingCartUserAddresses)

inserting users

We need to define the users globally, because we need the foreign key reference when creating Address instances.

james :: User
james = User "james@example.com" "James" "Smith" "b4cc344d25a2efe540adbf2678e2304c"

betty :: User
betty = User "betty@example.com" "Betty" "Jones" "82b054bd83ffad9b6cf8bdb98ce3cc2f"

sam :: User
sam = User "sam@example.com" "Sam" "Taylor" "332532dcfaa1cbf61e2a266bd723612c"

insertUsers :: Connection -> IO ()
insertUsers conn =
  withDatabaseDebug putStrLn conn $ B.runInsert $
    B.insert (_shoppingCartUsers shoppingCartDb) $
    insertValues [james, betty, sam]

inserting addresses

The only thing that is different from inserting users is the (pk betty) etc. for the foreign key reference.

insertAddresses :: Connection -> IO ()
insertAddresses conn =
  withDatabaseDebug putStrLn conn $ B.runInsert $
    B.insert (_shoppingCartUserAddresses shoppingCartDb) $
    insertValues [ Address (Auto Nothing) "123 Little Street" Nothing "Boston" "MA" "12345" (pk james)
                 , Address (Auto Nothing) "222 Main Street" (Just "Ste 1") "Houston" "TX" "8888" (pk betty)
                 , Address (Auto Nothing) "9999 Residence Ave" Nothing "Sugarland" "TX" "8989" (pk betty)
                 ]

selecting all users and addresses as pairs

getting all pairs, like the list monad

selectAllUsersAndAddressPairs :: Connection -> IO ([(User, Address)])
selectAllUsersAndAddressPairs conn =
  withDatabaseDebug putStrLn conn $ runSelectReturningList $ select $ do
    address <- allAddresses
    user <- allUsers
    return (user, address)

The sql produced for postgres is:

SELECT
  "t1"."email" AS "res0",
  "t1"."first_name" AS "res1",
  "t1"."last_name" AS "res2",
  "t1"."password" AS "res3",
  "t0"."id" AS "res4",
  "t0"."address1" AS "res5",
  "t0"."address2" AS "res6",
  "t0"."city" AS "res7",
  "t0"."state" AS "res8",
  "t0"."zip" AS "res9",
  "t0"."for_user__email" AS "res10"
FROM "cart_user_addresses" AS "t0"
CROSS JOIN "cart_users" AS "t1"

using beam to generate where clause doesn’t work with postgres

using guard to form a where clause

We can use a guard to make sure we only get the combinations of users and addresses that are related by their foreign key.

relatedUserAndAddressesWithGuard :: Connection -> IO [(User, Address)]
relatedUserAndAddressesWithGuard conn =
  withDatabaseDebug putStrLn conn $ runSelectReturningList $ select $ do
    user <- allUsers
    address <- allAddresses
    guard_ (address ^. addressForUserId ==. user ^. userEmail)
    return (user, address)

The sql generated for postgres is:

SELECT
  "t0"."email" AS "res0",
  "t0"."first_name" AS "res1",
  "t0"."last_name" AS "res2",
  "t0"."password" AS "res3",
  "t1"."id" AS "res4",
  "t1"."address1" AS "res5",
  "t1"."address2" AS "res6",
  "t1"."city" AS "res7",
  "t1"."state" AS "res8",
  "t1"."zip" AS "res9",
  "t1"."for_user__email" AS "res10"
FROM "cart_users" AS "t0"
CROSS JOIN "cart_user_addresses" AS "t1"
WHERE ("t1"."for_user__email") = ("t0"."email")

getting the inner join through references, beam automatically generate clause matching primary keys

selectUsersAndAddessesWithReferences :: Connection -> IO [(User, Address)]
selectUsersAndAddessesWithReferences conn =
  withDatabaseDebug putStrLn conn $ runSelectReturningList $ select $ do
    user <- allUsers
    address <- allAddresses
    guard_ (_addressForUser address `references_` user)
    return (user, address)

Again, this generates sql for postgres:

SELECT
  "t0"."email" AS "res0",
  "t0"."first_name" AS "res1",
  "t0"."last_name" AS "res2",
  "t0"."password" AS "res3",
  "t1"."id" AS "res4",
  "t1"."address1" AS "res5",
  "t1"."address2" AS "res6",
  "t1"."city" AS "res7",
  "t1"."state" AS "res8",
  "t1"."zip" AS "res9",
  "t1"."for_user__email" AS "res10"
FROM "cart_users" AS "t0"
CROSS JOIN "cart_user_addresses" AS "t1"
WHERE ("t1"."for_user__email") = ("t0"."email")

using on clause with related_ :try with template haskell:

selectAllUsersAndAddresses :: Connection -> IO ([(User, Address)])
selectAllUsersAndAddresses conn =
  withDatabaseDebug putStrLn conn $ runSelectReturningList $ select $ do
    address <- allAddresses
    user <- related_ (shoppingCartDb ^. shoppingCartUsers) (_addressForUser address)
    return (user, address)

The mixing of lens and record syntax might be confusing, but is there for a reason.

The relationship combinators want the entire PrimaryKey so we must use the record accessor _addressForUser to get us that. addressForUserId is a lens from a User to the id of the address in the _addressForUser field. The lens unwraps the data constructor, leaving us with UserId instead of a PrimaryKey

There is currently no way to use the generics mechanisms to automatically get these lenses. If you really would like a uniform syntax with lenses, just use template haskell and makeLenses from Control.Lens – this seems to work out just fine.

The sql for postgres is:

SELECT "t1"."email" AS "res0",
  "t1"."first_name" AS "res1",
  "t1"."last_name" AS "res2",
  "t1"."password" AS "res3",
  "t0"."id" AS "res4",
  "t0"."address1" AS "res5",
  "t0"."address2" AS "res6",
  "t0"."city" AS "res7",
  "t0"."state" AS "res8",
  "t0"."zip" AS "res9",
  "t0"."for_user__email" AS "res10"
FROM "cart_user_addresses" AS "t0"
INNER JOIN "cart_users" AS "t1"
ON ("t0"."for_user__email") = ("t1"."email")

selecting a specific user with id – two ways

We can select all addresses that belong to Betty with a guard_ clause, producing a where clause in the sql.

a little on val_

val_ takes a haskell literal (be it a scalar value, an entire table with scalar values, or a tuple of any of the above) and converts it into a sql expression with the given haskell type. That is to say you can think of it like

val_ :: a -> QExpr syntax s a

Except, if you give it a table of values (say -UserT Identity-):

val_ :: UserT Identity -> UserT (QExpr syntax s a)

from a Text value

bettyEmail :: Text
bettyEmail = "betty@example.com"

selectAddressForBettyEmail :: Connection -> IO [Address]
selectAddressForBettyEmail conn =
  withDatabaseDebug putStrLn conn $
    runSelectReturningList $ select $ do
      address <- all_ (shoppingCartDb ^. shoppingCartUserAddresses)
      guard_ (address ^. addressForUserId ==. val_ bettyEmail)
      return address

here, val_ has the type

HaskellLiteralForQExpr
  (QGenExpr QValueContext PgExpressionSyntax Database.Beam.Query.QueryInaccessible Text)
-> QGenExpr QValueContext PgExpressionSyntax Database.Beam.Query.QueryInaccessible Text

So we have to use the lens that unwraps the UserId, addressForUserId that yields a value of type

QGenExpr QValueContext PgExpressionSyntax Database.Beam.Query.QueryInaccessible Text

And this allows us to compare the two with ==.

from a UserId value

bettyId :: UserId
bettyId = UserId "betty@example.com"

selectAddressForBettyId :: Connection -> IO [Address]
selectAddressForBettyId conn =
  withDatabaseDebug putStrLn conn $
    runSelectReturningList $ select $ do
      address <- all_ (shoppingCartDb ^. shoppingCartUserAddresses)
      guard_ (_addressForUser address ==. val_ bettyId)
      return address

Here, val_ has the type

HaskellLiteralForQExpr
  (PrimaryKey UserT (QExpr PgExpressionSyntax Database.Beam.Query.QueryInaccessible))
-> PrimaryKey UserT (QExpr PgExpressionSyntax Database.Beam.Query.QueryInaccessible)

Here, we can’t use the lens that unwraps UserId because we aren’t comparing a Text value, we are comparing the whole PrimaryKey UserT f value.

We must use the record accessor _addressForUser on the AddressT f record for the boolean comparison.

updating rows in the database

with save

updatingUserWithSave :: Connection -> IO ()
updatingUserWithSave conn = do
  [james] <- withDatabaseDebug putStrLn conn $
             do
               runUpdate $
                 save (shoppingCartDb ^. shoppingCartUsers) (james {_userPassword = "52a516ca6df436828d9c0d26e31ef704" })

               runSelectReturningList $
                 B.lookup (shoppingCartDb ^. shoppingCartUsers) (UserId "james@example.com")

  putStrLn ("James's new password is " ++ show (james ^. userPassword))

This has the disadvantage of needing a full user to update, and it updates every column for that user, even if something didn’t change.

with update

Using an update statement, lets you update less certain fields only, multiple rows, or lets you use other criteria than a primary key match.

updatingAddressesWithFinerGrainedControl :: Connection -> IO ()
updatingAddressesWithFinerGrainedControl conn = do
  addresses <- withDatabaseDebug putStrLn conn $
               do
                 runUpdate $
                    update (shoppingCartDb ^. shoppingCartUserAddresses)
                           (\address -> [ address ^. addressCity <-. val_ "Sugarville"
                                        , address ^. addressZip <-. "12345"])
                           (\address -> address ^. addressCity ==. val_ "Sugarland" &&.
                                        address ^. addressState ==. val_ "TX")
                 runSelectReturningList $ select $ all_ (shoppingCartDb ^. shoppingCartUserAddresses)

  mapM_ print addresses

deletions with delete :fix docs typo:

The tutorial has this,

deleteBettysHoustonAddress :: Connection -> IO ()
deleteBettysHoustonAddress conn =
  withDatabaseDebug putStrLn conn $
  runDelete $ delete (shoppingCartDb ^. shoppingCartUserAddresses)
                     (\address -> address ^. addressCity ==. "Houston" &&.
                                  _addressForUser address `references_` betty)

unfortunately this yields a compiler error

• Couldn't match type ‘Identity’
                with ‘QGenExpr QValueContext PgExpressionSyntax s’
  Expected type: UserT (QGenExpr QValueContext PgExpressionSyntax s)
    Actual type: UserT Identity
• In the second argument of ‘references_’, namely ‘betty’

I figured out that val_ eliminates the compiler error and works like the tutorial says it should.

I am guessing that this is a documentation error I can ask about and then PR to fix. Maybe some documentation on val_ wouldn’t be a bad thing either. This really came about from just playing with different ways to get rid of the compiler error and was not the first thing I thought of, as it didn’t seem immediately obvious to me.

Beam with postgres - tutorial 3

add support for products table

data ProductT f = Product
  { _productId          :: C f (Auto Int)
  , _productTitle       :: C f Text
  , _productDescription :: C f Text
  , _productPrice       :: C f Int {- Price in cents -}
  } deriving (Generic)

type Product = ProductT Identity
deriving instance Show Product

instance Table ProductT where
  data PrimaryKey ProductT f = ProductId (Columnar f (Auto Int)) deriving Generic
  primaryKey = ProductId . _productId

instance Beamable ProductT
instance Beamable (PrimaryKey ProductT)

add support for orders and shipping table

order table

The order table needs the time library, and the import Data.Time.

It has a foreign key to the user who ordered it, to the address of the user, and to the shipping information where it should go to.

The shipping information foreign key is optional, hence the Nullable declaration. This is present in the tutorial to show some of the features of beam off, but unless this is legacy and the schema is already like this, it is better to have a primary key on the shipping info and not make it nullable, but we will do it like the tutorial does it.

deriving instance Show (PrimaryKey AddressT Identity)

data OrderT f = Order
  { _orderId            :: Columnar f (Auto Int)
  , _orderDate          :: Columnar f LocalTime
  , _orderForUser       :: PrimaryKey UserT f
  , _orderShipToAddress :: PrimaryKey AddressT f
  , _orderShippingInfo  :: PrimaryKey ShippingInfoT (Nullable f)
  } deriving (Generic)

type Order = OrderT Identity
deriving instance Show Order

instance Table OrderT where
    data PrimaryKey OrderT f = OrderId (Columnar f (Auto Int))
                               deriving Generic
    primaryKey = OrderId . _orderId

instance Beamable OrderT
instance Beamable (PrimaryKey OrderT)

shipping table

Again, unless legacy or something, probably should make this a non nullable primary key for shipping info.

The only other thing to note is that we will need to tell postgres how to store the enumeration ShippingCarrier.

data ShippingCarrier
  = USPS
  | FedEx
  | UPS
  | DHL
  deriving (Show, Read, Eq, Ord, Enum)

data ShippingInfoT f = ShippingInfo
  { _shippingInfoId             :: Columnar f (Auto Int)
  , _shippingInfoCarrier        :: Columnar f ShippingCarrier
  , _shippingInfoTrackingNumber :: Columnar f Text
  } deriving (Generic)

type ShippingInfo = ShippingInfoT Identity
deriving instance Show ShippingInfo

instance Table ShippingInfoT where
    data PrimaryKey ShippingInfoT f = ShippingInfoId (Columnar f (Auto Int))
                                      deriving Generic
    primaryKey = ShippingInfoId . _shippingInfoId

instance Beamable ShippingInfoT
instance Beamable (PrimaryKey ShippingInfoT)
deriving instance Show (PrimaryKey ShippingInfoT (Nullable Identity))

add support for a list of products with each order (line item)

Note the applicative bind for the line items id – it takes two parameters for a key, the orders primary key, and the products primary key.

You know how applicatives work, if not go read it again because it is a whole other thing to explain :)

deriving instance Show (PrimaryKey OrderT Identity)
deriving instance Show (PrimaryKey ProductT Identity)

data LineItemT f = LineItem
  { _lineItemInOrder :: PrimaryKey OrderT f
  , _lineItemForProduct :: PrimaryKey ProductT f
  , _lineItemQuantity :: Columnar f Int
  } deriving (Generic)

type LineItem = LineItemT Identity
deriving instance Show LineItem

instance Table LineItemT where
    data PrimaryKey LineItemT f = LineItemId (PrimaryKey OrderT f) (PrimaryKey ProductT f)
                                  deriving Generic
    primaryKey = LineItemId <$> _lineItemInOrder <*> _lineItemForProduct

instance Beamable LineItemT
instance Beamable (PrimaryKey LineItemT)

adding these databases to beam

data ShoppingCartDb f = ShoppingCartDb
  { _shoppingCartUsers         :: f (TableEntity UserT)
  , _shoppingCartUserAddresses :: f (TableEntity AddressT)
  , _shoppingCartProducts      :: f (TableEntity ProductT)
  , _shoppingCartOrders        :: f (TableEntity OrderT)
  , _shoppingCartShippingInfos :: f (TableEntity ShippingInfoT)
  , _shoppingCartLineItems     :: f (TableEntity LineItemT)
  } deriving (Generic)

lenses

LineItem _ _ (LensFor lineItemQuantity) = tableLenses

Product (LensFor productId)          (LensFor productTitle)
        (LensFor productDescription) (LensFor productPrice) = tableLenses

ShoppingCartDb (TableLens shoppingCartUsers) (TableLens shoppingCartUserAddresses)
               (TableLens shoppingCartProducts) (TableLens shoppingCartOrders)
               (TableLens shoppingCartShippingInfos) (TableLens shoppingCartLineItems) = dbLenses

You can notice the tutorial skips convenience lenses for order and shipping info for some reason.

It also skips lenses for line items foreign keys to order and product

changing default db settings

shoppingCartDb :: DatabaseSettings be ShoppingCartDb
shoppingCartDb =
  defaultDbSettings `withDbModification`
  dbModification
  { _shoppingCartUserAddresses =
      modifyTable (\_ -> "addresses") $
      tableModification
      { _addressLine1 = fieldNamed "address1"
      , _addressLine2 = fieldNamed "address2"
      }
  , _shoppingCartProducts = modifyTable (\_ -> "products") tableModification
  , _shoppingCartOrders =
      modifyTable (\_ -> "orders") $
      tableModification
      {_orderShippingInfo = ShippingInfoId "shipping_info__id"}
  , _shoppingCartShippingInfos =
      modifyTable (\_ -> "shipping_info") $
      tableModification
      { _shippingInfoId = "id"
      , _shippingInfoCarrier = "carrier"
      , _shippingInfoTrackingNumber = "tracking_number"
      }
  , _shoppingCartLineItems = modifyTable (\_ -> "line_items") tableModification
  }

this lets us be more haskelly with the records, at least with their names and lenses if we want them, but keeping the sql reasonable and conventional as well.

This is like the marriage of both of these naming conventions.

The data type address is really addresses in the database

the field _addressLine1 would be defaulted in beam to column with the name line1, but we want our sql column to be named address1 instead.

the same thing is happening to products, orders, shipping info and line items.

inserting into database (fixtures)

users

Using a cool syntax to destructure and bind at the same time.

users :: [User]
users@[james, betty, sam] = [ User "james@example.com" "James" "Smith" "b4cc344d25a2efe540adbf2678e2304c"
                            , User "betty@example.com" "Betty" "Jones" "82b054bd83ffad9b6cf8bdb98ce3cc2f"
                            , User "sam@example.com" "Sam" "Taylor" "332532dcfaa1cbf61e2a266bd723612c"]

insertUsers :: Connection -> IO ()
insertUsers conn =
  withDatabaseDebug putStrLn conn $ B.runInsert $
    B.insert (_shoppingCartUsers shoppingCartDb) $
    insertValues users

addresses

addresses :: [Address]
addresses = [ Address (Auto Nothing) "123 Little Street" Nothing "Boston" "MA" "12345" (pk james)
            , Address (Auto Nothing) "222 Main Street" (Just "Ste 1") "Houston" "TX" "8888" (pk betty)
            , Address (Auto Nothing) "9999 Residence Ave" Nothing "Sugarland" "TX" "8989" (pk betty)
            ]

insertReturning in postgres

For sqlite the insertReturningList syntax is:

insertAddresses :: Connection -> IO [Address]
insertAddresses conn =
  withDatabaseDebug putStrLn conn $
    runInsertReturningList $ insertReturning (shoppingCartDb ^. shoppingCartUserAddresses) $
    insertValues addresses

But for postgres, the syntax is a little different:

insertAddresses :: Connection -> IO [Address]
insertAddresses conn =
  withDatabaseDebug putStrLn conn $
    runInsertReturningList (shoppingCartDb ^. shoppingCartUserAddresses) $
    insertValues addresses

The confusion comes because beam-postgres has its own INSERT … RETURNING … syntax exposed by the insertReturning function. This is specific to postgres.

products

products :: [Product]
products = [ Product (Auto Nothing) "Red Ball" "A bright red, very spherical ball" 1000
           , Product (Auto Nothing) "Math Textbook" "Contains a lot of important math theorems and formulae" 2500
           , Product (Auto Nothing) "Intro to Haskell" "Learn the best programming language in the world" 3000
           , Product (Auto Nothing) "Suitcase" "A hard durable suitcase" 15000
           ]

insertProducts :: Connection -> IO [Product]
insertProducts conn =
  withDatabaseDebug putStrLn conn $
    runInsertReturningList (shoppingCartDb ^. shoppingCartProducts) $
    insertValues products

shipping information

Inserting shipping information makes us marshall the ShippingCarrier enumeration.

We will try to insert one shipping info row into the database.

shippingInfos :: [ShippingInfo]
shippingInfos = [ ShippingInfo (Auto Nothing) USPS "12345790ABCDEFGHI" ]

insertShippingInfos :: Connection -> IO [ShippingInfo]
insertShippingInfos conn =
 withDatabaseDebug putStrLn conn $
  runInsertReturningList (shoppingCartDb ^. shoppingCartShippingInfos) $
  insertValues shippingInfos

But boom! We get an error

error:
• No instance for (FromBackendRow Postgres ShippingCarrier)
    arising from a use of ‘runInsertReturningList’
• In the expression:
    runInsertReturningList
      (shoppingCartDb ^. shoppingCartShippingInfos)
      In the second argument of ‘($)’, namely
        ‘runInsertReturningList
          (shoppingCartDb ^. shoppingCartShippingInfos)
        $ insertValues shippingInfos’
      In the expression:
        withDatabaseDebug putStrLn conn
        $ runInsertReturningList
            (shoppingCartDb ^. shoppingCartShippingInfos)
          $ insertValues shippingInfos (intero)
error:
• No instance for (HasSqlValueSyntax PgValueSyntax ShippingCarrier)
    arising from a use of ‘insertValues’
• In the second argument of ‘($)’, namely
    ‘insertValues shippingInfos’
    In the second argument of ‘($)’, namely
      ‘runInsertReturningList
        (shoppingCartDb ^. shoppingCartShippingInfos)
      $ insertValues shippingInfos’
    In the expression:
      withDatabaseDebug putStrLn conn
      $ runInsertReturningList
          (shoppingCartDb ^. shoppingCartShippingInfos)
        $ insertValues shippingInfos (intero)

HasSqlValueSyntax error

{-# LANGUAGE UndecidableInstances #-}
import Database.Beam.Backend.SQL

instance HasSqlValueSyntax be String => HasSqlValueSyntax be ShippingCarrier where
  sqlValueSyntax = autoSqlValueSyntax

error:
  • No instance for (FromBackendRow Postgres ShippingCarrier)
      arising from a use of ‘runInsertReturningList’
  • In the expression:
      runInsertReturningList
        (shoppingCartDb ^. shoppingCartShippingInfos)
    In the second argument of ‘($)’, namely
      ‘runInsertReturningList
        (shoppingCartDb ^. shoppingCartShippingInfos)
      $ insertValues shippingInfos’
    In the expression:
      withDatabaseDebug putStrLn conn
      $ runInsertReturningList
          (shoppingCartDb ^. shoppingCartShippingInfos)
        $ insertValues shippingInfos (intero)

Same thing as the tutorial so far.

FromBackendRow error

{-# LANGUAGE MultiParamTypeClasses #-}
import           Database.Beam.Backend
instance FromBackendRow Postgres ShippingCarrier

This doesn’t work because there is no backend instance for unmarshalling the datatype. This can be seen in the compile error

error:
  • No instance for (FromField ShippingCarrier)
      arising from a use of ‘Database.Beam.Backend.Types.$dmfromBackendRow’
  • In the expression:
      Database.Beam.Backend.Types.$dmfromBackendRow
        @Postgres @ShippingCarrier
    In an equation for ‘fromBackendRow’:
        fromBackendRow
          = Database.Beam.Backend.Types.$dmfromBackendRow
              @Postgres @ShippingCarrier
    In the instance declaration for
      ‘FromBackendRow Postgres ShippingCarrier’ (intero)

FromField error

Let’s see if we can write Database.PostgreSQL.Simple.FromField.FromField instance for ShippingCarrier and then let’s try re-instantiating FromBackendRow.

import           Database.PostgreSQL.Simple.FromField
import           Text.Read

instance FromField ShippingCarrier where
  fromField f = do x <- readMaybe <$> fromField f
                   case x of
                     Nothing -> returnError ConversionFailed f "Could not 'read' value for 'ShippingCarrier'"
                     Just x -> pure x

instance FromBackendRow Postgres ShippingCarrier

Note: The tutorial has

instance FromBackendRow be ShippingCarrier

But I found that I needed to make it

instance FromBackendRow Postgres ShippingCarrier

The tutorial also has a FromField for sqlite

instance FromField ShippingCarrier where
  fromField f = do x <- readMaybe <$> fromField f
                  case x of
                    Nothing -> returnError ConversionFailed f "Could not 'read' value for 'ShippingCarrier'"
                    Just x -> pure x

But that doesn’t work for postgres, it needs an extra bytestring parameter

instance FromField ShippingCarrier where
  fromField f bs = do x <- readMaybe <$> fromField f bs
                      case x of
                        Nothing -> returnError ConversionFailed f "Could not 'read' value for 'ShippingCarrier'"
                        Just x -> pure x

NOW we can insert users

orders

insertOrders :: Connection -> [Address] -> ShippingInfo -> IO [Order]
insertOrders conn [jamesAddress1, bettyAddress1, bettyAddress2] bettyShippingInfo =
  do
    time <- getCurrentTime
    let localtime = utcToLocalTime utc time
    withDatabaseDebug putStrLn conn $
      runInsertReturningList (shoppingCartDb ^. shoppingCartOrders) $
      insertValues [ Order (Auto Nothing) localtime (pk james) (pk jamesAddress1) nothing_
                   , Order (Auto Nothing) localtime (pk betty) (pk bettyAddress1) (just_ (pk bettyShippingInfo))
                   , Order (Auto Nothing) localtime (pk james) (pk jamesAddress1) nothing_
                   ]

We need to send these lists in to this method through the main function

main :: IO ()
main = do
  conn <- connectPostgreSQL "host=localhost dbname=shoppingcart3"
  insertUsers conn
  addresses@[jamesAddress1, bettyAddress1, bettyAddress2] <- insertAddresses conn
  products@[redBall, mathTextbook, introToHaskell, suitcase] <- insertProducts conn
  [bettyShippingInfo] <- insertShippingInfos conn
  orders@[jamesOrder1, bettyOrder1, jamesOrder2] <- insertOrders conn addresses bettyShippingInfo

line items

insertLineItems :: Connection -> [Order] -> [Product] -> IO ()
insertLineItems conn orders@[jamesOrder1, bettyOrder1, jamesOrder2] products@[redBall, mathTextbook, introToHaskell, suitcase] =
  withDatabaseDebug putStrLn conn $
  B.runInsert $ B.insert (shoppingCartDb ^. shoppingCartLineItems) $
  insertValues [ 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 ]

Again need to pass these lists in from main

main :: IO ()
main = do
  conn <- connectPostgreSQL "host=localhost dbname=shoppingcart3"
  insertUsers conn
  addresses@[jamesAddress1, bettyAddress1, bettyAddress2] <- insertAddresses conn
  products@[redBall, mathTextbook, introToHaskell, suitcase] <- insertProducts conn
  [bettyShippingInfo] <- insertShippingInfos conn
  orders@[jamesOrder1, bettyOrder1, jamesOrder2] <- insertOrders conn addresses bettyShippingInfo
  insertLineItems conn orders products

left joining

straight left join users and orders, even with no orders

selectAllUsersAndOrdersLeftJoin :: Connection -> IO [(User, Maybe Order)]
selectAllUsersAndOrdersLeftJoin conn =
  withDatabaseDebug putStrLn conn $
      runSelectReturningList $ select $ do
        user  <- all_ (shoppingCartDb ^. shoppingCartUsers)
        order <- leftJoin_ (all_ (shoppingCartDb ^. shoppingCartOrders)) (\order -> _orderForUser order `references_` user)
        pure (user, order)

using left join to select only users with no orders

selectUsersWithNoOrdersLeftJoin :: Connection -> IO [User]
selectUsersWithNoOrdersLeftJoin conn =
   withDatabaseDebug putStrLn conn $
    runSelectReturningList $ select $ do
      user  <- all_ (shoppingCartDb ^. shoppingCartUsers)
      order <- leftJoin_ (all_ (shoppingCartDb ^. shoppingCartOrders)) (\order -> _orderForUser order `references_` user)
      guard_ (isNothing_ order)
      pure user

using exists_ combinator to select users with no orders

selectUsersWithNoOrdersExistsCombinator :: Connection -> IO [User]
selectUsersWithNoOrdersExistsCombinator conn =
   withDatabaseDebug putStrLn conn $
    runSelectReturningList $ select $ do
      user  <- all_ (shoppingCartDb ^. shoppingCartUsers)
      guard_ (not_ (exists_ (filter_ (\order -> _orderForUser order `references_` user) (all_ (shoppingCartDb ^. shoppingCartOrders)))))
      pure user

Yields the same sql as the tutorial

SELECT
  "t0"."email" AS "res0",
  "t0"."first_name" AS "res1",
  "t0"."last_name" AS "res2",
  "t0"."password" AS "res3"
FROM "cart_users" AS "t0"
WHERE NOT(EXISTS (SELECT
                    "t0"."id" AS "res0",
                    "t0"."date" AS "res1",
                    "t0"."for_user__email" AS "res2",
                    "t0"."ship_to_address__id" AS "res3",
                    "t0"."shipping_info__id" AS "res4"
                  FROM "orders" AS "t0"
                  WHERE ("t0"."for_user__email") = ("t0"."email")))

But if I change the sql in the subselect to bind to t1, in psql the correct result is yielded

SELECT
  "t0"."email" AS "res0",
  "t0"."first_name" AS "res1",
  "t0"."last_name" AS "res2",
  "t0"."password" AS "res3"
FROM "cart_users" AS "t0"
WHERE NOT(EXISTS (SELECT
                    "t1"."id" AS "res0",
                    "t1"."date" AS "res1",
                    "t1"."for_user__email" AS "res2",
                    "t1"."ship_to_address__id" AS "res3",
                    "t1"."shipping_info__id" AS "res4"
                  FROM "orders" AS "t1"
                  WHERE ("t1"."for_user__email") = ("t0"."email")))

orders with cost ordered using inner join

ordersWithCostOrdered :: Connection -> IO [(Order, Int)]
ordersWithCostOrdered conn =
  withDatabaseDebug putStrLn conn $
      runSelectReturningList $ select $
      orderBy_ (\(order, total) -> desc_ total) $
      aggregate_ (\(order, lineItem, product) ->
                    (group_ order, sum_ (lineItem ^. lineItemQuantity * product ^. productPrice))) $
      do
        lineItem <- all_ (shoppingCartDb ^. shoppingCartLineItems)
        order    <- related_ (shoppingCartDb ^. shoppingCartOrders) (_lineItemInOrder lineItem)
        product  <- related_ (shoppingCartDb ^. shoppingCartProducts) (_lineItemForProduct lineItem)
        pure (order, lineItem, product)

all user and totals with left join, aggregate and order by

allUsersAndTotals :: Connection -> IO [(User, Int)]
allUsersAndTotals conn =
  withDatabaseDebug putStrLn conn $
      runSelectReturningList $
      select $
      orderBy_ (\(user, total) -> desc_ total) $
      aggregate_ (\(user, lineItem, product) ->
                    (group_ user, sum_ (maybe_ 0 id (_lineItemQuantity lineItem) * maybe_ 0 id (product ^. productPrice)))) $
      do user     <- all_ (shoppingCartDb ^. shoppingCartUsers)
         order    <- leftJoin_ (all_ (shoppingCartDb ^. shoppingCartOrders))
                              (\order -> _orderForUser order `references_` user)
         lineItem <- leftJoin_ (all_ (shoppingCartDb ^. shoppingCartLineItems))
                              (\lineItem -> maybe_ (val_ False) (\order -> _lineItemInOrder lineItem `references_` order) order)
         product  <- leftJoin_ (all_ (shoppingCartDb ^. shoppingCartProducts))
                              (\product -> maybe_ (val_ False) (\lineItem -> _lineItemForProduct lineItem `references_` product) lineItem)
         pure (user, lineItem, product)

query with nullable FK, isNothing_

allUnshippedOrders :: Connection -> IO [Order]
allUnshippedOrders conn =
  withDatabaseDebug putStrLn conn $
    runSelectReturningList $
    select $
    filter_ (isNothing_ . _orderShippingInfo) $
    all_ (shoppingCartDb ^. shoppingCartOrders)

count of all shipped and unshipped orders by user

shippingInformationByUser :: Connection -> IO [(User, Int, Int)]
shippingInformationByUser conn =
  withDatabaseDebug putStrLn conn $
    runSelectReturningList $
    select $
    aggregate_ (\(user, order) ->
                   let ShippingInfoId shippingInfoId = _orderShippingInfo order
                   in ( group_ user
                      , as_ @Int $ count_ (as_ @(Maybe Int) (maybe_ (just_ 1) (\_ -> nothing_) shippingInfoId))
                      , as_ @Int $ count_ shippingInfoId ) ) $
    do user  <- all_ (shoppingCartDb ^. shoppingCartUsers)
       order <- leftJoin_ (all_ (shoppingCartDb ^. shoppingCartOrders)) (\order -> _orderForUser order `references_` user)
       pure (user, order)

count of all shipped and unshipped orders by user forcing subselects

shippingInformationByUserSubselect :: Connection -> IO [(User, Int, Int)]
shippingInformationByUserSubselect conn =
  withDatabaseDebug putStrLn conn $
    runSelectReturningList $
    select $
    do user <- all_ (shoppingCartDb ^. shoppingCartUsers)

       (userEmail, unshippedCount) <-
         aggregate_ (\(userEmail, order) -> (group_ userEmail, countAll_)) $
         do user  <- all_ (shoppingCartDb ^. shoppingCartUsers)
            order <- leftJoin_ (all_ (shoppingCartDb ^. shoppingCartOrders))
                               (\order -> _orderForUser order `references_` user &&. isNothing_ (_orderShippingInfo order))
            pure (pk user, order)

       guard_ (userEmail `references_` user)

       (userEmail, shippedCount) <-
         aggregate_ (\(userEmail, order) -> (group_ userEmail, countAll_)) $
         do user  <- all_ (shoppingCartDb ^. shoppingCartUsers)
            order <- leftJoin_ (all_ (shoppingCartDb ^. shoppingCartOrders))
                               (\order -> _orderForUser order `references_` user &&. isJust_ (_orderShippingInfo order))
            pure (pk user, order)
       guard_ (userEmail `references_` user)

       pure (user, unshippedCount, shippedCount)

count of all shipped and unshipped orders by user forcing subselect_ combinator

shippingInformationByUserSubselectCombinator :: Connection -> IO [(User, Int, Int)]
shippingInformationByUserSubselectCombinator conn =
  withDatabaseDebug putStrLn conn $
    runSelectReturningList $
    select $
    do user <- all_ (shoppingCartDb ^. shoppingCartUsers)

       (userEmail, unshippedCount) <-
         subselect_ $
         aggregate_ (\(userEmail, order) -> (group_ userEmail, countAll_)) $
         do user  <- all_ (shoppingCartDb ^. shoppingCartUsers)
            order <- leftJoin_ (all_ (shoppingCartDb ^. shoppingCartOrders))
                               (\order -> _orderForUser order `references_` user &&. isNothing_ (_orderShippingInfo order))
            pure (pk user, order)

       guard_ (userEmail `references_` user)

       (userEmail, shippedCount) <-
         subselect_ $
         aggregate_ (\(userEmail, order) -> (group_ userEmail, countAll_)) $
         do user  <- all_ (shoppingCartDb ^. shoppingCartUsers)
            order <- leftJoin_ (all_ (shoppingCartDb ^. shoppingCartOrders))
                               (\order -> _orderForUser order `references_` user &&. isJust_ (_orderShippingInfo order))
            pure (pk user, order)
       guard_ (userEmail `references_` user)

       pure (user, unshippedCount, shippedCount)