git.iko.soy/squeal
on abdaee4 help sign in
squeal/squeal-postgresql/exe/Example.hs
132 lines 4.3 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" :::
29 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
30 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
31 , "name" ::: 'NoDef :=> 'NotNull 'PGtext
32 , "vec" ::: 'NoDef :=> 'NotNull ('PGarray 'PGint2)
33 ]
34 , "emails" :::
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 & notNull) `As` #name :*
49 (vararray int2 & notNull) `As` #vec :* Nil )
50 ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )
51 >>>
52 createTable #emails
53 ( serial `As` #id :*
54 (int & notNull) `As` #user_id :*
55 text `As` #email :* Nil )
56 ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
57 foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
58 OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
60teardown :: Definition Schema '[]
61teardown = dropTable #emails >>> dropTable #users
63insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGarray 'PGint2)]
64 '[ "fromOnly" ::: 'NotNull 'PGint4 ]
65insertUser = insertRows #users
66 (Default `As` #id :* Set (param @1) `As` #name :* Set (param @2) `As` #vec :* Nil) []
67 OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
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 :* Nil ) []
74 OnConflictDoNothing (Returning Nil)
76getUsers :: Query Schema '[]
77 '[ "userName" ::: 'NotNull 'PGtext
78 , "userEmail" ::: 'Null 'PGtext
79 , "userVec" ::: 'NotNull ('PGarray 'PGint2)]
80getUsers = select
81 (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* #u ! #vec `As` #userVec :* Nil)
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 (RowNumber 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 = void $
125 withConnection "host=localhost port=5432 dbname=exampledb" . goPQ $
126 define setup
127 & pqThen session
128 & thenDefine teardown
129 where
130 goPQ pq conn = do
131 SOP.K x <- runPQ pq conn
132 return (x, SOP.K (SOP.unK conn))