GenreCommand.hs

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

module WikiMusic.PostgreSQL.GenreCommand () where

import Data.Text (pack)
import Hasql.Decoders as D
import Hasql.Encoders as E
import Hasql.Pool qualified
import Hasql.Statement (Statement (..))
import Relude
import WikiMusic.Free.GenreCommand
import WikiMusic.Interaction.Model.Genre
import WikiMusic.Model.Artwork
import WikiMusic.Model.Comment
import WikiMusic.Model.Genre
import WikiMusic.Model.Opinion
import WikiMusic.PostgreSQL.ReadAbstraction
import WikiMusic.PostgreSQL.WriteAbstraction
import WikiMusic.Protolude

insertGenres' :: (MonadIO m) => Env -> [Genre] -> m (Map UUID Genre)
insertGenres' env genres = do
  mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) genres
  now <- liftIO getCurrentTime
  mapM_
    ( \x -> do
        newUUID <- liftIO nextRandom
        liftIO $ exec @GenreCommand $ insertGenreExternalSources env [toExternalSource x now newUUID]
    )
    genres
  pure . fromList . map (\x -> (x ^. #identifier, x)) $ genres
  where
    toExternalSource x now newUUID =
      GenreExternalSources
        { identifier = newUUID,
          genreIdentifier = x ^. #identifier,
          spotifyUrl = x ^. #spotifyUrl,
          youtubeUrl = x ^. #youtubeUrl,
          soundcloudUrl = x ^. #soundcloudUrl,
          wikipediaUrl = x ^. #wikipediaUrl,
          createdAt = now,
          createdBy = x ^. #createdBy,
          lastEditedAt = Nothing
        }
    toRow x =
      ( x ^. #identifier,
        x ^. #displayName,
        x ^. #createdBy,
        fromIntegral $ x ^. #visibilityStatus,
        x ^. #approvedBy,
        x ^. #createdAt,
        x ^. #lastEditedAt,
        x ^. #description
      )
    encoder =
      contrazip8
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.text))
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.int8))
        (E.param (E.nullable E.uuid))
        (E.param (E.nonNullable E.timestamptz))
        (E.param (E.nullable E.timestamptz))
        (E.param (E.nullable E.text))
    stmt = Statement query encoder D.noResult True
    bindParams' = bindParams 8
    query =
      encodeUtf8
        [trimming|
        INSERT INTO genres
          (identifier, display_name, created_by, visibility_status,
          approved_by, created_at, last_edited_at, description)
        VALUES ($bindParams')
       |]

insertGenreComments' :: (MonadIO m) => Env -> [GenreComment] -> m (Map UUID GenreComment)
insertGenreComments' env comments = do
  mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) comments
  pure . fromList . map (\x -> (x ^. #comment % #identifier, x)) $ comments
  where
    toRow x =
      ( x ^. #comment % #identifier,
        x ^. #genreIdentifier,
        x ^. #comment % #parentIdentifier,
        x ^. #comment % #createdBy,
        fromIntegral $ x ^. #comment % #visibilityStatus,
        x ^. #comment % #contents,
        x ^. #comment % #approvedBy,
        x ^. #comment % #createdAt,
        x ^. #comment % #lastEditedAt
      )
    encoder =
      contrazip9
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nullable E.uuid))
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.int8))
        (E.param (E.nonNullable E.text))
        (E.param (E.nullable E.uuid))
        (E.param (E.nonNullable E.timestamptz))
        (E.param (E.nullable E.timestamptz))
    stmt = Statement query encoder D.noResult True
    bindParams' = bindParams 9
    query =
      encodeUtf8
        [trimming|
     INSERT INTO genre_comments
       (identifier, genre_identifier, parent_identifier, created_by,
       visibility_status, contents, approved_by, created_at, last_edited_at)
     VALUES ( $bindParams' )
    |]

insertGenreExternalSources' :: (MonadIO m) => Env -> [GenreExternalSources] -> m (Map UUID GenreExternalSources)
insertGenreExternalSources' env externalSources = do
  mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) externalSources
  pure . fromList . map (\x -> (x ^. #identifier, x)) $ externalSources
  where
    stmt = Statement query encoder D.noResult True
    encoder =
      contrazip9
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nullable E.text))
        (E.param (E.nullable E.text))
        (E.param (E.nullable E.text))
        (E.param (E.nullable E.text))
        (E.param (E.nonNullable E.timestamptz))
        (E.param (E.nullable E.timestamptz))
        (E.param (E.nonNullable E.uuid))
    bindParams' = bindParams 9
    query =
      encodeUtf8
        [trimming|
                   INSERT INTO genre_external_sources
                     (identifier, genre_identifier, spotify_url, youtube_url,
                     soundcloud_url, wikipedia_url, created_at, last_edited_at, created_by)
                   VALUES ( $bindParams' )
                  |]
    toRow x =
      ( x ^. #identifier,
        x ^. #genreIdentifier,
        x ^. #spotifyUrl,
        x ^. #youtubeUrl,
        x ^. #soundcloudUrl,
        x ^. #wikipediaUrl,
        x ^. #createdAt,
        x ^. #lastEditedAt,
        x ^. #createdBy
      )

insertGenreArtworks' :: (MonadIO m) => Env -> [GenreArtwork] -> m (Map UUID GenreArtwork)
insertGenreArtworks' env artworks = do
  mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) artworks
  pure . fromList . map (\x -> (x ^. #artwork % #identifier, x)) $ artworks
  where
    toRow x =
      ( x ^. #artwork % #identifier,
        x ^. #genreIdentifier,
        x ^. #artwork % #createdBy,
        fromIntegral $ x ^. #artwork % #visibilityStatus,
        x ^. #artwork % #approvedBy,
        x ^. #artwork % #contentUrl,
        x ^. #artwork % #createdAt,
        x ^. #artwork % #lastEditedAt,
        x ^. #artwork % #contentCaption,
        fromIntegral $ x ^. #artwork % #orderValue
      )
    stmt = Statement query encoder D.noResult True
    encoder =
      contrazip10
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.int8))
        (E.param (E.nullable E.uuid))
        (E.param (E.nonNullable E.text))
        (E.param (E.nonNullable E.timestamptz))
        (E.param (E.nullable E.timestamptz))
        (E.param (E.nullable E.text))
        (E.param (E.nonNullable E.int8))
    query =
      encodeUtf8
        [trimming|
          INSERT INTO genre_artworks
            (identifier, genre_identifier, created_by, visibility_status,
            approved_by, content_url, created_at, last_edited_at, content_caption, order_value)
          VALUES ($$1, $$2, $$3, $$4, $$5, $$6, $$7, $$8, $$9, $$10)                   
         |]

upsertGenreOpinions' :: (MonadIO m) => Env -> [GenreOpinion] -> m (Map UUID GenreOpinion)
upsertGenreOpinions' env opinions = do
  mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) opinions
  pure . fromList . map (\x -> (x ^. #opinion % #identifier, x)) $ opinions
  where
    bindParams' = bindParams 7
    query =
      encodeUtf8
        [trimming|
               INSERT INTO genre_opinions
                 (identifier, genre_identifier, created_by, is_like, is_dislike,
                 created_at, last_edited_at)
               VALUES ( $bindParams' )
               ON CONFLICT (genre_identifier, created_by) DO
                 UPDATE SET is_like = $$4, is_dislike = $$5,
                 last_edited_at = $$6
              |]
    stmt = Statement query encoder D.noResult True
    encoder =
      contrazip7
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.bool))
        (E.param (E.nonNullable E.bool))
        (E.param (E.nonNullable E.timestamptz))
        (E.param (E.nullable E.timestamptz))
    toRow x = do
      ( x ^. #opinion % #identifier,
        x ^. #genreIdentifier,
        x ^. #opinion % #createdBy,
        x ^. #opinion % #isLike,
        not $ x ^. #opinion % #isLike,
        x ^. #opinion % #createdAt,
        x ^. #opinion % #lastEditedAt
        )

deleteGenres' :: (MonadIO m) => Env -> [UUID] -> m (Either GenreCommandError ())
deleteGenres' env identifiers = do
  deleteArtworksOfGenresResult <- liftIO . exec @GenreCommand $ deleteArtworksOfGenres env identifiers
  deleteOpinionsOfGenresResult <- liftIO . exec @GenreCommand $ deleteOpinionsOfGenres env identifiers
  deleteCommentsOfGenresResult <- liftIO . exec @GenreCommand $ deleteCommentsOfGenres env identifiers
  deleteGenreExternalSourcesResult <- liftIO . exec @GenreCommand $ deleteGenreExternalSources env identifiers
  deleteGenresResult <- deleteStuffByUUID (env ^. #pool) "genres" "identifier" identifiers
  pure $
    deleteArtworksOfGenresResult
      <> deleteOpinionsOfGenresResult
      <> deleteGenreExternalSourcesResult
      <> deleteCommentsOfGenresResult
      <> first fromHasqlUsageError deleteGenresResult

updateGenreArtworkOrder' :: (MonadIO m) => Env -> [GenreArtworkOrderUpdate] -> m (Either a ())
updateGenreArtworkOrder' env orderUpdates =
  Right <$> mapM_ performUpdate orderUpdates
  where
    stmt = Statement query encoder D.noResult True
    query =
      encodeUtf8
        [trimming|
        UPDATE genre_artworks SET order_value = $$2 WHERE identifier = $$1                              
        |]
    encoder =
      contrazip2 (E.param . E.nonNullable $ E.uuid) (E.param . E.nonNullable $ E.int8)
    toRow x = (x ^. #identifier, fromIntegral $ x ^. #orderValue)
    performUpdate x = do
      operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x)
      pure $ first (pack . Relude.show) operationResults

updateGenres' :: (MonadIO m) => Env -> Map UUID (Genre, Maybe GenreDelta) -> m (Either Text ())
updateGenres' env deltas = do
  liftIO $ mapM_ performUpdate deltas
  exUpdate <- liftIO $ exec @GenreCommand $ updateGenreExternalSources env deltas
  pure $ exUpdate <> Right ()
  where
    stmt = Statement query encoder D.noResult True
    query =
      encodeUtf8
        [trimming|
               UPDATE genres SET display_name = $$2, last_edited_at = $$3, description = $$4 WHERE identifier = $$1
            |]
    encoder =
      contrazip4
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nonNullable E.text))
        (E.param (E.nullable E.timestamptz))
        (E.param (E.nullable E.text))
    toRow x xDelta now =
      ( x ^. #identifier,
        fromMaybe (x ^. #displayName) (xDelta ^. #displayName),
        Just now,
        xDelta ^. #description
      )
    performUpdate (_, Nothing) = pure $ Right ()
    performUpdate (x, Just xDelta) = do
      now <- getCurrentTime
      operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x xDelta now)
      pure $ first (pack . Relude.show) operationResults

updateGenreExternalSources' :: (MonadIO m) => Env -> Map UUID (Genre, Maybe GenreDelta) -> m (Either Text ())
updateGenreExternalSources' env deltas =
  Right <$> mapM_ performUpdate deltas
  where
    stmt = Statement query encoder D.noResult True
    query =
      encodeUtf8
        [trimming|
             UPDATE genre_external_sources SET
               spotify_url = $$2,
               youtube_url = $$3,
               wikipedia_url = $$4,
               soundcloud_url = $$5
             WHERE genre_identifier = $$1
            |]

    encoder =
      contrazip5
        (E.param (E.nonNullable E.uuid))
        (E.param (E.nullable E.text))
        (E.param (E.nullable E.text))
        (E.param (E.nullable E.text))
        (E.param (E.nullable E.text))
    toRow x xDelta =
      ( x ^. #identifier,
        xDelta ^. #spotifyUrl,
        xDelta ^. #youtubeUrl,
        xDelta ^. #wikipediaUrl,
        xDelta ^. #soundcloudUrl
      )
    performUpdate (_, Nothing) = pure $ Right ()
    performUpdate (x, Just xDelta) = do
      operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x xDelta)
      pure $ first (pack . Relude.show) operationResults

newGenreArtworkFromRequest' :: (MonadIO m) => UUID -> InsertGenreArtworksRequestItem -> m GenreArtwork
newGenreArtworkFromRequest' createdBy req = do
  newUUID <- liftIO nextRandom
  now <- liftIO getCurrentTime
  pure $
    GenreArtwork
      { genreIdentifier = req ^. #genreIdentifier,
        artwork =
          Artwork
            { identifier = newUUID,
              createdBy = createdBy,
              contentUrl = req ^. #contentUrl,
              contentCaption = req ^. #contentCaption,
              createdAt = now,
              lastEditedAt = Nothing,
              visibilityStatus = 0,
              approvedBy = Nothing,
              orderValue = req ^. #orderValue
            }
      }

newGenreOpinionFromRequest' :: (MonadIO m) => UUID -> UpsertGenreOpinionsRequestItem -> m GenreOpinion
newGenreOpinionFromRequest' createdBy req = do
  newUUID <- liftIO nextRandom
  now <- liftIO getCurrentTime
  pure $
    GenreOpinion
      { genreIdentifier = req ^. #genreIdentifier,
        opinion =
          Opinion
            { identifier = newUUID,
              createdBy = createdBy,
              isLike = req ^. #isLike,
              isDislike = not $ req ^. #isLike,
              createdAt = now,
              lastEditedAt = Nothing
            }
      }

newGenreFromRequest' :: (MonadIO m) => UUID -> InsertGenresRequestItem -> m Genre
newGenreFromRequest' createdBy req = do
  newUUID <- liftIO nextRandom
  now <- liftIO getCurrentTime
  pure $
    Genre
      { identifier = newUUID,
        parentIdentifier = Nothing,
        displayName = req ^. #displayName,
        createdBy = createdBy,
        visibilityStatus = 0,
        approvedBy = Nothing,
        createdAt = now,
        lastEditedAt = Nothing,
        artworks = fromList [],
        comments = [],
        opinions = fromList [],
        spotifyUrl = req ^. #spotifyUrl,
        youtubeUrl = req ^. #youtubeUrl,
        soundcloudUrl = req ^. #soundcloudUrl,
        wikipediaUrl = req ^. #wikipediaUrl,
        viewCount = 0,
        description = req ^. #description
      }

newGenreCommentFromRequest' :: (MonadIO m) => UUID -> InsertGenreCommentsRequestItem -> m GenreComment
newGenreCommentFromRequest' createdBy x = do
  newUUID <- liftIO nextRandom
  now <- liftIO getCurrentTime
  pure $
    GenreComment
      { genreIdentifier = x ^. #genreIdentifier,
        comment =
          Comment
            { identifier = newUUID,
              parentIdentifier = x ^. #parentIdentifier,
              createdBy = createdBy,
              visibilityStatus = 0,
              contents = x ^. #contents,
              approvedBy = Nothing,
              createdAt = now,
              lastEditedAt = Nothing
            }
      }

instance Exec GenreCommand where
  execAlgebra (IncrementViewsByOne env identifiers next) = next =<< incrementViewsByOne' env identifiers "genres"
  execAlgebra (InsertGenres env genres next) = next =<< insertGenres' env genres
  execAlgebra (InsertGenreComments env comments next) = next =<< insertGenreComments' env comments
  execAlgebra (InsertGenreExternalSources env externalSources next) = next =<< insertGenreExternalSources' env externalSources
  execAlgebra (InsertGenreArtworks env artworks next) = next =<< insertGenreArtworks' env artworks
  execAlgebra (UpsertGenreOpinions env opinions next) = next =<< upsertGenreOpinions' env opinions
  execAlgebra (DeleteGenres env identifiers next) = next =<< deleteGenres' env identifiers
  execAlgebra (DeleteGenreComments env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_comments" "identifier" identifiers
  execAlgebra (DeleteGenreArtworks env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_artworks" "identifier" identifiers
  execAlgebra (DeleteGenreOpinions env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_opinions" "identifier" identifiers
  execAlgebra (DeleteCommentsOfGenres env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_comments" "genre_identifier" identifiers
  execAlgebra (DeleteGenreExternalSources env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_external_sources" "genre_identifier" identifiers
  execAlgebra (DeleteArtworksOfGenres env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_artworks" "genre_identifier" identifiers
  execAlgebra (DeleteOpinionsOfGenres env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_opinions" "genre_identifier" identifiers
  execAlgebra (UpdateGenreArtworkOrder env orderUpdates next) = next =<< updateGenreArtworkOrder' env orderUpdates
  execAlgebra (UpdateGenres env deltas next) = next =<< updateGenres' env deltas
  execAlgebra (UpdateGenreExternalSources env deltas next) = next =<< updateGenreExternalSources' env deltas
  execAlgebra (NewGenreFromRequest createdBy req next) = next =<< newGenreFromRequest' createdBy req
  execAlgebra (NewGenreCommentFromRequest createdBy req next) = next =<< newGenreCommentFromRequest' createdBy req
  execAlgebra (NewGenreOpinionFromRequest createdBy req next) = next =<< newGenreOpinionFromRequest' createdBy req
  execAlgebra (NewGenreArtworkFromRequest createdBy req next) = next =<< newGenreArtworkFromRequest' createdBy req

fromHasqlUsageError :: Hasql.Pool.UsageError -> GenreCommandError
fromHasqlUsageError = PersistenceError . pack . Relude.show