SongQuery.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.SongQuery () where

import Control.Concurrent.Async
import Data.ByteString.Lazy qualified as BL
import Data.Map (elems, keys)
import Data.Map qualified as Map
import Data.Text (intercalate, pack, strip)
import Data.Vector qualified as V
import Hasql.Decoders as D
import Hasql.Encoders as E
import Hasql.Session qualified as Session
import Hasql.Statement (Statement (..))
import WikiMusic.Free.SongQuery
import WikiMusic.Model.Artwork
import WikiMusic.Model.Comment
import WikiMusic.Model.Opinion
import WikiMusic.Model.Other
import WikiMusic.Model.Song
import WikiMusic.Model.Thread as CommentThread
import WikiMusic.PostgreSQL.Model.Song
import WikiMusic.PostgreSQL.ReadAbstraction qualified as ReadAbstraction
import WikiMusic.Protolude

fetchSongContents' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongContent)
fetchSongContents' env identifiers = do
  let fromRow
        ( identifier,
          songIdentifier,
          versionName,
          createdBy,
          visibilityStatus,
          approvedBy,
          instrumentType,
          asciiLegend,
          asciiContents,
          pdfContents,
          guitarProContents,
          createdAt,
          lastEditedAt
          ) =
          SongContent
            { identifier = identifier,
              songIdentifier = songIdentifier,
              versionName = versionName,
              createdBy = createdBy,
              visibilityStatus = fromIntegral visibilityStatus,
              approvedBy = approvedBy,
              instrumentType = instrumentType,
              asciiLegend = asciiLegend,
              asciiContents = asciiContents,
              pdfContents = pdfContents,
              guitarProContents = guitarProContents,
              createdAt = createdAt,
              lastEditedAt = lastEditedAt
            }
      stmt = Statement query encoder decoder True
      query =
        encodeUtf8
          [trimming|
          SELECT identifier, song_identifier, version_name, created_by, visibility_status,
          approved_by, instrument_type, ascii_legend,
          ascii_contents, pdf_contents, guitarpro_contents, created_at, last_edited_at
          FROM song_contents
          WHERE song_identifier = ANY($$1)
         |]
      encoder =
        E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid)
      decoder = D.rowVector vector
      vector =
        (,,,,,,,,,,,,)
          <$> D.column (D.nonNullable D.uuid)
          <*> 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.text)
          <*> 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.timestamptz)
          <*> D.column (D.nullable D.timestamptz)
      parseSongContentRows =
        map
          ( \row ->
              let songContent :: SongContent = fromRow row
               in (songContent ^. #identifier, songContent)
          )

  ReadAbstraction.persistenceReadCall
    (env ^. #pool)
    (Session.statement identifiers stmt)
    fromList
    (parseSongContentRows . V.toList)

-- | PostgreSQL song row Hasql decoder for reading from `songs` table
songRowDecoder :: Result [SongRow]
songRowDecoder =
  D.rowList $
    (,,,,,,,,,,,,,,,,,)
      <$> D.column (D.nonNullable D.uuid)
      <*> D.column (D.nonNullable D.text)
      <*> 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.nullable 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 song
parseSongRows :: [SongRow] -> [(UUID, Song)]
parseSongRows = map parser
  where
    parser row = let song = songFromRow row in (song ^. #identifier, song)

-- | Fetch song artworks from storage
fetchSongArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongArtwork)
fetchSongArtworks' env identifiers =
  ReadAbstraction.fetchArtworks
    (env ^. #pool)
    (parseArtworkRows fromRow)
    "song_artworks"
    "song_identifier"
    (vectorFromList identifiers)
  where
    fromRow
      ( identifier,
        songIdentifier,
        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 SongArtwork {..}

-- | Fetch song comments from storage
fetchSongComments' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongComment)
fetchSongComments' env identifiers =
  ReadAbstraction.fetchComments
    (env ^. #pool)
    (parseCommentRows fromRow)
    "song_comments"
    "song_identifier"
    (vectorFromList identifiers)
  where
    fromRow
      ( identifier,
        songIdentifier,
        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 SongComment {..}

-- | Fetch song opinions from storage
fetchSongOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongOpinion)
fetchSongOpinions' env identifiers =
  ReadAbstraction.fetchOpinions
    (env ^. #pool)
    (parseOpinionRows fromRow)
    "song_opinions"
    "song_identifier"
    (vectorFromList identifiers)
  where
    fromRow
      ( identifier,
        songIdentifier,
        createdBy,
        isLike,
        isDislike,
        createdAt,
        lastEditedAt
        ) =
        let opinion = Opinion {..}
         in SongOpinion {..}

fetchSongs' :: (MonadIO m) => Env -> SongSortOrder -> Limit -> Offset -> m (Map UUID Song, [UUID])
fetchSongs' env sortOrder (Limit limit) (Offset offset) = do
  ReadAbstraction.persistenceReadCall
    (env ^. #pool)
    (Session.statement (fromIntegral limit, fromIntegral offset) stmt)
    (\queryResults -> (fromList queryResults, map fst queryResults))
    parseSongRows
  where
    sortOrder' = pack . WikiMusic.Model.Song.show $ sortOrder
    query =
      encodeUtf8
        [trimming|
                  SELECT songs.identifier, songs.display_name, songs.music_key,
                  songs.music_tuning, songs.music_creation_date, songs.album_name, songs.album_info_link,
                  songs.created_by, songs.visibility_status, songs.approved_by, songs.created_at, songs.last_edited_at,
                  spotify_url, youtube_url, soundcloud_url, wikipedia_url, songs.views, songs.description
                  FROM songs
                  LEFT JOIN song_external_sources ON song_external_sources.song_identifier = songs.identifier
                  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 songRowDecoder True

fetchSongsByUUID' :: (MonadIO m) => Env -> SongSortOrder -> [UUID] -> m (Map UUID Song, [UUID])
fetchSongsByUUID' env sortOrder identifiers = do
  ReadAbstraction.persistenceReadCall
    (env ^. #pool)
    (Session.statement identifiers stmt)
    (\queryResults -> (fromList queryResults, map fst queryResults))
    parseSongRows
  where
    stmt = Statement (BL.toStrict query) encoder songRowDecoder True
    sortOrder' = fromString . WikiMusic.Model.Song.show $ sortOrder
    query =
      encodeUtf8
        [trimming|
          SELECT songs.identifier, songs.display_name, songs.music_key,
          songs.music_tuning, songs.music_creation_date, songs.album_name, songs.album_info_link,
          songs.created_by, songs.visibility_status, songs.approved_by, songs.created_at, songs.last_edited_at,
          spotify_url, youtube_url, soundcloud_url, wikipedia_url, songs.views, songs.description
          FROM songs
          LEFT JOIN song_external_sources ON song_external_sources.song_identifier = songs.identifier
          WHERE songs.identifier = ANY($$1) ORDER BY $sortOrder'
          |]
    encoder = E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid)

instance Exec SongQuery where
  execAlgebra (FetchSongs env sortOrder limit offset next) = next =<< fetchSongs' env sortOrder limit offset
  execAlgebra (FetchSongsByUUID env sortOrder identifiers next) = next =<< fetchSongsByUUID' env sortOrder identifiers
  execAlgebra (EnrichedSongResponse env songMap enrichSongParams next) = do
    let isChildOf' p x = Just (p ^. #comment % #identifier) == (x ^. #comment % #parentIdentifier)
        songIds = keys songMap
        getComment =
          if enrichSongParams ^. #includeComments
            then exec @SongQuery $ fetchSongComments env songIds
            else pure $ fromList []
        getArtwork =
          if enrichSongParams ^. #includeArtworks
            then exec @SongQuery $ fetchSongArtworks env songIds
            else pure $ fromList []
        getOpinion =
          if enrichSongParams ^. #includeOpinions
            then exec @SongQuery $ fetchSongOpinions env songIds
            else pure $ fromList []
        getArtist =
          if enrichSongParams ^. #includeArtists
            then exec @SongQuery $ fetchSongArtists env songIds
            else pure $ fromList []
        getContent =
          if enrichSongParams ^. #includeContents
            then exec @SongQuery $ fetchSongContents env songIds
            else pure $ fromList []

    (commentMap, artworkMap) <- concurrently getComment getArtwork
    (contentMap, opinionMap) <- concurrently getContent getOpinion
    artistPerSongList <- getArtist
    let matchesSongIdentifier song = (== song ^. #identifier) . (^. #songIdentifier)
    let enrichedSongs =
          mapMap
            ( \song -> do
                let rawCommentMap = Map.filter (matchesSongIdentifier song) commentMap
                    allComments = elems rawCommentMap
                    commentThreads = map renderThread $ mkThreads allComments isChildOf' (^. #comment % #parentIdentifier)
                    relevantArtists = filter (\(songId, _, _) -> songId == song ^. #identifier) artistPerSongList

                song
                  { comments = commentThreads,
                    contents = filterMap (matchesSongIdentifier song) contentMap,
                    artworks = filterMap (matchesSongIdentifier song) artworkMap,
                    opinions = filterMap (matchesSongIdentifier song) opinionMap,
                    artists = Map.fromList $ map (\(_, artistId, artistName) -> (artistId, artistName)) relevantArtists
                  }
            )
            songMap
    next enrichedSongs
  execAlgebra (FetchSongComments env identifiers next) =
    next =<< fetchSongComments' env identifiers
  execAlgebra (FetchSongOpinions env identifiers next) =
    next =<< fetchSongOpinions' env identifiers
  execAlgebra (FetchSongArtworks env identifiers next) =
    next =<< fetchSongArtworks' env identifiers
  execAlgebra (FetchSongArtists env identifiers next) = do
    let stmt = Statement query encoder decoder True
        query =
          "SELECT song_artists.song_identifier, artists.identifier, artists.display_name FROM song_artists \
          \ INNER JOIN artists ON song_artists.artist_identifier = artists.identifier \
          \ WHERE song_identifier = ANY($1)"
        encoder =
          E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid)
        decoder = D.rowVector vector
        vector =
          (,,)
            <$> D.column (D.nonNullable D.uuid)
            <*> D.column (D.nonNullable D.uuid)
            <*> D.column (D.nonNullable D.text)
    r <-
      ReadAbstraction.persistenceReadCall
        (env ^. #pool)
        (Session.statement identifiers stmt)
        fromList
        V.toList
    next r
  execAlgebra (SearchSongs env searchInput sortOrder (Limit limit) (Offset offset) next) = do
    let sortOrder' = pack . WikiMusic.Model.Song.show $ sortOrder
        cleanWords = map (filterText (\x -> x /= '\'' && x /= '%' && x /= ';' && x /= '"') . strip) (words $ searchInput ^. #value)
        inputs = map (\x -> [untrimming|songs.display_name ILIKE '%$x%' OR songs.album_name ILIKE '%$x%'|]) cleanWords
        search' = Data.Text.intercalate " AND " inputs
        query =
          [untrimming|
           SELECT songs.identifier, songs.display_name, songs.music_key,
           songs.music_tuning, songs.music_creation_date, songs.album_name, songs.album_info_link,
           songs.created_by, songs.visibility_status, songs.approved_by, songs.created_at, songs.last_edited_at,
           spotify_url, youtube_url, soundcloud_url, wikipedia_url, songs.views, songs.description
           FROM songs
           LEFT JOIN song_external_sources ON song_external_sources.song_identifier = songs.identifier
           WHERE ${search'}
           ORDER BY ${sortOrder'}
           LIMIT ($$1) OFFSET $$2
          |]

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

    r <-
      ReadAbstraction.persistenceReadCall
        (env ^. #pool)
        (Session.statement (fromIntegral limit, fromIntegral offset) stmt)
        (\queryResults -> (fromList queryResults, map fst queryResults))
        parseSongRows
    next r
  execAlgebra (FetchSongContents env identifiers next) = next =<< fetchSongContents' env identifiers