git.iko.soy/squeal
on f7aedef help sign in
squeal/squeal-postgresql/exe/Example.hs
128 lines 4.1 kB history raw
1{-# LANGUAGE
2 DataKinds
3 , DeriveGeneric
4 , FlexibleContexts
5 , OverloadedLabels
6 , OverloadedStrings
7 , OverloadedLists
8 , TypeApplications
9 , TypeOperators
10#-}
12module Main (main, main2) where
14import Control.Monad (void)
15import Control.Monad.Base (liftBase, MonadBase)
16import Data.Int (Int16, Int32)
17import Data.Monoid ((<>))
18import Data.Text (Text)
19import Data.Vector (Vector)
21import Squeal.PostgreSQL
23import qualified Data.ByteString.Char8 as Char8
24import qualified Generics.SOP as SOP
25import qualified GHC.Generics as GHC
27type Schema =
28 '[ "users" ::: 'Table (
29 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
30 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
31 , "name" ::: 'NoDef :=> 'NotNull 'PGtext
32 , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
33 ])
34 , "emails" ::: 'Table (
35 '[ "pk_emails" ::: 'PrimaryKey '["id"]
36 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
37 ] :=>
38 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
40 , "email" ::: 'NoDef :=> 'Null 'PGtext
41 ])
42 ]
44setup :: Definition '[] Schema
45setup =
46 createTable #users
47 ( serial `as` #id :*
48 (text & notNullable) `as` #name :*
49 (vararray int2 & notNullable) `as` #vec )
50 ( primaryKey #id `as` #pk_users )
51 >>>
52 createTable #emails
53 ( serial `as` #id :*
54 (int & notNullable) `as` #user_id :*
55 (text & nullable) `as` #email )
56 ( primaryKey #id `as` #pk_emails :*
57 foreignKey #user_id #users #id
58 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
60teardown :: Definition Schema '[]
61teardown = dropTable #emails >>> dropTable #users
63insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
64 '[ "fromOnly" ::: 'NotNull 'PGint4 ]
65insertUser = insertRows #users
66 (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec) []
67 OnConflictDoNothing (Returning (#id `as` #fromOnly))
69insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
70insertEmail = insertRows #emails
71 ( Default `as` #id :*
72 Set (param @1) `as` #user_id :*
73 Set (param @2) `as` #email ) []
74 OnConflictDoNothing (Returning Nil)
76getUsers :: Query Schema '[]
77 '[ "userName" ::: 'NotNull 'PGtext
78 , "userEmail" ::: 'Null 'PGtext
79 , "userVec" ::: 'NotNull ('PGvararray ('Null 'PGint2))]
80getUsers = select
81 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)
82 ( from (table (#users `as` #u)
83 & innerJoin (table (#emails `as` #e))
84 (#u ! #id .== #e ! #user_id)) )
86data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: Vector (Maybe Int16) }
87 deriving (Show, GHC.Generic)
88instance SOP.Generic User
89instance SOP.HasDatatypeInfo User
91users :: [User]
92users =
93 [ User "Alice" (Just "alice@gmail.com") [Nothing, Just 1]
94 , User "Bob" Nothing [Just 2, Nothing]
95 , User "Carole" (Just "carole@hotmail.com") [Just 3]
96 ]
98session :: (MonadBase IO pq, MonadPQ Schema pq) => pq ()
99session = do
100 liftBase $ Char8.putStrLn "manipulating"
101 idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])
102 ids <- traverse (fmap fromOnly . getRow 0) idResults
103 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
104 liftBase $ Char8.putStrLn "querying"
105 usersResult <- runQuery getUsers
106 usersRows <- getRows usersResult
107 liftBase $ print (usersRows :: [User])
109main :: IO ()
110main = do
111 Char8.putStrLn "squeal"
112 connectionString <- pure
113 "host=localhost port=5432 dbname=exampledb"
114 Char8.putStrLn $ "connecting to " <> connectionString
115 connection0 <- connectdb connectionString
116 Char8.putStrLn "setting up schema"
117 connection1 <- execPQ (define setup) connection0
118 connection2 <- execPQ session connection1
119 Char8.putStrLn "tearing down schema"
120 connection3 <- execPQ (define teardown) connection2
121 finish connection3
123main2 :: IO ()
124main2 =
125 void . withConnection "host=localhost port=5432 dbname=exampledb" $
126 define setup
127 & pqThen session
128 & pqThen (define teardown)