GenreQuery.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module WikiMusic.PostgreSQL.GenreQuery () where

import Control.Concurrent.Async
import Data.Map (elems, keys)
import Data.Map qualified as Map
import Data.Text (pack)
import Hasql.Decoders as D
import Hasql.Encoders as E
import Hasql.Session qualified as Session
import Hasql.Statement (Statement (..))
import WikiMusic.Free.GenreQuery
import WikiMusic.Model.Artwork
import WikiMusic.Model.Comment
import WikiMusic.Model.Genre
import WikiMusic.Model.Opinion
import WikiMusic.Model.Other
import WikiMusic.Model.Thread as CommentThread
import WikiMusic.PostgreSQL.Model.Genre
import WikiMusic.PostgreSQL.ReadAbstraction qualified as ReadAbstraction
import WikiMusic.Protolude

instance Exec GenreQuery where
  execAlgebra (FetchGenres env sortOrder limit offset next) =
    next =<< fetchGenres' env sortOrder limit offset
  execAlgebra (FetchGenresByUUID env sortOrder identifiers next) =
    next =<< fetchGenresByUUID' env sortOrder identifiers
  execAlgebra (EnrichedGenreResponse env genreMap enrichGenreParams next) =
    next =<< enrichedGenreResponse' env genreMap enrichGenreParams
  execAlgebra (FetchGenreComments env identifiers next) =
    next =<< fetchGenreComments' env identifiers
  execAlgebra (FetchGenreOpinions env identifiers next) =
    next =<< fetchGenreOpinions' env identifiers
  execAlgebra (SearchGenres env searchInput sortOrder limit offset next) =
    next =<< searchGenres' env searchInput sortOrder limit offset
  execAlgebra (FetchGenreArtworks env identifiers next) =
    next =<< fetchGenreArtworks' env identifiers

-- | PostgreSQL genre row Hasql decoder for reading from `genres` table
genreRowDecoder :: Result [GenreRow]
genreRowDecoder =
  D.rowList $
    (,,,,,,,,,,,,,)
      <$> D.column (D.nonNullable D.uuid)
      <*> D.column (D.nullable D.uuid)
      <*> D.column (D.nonNullable D.text)
      <*> D.column (D.nonNullable D.uuid)
      <*> D.column (D.nonNullable D.int8)
      <*> D.column (D.nullable D.uuid)
      <*> D.column (D.nonNullable D.timestamptz)
      <*> D.column (D.nullable D.timestamptz)
      <*> D.column (D.nullable D.text)
      <*> D.column (D.nullable D.text)
      <*> D.column (D.nullable D.text)
      <*> D.column (D.nullable D.text)
      <*> D.column (D.nonNullable D.int8)
      <*> D.column (D.nullable D.text)

-- | Parse a PostgreSQL Hasql row to a domain representation of genre
parseGenreRows :: [GenreRow] -> [(UUID, Genre)]
parseGenreRows = map parser
  where
    parser row = let genre = genreFromRow row in (genre ^. #identifier, genre)

-- | Fetch genres from storage, according to a sort order, limit and offset
fetchGenres' :: (MonadIO m) => Env -> GenreSortOrder -> Limit -> Offset -> m (Map UUID Genre, [UUID])
fetchGenres' env sortOrder (Limit limit) (Offset offset) =
  ReadAbstraction.persistenceReadCall
    (env ^. #pool)
    (Session.statement (fromIntegral limit, fromIntegral offset) stmt)
    (\xs -> (fromList xs, map fst xs))
    parseGenreRows
  where
    stmt = Statement query encoder genreRowDecoder True
    sortOrder' = fromString . WikiMusic.Model.Genre.show $ sortOrder
    query =
      encodeUtf8
        [untrimming|
        SELECT genres.identifier, genres.parent_identifier, genres.display_name, genres.created_by,
        genres.visibility_status, genres.approved_by, genres.created_at, genres.last_edited_at,
        spotify_url, youtube_url, soundcloud_url, wikipedia_url, genres.views, genres.description
        FROM genres
        LEFT JOIN genre_external_sources ON genre_external_sources.genre_identifier = genres.identifier
        ORDER BY $sortOrder'
        LIMIT ($$1) OFFSET $$2
      |]
    encoder =
      contrazip2
        (E.param . E.nonNullable $ E.int8)
        (E.param . E.nonNullable $ E.int8)

-- | Fetch genres by UUID from storage, according to a sort order
fetchGenresByUUID' :: (MonadIO m) => Env -> GenreSortOrder -> [UUID] -> m (Map UUID Genre, [UUID])
fetchGenresByUUID' env sortOrder identifiers =
  ReadAbstraction.persistenceReadCall
    (env ^. #pool)
    (Session.statement identifiers stmt)
    (\xs -> (fromList xs, map fst xs))
    parseGenreRows
  where
    stmt = Statement query encoder genreRowDecoder True
    sortOrder' = fromString . WikiMusic.Model.Genre.show $ sortOrder
    query =
      encodeUtf8
        [untrimming|
        SELECT genres.identifier, genres.parent_identifier, genres.display_name, genres.created_by,
        genres.visibility_status, genres.approved_by, genres.created_at, genres.last_edited_at,
        spotify_url, youtube_url, soundcloud_url, wikipedia_url, genres.views, genres.description 
        FROM genres 
        LEFT JOIN genre_external_sources ON genre_external_sources.genre_identifier = genres.identifier
        WHERE genres.identifier = ANY($$1) ORDER BY $sortOrder'            
      |]
    encoder = E.param . E.nonNullable $ E.foldableArray . E.nonNullable $ E.uuid

-- | Fetch genre artworks from storage
fetchGenreArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID GenreArtwork)
fetchGenreArtworks' env identifiers =
  ReadAbstraction.fetchArtworks
    (env ^. #pool)
    (parseArtworkRows fromRow)
    "genre_artworks"
    "genre_identifier"
    (vectorFromList identifiers)
  where
    fromRow
      ( identifier,
        genreIdentifier,
        createdBy,
        visibilityStatus,
        approvedBy,
        contentUrl,
        contentCaption,
        createdAt,
        lastEditedAt,
        orderValue
        ) =
        let artwork =
              Artwork
                { identifier = identifier,
                  createdBy = createdBy,
                  visibilityStatus = fromIntegral visibilityStatus,
                  approvedBy = approvedBy,
                  contentUrl = contentUrl,
                  contentCaption = contentCaption,
                  createdAt = createdAt,
                  lastEditedAt = lastEditedAt,
                  orderValue = fromIntegral orderValue
                }
         in GenreArtwork {..}

-- | Enrich genres with related information, according to enrichment parameters
enrichedGenreResponse' :: (MonadIO m) => Env -> Map UUID Genre -> EnrichGenreParams -> m (Map UUID Genre)
enrichedGenreResponse' env genreMap enrichGenreParams = do
  (artworkMap, (opinionMap, commentMap)) <- liftIO $ concurrently getArtwork (concurrently getOpinion getComment)
  let enrichedGenres =
        mapMap
          ( \genre -> do
              let rawCommentMap = Map.filter (matchesGenreIdentifier genre) commentMap
                  allComments = elems rawCommentMap
                  commentThreads = map renderThread $ mkThreads allComments isChildOf' (^. #comment % #parentIdentifier)

              genre
                { comments = commentThreads,
                  artworks = filterMap (matchesGenreIdentifier genre) artworkMap,
                  opinions = filterMap (matchesGenreIdentifier genre) opinionMap
                }
          )
          genreMap

  pure enrichedGenres
  where
    matchesGenreIdentifier genre = (== genre ^. #identifier) . (^. #genreIdentifier)
    isChildOf' p x = Just (p ^. #comment % #identifier) == x ^. #comment % #parentIdentifier
    genreIds = keys genreMap
    getComment =
      if enrichGenreParams ^. #includeComments
        then exec @GenreQuery $ fetchGenreComments env genreIds
        else pure $ fromList []
    getArtwork =
      if enrichGenreParams ^. #includeArtworks
        then exec @GenreQuery $ fetchGenreArtworks env genreIds
        else pure $ fromList []
    getOpinion =
      if enrichGenreParams ^. #includeOpinions
        then exec @GenreQuery $ fetchGenreOpinions env genreIds
        else pure $ fromList []

-- | Fetch genre comments from storage
fetchGenreComments' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID GenreComment)
fetchGenreComments' env identifiers =
  ReadAbstraction.fetchComments
    (env ^. #pool)
    (parseCommentRows fromRow)
    "genre_comments"
    "genre_identifier"
    (vectorFromList identifiers)
  where
    fromRow
      ( identifier,
        genreIdentifier,
        parentIdentifier,
        createdBy,
        visibilityStatus,
        contents,
        approvedBy,
        createdAt,
        lastEditedAt
        ) =
        let comment =
              Comment
                { identifier = identifier,
                  parentIdentifier = parentIdentifier,
                  createdBy = createdBy,
                  visibilityStatus = fromIntegral visibilityStatus,
                  contents = contents,
                  approvedBy = approvedBy,
                  createdAt = createdAt,
                  lastEditedAt = lastEditedAt
                }
         in GenreComment {..}

-- | Search genres by keywords from storage, according to a sort order, limit and offset
searchGenres' :: (MonadIO m) => Env -> SearchInput -> GenreSortOrder -> Limit -> Offset -> m (Map UUID Genre, [UUID])
searchGenres' env searchInput sortOrder (Limit limit) (Offset offset) =
  ReadAbstraction.persistenceReadCall
    (env ^. #pool)
    (Session.statement (fromIntegral limit, fromIntegral offset) stmt)
    (\xs -> (fromList xs, map fst xs))
    parseGenreRows
  where
    sortOrder' = pack . WikiMusic.Model.Genre.show $ sortOrder
    searchConstraints = ReadAbstraction.mkSearchConstraints (searchInput ^. #value)
    query =
      encodeUtf8
        [untrimming|
          SELECT genres.identifier, genres.parent_identifier, genres.display_name, genres.created_by, 
          genres.visibility_status, genres.approved_by, genres.created_at, genres.last_edited_at, 
          spotify_url, youtube_url, soundcloud_url, wikipedia_url, genres.views, genres.description 
          FROM genres 
          LEFT JOIN genre_external_sources ON genre_external_sources.genre_identifier = genres.identifier 
          WHERE $searchConstraints
          ORDER BY $sortOrder'
          LIMIT ($$1) OFFSET $$2
        |]

    encoder =
      contrazip2
        (E.param . E.nonNullable $ E.int8)
        (E.param . E.nonNullable $ E.int8)
    stmt = Statement query encoder genreRowDecoder True

-- | Fetch genre opinions from storage
fetchGenreOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID GenreOpinion)
fetchGenreOpinions' env identifiers =
  ReadAbstraction.fetchOpinions
    (env ^. #pool)
    (parseOpinionRows fromRow)
    "genre_opinions"
    "genre_identifier"
    (vectorFromList identifiers)
  where
    fromRow
      ( identifier,
        genreIdentifier,
        createdBy,
        isLike,
        isDislike,
        createdAt,
        lastEditedAt
        ) =
        let opinion = Opinion {..}
         in GenreOpinion {..}