ArtistCommand.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.ArtistCommand () 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.ArtistCommand
import WikiMusic.Interaction.Model.Artist
import WikiMusic.Model.Artist
import WikiMusic.Model.Artwork
import WikiMusic.Model.Comment
import WikiMusic.Model.Opinion
import WikiMusic.PostgreSQL.ReadAbstraction
import WikiMusic.PostgreSQL.WriteAbstraction
import WikiMusic.Protolude

insertArtists' :: (MonadIO m) => Env -> [Artist] -> m (Map UUID Artist)
insertArtists' env artists = do
  mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) artists
  now <- liftIO getCurrentTime
  mapM_
    ( \x -> do
        newUUID <- liftIO nextRandom
        liftIO $ exec @ArtistCommand $ insertArtistExternalSources env [toExternalSource x now newUUID]
    )
    artists
  pure . fromList . map (\x -> (x ^. #identifier, x)) $ artists
  where
    toExternalSource x now newUUID =
      ArtistExternalSources
        { identifier = newUUID,
          artistIdentifier = 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 artists
          (identifier, display_name, created_by, visibility_status,
          approved_by, created_at, last_edited_at, description)
        VALUES ( $bindParams' )
       |]

insertArtistComments' :: (MonadIO m) => Env -> [ArtistComment] -> m (Map UUID ArtistComment)
insertArtistComments' 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 ^. #artistIdentifier,
        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 artist_comments
       (identifier, artist_identifier, parent_identifier, created_by,
       visibility_status, contents, approved_by, created_at, last_edited_at)
     VALUES ( $bindParams' )
    |]

insertArtistExternalSources' :: (MonadIO m) => Env -> [ArtistExternalSources] -> m (Map UUID ArtistExternalSources)
insertArtistExternalSources' 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 artist_external_sources
                     (identifier, artist_identifier, spotify_url, youtube_url,
                     soundcloud_url, wikipedia_url, created_at, last_edited_at, created_by)
                   VALUES ( $bindParams' )
                  |]
    toRow x =
      ( x ^. #identifier,
        x ^. #artistIdentifier,
        x ^. #spotifyUrl,
        x ^. #youtubeUrl,
        x ^. #soundcloudUrl,
        x ^. #wikipediaUrl,
        x ^. #createdAt,
        x ^. #lastEditedAt,
        x ^. #createdBy
      )

insertArtistArtworks' :: (MonadIO m) => Env -> [ArtistArtwork] -> m (Map UUID ArtistArtwork)
insertArtistArtworks' 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 ^. #artistIdentifier,
        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))
    bindParams' = bindParams 10
    query =
      encodeUtf8
        [trimming|
          INSERT INTO artist_artworks
            (identifier, artist_identifier, created_by, visibility_status,
            approved_by, content_url, created_at, last_edited_at, content_caption, order_value)
          VALUES ( $bindParams' )                   
         |]

upsertArtistOpinions' :: (MonadIO m) => Env -> [ArtistOpinion] -> m (Map UUID ArtistOpinion)
upsertArtistOpinions' 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 artist_opinions
                 (identifier, artist_identifier, created_by, is_like, is_dislike,
                 created_at, last_edited_at)
               VALUES ( $bindParams' )
               ON CONFLICT (artist_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 ^. #artistIdentifier,
        x ^. #opinion % #createdBy,
        x ^. #opinion % #isLike,
        not $ x ^. #opinion % #isLike,
        x ^. #opinion % #createdAt,
        x ^. #opinion % #lastEditedAt
        )

deleteArtists' :: (MonadIO m) => Env -> [UUID] -> m (Either ArtistCommandError ())
deleteArtists' env identifiers = do
  deleteArtworksOfArtistsResult <- liftIO . exec @ArtistCommand $ deleteArtworksOfArtists env identifiers
  deleteOpinionsOfArtistsResult <- liftIO . exec @ArtistCommand $ deleteOpinionsOfArtists env identifiers
  deleteCommentsOfArtistsResult <- liftIO . exec @ArtistCommand $ deleteCommentsOfArtists env identifiers
  deleteArtistExternalSourcesResult <- liftIO . exec @ArtistCommand $ deleteArtistExternalSources env identifiers
  deleteArtistsResult <- deleteStuffByUUID (env ^. #pool) "artists" "identifier" identifiers
  pure $
    deleteArtworksOfArtistsResult
      <> deleteOpinionsOfArtistsResult
      <> deleteArtistExternalSourcesResult
      <> deleteCommentsOfArtistsResult
      <> first fromHasqlUsageError deleteArtistsResult

updateArtistArtworkOrder' :: (MonadIO m) => Env -> [ArtistArtworkOrderUpdate] -> m (Either a ())
updateArtistArtworkOrder' env orderUpdates =
  Right <$> mapM_ performUpdate orderUpdates
  where
    stmt = Statement query encoder D.noResult True
    query =
      encodeUtf8
        [trimming|
        UPDATE artist_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

updateArtists' :: (MonadIO m) => Env -> Map UUID (Artist, Maybe ArtistDelta) -> m (Either Text ())
updateArtists' env deltas = do
  liftIO $ mapM_ performUpdate deltas
  exUpdate <- liftIO $ exec @ArtistCommand $ updateArtistExternalSources env deltas
  pure $ exUpdate <> Right ()
  where
    stmt = Statement query encoder D.noResult True
    query =
      encodeUtf8
        [trimming|
               UPDATE artists 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

updateArtistExternalSources' :: (MonadIO m) => Env -> Map UUID (Artist, Maybe ArtistDelta) -> m (Either Text ())
updateArtistExternalSources' env deltas =
  Right <$> mapM_ performUpdate deltas
  where
    stmt = Statement query encoder D.noResult True
    query =
      encodeUtf8
        [trimming|
             UPDATE artist_external_sources SET
               spotify_url = $$2,
               youtube_url = $$3,
               wikipedia_url = $$4,
               soundcloud_url = $$5
             WHERE artist_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

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

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

newArtistFromRequest' :: (MonadIO m) => UUID -> InsertArtistsRequestItem -> m Artist
newArtistFromRequest' createdBy req = do
  newUUID <- liftIO nextRandom
  now <- liftIO getCurrentTime
  pure $
    Artist
      { identifier = newUUID,
        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
      }

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

instance Exec ArtistCommand where
  execAlgebra (IncrementViewsByOne env identifiers next) = next =<< incrementViewsByOne' env identifiers "artists"
  execAlgebra (InsertArtists env artists next) = next =<< insertArtists' env artists
  execAlgebra (InsertArtistComments env comments next) = next =<< insertArtistComments' env comments
  execAlgebra (InsertArtistExternalSources env externalSources next) = next =<< insertArtistExternalSources' env externalSources
  execAlgebra (InsertArtistArtworks env artworks next) = next =<< insertArtistArtworks' env artworks
  execAlgebra (UpsertArtistOpinions env opinions next) = next =<< upsertArtistOpinions' env opinions
  execAlgebra (DeleteArtists env identifiers next) = next =<< deleteArtists' env identifiers
  execAlgebra (DeleteArtistComments env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_comments" "identifier" identifiers
  execAlgebra (DeleteArtistArtworks env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_artworks" "identifier" identifiers
  execAlgebra (DeleteArtistOpinions env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_opinions" "identifier" identifiers
  execAlgebra (DeleteCommentsOfArtists env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_comments" "artist_identifier" identifiers
  execAlgebra (DeleteArtistExternalSources env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_external_sources" "artist_identifier" identifiers
  execAlgebra (DeleteArtworksOfArtists env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_artworks" "artist_identifier" identifiers
  execAlgebra (DeleteOpinionsOfArtists env identifiers next) = do
    next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_opinions" "artist_identifier" identifiers
  execAlgebra (UpdateArtistArtworkOrder env orderUpdates next) = next =<< updateArtistArtworkOrder' env orderUpdates
  execAlgebra (UpdateArtists env deltas next) = next =<< updateArtists' env deltas
  execAlgebra (UpdateArtistExternalSources env deltas next) = next =<< updateArtistExternalSources' env deltas
  execAlgebra (NewArtistFromRequest createdBy req next) = next =<< newArtistFromRequest' createdBy req
  execAlgebra (NewArtistCommentFromRequest createdBy req next) = next =<< newArtistCommentFromRequest' createdBy req
  execAlgebra (NewArtistOpinionFromRequest createdBy req next) = next =<< newArtistOpinionFromRequest' createdBy req
  execAlgebra (NewArtistArtworkFromRequest createdBy req next) = next =<< newArtistArtworkFromRequest' createdBy req

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