Hasql

Hasql.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Main where

import Control.Monad (replicateM)
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Char8 (ByteString)
import Data.Foldable (foldl')
import Data.Functor.Contravariant (contramap)
import Data.Int (Int64)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time (UTCTime)
import qualified Hasql.Connection as Connection
import qualified Hasql.Decoders as Decoders
import Hasql.Decoders (Row)
import qualified Hasql.Encoders as Encoders
import Hasql.Encoders (Params)
import qualified Hasql.Session as Session
import Hasql.Statement (Statement(Statement))
import qualified Hasql.Statement as Hasql
import NeatInterpolation (text)
import Prelude hiding (id)
import System.Environment (getEnv)

tagsValue :: Decoders.Value (Set Text)
tagsValue =
  Set.fromList <$>
    Decoders.array
      (Decoders.dimension replicateM (Decoders.element Decoders.text))

data Profile = Profile
  { username :: Text
  , bio :: Text
  , image :: Maybe Text
  , following :: Bool
  } deriving (Show)

profileRow :: Row Profile
profileRow =
  Profile
    <$> Decoders.column Decoders.text
    <*> Decoders.column Decoders.text
    <*> Decoders.nullableColumn Decoders.text
    <*> Decoders.column Decoders.bool

data Article = Article
  { slug :: Text
  , title :: Text
  , description :: Text
  , body :: Text
  , tagList :: Set Text
  , createdAt :: UTCTime
  , updatedAt :: UTCTime
  , favorited :: Bool
  , favoritesCount :: Int
  , author :: Profile
  } deriving (Show)

articleRow :: Row Article
articleRow =
  Article
    <$> Decoders.column Decoders.text
    <*> Decoders.column Decoders.text
    <*> Decoders.column Decoders.text
    <*> Decoders.column Decoders.text
    <*> Decoders.column tagsValue
    <*> Decoders.column Decoders.timestamptz
    <*> Decoders.column Decoders.timestamptz
    <*> Decoders.column Decoders.bool
    <*> (fromIntegral <$> Decoders.column Decoders.int8)
    <*> profileRow

data ArticleQuery = ArticleQuery
  { currentUserId :: Maybe Int
  , tagNames :: Set Text
  , usernames :: Set Text
  , limit :: Int
  , offset :: Int
  }

foldableOfTextEncoder :: Foldable t => Encoders.Value (t Text)
foldableOfTextEncoder =
  Encoders.array (Encoders.dimension foldl' (Encoders.element Encoders.text))

articleQueryEncoder :: Params ArticleQuery
articleQueryEncoder =
  contramap ((fromIntegral <$>) . currentUserId) (Encoders.nullableParam Encoders.int8) <>
  contramap tagNames (Encoders.param foldableOfTextEncoder) <>
  contramap usernames (Encoders.param foldableOfTextEncoder) <>
  contramap (fromIntegral . limit) (Encoders.param Encoders.int8) <>
  contramap (fromIntegral . offset) (Encoders.param Encoders.int8)

selectArticlesSql :: Text
selectArticlesSql =
  [text|
    select
      articles.slug as article_slug,
      articles.title as article_title,
      articles.description as article_description,
      articles.body as article_body,
      array_agg(article_tags.tag__name) as article_tags_list,
      articles.created_at as article_created_at,
      articles.updated_at as article_updated_at,
      bool_or(case when $$1 is null
        then false
        else $$1 = favorites.user__id
      end) as article_favorited,
      count(favorites.user__id) as article_favorite_count,

      users.username as profile_username,
      users.bio as profile_bio,
      users.image as profile_image,
      bool_or(case when $$1 is null
        then false
        else $$1 = follows.follower__id
      end) as profile_following

    from articles

    left join article_tags
      on articles.id = article_tags.article__id

    left join favorites
      on articles.id = favorites.article__id

    join users
      on articles.author__id = users.id

    left join follows
      on users.id = follows.followee__id

    group by
      articles.slug,
      articles.title,
      articles.description,
      articles.body,
      articles.created_at,
      articles.updated_at,
      articles.author__id,
      favorites.user__id,

      users.username,
      users.bio,
      users.image
  |]

selectFilterdArticlesSql :: Text
selectFilterdArticlesSql =
  [text|
    select
      *

    from
      (${selectArticlesSql}) as articles

    where
      case when cardinality($$2) = 0
        then true
        else $$2 && articles.article_tags_list
      end
    and
      case when cardinality($$3) = 0
        then true
        else $$3 @> array[articles.profile_username]
      end

    order by articles.article_created_at asc

    limit $$4

    offset $$5
  |]

selectArticles :: Statement ArticleQuery [Article]
selectArticles = Statement sql encoder decoder True
  where
    sql = encodeUtf8 selectFilterdArticlesSql
    encoder = articleQueryEncoder
    decoder = Decoders.rowList articleRow

selectFeedArticles :: Statement ArticleQuery [Article]
selectFeedArticles = Statement sql encoder decoder True
  where
    sql =
      encodeUtf8 [text|
        select
          *

        from
          (${selectFilterdArticlesSql}) as filtered_articles

        where
          filtered_articles.profile_following
      |]
    encoder = articleQueryEncoder
    decoder = Decoders.rowList articleRow

selectArticle :: Statement (Maybe Int, Text) (Maybe Article)
selectArticle = Statement sql encoder decoder True
  where
    sql =
      encodeUtf8 [text|
        select
          *

        from
          (${selectArticlesSql}) as articles

        where
          articles.article_slug = $$2
      |]
    encoder =
      contramap ((fromIntegral <$>) . fst) (Encoders.nullableParam Encoders.int8) <>
      contramap snd (Encoders.param Encoders.text)
    decoder = Decoders.rowMaybe articleRow

defaultArticleQuery :: ArticleQuery
defaultArticleQuery =
  ArticleQuery Nothing Set.empty Set.empty 20 0

main :: IO ()
main = do
  databaseUrl <- BS.pack <$> getEnv "DATABASE_URL"
  conn <- Connection.acquire databaseUrl
  case conn of
    Left err -> print err
    Right c -> do
      let query = defaultArticleQuery { tagNames = Set.singleton "tig" }
      print =<< Session.run (Session.statement query selectArticles) c
      print =<< Session.run (Session.statement query selectFeedArticles) c
      print =<< Session.run (Session.statement (Nothing, "a-thing") selectArticle) c