ArtistQuery.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.ArtistQuery () 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.ArtistQuery
import WikiMusic.Model.Artist
import WikiMusic.Model.Artwork
import WikiMusic.Model.Comment
import WikiMusic.Model.Opinion
import WikiMusic.Model.Other
import WikiMusic.Model.Thread as CommentThread
import WikiMusic.PostgreSQL.Model.Artist
import WikiMusic.PostgreSQL.ReadAbstraction qualified as ReadAbstraction
import WikiMusic.Protolude

instance Exec ArtistQuery where
  execAlgebra (FetchArtists env sortOrder limit offset next) =
    next =<< fetchArtists' env sortOrder limit offset
  execAlgebra (FetchArtistsByUUID env sortOrder identifiers next) =
    next =<< fetchArtistsByUUID' env sortOrder identifiers
  execAlgebra (EnrichedArtistResponse env artistMap enrichArtistParams next) =
    next =<< enrichedArtistResponse' env artistMap enrichArtistParams
  execAlgebra (FetchArtistComments env identifiers next) =
    next =<< fetchArtistComments' env identifiers
  execAlgebra (FetchArtistOpinions env identifiers next) =
    next =<< fetchArtistOpinions' env identifiers
  execAlgebra (SearchArtists env searchInput sortOrder limit offset next) =
    next =<< searchArtists' env searchInput sortOrder limit offset
  execAlgebra (FetchArtistArtworks env identifiers next) =
    next =<< fetchArtistArtworks' env identifiers

-- | PostgreSQL artist row Hasql decoder for reading from `artists` table
artistRowDecoder :: Result [ArtistRow]
artistRowDecoder =
  D.rowList $
    (,,,,,,,,,,,,)
      <$> D.column (D.nonNullable 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 artist
parseArtistRows :: [ArtistRow] -> [(UUID, Artist)]
parseArtistRows = map parser
  where
    parser row = let artist = artistFromRow row in (artist ^. #identifier, artist)

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

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

-- | Fetch artist artworks from storage
fetchArtistArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID ArtistArtwork)
fetchArtistArtworks' env identifiers =
  ReadAbstraction.fetchArtworks
    (env ^. #pool)
    (parseArtworkRows fromRow)
    "artist_artworks"
    "artist_identifier"
    (vectorFromList identifiers)
  where
    fromRow
      ( identifier,
        artistIdentifier,
        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 ArtistArtwork {..}

-- | Enrich artists with related information, according to enrichment parameters
enrichedArtistResponse' :: (MonadIO m) => Env -> Map UUID Artist -> EnrichArtistParams -> m (Map UUID Artist)
enrichedArtistResponse' env artistMap enrichArtistParams = do
  (artworkMap, (opinionMap, commentMap)) <- liftIO $ concurrently getArtwork (concurrently getOpinion getComment)
  let enrichedArtists =
        mapMap
          ( \artist -> do
              let rawCommentMap = Map.filter (matchesArtistIdentifier artist) commentMap
                  allComments = elems rawCommentMap
                  commentThreads = map renderThread $ mkThreads allComments isChildOf' (^. #comment % #parentIdentifier)

              artist
                { comments = commentThreads,
                  artworks = filterMap (matchesArtistIdentifier artist) artworkMap,
                  opinions = filterMap (matchesArtistIdentifier artist) opinionMap
                }
          )
          artistMap

  pure enrichedArtists
  where
    matchesArtistIdentifier artist = (== artist ^. #identifier) . (^. #artistIdentifier)
    isChildOf' p x = Just (p ^. #comment % #identifier) == x ^. #comment % #parentIdentifier
    artistIds = keys artistMap
    getComment =
      if enrichArtistParams ^. #includeComments
        then exec @ArtistQuery $ fetchArtistComments env artistIds
        else pure $ fromList []
    getArtwork =
      if enrichArtistParams ^. #includeArtworks
        then exec @ArtistQuery $ fetchArtistArtworks env artistIds
        else pure $ fromList []
    getOpinion =
      if enrichArtistParams ^. #includeOpinions
        then exec @ArtistQuery $ fetchArtistOpinions env artistIds
        else pure $ fromList []

-- | Fetch artist comments from storage
fetchArtistComments' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID ArtistComment)
fetchArtistComments' env identifiers =
  ReadAbstraction.fetchComments
    (env ^. #pool)
    (parseCommentRows fromRow)
    "artist_comments"
    "artist_identifier"
    (vectorFromList identifiers)
  where
    fromRow
      ( identifier,
        artistIdentifier,
        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 ArtistComment {..}

-- | Search artists by keywords from storage, according to a sort order, limit and offset
searchArtists' :: (MonadIO m) => Env -> SearchInput -> ArtistSortOrder -> Limit -> Offset -> m (Map UUID Artist, [UUID])
searchArtists' env searchInput sortOrder (Limit limit) (Offset offset) =
  ReadAbstraction.persistenceReadCall
    (env ^. #pool)
    (Session.statement (fromIntegral limit, fromIntegral offset) stmt)
    (\xs -> (fromList xs, map fst xs))
    parseArtistRows
  where
    sortOrder' = pack . WikiMusic.Model.Artist.show $ sortOrder
    searchConstraints = ReadAbstraction.mkSearchConstraints (searchInput ^. #value)
    query =
      encodeUtf8
        [untrimming|
          SELECT artists.identifier, artists.display_name, artists.created_by, 
          artists.visibility_status, artists.approved_by, artists.created_at, artists.last_edited_at, 
          spotify_url, youtube_url, soundcloud_url, wikipedia_url, artists.views, artists.description 
          FROM artists 
          LEFT JOIN artist_external_sources ON artist_external_sources.artist_identifier = artists.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 artistRowDecoder True

-- | Fetch artist opinions from storage
fetchArtistOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID ArtistOpinion)
fetchArtistOpinions' env identifiers =
  ReadAbstraction.fetchOpinions
    (env ^. #pool)
    (parseOpinionRows fromRow)
    "artist_opinions"
    "artist_identifier"
    (vectorFromList identifiers)
  where
    fromRow
      ( identifier,
        artistIdentifier,
        createdBy,
        isLike,
        isDislike,
        createdAt,
        lastEditedAt
        ) =
        let opinion = Opinion {..}
         in ArtistOpinion {..}