git.iko.soy/squeal
on 4a99bc9 help sign in
squeal/squeal-postgresql/exe/Example.hs
123 lines 4.0 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 ]
44type Schemas = Public Schema
46setup :: Definition (Public '[]) Schemas
47setup =
48 createTable #users
49 ( serial `as` #id :*
50 (text & notNullable) `as` #name :*
51 (vararray int2 & notNullable) `as` #vec )
52 ( primaryKey #id `as` #pk_users )
53 >>>
54 createTable #emails
55 ( serial `as` #id :*
56 (int & notNullable) `as` #user_id :*
57 (text & nullable) `as` #email )
58 ( primaryKey #id `as` #pk_emails :*
59 foreignKey #user_id #users #id
60 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
62teardown :: Definition Schemas (Public '[])
63teardown = dropTable #emails >>> dropTable #users
65insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
66insertUser = insertInto #users
67 (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))
68 (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
70insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
71insertEmail = insertInto_ #emails
72 (Values_ (defaultAs #id :* param @1 `as` #user_id :* param @2 `as` #email))
74getUsers :: Query_ Schemas () User
75getUsers = select_
76 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)
77 ( from (table (#users `as` #u)
78 & innerJoin (table (#emails `as` #e))
79 (#u ! #id .== #e ! #user_id)) )
81data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) }
82 deriving (Show, GHC.Generic)
83instance SOP.Generic User
84instance SOP.HasDatatypeInfo User
86users :: [User]
87users =
88 [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])
89 , User "Bob" Nothing (VarArray [Just 2, Nothing])
90 , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3])
91 ]
93session :: (MonadBase IO pq, MonadPQ Schemas pq) => pq ()
94session = do
95 liftBase $ Char8.putStrLn "manipulating"
96 idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])
97 ids <- traverse (fmap fromOnly . getRow 0) idResults
98 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
99 liftBase $ Char8.putStrLn "querying"
100 usersResult <- runQuery getUsers
101 usersRows <- getRows usersResult
102 liftBase $ print (usersRows :: [User])
104main :: IO ()
105main = do
106 Char8.putStrLn "squeal"
107 connectionString <- pure
108 "host=localhost port=5432 dbname=exampledb"
109 Char8.putStrLn $ "connecting to " <> connectionString
110 connection0 <- connectdb connectionString
111 Char8.putStrLn "setting up schema"
112 connection1 <- execPQ (define setup) connection0
113 connection2 <- execPQ session connection1
114 Char8.putStrLn "tearing down schema"
115 connection3 <- execPQ (define teardown) connection2
116 finish connection3
118main2 :: IO ()
119main2 =
120 void . withConnection "host=localhost port=5432 dbname=exampledb" $
121 define setup
122 & pqThen session
123 & pqThen (define teardown)