@@ -12,31 +12,85 @@
1212 , TypeSynonymInstances
1313#-}
1414
15−module Main (main,col1,col2) where
15+module Main (main) where
1616
1717import Control.Category ((>>>))
1818import Control.Monad.Base
1919import Data.Function ((&))
2020import Data.Int
2121import Data.Monoid
22−import Generics.SOP hiding (from)
22+import Data.Text hiding (zip)
2323import Squeal.PostgreSQL
2424
2525import qualified Data.ByteString.Char8 as Char8
26+import qualified Generics.SOP as SOP
2627import qualified GHC.Generics as GHC
2728
2829type Schema =
29− '[ "students" ::: '["name" ::: 'Required ('NotNull 'PGtext)]
30− , "table1" :::
31− '[ "col1" ::: 'Required ('NotNull 'PGint4)
32− , "col2" ::: 'Required ('NotNull 'PGint4)
30+ '[ "users" :::
31+ '[ "id" ::: 'Optional ('NotNull 'PGint4)
32+ , "name" ::: 'Required ('NotNull 'PGtext)
33+ ]
34+ , "emails" :::
35+ '[ "id" ::: 'Optional ('NotNull 'PGint4)
36+ , "user_id" ::: 'Required ('NotNull 'PGint4)
37+ , "email" ::: 'Required ('Null 'PGtext)
3338 ]
3439 ]
3540
36−data Row = Row { col1 :: Int32, col2 :: Int32 }
41+setup :: Definition '[] Schema
42+setup =
43+ createTable #users
44+ ( serial `As` #id :*
45+ (text & notNull) `As` #name :* Nil )
46+ [ primaryKey (Column #id :* Nil) ]
47+ >>>
48+ createTable #emails
49+ ( serial `As` #id :*
50+ (int & notNull) `As` #user_id :*
51+ text `As` #email :* Nil )
52+ [ primaryKey (Column #id :* Nil)
53+ , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
54+ OnDeleteCascade OnUpdateCascade ]
55+
56+teardown :: Definition Schema '[]
57+teardown = dropTable #emails >>> dropTable #users
58+
59+insertUser :: Manipulation Schema
60+ '[ 'Required ('NotNull 'PGtext)]
61+ '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]
62+insertUser = insertInto #users
63+ ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )
64+ OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
65+
66+insertEmail :: Manipulation Schema
67+ '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]
68+insertEmail = insertInto #emails ( Values
69+ ( def `As` #id :*
70+ param @1 `As` #user_id :*
71+ param @2 `As` #email :* Nil) [] )
72+ OnConflictDoNothing (Returning Nil)
73+
74+getUsers :: Query Schema '[]
75+ '[ "userName" ::: 'Required ('NotNull 'PGtext)
76+ , "userEmail" ::: 'Required ('Null 'PGtext) ]
77+getUsers = select
78+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
79+ ( from (Table (#users `As` #u)
80+ & InnerJoin (Table (#emails `As` #e))
81+ (#u ! #id .== #e ! #user_id)) )
82+
83+data User = User { userName :: Text, userEmail :: Maybe Text }
3784 deriving (Show, GHC.Generic)
38−instance Generic Row
39−instance HasDatatypeInfo Row
85+instance SOP.Generic User
86+instance SOP.HasDatatypeInfo User
87+
88+users :: [User]
89+users =
90+ [ User "Alice" (Just "alice@gmail.com")
91+ , User "Bob" Nothing
92+ , User "Carole" (Just "carole@hotmail.com")
93+ ]
4094
4195main :: IO ()
4296main = do
@@ -46,42 +100,16 @@ main = do
46100 Char8.putStrLn $ "connecting to " <> connectionString
47101 connection0 <- connectdb connectionString
48102 Char8.putStrLn "setting up schema"
49− connection1 <- flip execPQ (connection0 :: Connection '[]) $ define $
50− createTable #students ((text & notNull) `As` #name :* Nil ) []
51− >>>
52− createTable #table1
53− ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil) []
54− connection2 <- flip execPQ (connection1 :: Connection Schema) $ do
55− let
56− insert :: Manipulation Schema '[_,_,_,_] '[]
57− insert =
58− insertInto #table1
59− ( Values
60− (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil)
61− [param @3 `As` #col1 :* param @4 `As` #col2 :* Nil]
62− ) OnConflictDoNothing (Returning Nil)
103+ connection1 <- execPQ (define setup) connection0
104+ connection2 <- flip execPQ connection1 $ do
63105 liftBase $ Char8.putStrLn "manipulating"
64− _insertResult <- manipulateParams insert
65− (1::Int32,2::Int32,3::Int32,4::Int32)
106+ idResults <- traversePrepared insertUser (Only . userName <$> users)
107+ ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults
108+ traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
66109 liftBase $ Char8.putStrLn "querying"
67− result <- runQuery $
68− selectStar (from (Table (#table1 `As` #table1)))
69− value00 <- getValue (RowNumber 0) (columnNumber @0) result
70− value01 <- getValue (RowNumber 0) (columnNumber @1) result
71− value10 <- getValue (RowNumber 1) (columnNumber @0) result
72− value11 <- getValue (RowNumber 1) (columnNumber @1) result
73− row0 <- getRow (RowNumber 0) result
74− row1 <- getRow (RowNumber 1) result
75− rows <- getRows result
76− liftBase $ do
77− print (value00 :: Int32)
78− print (value01 :: Int32)
79− print (value10 :: Int32)
80− print (value11 :: Int32)
81− print (row0 :: Row)
82− print (row1 :: Row)
83− print (rows :: [Row])
110+ usersResult <- runQuery getUsers
111+ usersRows <- getRows usersResult
112+ liftBase $ print (usersRows :: [User])
84113 Char8.putStrLn "tearing down schema"
85− connection3 <- flip execPQ (connection2 :: Connection Schema) $ define $
86− dropTable #table1 >>> dropTable #students
87− finish (connection3 :: Connection '[])
114+ connection3 <- execPQ (define teardown) connection2
115+ finish connection3