{-# LANGUAGE
DataKinds
, DeriveGeneric
, FlexibleContexts
, OverloadedLabels
, OverloadedStrings
, OverloadedLists
, TypeApplications
, TypeOperators
#-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Main (main, main2, upsertUser) where
import Control.Monad.Except (MonadError (throwError))
import Control.Monad.IO.Class (MonadIO (..))
import Data.Int (Int16, Int32)
import Data.Text (Text)
import Data.Vector (Vector)
import Squeal.PostgreSQL
import qualified Data.ByteString.Char8 as Char8
import qualified Generics.SOP as SOP
import qualified GHC.Generics as GHC
type UserSchema =
'[ "users" ::: 'Table (
'[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
, "name" ::: 'NoDef :=> 'NotNull 'PGtext
, "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
])
, "emails" ::: 'Table (
'[ "pk_emails" ::: 'PrimaryKey '["id"]
, "fk_user_id" ::: 'ForeignKey '["user_id"] "user" "users" '["id"]
] :=>
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
, "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
, "email" ::: 'NoDef :=> 'Null 'PGtext
])
]
type PublicSchema = '[ "positive" ::: 'Typedef 'PGfloat4 ]
type OrgSchema =
'[ "organizations" ::: 'Table (
'[ "pk_organizations" ::: 'PrimaryKey '["id"] ] :=>
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
, "name" ::: 'NoDef :=> 'NotNull 'PGtext
, "type" ::: 'NoDef :=> 'NotNull 'PGtext
])
, "members" ::: 'Table (
'[ "fk_member" ::: 'ForeignKey '["member"] "user" "users" '["id"]
, "fk_organization" ::: 'ForeignKey '["organization"] "org" "organizations" '["id"] ] :=>
'[ "member" ::: 'NoDef :=> 'NotNull 'PGint4
, "organization" ::: 'NoDef :=> 'NotNull 'PGint4 ])
]
type Schemas
= '[ "public" ::: PublicSchema, "user" ::: UserSchema, "org" ::: OrgSchema ]
setup :: Definition (Public '[]) Schemas
setup =
createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
>>>
createSchema #user
>>>
createSchema #org
>>>
createTable (#user ! #jokers)
( serial `as` #id :*
(text & notNullable) `as` #name :*
(vararray int2 & notNullable) `as` #vec )
( primaryKey #id `as` #pk_users )
>>>
alterTableRename (#user ! #jokers) #users
>>>
createTable (#user ! #emails)
( serial `as` #id :*
columntypeFrom @Int32 `as` #user_id :*
columntypeFrom @(Maybe Text) `as` #email )
( primaryKey #id `as` #pk_emails :*
foreignKey #user_id (#user ! #users) #id
(OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id )
>>>
createTable (#org ! #organizations)
( serial `as` #id :*
(text & notNullable) `as` #name :*
(text & notNullable) `as` #type )
( primaryKey #id `as` #pk_organizations )
>>>
createTable (#org ! #members)
( notNullable int4 `as` #member :*
notNullable int4 `as` #organization )
( foreignKey #member (#user ! #users) #id
(OnDelete Cascade) (OnUpdate Cascade) `as` #fk_member :*
foreignKey #organization (#org ! #organizations) #id
(OnDelete Cascade) (OnUpdate Cascade) `as` #fk_organization )
teardown :: Definition Schemas (Public '[])
teardown = dropType #positive >>> dropSchemaCascade #user >>> dropSchemaCascade #org
insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
insertUser = insertInto (#user ! #users)
(Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
(OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
insertEmail = insertInto_ (#user ! #emails)
(Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email))
insertOrganization :: Manipulation_ Schemas (Text, OrganizationType) (Only Int32)
insertOrganization = insertInto (#org ! #organizations)
(Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #type))
(OnConflict (OnConstraint #pk_organizations) DoNothing) (Returning_ (#id `as` #fromOnly))
getUsers :: Query_ Schemas () User
getUsers = select_
(#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)
( from (table ((#user ! #users) `as` #u)
& innerJoin (table ((#user ! #emails) `as` #e))
(#u ! #id .== #e ! #user_id)) )
getOrganizations :: Query_ Schemas () Organization
getOrganizations = select_
( #o ! #id `as` #orgId :*
#o ! #name `as` #orgName :*
#o ! #type `as` #orgType
)
(from (table (#org ! #organizations `as` #o)))
getOrganizationsBy ::
forall hsty.
(ToPG Schemas hsty) =>
Condition
'Ungrouped
'[]
'[]
Schemas
'[NullPG hsty]
'["o" ::: ["id" ::: NotNull PGint4, "name" ::: NotNull PGtext, "type" ::: NotNull PGtext]] ->
Query_ Schemas (Only hsty) Organization
getOrganizationsBy condition =
select_
( #o ! #id `as` #orgId :*
#o ! #name `as` #orgName :*
#o ! #type `as` #orgType
)
(
from (table (#org ! #organizations `as` #o))
& where_ condition
)
upsertUser :: Manipulation_ Schemas (Int32, String, VarArray [Maybe Int16]) ()
upsertUser = insertInto (#user ! #users `as` #u)
(Values_ (Set (param @1) `as` #id :* setUser))
(OnConflict (OnConstraint #pk_users) (DoUpdate setUser [#u ! #id .== param @1]))
(Returning_ Nil)
where
setUser = Set (param @2) `as` #name :* Set (param @3) `as` #vec :* Nil
data User
= User
{ userName :: Text
, userEmail :: Maybe Text
, userVec :: VarArray (Vector (Maybe Int16))
} deriving (Show, GHC.Generic)
instance SOP.Generic User
instance SOP.HasDatatypeInfo User
users :: [User]
users =
[ User "Alice" (Just "alice@gmail.com") (VarArray [Just 1,Just 2,Nothing])
, User "Bob" Nothing (VarArray [Nothing,Just (-3)])
, User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3,Nothing, Just 4])
]
data Organization
= Organization
{ orgId :: Int32
, orgName :: Text
, orgType :: OrganizationType
} deriving (Show, GHC.Generic)
instance SOP.Generic Organization
instance SOP.HasDatatypeInfo Organization
data OrganizationType
= ForProfit
| NonProfit
deriving (Show, GHC.Generic)
instance SOP.Generic OrganizationType
instance SOP.HasDatatypeInfo OrganizationType
instance IsPG OrganizationType where
type PG OrganizationType = 'PGtext
instance ToPG db OrganizationType where
toPG = toPG . toText
where
toText ForProfit = "for-profit" :: Text
toText NonProfit = "non-profit" :: Text
instance FromPG OrganizationType where
fromPG = do
value <- fromPG @Text
fromText value
where
fromText "for-profit" = pure ForProfit
fromText "non-profit" = pure NonProfit
fromText value = throwError $ "Invalid organization type: \"" <> value <> "\""
organizations :: [Organization]
organizations =
[ Organization { orgId = 1, orgName = "ACME", orgType = ForProfit }
, Organization { orgId = 2, orgName = "Haskell Foundation", orgType = NonProfit }
]
session :: (MonadIO pq, MonadPQ Schemas pq) => pq ()
session = do
liftIO $ Char8.putStrLn "===> manipulating"
userIdResults <- traversePrepared insertUser [(userName user, userVec user) | user <- users]
userIds <- traverse (fmap fromOnly . getRow 0) (userIdResults :: [Result (Only Int32)])
traversePrepared_ insertEmail (zip (userIds :: [Int32]) (userEmail <$> users))
orgIdResults <- traversePrepared
insertOrganization
[(orgName organization, orgType organization) | organization <- organizations]
_ <- traverse (fmap fromOnly . getRow 0) (orgIdResults :: [Result (Only Int32)])
liftIO $ Char8.putStrLn "===> querying: users"
usersResult <- runQuery getUsers
usersRows <- getRows usersResult
liftIO $ print (usersRows :: [User])
liftIO $ Char8.putStrLn "===> querying: organizations: all"
organizationsResult1 <- runQuery getOrganizations
organizationRows1 <- getRows organizationsResult1
liftIO $ print (organizationRows1 :: [Organization])
liftIO $ Char8.putStrLn "===> querying: organizations: by ID (2)"
organizationsResult2 <- runQueryParams
(getOrganizationsBy @Int32 ((#o ! #id) .== param @1)) (Only (2 :: Int32))
organizationRows2 <- getRows organizationsResult2
liftIO $ print (organizationRows2 :: [Organization])
liftIO $ Char8.putStrLn "===> querying: organizations: by name (ACME)"
organizationsResult3 <- runQueryParams
(getOrganizationsBy @Text ((#o ! #name) .== param @1)) (Only ("ACME" :: Text))
organizationRows3 <- getRows organizationsResult3
liftIO $ print (organizationRows3 :: [Organization])
liftIO $ Char8.putStrLn "===> querying: organizations: by type (non-profit)"
organizationsResult4 <- runQueryParams
(getOrganizationsBy @Text ((#o ! #type) .== param @1)) (Only NonProfit)
organizationRows4 <- getRows organizationsResult4
liftIO $ print (organizationRows4 :: [Organization])
main :: IO ()
main = do
Char8.putStrLn "===> squeal"
connectionString <- pure
"host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
Char8.putStrLn $ "connecting to " <> connectionString
connection0 <- connectdb connectionString
Char8.putStrLn "===> setting up schema"
connection1 <- execPQ (define setup) connection0
connection2 <- execPQ session connection1
Char8.putStrLn "===> tearing down schema"
connection3 <- execPQ (define teardown) connection2
finish connection3
main2 :: IO ()
main2 =
withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $
define setup
& pqThen session
& pqThen (define teardown)