Skip to content

Instantly share code, notes, and snippets.

@bradparker

bradparker/Opaleye.hs

Last active December 19, 2018 23:31
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save bradparker/7d54183361a7ae9909d163ca5afb8366 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save bradparker/7d54183361a7ae9909d163ca5afb8366 to your computer and use it in GitHub Desktop.
Download ZIP
Opaleye-in'
Raw
Opaleye.hs
{-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wall #-}
module Main where
import Data.Bool (bool)
import Data.Text (Text)
import Control.Arrow (returnA)
import Control.Lens ((^.), _1, _2, _4, _8)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Profunctor.Product (p2, p5, p6, p8)
import Data.Profunctor.Product.Default (Default)
import Opaleye
( Aggregator
, Field
, FieldNullable
, Nullable
, Select
, SelectArr
, SqlArray
, SqlBool
, SqlInt8
, SqlText
, SqlTimestamptz
, Table
, Unpackspec
, (.==)
, aggregate
, arrayAgg
, boolOr
, constant
, count
, groupBy
, leftJoinA
, matchNullable
, restrict
, selectTable
, showSqlForPostgres
, table
, tableField
, in_
)
printSql :: Default Unpackspec a a => Select a -> IO ()
printSql = putStrLn . fromMaybe "Empty query" . showSqlForPostgres
type User
= ( Field SqlInt8
, Field SqlText
, Field SqlText
, Field SqlText
, Field SqlText
, FieldNullable SqlText
)
userTable :: Table User User
userTable =
table "users" $
p6
( tableField "id"
, tableField "password"
, tableField "email"
, tableField "username"
, tableField "bio"
, tableField "image")
userSelect :: Select User
userSelect = selectTable userTable
findUser :: SelectArr (Field SqlInt8) User
findUser =
proc userId -> do
user <- userSelect -< ()
restrict -< userId .== (user ^. _1)
returnA -< user
type Follow
= ( Field SqlInt8
, Field SqlInt8
)
followTable :: Table Follow Follow
followTable =
table "follows" $
p2
( tableField "follower__id"
, tableField "followee__id"
)
followSelect :: Select Follow
followSelect = selectTable followTable
type FollowNullable
= ( FieldNullable SqlInt8
, FieldNullable SqlInt8
)
followLeftJoin :: SelectArr (Follow -> Field SqlBool) FollowNullable
followLeftJoin = leftJoinA followSelect
userFollowLeftJoin :: SelectArr (Field SqlInt8) FollowNullable
userFollowLeftJoin =
proc userId ->
followLeftJoin -< (\follow -> (follow ^. _1) .== userId)
isFollowedBy :: Int64 -> SelectArr FollowNullable (Field SqlBool)
isFollowedBy userId = proc follow ->
returnA -< matchNullable (constant False) (.== constant userId) (follow ^. _2)
userAggregator :: Aggregator User User
userAggregator =
p6
( groupBy
, groupBy
, groupBy
, groupBy
, groupBy
, groupBy
)
type DecoratedUser
= ( User
, Field SqlBool
)
decoratedUser :: Maybe Int64 -> Select DecoratedUser
decoratedUser currentUserId = aggregate (p2 (userAggregator, boolOr)) $ proc () -> do
user <- userSelect -< ()
follow <- userFollowLeftJoin -< user ^. _1
followed <- maybe (pure (constant False)) isFollowedBy currentUserId -< follow
returnA -< (user, followed)
decoratedUserAggregator :: Aggregator DecoratedUser DecoratedUser
decoratedUserAggregator = p2 (userAggregator, groupBy)
type Article
= ( Field SqlInt8
, Field SqlText
, Field SqlText
, Field SqlText
, Field SqlText
, Field SqlTimestamptz
, Field SqlTimestamptz
, Field SqlInt8
)
articleTable :: Table Article Article
articleTable =
table "articles" $
p8
( tableField "id"
, tableField "slug"
, tableField "title"
, tableField "description"
, tableField "body"
, tableField "created_at"
, tableField "updated_at"
, tableField "author__id"
)
articleSelect :: Select Article
articleSelect = selectTable articleTable
articleAndDecoratedAuthorSelect :: Maybe Int64 -> Select (Article, DecoratedUser)
articleAndDecoratedAuthorSelect currentUserId =
proc () -> do
article <- articleSelect -< ()
author <- decoratedUser currentUserId -< ()
restrict -< (article ^. _8) .== (author ^. _1 . _1)
returnA -< (article, author)
type Favorite
= ( Field SqlInt8
, Field SqlInt8
)
favoriteTable :: Table Favorite Favorite
favoriteTable =
table "favorites" $
p2
( tableField "article__id"
, tableField "user__id"
)
favoriteSelect :: Select Favorite
favoriteSelect = selectTable favoriteTable
type FavoriteNullable
= ( FieldNullable SqlInt8
, FieldNullable SqlInt8
)
favoriteLeftJoin :: SelectArr (Favorite -> Field SqlBool) FavoriteNullable
favoriteLeftJoin = leftJoinA favoriteSelect
articleFavoriteLeftJoin :: SelectArr (Field SqlInt8) FavoriteNullable
articleFavoriteLeftJoin =
proc articleId ->
favoriteLeftJoin -< (\ favorite -> (favorite ^. _1) .== articleId)
isFavoriteBy :: Int64 -> SelectArr FavoriteNullable (Field SqlBool)
isFavoriteBy userId = proc favorite ->
returnA -< matchNullable (constant False) (.== constant userId) (favorite ^. _2)
type Tag
= ( Field SqlInt8
, Field SqlText
)
tagTable :: Table Tag Tag
tagTable =
table "article_tags" $
p2
( tableField "article__id"
, tableField "tag__name"
)
tagSelect :: Select Tag
tagSelect = selectTable tagTable
type TagNullable
= ( FieldNullable SqlInt8
, FieldNullable SqlText
)
tagLeftJoin :: SelectArr (Tag -> Field SqlBool) TagNullable
tagLeftJoin = leftJoinA tagSelect
articleTagLeftJoin :: SelectArr (Field SqlInt8) TagNullable
articleTagLeftJoin =
proc articleId ->
tagLeftJoin -< (\ articleTag -> (articleTag ^. _1) .== articleId)
articleAggregator :: Aggregator Article Article
articleAggregator =
p8
( groupBy
, groupBy
, groupBy
, groupBy
, groupBy
, groupBy
, groupBy
, groupBy
)
type UnaggregatedDecoratedArticle
= ( Article
, DecoratedUser
, TagNullable
, FavoriteNullable
)
unaggregatedDecoratedArticleSelect :: Maybe Int64 -> Select UnaggregatedDecoratedArticle
unaggregatedDecoratedArticleSelect currentUserId =
proc () -> do
(article, author) <- articleAndDecoratedAuthorSelect currentUserId -< ()
favorite <- articleFavoriteLeftJoin -< article ^. _8
tag <- articleTagLeftJoin -< article ^. _8
returnA -< (article, author, tag, favorite)
type DecoratedArticle
= ( Article
, DecoratedUser
, Field (SqlArray (Nullable SqlText))
, Field SqlInt8
, Field SqlBool
)
guardTaggedWith :: [Text] -> SelectArr (FieldNullable SqlText) ()
guardTaggedWith tags = proc nullableTag ->
restrict -< matchNullable (constant False) (in_ (map constant tags)) nullableTag
guardAuthoredBy :: [Text] -> SelectArr (Field SqlText) ()
guardAuthoredBy usernames = proc username ->
restrict -< in_ (map constant usernames) username
decoratedArticleSelect :: Maybe Int64 -> [Text] -> [Text] -> Select DecoratedArticle
decoratedArticleSelect currentUserId usernames tags =
aggregate
(p5
( articleAggregator
, decoratedUserAggregator
, arrayAgg
, count
, boolOr)) $
proc () -> do
(article, author, tag, favorite) <- unaggregatedDecoratedArticleSelect currentUserId -< ()
bool (guardAuthoredBy usernames) (pure ()) (null usernames) -< author ^. _1 . _4
bool (guardTaggedWith tags) (pure ()) (null tags) -< tag ^. _2
favorited <- maybe (pure (constant False)) isFavoriteBy currentUserId -< favorite
returnA -< (article, author, tag ^. _2, favorite ^. _2, favorited)
main :: IO ()
main = do
printSql $ decoratedArticleSelect Nothing [] []
printSql $ decoratedArticleSelect (Just 1) ["bob"] ["cats"]
Raw
plan
QUERY PLAN
-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
HashAggregate (cost=111.84..112.75 rows=73 width=358)
Group Key: "T1".id, "T1_3".id, "T1_3".password, "T1_3".email, "T1_3".username, "T1_3".bio, "T1_3".image, (bool_or(CASE WHEN ("T1_4".followee__id IS NULL) THEN false ELSE ("T1_4".followee__id = 1) END))
-> Hash Right Join (cost=67.89..109.65 rows=73 width=353)
Hash Cond: ("T1_1".article__id = "T1".author__id)
-> Seq Scan on favorites "T1_1" (cost=0.00..32.60 rows=2260 width=8)
-> Hash (cost=67.82..67.82 rows=6 width=349)
-> Nested Loop Left Join (cost=50.88..67.82 rows=6 width=349)
Filter: CASE WHEN ("T1_2".tag__name IS NULL) THEN false ELSE ("T1_2".tag__name = 'cats'::text) END
-> Hash Join (cost=50.73..66.94 rows=2 width=317)
Hash Cond: ("T1".author__id = "T1_3".id)
-> Seq Scan on articles "T1" (cost=0.00..14.50 rows=450 width=152)
-> Hash (cost=50.72..50.72 rows=1 width=165)
-> HashAggregate (cost=50.70..50.71 rows=1 width=165)
Group Key: "T1_3".id
-> Hash Right Join (cost=1.04..42.22 rows=1130 width=168)
Hash Cond: ("T1_4".follower__id = "T1_3".id)
-> Seq Scan on follows "T1_4" (cost=0.00..32.60 rows=2260 width=8)
-> Hash (cost=1.02..1.02 rows=1 width=164)
-> Seq Scan on users "T1_3" (cost=0.00..1.02 rows=1 width=164)
Filter: (username = 'bob'::text)
-> Index Only Scan using article_tags_article__id_tag__name_key on article_tags "T1_2" (cost=0.15..0.36 rows=6 width=36)
Index Cond: (article__id = "T1".author__id)
(22 rows)
Raw
query.sql
SELECT
"result0_10" as "result1_11",
"result1_10" as "result2_11",
"result2_10" as "result3_11",
"result3_10" as "result4_11",
"result4_10" as "result5_11",
"result5_10" as "result6_11",
"result6_10" as "result7_11",
"result7_10" as "result8_11",
"result8_10" as "result9_11",
"result9_10" as "result10_11",
"result10_10" as "result11_11",
"result11_10" as "result12_11",
"result12_10" as "result13_11",
"result13_10" as "result14_11",
"result14_10" as "result15_11",
"result15_10" as "result16_11",
"result16_10" as "result17_11",
"result17_10" as "result18_11"
FROM (SELECT
*
FROM (SELECT
"id0_1" as "result0_10",
"slug1_1" as "result1_10",
"title2_1" as "result2_10",
"description3_1" as "result3_10",
"body4_1" as "result4_10",
"created_at5_1" as "result5_10",
"updated_at6_1" as "result6_10",
"author__id7_1" as "result7_10",
"result0_5" as "result8_10",
"result1_5" as "result9_10",
"result2_5" as "result10_10",
"result3_5" as "result11_10",
"result4_5" as "result12_10",
"result5_5" as "result13_10",
"result6_5" as "result14_10",
ARRAY_AGG("result2_1_9") as "result15_10",
COUNT("result2_1_7") as "result16_10",
BOOL_OR(CASE WHEN ("result2_1_7") IS NULL THEN FALSE ELSE ("result2_1_7") = 1 END) as "result17_10"
FROM (SELECT
*
FROM (SELECT *
FROM
(SELECT
0,
*
FROM (SELECT *
FROM
(SELECT
0,
*
FROM (SELECT
*
FROM (SELECT
"id" as "id0_1",
"slug" as "slug1_1",
"title" as "title2_1",
"description" as "description3_1",
"body" as "body4_1",
"created_at" as "created_at5_1",
"updated_at" as "updated_at6_1",
"author__id" as "author__id7_1"
FROM "articles" as "T1") as "T1",
(SELECT
"id0_2" as "result0_5",
"password1_2" as "result1_5",
"email2_2" as "result2_5",
"username3_2" as "result3_5",
"bio4_2" as "result4_5",
"image5_2" as "result5_5",
BOOL_OR(CASE WHEN ("result2_1_4") IS NULL THEN FALSE ELSE ("result2_1_4") = 1 END) as "result6_5"
FROM (SELECT *
FROM
(SELECT
0,
*
FROM (SELECT
*
FROM (SELECT
"id" as "id0_2",
"password" as "password1_2",
"email" as "email2_2",
"username" as "username3_2",
"bio" as "bio4_2",
"image" as "image5_2"
FROM "users" as "T1") as "T1") as "T1") as "T1"
LEFT OUTER JOIN
(SELECT
"follower__id0_3" as "result2_0_4",
"followee__id1_3" as "result2_1_4",
*
FROM (SELECT
*
FROM (SELECT
"follower__id" as "follower__id0_3",
"followee__id" as "followee__id1_3"
FROM "follows" as "T1") as "T1") as "T1") as "T2"
ON
("result2_0_4") = ("id0_2")) as "T1"
GROUP BY "id0_2",
"password1_2",
"email2_2",
"username3_2",
"bio4_2",
"image5_2") as "T2"
WHERE (("author__id7_1") = ("result0_5"))) as "T1") as "T1"
LEFT OUTER JOIN
(SELECT
"article__id0_6" as "result2_0_7",
"user__id1_6" as "result2_1_7",
*
FROM (SELECT
*
FROM (SELECT
"article__id" as "article__id0_6",
"user__id" as "user__id1_6"
FROM "favorites" as "T1") as "T1") as "T1") as "T2"
ON
("result2_0_7") = ("author__id7_1")) as "T1") as "T1"
LEFT OUTER JOIN
(SELECT
"article__id0_8" as "result2_0_9",
"tag__name1_8" as "result2_1_9",
*
FROM (SELECT
*
FROM (SELECT
"article__id" as "article__id0_8",
"tag__name" as "tag__name1_8"
FROM "article_tags" as "T1") as "T1") as "T1") as "T2"
ON
("result2_0_9") = ("author__id7_1")) as "T1"
WHERE (CASE WHEN ("result2_1_9") IS NULL THEN FALSE ELSE "result2_1_9" IN (E'cats') END) AND ("result3_5" IN (E'bob'))) as "T1"
GROUP BY "id0_1",
"slug1_1",
"title2_1",
"description3_1",
"body4_1",
"created_at5_1",
"updated_at6_1",
"author__id7_1",
"result0_5",
"result1_5",
"result2_5",
"result3_5",
"result4_5",
"result5_5",
"result6_5") as "T1") as "T1"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment