git.iko.soy/squeal
on 2c4bfcd help sign in
squeal/squeal-postgresql/exe/Example.hs
121 lines 3.6 kB history raw
1{-# LANGUAGE
2 DataKinds
3 , DeriveGeneric
4 , FlexibleContexts
5 , OverloadedLabels
6 , OverloadedStrings
7 , TypeApplications
8 , TypeOperators
9#-}
11module Main (main, main2) where
13import Control.Monad (void)
14import Control.Monad.Base (liftBase, MonadBase)
15import Data.Int (Int32)
16import Data.Monoid ((<>))
17import Data.Text (Text)
19import Squeal.PostgreSQL
21import qualified Data.ByteString.Char8 as Char8
22import qualified Generics.SOP as SOP
23import qualified GHC.Generics as GHC
25type Schema =
26 '[ "users" :::
27 '[ "id" ::: 'Optional ('NotNull 'PGint4)
28 , "name" ::: 'Required ('NotNull 'PGtext)
29 ]
30 , "emails" :::
31 '[ "id" ::: 'Optional ('NotNull 'PGint4)
32 , "user_id" ::: 'Required ('NotNull 'PGint4)
33 , "email" ::: 'Required ('Null 'PGtext)
34 ]
35 ]
37setup :: Definition '[] Schema
38setup =
39 createTable #users
40 ( serial `As` #id :*
41 (text & notNull) `As` #name :* Nil )
42 [ primaryKey (Column #id :* Nil) ]
43 >>>
44 createTable #emails
45 ( serial `As` #id :*
46 (int & notNull) `As` #user_id :*
47 text `As` #email :* Nil )
48 [ primaryKey (Column #id :* Nil)
49 , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
50 OnDeleteCascade OnUpdateCascade ]
52teardown :: Definition Schema '[]
53teardown = dropTable #emails >>> dropTable #users
55insertUser :: Manipulation Schema
56 '[ 'Required ('NotNull 'PGtext)]
57 '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]
58insertUser = insertInto #users
59 ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )
60 OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
62insertEmail :: Manipulation Schema
63 '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]
64insertEmail = insertInto #emails ( Values
65 ( def `As` #id :*
66 param @1 `As` #user_id :*
67 param @2 `As` #email :* Nil) [] )
68 OnConflictDoNothing (Returning Nil)
70getUsers :: Query Schema '[]
71 '[ "userName" ::: 'Required ('NotNull 'PGtext)
72 , "userEmail" ::: 'Required ('Null 'PGtext) ]
73getUsers = select
74 (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
75 ( from (Table (#users `As` #u)
76 & InnerJoin (Table (#emails `As` #e))
77 (#u ! #id .== #e ! #user_id)) )
79data User = User { userName :: Text, userEmail :: Maybe Text }
80 deriving (Show, GHC.Generic)
81instance SOP.Generic User
82instance SOP.HasDatatypeInfo User
84users :: [User]
85users =
86 [ User "Alice" (Just "alice@gmail.com")
87 , User "Bob" Nothing
88 , User "Carole" (Just "carole@hotmail.com")
89 ]
91session :: (MonadBase IO pq, MonadPQ Schema pq) => pq ()
92session = do
93 liftBase $ Char8.putStrLn "manipulating"
94 idResults <- traversePrepared insertUser (Only . userName <$> users)
95 ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults
96 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
97 liftBase $ Char8.putStrLn "querying"
98 usersResult <- runQuery getUsers
99 usersRows <- getRows usersResult
100 liftBase $ print (usersRows :: [User])
102main :: IO ()
103main = do
104 Char8.putStrLn "squeal"
105 connectionString <- pure
106 "host=localhost port=5432 dbname=exampledb"
107 Char8.putStrLn $ "connecting to " <> connectionString
108 connection0 <- connectdb connectionString
109 Char8.putStrLn "setting up schema"
110 connection1 <- execPQ (define setup) connection0
111 connection2 <- execPQ session connection1
112 Char8.putStrLn "tearing down schema"
113 connection3 <- execPQ (define teardown) connection2
114 finish connection3
116main2 :: IO ()
117main2 = void $
118 withConnection "host=localhost port=5432 dbname=exampledb" . runPQ $
119 define setup
120 & pqThen session
121 & thenDefine teardown