git.iko.soy/squeal
on dev help sign in
squeal/squeal-postgresql/exe/Example.hs
125 lines 4.1 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.IO.Class (MonadIO (..))
15import Data.Int (Int16, Int32)
16import Data.Monoid ((<>))
17import Data.Text (Text)
18import Data.Vector (Vector)
20import Squeal.PostgreSQL
22import qualified Data.ByteString.Char8 as Char8
23import qualified Generics.SOP as SOP
24import qualified GHC.Generics as GHC
26type Schema =
27 '[ "users" ::: 'Table (
28 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
29 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
30 , "name" ::: 'NoDef :=> 'NotNull 'PGtext
31 , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
32 ])
33 , "emails" ::: 'Table (
34 '[ "pk_emails" ::: 'PrimaryKey '["id"]
35 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
36 ] :=>
37 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
38 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
39 , "email" ::: 'NoDef :=> 'Null 'PGtext
40 ])
41 , "positive" ::: 'Typedef 'PGfloat4
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 hask @Int32 `as` #user_id :*
57 hask @(Maybe Text) `as` #email )
58 ( primaryKey #id `as` #pk_emails :*
59 foreignKey #user_id #users #id
60 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
61 >>>
62 createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
64teardown :: Definition Schemas (Public '[])
65teardown = dropType #positive >>> dropTable #emails >>> dropTable #users
67insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
68insertUser = insertInto #users
69 (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
70 (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
72insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
73insertEmail = insertInto_ #emails
74 (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email))
76getUsers :: Query_ Schemas () User
77getUsers = select_
78 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)
79 ( from (table (#users `as` #u)
80 & innerJoin (table (#emails `as` #e))
81 (#u ! #id .== #e ! #user_id)) )
83data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) }
84 deriving (Show, GHC.Generic)
85instance SOP.Generic User
86instance SOP.HasDatatypeInfo User
88users :: [User]
89users =
90 [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])
91 , User "Bob" Nothing (VarArray [Just 2, Nothing])
92 , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3])
93 ]
95session :: (MonadIO pq, MonadPQ Schemas pq) => pq ()
96session = do
97 liftIO $ Char8.putStrLn "manipulating"
98 idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])
99 ids <- traverse (fmap fromOnly . getRow 0) idResults
100 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
101 liftIO $ Char8.putStrLn "querying"
102 usersResult <- runQuery getUsers
103 usersRows <- getRows usersResult
104 liftIO $ print (usersRows :: [User])
106main :: IO ()
107main = do
108 Char8.putStrLn "squeal"
109 connectionString <- pure
110 "host=localhost port=5432 dbname=exampledb"
111 Char8.putStrLn $ "connecting to " <> connectionString
112 connection0 <- connectdb connectionString
113 Char8.putStrLn "setting up schema"
114 connection1 <- execPQ (define setup) connection0
115 connection2 <- execPQ session connection1
116 Char8.putStrLn "tearing down schema"
117 connection3 <- execPQ (define teardown) connection2
118 finish connection3
120main2 :: IO ()
121main2 =
122 withConnection "host=localhost port=5432 dbname=exampledb" $
123 define setup
124 & pqThen session
125 & pqThen (define teardown)