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