Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# LANGUAGE DeriveGeneric #-}
- {-# LANGUAGE OverloadedStrings #-}
- {-# LANGUAGE FlexibleInstances #-}
- {-# LANGUAGE TypeFamilies #-}
- {-# LANGUAGE TypeApplications #-}
- {-# LANGUAGE StandaloneDeriving #-}
- {-# LANGUAGE TypeSynonymInstances #-}
- {-# LANGUAGE MultiParamTypeClasses #-}
- {-# LANGUAGE PartialTypeSignatures #-}
- {-# LANGUAGE ImpredicativeTypes #-}
- module BeamTutorial where
- import Database.Beam
- import Database.Beam.Postgres (connect, defaultConnectInfo, runBeamPostgresDebug, PgSelectSyntax)
- import Data.Text (Text)
- data UserT f = User
- { _userEmail :: Columnar f Text
- , _userFirstName :: Columnar f Text
- , _userLastName :: Columnar f Text
- , _userPassword :: Columnar f Text
- } deriving Generic
- type User = UserT Identity
- type UserId = PrimaryKey UserT Identity
- deriving instance Show User
- deriving instance Eq User
- instance Beamable UserT
- instance Table UserT where
- data PrimaryKey UserT f = UserId (Columnar f Text) deriving Generic
- primaryKey = UserId . _userEmail
- instance Beamable (PrimaryKey UserT)
- -- userKey = UserId "john@doe.org"
- data ShoppingCartDb f = ShoppingCartDb
- { _shoppingCartUsers :: f (TableEntity UserT)
- , _shoppingCartUserAddresses :: f (TableEntity AddressT)
- } deriving Generic
- instance Database be ShoppingCartDb
- shoppingCartDb :: DatabaseSettings be ShoppingCartDb
- shoppingCartDb = defaultDbSettings `withDbModification`
- dbModification {
- _shoppingCartUserAddresses =
- modifyTable (\_ -> "addresses") $
- tableModification {
- _addressLine1 = fieldNamed "address1",
- _addressLine2 = fieldNamed "address2"
- }
- }
- test :: IO ()
- test = do
- conn <- connect defaultConnectInfo
- putStrLn "Sorted Users"
- queryUsersSort conn
- -- putStrLn "Bounded Users"
- -- queryBounded conn
- putStrLn "Count"
- queryCount conn
- putStrLn "Count Names"
- queryCountNames conn
- where
- addUsers conn = do
- runBeamPostgresDebug putStrLn conn $ runInsert $
- insert (_shoppingCartUsers shoppingCartDb) $
- insertValues [ User "james@example.com" "James" "Smith" "b4cc344d25a2efe540adbf2678e2304c" {- james -}
- , User "betty@example.com" "Betty" "Jones" "82b054bd83ffad9b6cf8bdb98ce3cc2f" {- betty -}
- , User "sam@example.com" "Sam" "Taylor" "332532dcfaa1cbf61e2a266bd723612c" {- sam -} ]
- queryUsers conn = do
- let allUsers = all_ (_shoppingCartUsers shoppingCartDb)
- runBeamPostgresDebug putStrLn conn $ do
- users <- runSelectReturningList $ select allUsers
- mapM_ (liftIO . print) users
- queryUsersSort conn = do
- let sortUsersByFirstName = orderBy_ (\u -> (asc_ (_userFirstName u), desc_ (_userLastName u))) (all_ (_shoppingCartUsers shoppingCartDb))
- runBeamPostgresDebug putStrLn conn $ do
- users <- runSelectReturningList $ select sortUsersByFirstName
- mapM_ (liftIO . putStrLn . show) users
- -- queryBounded conn = do
- -- let boundedQuery :: Q PgSelectSyntax _ _ _
- -- boundedQuery = limit_ 1 $ offset_ 1 $
- -- orderBy_ (asc_ . _userFirstName) $
- -- all_ (_shoppingCartUsers shoppingCartDb)
- -- runBeamPostgresDebug putStrLn conn $ do
- -- users <- runSelectReturningList (select boundedQuery :: SqlSelect PgSelectSyntax _)
- -- mapM_ (liftIO . putStrLn . show) users
- queryCount conn = do
- let userCount = aggregate_ (\u -> countAll_) (all_ (_shoppingCartUsers shoppingCartDb))
- runBeamPostgresDebug putStrLn conn $ do
- Just c <- runSelectReturningOne $ select userCount
- liftIO $ putStrLn ("We have " ++ show c ++ " users in the database")
- queryCountNames conn = do
- let numberOfUsersByName = aggregate_ (\u -> (group_ (_userFirstName u), countAll_)) $
- all_ (_shoppingCartUsers shoppingCartDb)
- runBeamPostgresDebug putStrLn conn $ do
- countedByName <- runSelectReturningList $ select numberOfUsersByName
- mapM_ (liftIO . putStrLn . show) countedByName
- --- part 2 --------------------------------------
- data AddressT f = Address
- { _addressId :: C f 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
- deriving instance Show (PrimaryKey UserT Identity)
- deriving instance Show Address
- instance Table AddressT where
- data PrimaryKey AddressT f = AddressId (Columnar f Int) deriving Generic
- primaryKey = AddressId . _addressId
- type AddressId = PrimaryKey AddressT Identity -- For convenience
- instance Beamable AddressT
- instance Beamable (PrimaryKey AddressT)
- 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
- test2 :: IO ()
- test2 = do
- conn <- connect defaultConnectInfo
- print "HELLO"
- insertUsers conn
- where
- insertUsers conn = do
- let james = User "james@example.com" "James" "Smith" "b4cc344d25a2efe540adbf2678e2304c"
- betty = User "betty@example.com" "Betty" "Jones" "82b054bd83ffad9b6cf8bdb98ce3cc2f"
- sam = User "sam@example.com" "Sam" "Taylor" "332532dcfaa1cbf61e2a266bd723612c"
- runBeamPostgresDebug putStrLn conn $ runInsert $
- insert (_shoppingCartUsers shoppingCartDb) $
- insertValues [ james, betty, sam ]
- let addresses = [ Address default_ (val_ "123 Little Street") (val_ Nothing) (val_ "Boston") (val_ "MA") (val_ "12345") (pk james)
- , Address default_ (val_ "222 Main Street") (val_ (Just "Ste 1")) (val_ "Houston") (val_ "TX") (val_ "8888") (pk betty)
- , Address default_ (val_ "9999 Residence Ave") (val_ Nothing) (val_ "Sugarland") (val_ "TX") (val_ "8989") (pk betty) ]
- runBeamPostgresDebug putStrLn conn $ runInsert $
- insert (_shoppingCartUserAddresses shoppingCartDb) $
- insertExpressions addresses
Add Comment
Please, Sign In to add comment