diff --git a/CHANGELOG.org b/CHANGELOG.org new file mode 100644 --- /dev/null +++ b/CHANGELOG.org @@ -0,0 +1,12 @@ +* Changelog for `wikimusic-api` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +** Releases +*** v0.3.0.0 +- Using ~Hasql.Pool~ package across the entire system when doing database queries. +- Implemented the typeclasses for ~Command~ and ~Query~ for the entities ~Artist~ and ~Song~. This means that the Handlers have become lean as f*ck and we have 100% loose coupling between the persistence layer and the domain and handler layers. In principle this is actually a typeclass dependency injection, very elegant. diff --git a/README.org b/README.org new file mode 100644 --- /dev/null +++ b/README.org @@ -0,0 +1,158 @@ +#+title: WikiMusic API +#+options: toc:nil + +API and Persistence layer to PostgreSQL for WikiMusic, the invite-only private knowledge sharing of music community. + +/WikiMusic/ + +#+begin_html +
+Haskell +PostgreSQL +GNU Emacs +NixOS +Redis +
+#+end_html + + +WikiMusic as a software means an ingenious combination of a backend, a REST API, a database, and a user-interface to create a Content Management System (CMS) and a Gallery for music of all kinds, with educational intents. + +This is 100% free software, licensed under the GNU General Public License v3 or later. +[[https://www.gnu.org/licenses/gpl-3.0.en.html][Refer to the full license, on GNU's website]] + +The WikiMusic project is an invite-only community, with the goal of knowledge sharing, and not for profit driven. + +[[https://www.buymeacoffee.com/jjbigorra][Please donate by clicking here]]. This helps us keep the underlying cloud infrastructure and Joe's work hours going strong. + +In this Git repository you will find the source code behind WikiMusic's backend. + +To see the living API spec of WikiMusic, also known as API definition, go to [[file:src/WikiMusic/Servant/ApiSpec.hs]] + +** Project structure + +~src/WikiMusic/~ harbours the Haskell code that makes the API work. Inside there you will find: +- ~Console~ is a package with functionality related to logging to console / stdout. +- ~Free~ is a package with free monadic definitions of the possible interactions with the WikiMusic system. +- ~Interaction~ is a package with the implementation agnostic "business logic" of the WikiMusic system. +- ~Model~ is a package with common data models to the entire system. +- ~PostgreSQL~ is a package with the PostgreSQL implementation of several ~Command~ and ~Query~ interactions. +- ~SMTP~ is a package that contains SMTP Mail related implementations. +- ~Servant~ is a package that contains the API definition, routes and wiring of HTTP. +- ~Boot.hs~ is the entry point to start this REST API. +- ~Protolude.hs~ contains a custom tailor-made standard library (prelude) for WikiMusic, which helps developing. + +** Implementation details + +WikiMusic API is made using Haskell and free(er) monad techniques, along with great libraries made by the brilliant Haskell community. Some worthy mentions include servant, hasql, rio, free-alacarte, wai, keuringsdienst, optics. + +Using free(er) monads means that we can describe the business logic of certain layers at a very high abstraction level, and we are free to interpret this logic as we see fit, depending on the use case. This helps testing, decoupling, and maintaining code. + +** Installing and running + +This Haskell project requires certain C / C++ libraries to run. Pay attention the the error messages at build time and install dependencies accordingly. + +We recommend running WikiMusic API with the Nix package manager, and even better with NixOS, since this project has a close integrations for NixOS machines. + +Otherwise, on systems like Void Linux : +#+begin_src +sudo xbps-install zlib zlib-devel libpqxx-devel postgresql-libs postgresql-libs-devel ncurses-libtinfo-devel +#+end_src + +You will also need a PostgreSQL database and a Redis instance (to rate limit certain requests) to be accessible from WikiMusic API and running. + +WikiMusic will take care of the database schema migrations for you. + +There are also example docker compose files ready to be used at the ~resources~ folder for your convenience. + +* User permission + +In WikiMusic we have users of several kinds, with different privileges. See the table below for an understanding on what you can/cannot do depending on your rank. + +Demo user: + +| Resource | Create | Read | Update | Delete | Comment | Like/Dislike | +|----------+--------+------+--------+--------+---------+--------------| +| Song | ❌ | ✅ | ❌ | ❌ | ✅ | ✅ | +| Artist | ❌ | ✅ | ❌ | ❌ | ✅ | ✅ | +| Genre | ❌ | ✅ | ❌ | ❌ | ✅ | ✅ | +| User | ❌ | ❌ | ❌ | ❌ | N/A | N/A | + +Low-rank user: + +| Resource | Create | Read | Update | Delete | Comment | Like/Dislike | +|----------+--------+------+--------+--------+---------+--------------| +| Song | ✅ | ✅ | ✅ | ❌ | ✅ | ✅ | +| Artist | ✅ | ✅ | ✅ | ❌ | ✅ | ✅ | +| Genre | ✅ | ✅ | ✅ | ❌ | ✅ | ✅ | +| User | ❌ | ❌ | ❌ | ❌ | N/A | N/A | + +Maintainer user: + +| Resource | Create | Read | Update | Delete | Comment | Like/Dislike | +|----------+--------+------+--------+--------+---------+--------------| +| Song | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ | +| Artist | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ | +| Genre | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ | +| User | ✅ | ✅ | ✅ | ❌ | N/A | N/A | + +Super-user: can do everyting to the system! + +* NixOS + +Enter a nice shell provided by flakes, by doing ~nix develop~. You can also do ~nix build~ to build the project with Nix. + +Run the API with for example: ~nix run . -- "./resources/config/run-local.toml"~ . + + +** Bare metal + +It can be needed, if you want to run bare metal without direnv, to do things like this sometimes in the ~cabal.project~ (find by ~find /nix -name "zlib.h*"~): + +#+begin_src nix +package postgresql-libpq + extra-include-dirs: /nix/store/ahb6l0carh3yc6a5d4zdxsxf69sdhnhh-postgresql-15.4/include + +package zlib + extra-include-dirs: /nix/store/686lhcz4bwg3wk09pi1xxjgzbxv7ys5q-zlib-1.3-dev/include + extra-lib-dirs: /nix/store/4rx3vkkd91wkbhpflsplfga603cp1l1c-zlib-1.3/lib +#+end_src + +* API documentation + +When running WikiMusic API, you can navigate to ~/swagger.json~ to get the OpenAPI spec for WikiMusic. + + +* Example config file + +For local runs you can take a look at [[file:resources/config/run-local.toml]]. + +* Production environment diagram + +#+begin_src dot :file resources/images/production-env-diagram.png :exports results :mkdirp yes + digraph prodenv { + subgraph clusterA { + fontname="Inter,Helvetica,Arial,sans-serif" + node [ shape="box", fontname="Inter,Helvetica,Arial,sans-serif" ] + edge [ fontname="Inter,Helvetica,Arial,sans-serif", arrowhead="rnormal", arrowtail="dot" ] + + I1 [ label="api.wikimusic.jointhefreeworld.org via HTTPS" ] + I2 [ label="AWS Cloudfront" ] + I3 [ label="AWS EC2 t3.small instance\nrunning NixOS" ] + I4 [ label="Haskell + Servant + PostgreSQL + Redis" ] + I5 [ label="GitLab CI/CD" ] + I6 [ label="AWS SQS queue" ] + + + I1 -> I2; + I2 -> I3; + I3 -> I4; + I5 -> I6; + I3 -> I6; + + } + } +#+end_src + +#+RESULTS: +[[file:resources/images/production-env-diagram.png]] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import WikiMusic.Boot qualified +import WikiMusic.Protolude + +main :: (MonadIO m) => m () +main = liftIO $ WikiMusic.Boot.boot diff --git a/src/WikiMusic/Boot.hs b/src/WikiMusic/Boot.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Boot.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Boot + ( boot, + ) +where + +import Control.Monad +import Data.ByteString.Lazy qualified as BL +import Data.Text (pack, unpack) +import Database.Redis qualified as Redis +import Hasql.Connection qualified +import Hasql.Pool qualified +import Hasql.Session qualified +import Network.Wai.Handler.Warp +import Optics +import Relude +import WikiMusic.Config +import WikiMusic.Model.Config +import WikiMusic.PostgreSQL.Migration +import WikiMusic.Servant.ApiSetup + +boot :: (MonadIO m) => m () +boot = do + args <- liftIO getArgs + case nonEmpty args of + Just (x :| []) -> do + cfg <- readConfig (pack x) + liftIO $ either crashWithBadConfig doRun cfg + _ -> crashWithNoConfigFile args + where + crashWithNoConfigFile args = error $ "No path to a config file was specified! Args: " <> show args + crashWithBadConfig e = error ("Bad config could not be parsed! " <> show e) + doRun cfg = do + pool <- makePostgresPool cfg + redisConn <- makeRedisConn cfg + startWikiMusicAPI cfg pool redisConn + +startWikiMusicAPI :: (MonadIO m) => AppConfig -> Hasql.Pool.Pool -> Redis.Connection -> m () +startWikiMusicAPI cfg pool redisConn = do + maybeRunMigrations + liftIO . BL.putStr $ "Starting REST API ..." + liftIO $ runSettings apiSettings =<< mkApp cfg pool redisConn + where + apiSettings = setPort (cfg ^. #servant % #port) defaultSettings + maybeRunMigrations = do + when (cfg ^. #postgresql % #runMigrations) $ do + liftIO . BL.putStr $ "Starting database migrations ..." + ex <- liftIO . runWikiMusicMigrations $ pool + liftIO . BL.putStr . fromString . show $ ex + pure () + +makeRedisConn :: (MonadIO m) => AppConfig -> m Redis.Connection +makeRedisConn cfg = liftIO $ Redis.checkedConnect redisConnectionSettings + where + redisConnectionSettings = + Redis.defaultConnectInfo + { Redis.connectPort = Redis.PortNumber (fromIntegral $ cfg ^. #redis % #port), + Redis.connectAuth = fmap (fromString . unpack) (cfg ^. #redis % #password) + } + +makePostgresPool :: (MonadIO m) => AppConfig -> m Hasql.Pool.Pool +makePostgresPool cfg = do + pool <- liftIO $ Hasql.Pool.acquire poolSize 10 10 10 dbConnectionSettings + + let healthSess = Hasql.Session.sql "SELECT 1" + s <- liftIO $ Hasql.Pool.use pool healthSess + either (liftIO . BL.putStr . fromString . show) pure s + + pure pool + where + poolSize = cfg ^. #postgresql % #poolSize + dbConnectionSettings = + Hasql.Connection.settings + (fromString . unpack $ cfg ^. #postgresql % #host) + (fromIntegral $ cfg ^. #postgresql % #port) + (fromString . unpack $ cfg ^. #postgresql % #user) + (maybe "" (fromString . unpack) (cfg ^. #postgresql % #password)) + (fromString . unpack $ cfg ^. #postgresql % #name) diff --git a/src/WikiMusic/Clock/LiveClock.hs b/src/WikiMusic/Clock/LiveClock.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Clock/LiveClock.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Clock.LiveClock () where + +import Data.Text qualified as T +import Data.Time +import Free.AlaCarte +import Relude +import WikiMusic.Free.Clock + +instance Exec Clock where + execAlgebra (TimeElapsedUntilNow fromTime f) = do + diffWithNow fromTime >>= f + execAlgebra (Now f) = do + getCurrentTime >>= f + +diffWithNow :: (MonadIO m) => UTCTime -> m Text +diffWithNow fromTime = do + now' <- liftIO getCurrentTime + pure $ T.pack . show $ diffUTCTime now' fromTime diff --git a/src/WikiMusic/Config.hs b/src/WikiMusic/Config.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Config.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Config (readConfig) where + +import Data.ByteString.Lazy qualified as BL +import Data.Text (strip, unpack) +import Data.Text.Encoding qualified +import Toml +import WikiMusic.Model.Config +import WikiMusic.Protolude + +readConfig :: (MonadIO m) => Text -> m (Either Text AppConfig) +readConfig filePath = do + parseResult <- liftIO $ decodeFileEither appConfigCodec (unpack filePath) + case parseResult of + Left e -> pure . Left $ prettyTomlDecodeErrors e + Right r -> readSecrets r <&> Right + +readSecrets :: (MonadIO m) => AppConfig -> m AppConfig +readSecrets cfg = do + postgresqlPassword <- readSecretFromFile cfg (^. #postgresql % #passwordFile) + redisPassword <- readSecretFromFile cfg (^. #redis % #passwordFile) + mailPassword <- readSecretFromFile cfg (^. #mail % #passwordFile) + let withRedisCfg = cfg & #redis .~ ((cfg ^. #redis) & #password ?~ redisPassword) + withPostgresCfg = + withRedisCfg + & #postgresql + .~ ((withRedisCfg ^. #postgresql) & #password ?~ postgresqlPassword) + finalCfg = + withPostgresCfg + & #mail + .~ ((withPostgresCfg ^. #mail) & #password ?~ mailPassword) + pure finalCfg + +readSecretFromFile :: (MonadIO m) => t -> (t -> Text) -> m Text +readSecretFromFile cfg getFilePath = do + passwordFileContents <- liftIO . BL.readFile . unpack . getFilePath $ cfg + pure + . strip + . Data.Text.Encoding.decodeUtf8 + . BL.toStrict + $ passwordFileContents diff --git a/src/WikiMusic/Console/Logger.hs b/src/WikiMusic/Console/Logger.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Console/Logger.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Console.Logger () where + +import Data.ByteString.Lazy qualified as BL +import Data.Text qualified as T +import Data.Time +import Relude +import WikiMusic.Free.Logger +import WikiMusic.Protolude + +instance Exec Logger where + execAlgebra (LogInfo msg next) = do + now <- iso8601 + _ <- textToStdout (logExpr now "INFO" msg) + next + execAlgebra (LogError msg next) = do + now <- iso8601 + _ <- textToStderr (logExpr now "ERROR" msg) + next + execAlgebra (LogDebug msg next) = do + now <- iso8601 + _ <- textToStdout (logExpr now "DEBUG" msg) + next + +textToStdout :: (MonadIO m) => Text -> m () +textToStdout = liftIO . BL.hPutStr stdout . BL.fromStrict . encodeUtf8 . liner + +textToStderr :: (MonadIO m) => Text -> m () +textToStderr = liftIO . BL.hPutStr stderr . BL.fromStrict . encodeUtf8 . liner + +liner :: Text -> Text +liner = (<> "\n") + +-- Construct format string according to . +iso8601 :: (MonadIO m) => m Text +iso8601 = do + n <- liftIO getCurrentTime + let n' = T.pack $ formatTime defaultTimeLocale (T.unpack "%Y-%m-%dT%H:%M:%SZ") n + pure n' + +logExpr :: (Semigroup a, IsString a) => a -> a -> a -> a +logExpr now lev msg = "[" <> now <> "][" <> lev <> "] " <> msg diff --git a/src/WikiMusic/Free/ArtistCommand.hs b/src/WikiMusic/Free/ArtistCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/ArtistCommand.hs @@ -0,0 +1,121 @@ +module WikiMusic.Free.ArtistCommand + ( ArtistCommand (..), + insertArtists, + insertArtistComments, + insertArtistArtworks, + upsertArtistOpinions, + insertArtistExternalSources, + deleteArtists, + deleteArtistComments, + deleteArtistArtworks, + deleteArtistOpinions, + deleteCommentsOfArtists, + deleteArtistExternalSources, + deleteArtworksOfArtists, + deleteOpinionsOfArtists, + updateArtistArtworkOrder, + updateArtists, + updateArtistExternalSources, + newArtistFromRequest, + newArtistCommentFromRequest, + newArtistOpinionFromRequest, + newArtistArtworkFromRequest, + ArtistCommandError (..), + incrementViewsByOne, + ) +where + +import WikiMusic.Interaction.Model.Artist +import WikiMusic.Model.Artist +import WikiMusic.Protolude + +data ArtistCommandError = PersistenceError Text | LogicError Text + deriving (Eq, Show) + +type ArtistCommand :: Type -> Type +data ArtistCommand a + = InsertArtists Env [Artist] (Map UUID Artist -> a) + | InsertArtistComments Env [ArtistComment] (Map UUID ArtistComment -> a) + | InsertArtistArtworks Env [ArtistArtwork] (Map UUID ArtistArtwork -> a) + | UpsertArtistOpinions Env [ArtistOpinion] (Map UUID ArtistOpinion -> a) + | InsertArtistExternalSources Env [ArtistExternalSources] (Map UUID ArtistExternalSources -> a) + | DeleteArtists Env [UUID] (Either ArtistCommandError () -> a) + | DeleteArtistComments Env [UUID] (Either ArtistCommandError () -> a) + | DeleteArtistArtworks Env [UUID] (Either ArtistCommandError () -> a) + | DeleteArtistOpinions Env [UUID] (Either ArtistCommandError () -> a) + | DeleteCommentsOfArtists Env [UUID] (Either ArtistCommandError () -> a) + | DeleteArtistExternalSources Env [UUID] (Either ArtistCommandError () -> a) + | DeleteArtworksOfArtists Env [UUID] (Either ArtistCommandError () -> a) + | DeleteOpinionsOfArtists Env [UUID] (Either ArtistCommandError () -> a) + | UpdateArtistArtworkOrder Env [ArtistArtworkOrderUpdate] (Either Text () -> a) + | UpdateArtists Env (Map UUID (Artist, Maybe ArtistDelta)) (Either Text () -> a) + | UpdateArtistExternalSources Env (Map UUID (Artist, Maybe ArtistDelta)) (Either Text () -> a) + | NewArtistFromRequest UUID InsertArtistsRequestItem (Artist -> a) + | NewArtistCommentFromRequest UUID InsertArtistCommentsRequestItem (ArtistComment -> a) + | NewArtistOpinionFromRequest UUID UpsertArtistOpinionsRequestItem (ArtistOpinion -> a) + | NewArtistArtworkFromRequest UUID InsertArtistArtworksRequestItem (ArtistArtwork -> a) + | IncrementViewsByOne Env [UUID] (Either ArtistCommandError () -> a) + deriving (Functor) + +insertArtists :: (ArtistCommand :<: f) => Env -> [Artist] -> Free f (Map UUID Artist) +insertArtists env artists = injectFree (InsertArtists env artists Pure) + +insertArtistComments :: (ArtistCommand :<: f) => Env -> [ArtistComment] -> Free f (Map UUID ArtistComment) +insertArtistComments env artistComments = injectFree (InsertArtistComments env artistComments Pure) + +insertArtistArtworks :: (ArtistCommand :<: f) => Env -> [ArtistArtwork] -> Free f (Map UUID ArtistArtwork) +insertArtistArtworks env artistArtworks = injectFree (InsertArtistArtworks env artistArtworks Pure) + +upsertArtistOpinions :: (ArtistCommand :<: f) => Env -> [ArtistOpinion] -> Free f (Map UUID ArtistOpinion) +upsertArtistOpinions env artistOpinions = injectFree (UpsertArtistOpinions env artistOpinions Pure) + +insertArtistExternalSources :: (ArtistCommand :<: f) => Env -> [ArtistExternalSources] -> Free f (Map UUID ArtistExternalSources) +insertArtistExternalSources env artistExternalSources = injectFree (InsertArtistExternalSources env artistExternalSources Pure) + +deleteArtists :: (ArtistCommand :<: f) => Env -> [UUID] -> Free f (Either ArtistCommandError ()) +deleteArtists env uuids = injectFree (DeleteArtists env uuids Pure) + +deleteArtistComments :: (ArtistCommand :<: f) => Env -> [UUID] -> Free f (Either ArtistCommandError ()) +deleteArtistComments env uuids = injectFree (DeleteArtistComments env uuids Pure) + +deleteArtistArtworks :: (ArtistCommand :<: f) => Env -> [UUID] -> Free f (Either ArtistCommandError ()) +deleteArtistArtworks env uuids = injectFree (DeleteArtistArtworks env uuids Pure) + +deleteArtistOpinions :: (ArtistCommand :<: f) => Env -> [UUID] -> Free f (Either ArtistCommandError ()) +deleteArtistOpinions env uuids = injectFree (DeleteArtistOpinions env uuids Pure) + +deleteCommentsOfArtists :: (ArtistCommand :<: f) => Env -> [UUID] -> Free f (Either ArtistCommandError ()) +deleteCommentsOfArtists env uuids = injectFree (DeleteCommentsOfArtists env uuids Pure) + +deleteArtistExternalSources :: (ArtistCommand :<: f) => Env -> [UUID] -> Free f (Either ArtistCommandError ()) +deleteArtistExternalSources env uuids = injectFree (DeleteArtistExternalSources env uuids Pure) + +deleteArtworksOfArtists :: (ArtistCommand :<: f) => Env -> [UUID] -> Free f (Either ArtistCommandError ()) +deleteArtworksOfArtists env uuids = injectFree (DeleteArtworksOfArtists env uuids Pure) + +deleteOpinionsOfArtists :: (ArtistCommand :<: f) => Env -> [UUID] -> Free f (Either ArtistCommandError ()) +deleteOpinionsOfArtists env uuids = injectFree (DeleteOpinionsOfArtists env uuids Pure) + +updateArtistArtworkOrder :: (ArtistCommand :<: f) => Env -> [ArtistArtworkOrderUpdate] -> Free f (Either Text ()) +updateArtistArtworkOrder env uuids = injectFree (UpdateArtistArtworkOrder env uuids Pure) + +updateArtists :: (ArtistCommand :<: f) => Env -> Map UUID (Artist, Maybe ArtistDelta) -> Free f (Either Text ()) +updateArtists env deltas = injectFree (UpdateArtists env deltas Pure) + +updateArtistExternalSources :: (ArtistCommand :<: f) => Env -> Map UUID (Artist, Maybe ArtistDelta) -> Free f (Either Text ()) +updateArtistExternalSources env deltas = injectFree (UpdateArtistExternalSources env deltas Pure) + +newArtistFromRequest :: (ArtistCommand :<: f) => UUID -> InsertArtistsRequestItem -> Free f Artist +newArtistFromRequest uuid req = injectFree (NewArtistFromRequest uuid req Pure) + +newArtistCommentFromRequest :: (ArtistCommand :<: f) => UUID -> InsertArtistCommentsRequestItem -> Free f ArtistComment +newArtistCommentFromRequest uuid req = injectFree (NewArtistCommentFromRequest uuid req Pure) + +newArtistOpinionFromRequest :: (ArtistCommand :<: f) => UUID -> UpsertArtistOpinionsRequestItem -> Free f ArtistOpinion +newArtistOpinionFromRequest uuid req = injectFree (NewArtistOpinionFromRequest uuid req Pure) + +newArtistArtworkFromRequest :: (ArtistCommand :<: f) => UUID -> InsertArtistArtworksRequestItem -> Free f ArtistArtwork +newArtistArtworkFromRequest uuid req = injectFree (NewArtistArtworkFromRequest uuid req Pure) + +incrementViewsByOne :: (ArtistCommand :<: f) => Env -> [UUID] -> Free f (Either ArtistCommandError ()) +incrementViewsByOne env uuids = injectFree (IncrementViewsByOne env uuids Pure) diff --git a/src/WikiMusic/Free/ArtistQuery.hs b/src/WikiMusic/Free/ArtistQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/ArtistQuery.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Free.ArtistQuery + ( ArtistQuery (..), + fetchArtists, + fetchArtistsByUUID, + enrichedArtistResponse, + fetchArtistComments, + fetchArtistOpinions, + fetchArtistArtworks, + ArtistQueryError (..), + searchArtists, + ) +where + +import WikiMusic.Interaction.Model.Artist +import WikiMusic.Model.Artist +import WikiMusic.Model.Other +import WikiMusic.Protolude + +data ArtistQueryError = PersistenceError Text | LogicError Text + deriving (Eq, Show) + +type ArtistQuery :: Type -> Type +data ArtistQuery a + = FetchArtists Env ArtistSortOrder Limit Offset ((Map UUID Artist, [UUID]) -> a) + | FetchArtistsByUUID Env ArtistSortOrder [UUID] ((Map UUID Artist, [UUID]) -> a) + | EnrichedArtistResponse Env (Map UUID Artist) EnrichArtistParams (Map UUID Artist -> a) + | FetchArtistComments Env [UUID] (Map UUID ArtistComment -> a) + | FetchArtistOpinions Env [UUID] (Map UUID ArtistOpinion -> a) + | FetchArtistArtworks Env [UUID] (Map UUID ArtistArtwork -> a) + | SearchArtists Env SearchInput ArtistSortOrder Limit Offset ((Map UUID Artist, [UUID]) -> a) + deriving (Functor) + +fetchArtists :: (ArtistQuery :<: f) => Env -> ArtistSortOrder -> Limit -> Offset -> Free f (Map UUID Artist, [UUID]) +fetchArtists env sortOrder limit offset = injectFree (FetchArtists env sortOrder limit offset Pure) + +fetchArtistsByUUID :: (ArtistQuery :<: f) => Env -> ArtistSortOrder -> [UUID] -> Free f (Map UUID Artist, [UUID]) +fetchArtistsByUUID env sortOrder uuids = injectFree (FetchArtistsByUUID env sortOrder uuids Pure) + +enrichedArtistResponse :: (ArtistQuery :<: f) => Env -> Map UUID Artist -> EnrichArtistParams -> Free f (Map UUID Artist) +enrichedArtistResponse env artists enrichParams = injectFree (EnrichedArtistResponse env artists enrichParams Pure) + +fetchArtistComments :: (ArtistQuery :<: f) => Env -> [UUID] -> Free f (Map UUID ArtistComment) +fetchArtistComments env uuids = injectFree (FetchArtistComments env uuids Pure) + +fetchArtistOpinions :: (ArtistQuery :<: f) => Env -> [UUID] -> Free f (Map UUID ArtistOpinion) +fetchArtistOpinions env uuids = injectFree (FetchArtistOpinions env uuids Pure) + +fetchArtistArtworks :: (ArtistQuery :<: f) => Env -> [UUID] -> Free f (Map UUID ArtistArtwork) +fetchArtistArtworks env uuids = injectFree (FetchArtistArtworks env uuids Pure) + +searchArtists :: (ArtistQuery :<: f) => Env -> SearchInput -> ArtistSortOrder -> Limit -> Offset -> Free f (Map UUID Artist, [UUID]) +searchArtists env searchInput sortOrder limit offset = injectFree (SearchArtists env searchInput sortOrder limit offset Pure) diff --git a/src/WikiMusic/Free/AuthQuery.hs b/src/WikiMusic/Free/AuthQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/AuthQuery.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Free.AuthQuery + ( AuthQuery (..), + fetchUserForAuthCheck, + fetchMe, + fetchUserRoles, + fetchUserFromToken, + AuthQueryError (..), + ) +where + +import Free.AlaCarte +import WikiMusic.Protolude + +data AuthQueryError = PersistenceError Text | LogicError Text | AuthError Text + deriving (Eq, Show) + +type AuthQuery :: Type -> Type +data AuthQuery a + = FetchUserForAuthCheck Env Text (Either AuthQueryError (Maybe WikiMusicUser) -> a) + | FetchUserFromToken Env Text (Either AuthQueryError (Maybe WikiMusicUser) -> a) + | FetchMe Env UUID (Either AuthQueryError (Maybe WikiMusicUser) -> a) + | FetchUserRoles Env UUID (Either AuthQueryError [UserRole] -> a) + deriving (Functor) + +fetchUserForAuthCheck :: (AuthQuery :<: f) => Env -> Text -> Free f (Either AuthQueryError (Maybe WikiMusicUser)) +fetchUserForAuthCheck env token = injectFree (FetchUserForAuthCheck env token Pure) + +fetchUserFromToken :: (AuthQuery :<: f) => Env -> Text -> Free f (Either AuthQueryError (Maybe WikiMusicUser)) +fetchUserFromToken env token = injectFree (FetchUserFromToken env token Pure) + +fetchMe :: (AuthQuery :<: f) => Env -> UUID -> Free f (Either AuthQueryError (Maybe WikiMusicUser)) +fetchMe env uid = injectFree (FetchMe env uid Pure) + +fetchUserRoles :: (AuthQuery :<: f) => Env -> UUID -> Free f (Either AuthQueryError [UserRole]) +fetchUserRoles env uid = injectFree (FetchUserRoles env uid Pure) diff --git a/src/WikiMusic/Free/Clock.hs b/src/WikiMusic/Free/Clock.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/Clock.hs @@ -0,0 +1,22 @@ +module WikiMusic.Free.Clock + ( timeElapsedUntilNow, + now, + Clock (..), + ) +where + +import Data.Time +import Free.AlaCarte +import Relude + +type Clock :: Type -> Type +data Clock a + = TimeElapsedUntilNow UTCTime (Text -> a) + | Now (UTCTime -> a) + deriving (Functor) + +timeElapsedUntilNow :: (Clock :<: f) => UTCTime -> Free f Text +timeElapsedUntilNow fromTime = injectFree (TimeElapsedUntilNow fromTime Pure) + +now :: (Clock :<: f) => Free f UTCTime +now = injectFree (Now Pure) diff --git a/src/WikiMusic/Free/GenreCommand.hs b/src/WikiMusic/Free/GenreCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/GenreCommand.hs @@ -0,0 +1,123 @@ +module WikiMusic.Free.GenreCommand + ( GenreCommand (..), + insertGenres, + insertGenreComments, + insertGenreArtworks, + upsertGenreOpinions, + insertGenreExternalSources, + deleteGenres, + deleteGenreComments, + deleteGenreArtworks, + deleteGenreOpinions, + deleteCommentsOfGenres, + deleteGenreExternalSources, + deleteArtworksOfGenres, + deleteOpinionsOfGenres, + updateGenreArtworkOrder, + updateGenres, + updateGenreExternalSources, + newGenreFromRequest, + newGenreCommentFromRequest, + newGenreOpinionFromRequest, + newGenreArtworkFromRequest, + GenreCommandError (..), + incrementViewsByOne, + ) +where + +import Free.AlaCarte +import WikiMusic.Interaction.Model.Genre +import WikiMusic.Model.Genre +import WikiMusic.Protolude + +data GenreCommandError = PersistenceError Text | LogicError Text + deriving (Eq, Show) + +type GenreCommand :: Type -> Type +data GenreCommand a + = InsertGenres Env [Genre] (Map UUID Genre -> a) + | InsertGenreComments Env [GenreComment] (Map UUID GenreComment -> a) + | InsertGenreArtworks Env [GenreArtwork] (Map UUID GenreArtwork -> a) + | UpsertGenreOpinions Env [GenreOpinion] (Map UUID GenreOpinion -> a) + | InsertGenreExternalSources Env [GenreExternalSources] (Map UUID GenreExternalSources -> a) + | DeleteGenres Env [UUID] (Either GenreCommandError () -> a) + | DeleteGenreComments Env [UUID] (Either GenreCommandError () -> a) + | DeleteGenreArtworks Env [UUID] (Either GenreCommandError () -> a) + | DeleteGenreOpinions Env [UUID] (Either GenreCommandError () -> a) + | DeleteCommentsOfGenres Env [UUID] (Either GenreCommandError () -> a) + | DeleteGenreExternalSources Env [UUID] (Either GenreCommandError () -> a) + | DeleteArtworksOfGenres Env [UUID] (Either GenreCommandError () -> a) + | DeleteOpinionsOfGenres Env [UUID] (Either GenreCommandError () -> a) + | UpdateGenreArtworkOrder Env [GenreArtworkOrderUpdate] (Either Text () -> a) + | UpdateGenres Env (Map UUID (Genre, Maybe GenreDelta)) (Either Text () -> a) + | UpdateGenreExternalSources Env (Map UUID (Genre, Maybe GenreDelta)) (Either Text () -> a) + | NewGenreFromRequest UUID InsertGenresRequestItem (Genre -> a) + | -- TODO: separate model generators to their own monad + NewGenreCommentFromRequest UUID InsertGenreCommentsRequestItem (GenreComment -> a) + | NewGenreOpinionFromRequest UUID UpsertGenreOpinionsRequestItem (GenreOpinion -> a) + | NewGenreArtworkFromRequest UUID InsertGenreArtworksRequestItem (GenreArtwork -> a) + | IncrementViewsByOne Env [UUID] (Either GenreCommandError () -> a) + deriving (Functor) + +insertGenres :: (GenreCommand :<: f) => Env -> [Genre] -> Free f (Map UUID Genre) +insertGenres env genres = injectFree (InsertGenres env genres Pure) + +insertGenreComments :: (GenreCommand :<: f) => Env -> [GenreComment] -> Free f (Map UUID GenreComment) +insertGenreComments env genreComments = injectFree (InsertGenreComments env genreComments Pure) + +insertGenreArtworks :: (GenreCommand :<: f) => Env -> [GenreArtwork] -> Free f (Map UUID GenreArtwork) +insertGenreArtworks env genreArtworks = injectFree (InsertGenreArtworks env genreArtworks Pure) + +upsertGenreOpinions :: (GenreCommand :<: f) => Env -> [GenreOpinion] -> Free f (Map UUID GenreOpinion) +upsertGenreOpinions env genreOpinions = injectFree (UpsertGenreOpinions env genreOpinions Pure) + +insertGenreExternalSources :: (GenreCommand :<: f) => Env -> [GenreExternalSources] -> Free f (Map UUID GenreExternalSources) +insertGenreExternalSources env genreExternalSources = injectFree (InsertGenreExternalSources env genreExternalSources Pure) + +deleteGenres :: (GenreCommand :<: f) => Env -> [UUID] -> Free f (Either GenreCommandError ()) +deleteGenres env uuids = injectFree (DeleteGenres env uuids Pure) + +deleteGenreComments :: (GenreCommand :<: f) => Env -> [UUID] -> Free f (Either GenreCommandError ()) +deleteGenreComments env uuids = injectFree (DeleteGenreComments env uuids Pure) + +deleteGenreArtworks :: (GenreCommand :<: f) => Env -> [UUID] -> Free f (Either GenreCommandError ()) +deleteGenreArtworks env uuids = injectFree (DeleteGenreArtworks env uuids Pure) + +deleteGenreOpinions :: (GenreCommand :<: f) => Env -> [UUID] -> Free f (Either GenreCommandError ()) +deleteGenreOpinions env uuids = injectFree (DeleteGenreOpinions env uuids Pure) + +deleteCommentsOfGenres :: (GenreCommand :<: f) => Env -> [UUID] -> Free f (Either GenreCommandError ()) +deleteCommentsOfGenres env uuids = injectFree (DeleteCommentsOfGenres env uuids Pure) + +deleteGenreExternalSources :: (GenreCommand :<: f) => Env -> [UUID] -> Free f (Either GenreCommandError ()) +deleteGenreExternalSources env uuids = injectFree (DeleteGenreExternalSources env uuids Pure) + +deleteArtworksOfGenres :: (GenreCommand :<: f) => Env -> [UUID] -> Free f (Either GenreCommandError ()) +deleteArtworksOfGenres env uuids = injectFree (DeleteArtworksOfGenres env uuids Pure) + +deleteOpinionsOfGenres :: (GenreCommand :<: f) => Env -> [UUID] -> Free f (Either GenreCommandError ()) +deleteOpinionsOfGenres env uuids = injectFree (DeleteOpinionsOfGenres env uuids Pure) + +updateGenreArtworkOrder :: (GenreCommand :<: f) => Env -> [GenreArtworkOrderUpdate] -> Free f (Either Text ()) +updateGenreArtworkOrder env uuids = injectFree (UpdateGenreArtworkOrder env uuids Pure) + +updateGenres :: (GenreCommand :<: f) => Env -> Map UUID (Genre, Maybe GenreDelta) -> Free f (Either Text ()) +updateGenres env deltas = injectFree (UpdateGenres env deltas Pure) + +updateGenreExternalSources :: (GenreCommand :<: f) => Env -> Map UUID (Genre, Maybe GenreDelta) -> Free f (Either Text ()) +updateGenreExternalSources env deltas = injectFree (UpdateGenreExternalSources env deltas Pure) + +newGenreFromRequest :: (GenreCommand :<: f) => UUID -> InsertGenresRequestItem -> Free f Genre +newGenreFromRequest uuid req = injectFree (NewGenreFromRequest uuid req Pure) + +newGenreCommentFromRequest :: (GenreCommand :<: f) => UUID -> InsertGenreCommentsRequestItem -> Free f GenreComment +newGenreCommentFromRequest uuid req = injectFree (NewGenreCommentFromRequest uuid req Pure) + +newGenreOpinionFromRequest :: (GenreCommand :<: f) => UUID -> UpsertGenreOpinionsRequestItem -> Free f GenreOpinion +newGenreOpinionFromRequest uuid req = injectFree (NewGenreOpinionFromRequest uuid req Pure) + +newGenreArtworkFromRequest :: (GenreCommand :<: f) => UUID -> InsertGenreArtworksRequestItem -> Free f GenreArtwork +newGenreArtworkFromRequest uuid req = injectFree (NewGenreArtworkFromRequest uuid req Pure) + +incrementViewsByOne :: (GenreCommand :<: f) => Env -> [UUID] -> Free f (Either GenreCommandError ()) +incrementViewsByOne env uuids = injectFree (IncrementViewsByOne env uuids Pure) diff --git a/src/WikiMusic/Free/GenreQuery.hs b/src/WikiMusic/Free/GenreQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/GenreQuery.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Free.GenreQuery + ( GenreQuery (..), + fetchGenres, + fetchGenresByUUID, + enrichedGenreResponse, + fetchGenreComments, + fetchGenreOpinions, + fetchGenreArtworks, + GenreQueryError (..), + searchGenres, + ) +where + +import Free.AlaCarte +import WikiMusic.Interaction.Model.Genre +import WikiMusic.Model.Genre +import WikiMusic.Model.Other +import WikiMusic.Protolude + +data GenreQueryError = PersistenceError Text | LogicError Text + deriving (Eq, Show) + +type GenreQuery :: Type -> Type +data GenreQuery a + = FetchGenres Env GenreSortOrder Limit Offset ((Map UUID Genre, [UUID]) -> a) + | FetchGenresByUUID Env GenreSortOrder [UUID] ((Map UUID Genre, [UUID]) -> a) + | EnrichedGenreResponse Env (Map UUID Genre) EnrichGenreParams (Map UUID Genre -> a) + | FetchGenreComments Env [UUID] (Map UUID GenreComment -> a) + | FetchGenreOpinions Env [UUID] (Map UUID GenreOpinion -> a) + | FetchGenreArtworks Env [UUID] (Map UUID GenreArtwork -> a) + | SearchGenres Env SearchInput GenreSortOrder Limit Offset ((Map UUID Genre, [UUID]) -> a) + deriving (Functor) + +fetchGenres :: (GenreQuery :<: f) => Env -> GenreSortOrder -> Limit -> Offset -> Free f (Map UUID Genre, [UUID]) +fetchGenres env sortOrder limit offset = injectFree (FetchGenres env sortOrder limit offset Pure) + +fetchGenresByUUID :: (GenreQuery :<: f) => Env -> GenreSortOrder -> [UUID] -> Free f (Map UUID Genre, [UUID]) +fetchGenresByUUID env sortOrder uuids = injectFree (FetchGenresByUUID env sortOrder uuids Pure) + +enrichedGenreResponse :: (GenreQuery :<: f) => Env -> Map UUID Genre -> EnrichGenreParams -> Free f (Map UUID Genre) +enrichedGenreResponse env genres enrichParams = injectFree (EnrichedGenreResponse env genres enrichParams Pure) + +fetchGenreComments :: (GenreQuery :<: f) => Env -> [UUID] -> Free f (Map UUID GenreComment) +fetchGenreComments env uuids = injectFree (FetchGenreComments env uuids Pure) + +fetchGenreOpinions :: (GenreQuery :<: f) => Env -> [UUID] -> Free f (Map UUID GenreOpinion) +fetchGenreOpinions env uuids = injectFree (FetchGenreOpinions env uuids Pure) + +fetchGenreArtworks :: (GenreQuery :<: f) => Env -> [UUID] -> Free f (Map UUID GenreArtwork) +fetchGenreArtworks env uuids = injectFree (FetchGenreArtworks env uuids Pure) + +searchGenres :: (GenreQuery :<: f) => Env -> SearchInput -> GenreSortOrder -> Limit -> Offset -> Free f (Map UUID Genre, [UUID]) +searchGenres env searchInput sortOrder limit offset = injectFree (SearchGenres env searchInput sortOrder limit offset Pure) diff --git a/src/WikiMusic/Free/Logger.hs b/src/WikiMusic/Free/Logger.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/Logger.hs @@ -0,0 +1,26 @@ +module WikiMusic.Free.Logger + ( logInfo, + logError, + logDebug, + Logger (..), + ) +where + +import Free.AlaCarte +import Relude + +type Logger :: Type -> Type +data Logger a + = LogInfo Text a + | LogError Text a + | LogDebug Text a + deriving (Functor) + +logInfo :: (Logger :<: f) => Text -> Free f () +logInfo message = injectFree (LogInfo message (Pure ())) + +logError :: (Logger :<: f) => Text -> Free f () +logError message = injectFree (LogError message (Pure ())) + +logDebug :: (Logger :<: f) => Text -> Free f () +logDebug message = injectFree (LogDebug message (Pure ())) diff --git a/src/WikiMusic/Free/MailCommand.hs b/src/WikiMusic/Free/MailCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/MailCommand.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Free.MailCommand + ( sendMail, + MailCommand (..), + ) +where + +import WikiMusic.Model.Env +import WikiMusic.Model.Mail +import WikiMusic.Protolude + +data MailCommand a + = SendMail Env MailSendRequest (Either MailCommandError MailCommandOutcome -> a) + deriving (Functor) + +sendMail :: (MailCommand :<: f) => Env -> MailSendRequest -> Free f (Either MailCommandError MailCommandOutcome) +sendMail env req = injectFree (SendMail env req Pure) diff --git a/src/WikiMusic/Free/SongCommand.hs b/src/WikiMusic/Free/SongCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/SongCommand.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Free.SongCommand + ( SongCommand (..), + insertSongs, + insertSongComments, + insertSongArtworks, + upsertSongOpinions, + insertSongExternalSources, + deleteSongs, + deleteSongComments, + deleteSongArtworks, + deleteSongOpinions, + deleteCommentsOfSongs, + deleteSongExternalSources, + deleteArtworksOfSongs, + deleteOpinionsOfSongs, + insertArtistsOfSongs, + deleteArtistsOfSongs, + deleteArtistOfSong, + updateSongArtworkOrder, + updateSongs, + updateSongExternalSources, + newSongFromRequest, + newSongCommentFromRequest, + newSongOpinionFromRequest, + newSongArtworkFromRequest, + newArtistOfSongFromRequest, + SongCommandError (..), + insertSongContents, + updateSongContents, + deleteSongContents, + deleteContentsOfSongs, + newSongContentFromRequest, + incrementViewsByOne, + ) +where + +import Data.UUID +import Free.AlaCarte +import Relude +import WikiMusic.Interaction.Model.Song +import WikiMusic.Model.Env +import WikiMusic.Model.Song + +data SongCommandError = PersistenceError Text | LogicError Text + deriving (Eq, Show) + +type SongCommand :: Type -> Type +data SongCommand a + = InsertSongs Env [Song] (Map UUID Song -> a) + | InsertSongComments Env [SongComment] (Map UUID SongComment -> a) + | InsertSongArtworks Env [SongArtwork] (Map UUID SongArtwork -> a) + | InsertArtistsOfSongs Env [ArtistOfSong] (Map UUID ArtistOfSong -> a) + | InsertSongExternalSources Env [SongExternalSources] (Map UUID SongExternalSources -> a) + | InsertSongContents Env [SongContent] (Map UUID SongContent -> a) + | DeleteSongs Env [UUID] (Either SongCommandError () -> a) + | DeleteSongComments Env [UUID] (Either SongCommandError () -> a) + | DeleteSongArtworks Env [UUID] (Either SongCommandError () -> a) + | DeleteSongOpinions Env [UUID] (Either SongCommandError () -> a) + | DeleteCommentsOfSongs Env [UUID] (Either SongCommandError () -> a) + | DeleteSongExternalSources Env [UUID] (Either SongCommandError () -> a) + | DeleteArtworksOfSongs Env [UUID] (Either SongCommandError () -> a) + | DeleteOpinionsOfSongs Env [UUID] (Either SongCommandError () -> a) + | DeleteArtistsOfSongs Env [UUID] (Either SongCommandError () -> a) + | DeleteArtistOfSong Env (UUID, UUID) (Either SongCommandError () -> a) + | DeleteSongContents Env [UUID] (Either SongCommandError () -> a) + | DeleteContentsOfSongs Env [UUID] (Either SongCommandError () -> a) + | UpsertSongOpinions Env [SongOpinion] (Map UUID SongOpinion -> a) + | UpdateSongArtworkOrder Env [SongArtworkOrderUpdate] (Either Text () -> a) + | UpdateSongs Env (Map UUID (Song, Maybe SongDelta)) (Either Text () -> a) + | UpdateSongExternalSources Env (Map UUID (Song, Maybe SongDelta)) (Either Text () -> a) + | UpdateSongContents Env [SongContentDelta] (Either Text () -> a) + | NewSongFromRequest UUID InsertSongsRequestItem (Song -> a) + | -- TODO: separate model generators to their own monad + NewSongCommentFromRequest UUID InsertSongCommentsRequestItem (SongComment -> a) + | NewSongOpinionFromRequest UUID UpsertSongOpinionsRequestItem (SongOpinion -> a) + | NewSongArtworkFromRequest UUID InsertSongArtworksRequestItem (SongArtwork -> a) + | NewArtistOfSongFromRequest UUID InsertArtistsOfSongsRequestItem (ArtistOfSong -> a) + | NewSongContentFromRequest UUID InsertSongContentsRequestItem (SongContent -> a) + | IncrementViewsByOne Env [UUID] (Either SongCommandError () -> a) + deriving (Functor) + +insertSongs :: (SongCommand :<: f) => Env -> [Song] -> Free f (Map UUID Song) +insertSongs env songs = injectFree (InsertSongs env songs Pure) + +insertSongComments :: (SongCommand :<: f) => Env -> [SongComment] -> Free f (Map UUID SongComment) +insertSongComments env songComments = injectFree (InsertSongComments env songComments Pure) + +insertSongArtworks :: (SongCommand :<: f) => Env -> [SongArtwork] -> Free f (Map UUID SongArtwork) +insertSongArtworks env songArtworks = injectFree (InsertSongArtworks env songArtworks Pure) + +upsertSongOpinions :: (SongCommand :<: f) => Env -> [SongOpinion] -> Free f (Map UUID SongOpinion) +upsertSongOpinions env songOpinions = injectFree (UpsertSongOpinions env songOpinions Pure) + +insertSongExternalSources :: (SongCommand :<: f) => Env -> [SongExternalSources] -> Free f (Map UUID SongExternalSources) +insertSongExternalSources env songExternalSources = injectFree (InsertSongExternalSources env songExternalSources Pure) + +deleteSongs :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteSongs env uuids = injectFree (DeleteSongs env uuids Pure) + +deleteSongComments :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteSongComments env uuids = injectFree (DeleteSongComments env uuids Pure) + +deleteSongArtworks :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteSongArtworks env uuids = injectFree (DeleteSongArtworks env uuids Pure) + +deleteArtistsOfSongs :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteArtistsOfSongs env uuids = injectFree (DeleteArtistsOfSongs env uuids Pure) + +deleteArtistOfSong :: (SongCommand :<: f) => Env -> (UUID, UUID) -> Free f (Either SongCommandError ()) +deleteArtistOfSong env uuids = injectFree (DeleteArtistOfSong env uuids Pure) + +deleteSongContents :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteSongContents env uuids = injectFree (DeleteSongContents env uuids Pure) + +deleteContentsOfSongs :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteContentsOfSongs env uuids = injectFree (DeleteContentsOfSongs env uuids Pure) + +deleteSongOpinions :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteSongOpinions env uuids = injectFree (DeleteSongOpinions env uuids Pure) + +deleteCommentsOfSongs :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteCommentsOfSongs env uuids = injectFree (DeleteCommentsOfSongs env uuids Pure) + +deleteSongExternalSources :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteSongExternalSources env uuids = injectFree (DeleteSongExternalSources env uuids Pure) + +deleteArtworksOfSongs :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteArtworksOfSongs env uuids = injectFree (DeleteArtworksOfSongs env uuids Pure) + +deleteOpinionsOfSongs :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +deleteOpinionsOfSongs env uuids = injectFree (DeleteOpinionsOfSongs env uuids Pure) + +insertSongContents :: (SongCommand :<: f) => Env -> [SongContent] -> Free f (Map UUID SongContent) +insertSongContents env contents = injectFree (InsertSongContents env contents Pure) + +updateSongArtworkOrder :: (SongCommand :<: f) => Env -> [SongArtworkOrderUpdate] -> Free f (Either Text ()) +updateSongArtworkOrder env uuids = injectFree (UpdateSongArtworkOrder env uuids Pure) + +updateSongs :: (SongCommand :<: f) => Env -> Map UUID (Song, Maybe SongDelta) -> Free f (Either Text ()) +updateSongs env deltas = injectFree (UpdateSongs env deltas Pure) + +updateSongExternalSources :: (SongCommand :<: f) => Env -> Map UUID (Song, Maybe SongDelta) -> Free f (Either Text ()) +updateSongExternalSources env deltas = injectFree (UpdateSongExternalSources env deltas Pure) + +updateSongContents :: (SongCommand :<: f) => Env -> [SongContentDelta] -> Free f (Either Text ()) +updateSongContents env deltas = injectFree (UpdateSongContents env deltas Pure) + +newSongFromRequest :: (SongCommand :<: f) => UUID -> InsertSongsRequestItem -> Free f Song +newSongFromRequest uuid req = injectFree (NewSongFromRequest uuid req Pure) + +newSongCommentFromRequest :: (SongCommand :<: f) => UUID -> InsertSongCommentsRequestItem -> Free f SongComment +newSongCommentFromRequest uuid req = injectFree (NewSongCommentFromRequest uuid req Pure) + +newSongOpinionFromRequest :: (SongCommand :<: f) => UUID -> UpsertSongOpinionsRequestItem -> Free f SongOpinion +newSongOpinionFromRequest uuid req = injectFree (NewSongOpinionFromRequest uuid req Pure) + +newSongContentFromRequest :: (SongCommand :<: f) => UUID -> InsertSongContentsRequestItem -> Free f SongContent +newSongContentFromRequest uuid req = injectFree (NewSongContentFromRequest uuid req Pure) + +newSongArtworkFromRequest :: (SongCommand :<: f) => UUID -> InsertSongArtworksRequestItem -> Free f SongArtwork +newSongArtworkFromRequest uuid req = injectFree (NewSongArtworkFromRequest uuid req Pure) + +insertArtistsOfSongs :: (SongCommand :<: f) => Env -> [ArtistOfSong] -> Free f (Map UUID ArtistOfSong) +insertArtistsOfSongs env art = injectFree (InsertArtistsOfSongs env art Pure) + +newArtistOfSongFromRequest :: (SongCommand :<: f) => UUID -> InsertArtistsOfSongsRequestItem -> Free f ArtistOfSong +newArtistOfSongFromRequest uuid req = injectFree (NewArtistOfSongFromRequest uuid req Pure) + +incrementViewsByOne :: (SongCommand :<: f) => Env -> [UUID] -> Free f (Either SongCommandError ()) +incrementViewsByOne env uuids = injectFree (IncrementViewsByOne env uuids Pure) diff --git a/src/WikiMusic/Free/SongQuery.hs b/src/WikiMusic/Free/SongQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/SongQuery.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Free.SongQuery + ( SongQuery (..), + fetchSongs, + fetchSongsByUUID, + enrichedSongResponse, + fetchSongComments, + fetchSongOpinions, + fetchSongArtworks, + SongQueryError (..), + searchSongs, + fetchSongContents, + fetchSongArtists, + ) +where + +import Free.AlaCarte +import WikiMusic.Interaction.Model.Song +import WikiMusic.Model.Other +import WikiMusic.Model.Song +import WikiMusic.Protolude + +data SongQueryError = PersistenceError Text | LogicError Text + deriving (Eq, Show) + +type SongQuery :: Type -> Type +data SongQuery a + = FetchSongs Env SongSortOrder Limit Offset ((Map UUID Song, [UUID]) -> a) + | FetchSongsByUUID Env SongSortOrder [UUID] ((Map UUID Song, [UUID]) -> a) + | EnrichedSongResponse Env (Map UUID Song) EnrichSongParams (Map UUID Song -> a) + | FetchSongComments Env [UUID] (Map UUID SongComment -> a) + | FetchSongOpinions Env [UUID] (Map UUID SongOpinion -> a) + | FetchSongArtworks Env [UUID] (Map UUID SongArtwork -> a) + | FetchSongContents Env [UUID] (Map UUID SongContent -> a) + | FetchSongArtists Env [UUID] ([(UUID, UUID, Text)] -> a) + | SearchSongs Env SearchInput SongSortOrder Limit Offset ((Map UUID Song, [UUID]) -> a) + deriving (Functor) + +fetchSongs :: (SongQuery :<: f) => Env -> SongSortOrder -> Limit -> Offset -> Free f (Map UUID Song, [UUID]) +fetchSongs env sortOrder fetchLimit offset = injectFree (FetchSongs env sortOrder fetchLimit offset Pure) + +fetchSongsByUUID :: (SongQuery :<: f) => Env -> SongSortOrder -> [UUID] -> Free f (Map UUID Song, [UUID]) +fetchSongsByUUID env sortOrder uuids = injectFree (FetchSongsByUUID env sortOrder uuids Pure) + +enrichedSongResponse :: (SongQuery :<: f) => Env -> Map UUID Song -> EnrichSongParams -> Free f (Map UUID Song) +enrichedSongResponse env songs enrichParams = injectFree (EnrichedSongResponse env songs enrichParams Pure) + +fetchSongComments :: (SongQuery :<: f) => Env -> [UUID] -> Free f (Map UUID SongComment) +fetchSongComments env uuids = injectFree (FetchSongComments env uuids Pure) + +fetchSongOpinions :: (SongQuery :<: f) => Env -> [UUID] -> Free f (Map UUID SongOpinion) +fetchSongOpinions env uuids = injectFree (FetchSongOpinions env uuids Pure) + +fetchSongArtworks :: (SongQuery :<: f) => Env -> [UUID] -> Free f (Map UUID SongArtwork) +fetchSongArtworks env uuids = injectFree (FetchSongArtworks env uuids Pure) + +searchSongs :: (SongQuery :<: f) => Env -> SearchInput -> SongSortOrder -> Limit -> Offset -> Free f (Map UUID Song, [UUID]) +searchSongs env searchInput sortOrder fetchLimit offset = injectFree (SearchSongs env searchInput sortOrder fetchLimit offset Pure) + +fetchSongContents :: (SongQuery :<: f) => Env -> [UUID] -> Free f (Map UUID SongContent) +fetchSongContents env uuids = injectFree (FetchSongContents env uuids Pure) + +fetchSongArtists :: (SongQuery :<: f) => Env -> [UUID] -> Free f [(UUID, UUID, Text)] +fetchSongArtists env uuids = injectFree (FetchSongArtists env uuids Pure) diff --git a/src/WikiMusic/Free/UserCommand.hs b/src/WikiMusic/Free/UserCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/UserCommand.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Free.UserCommand + ( UserCommand (..), + makeResetPasswordLink, + changePasswordByEmail, + invalidateResetTokenByEmail, + inviteUser, + deleteUser, + UserCommandError (..), + UserEmail (..), + UserPassword (..), + UserName (..), + ) +where + +import WikiMusic.Protolude + +newtype UserEmail = UserEmail {value :: Text} + deriving (Generic, Eq, Show) + +makeFieldLabelsNoPrefix ''UserEmail + +newtype UserPassword = UserPassword {value :: Text} + deriving (Generic, Eq, Show) + +makeFieldLabelsNoPrefix ''UserPassword + +newtype UserName = UserName {value :: Text} + deriving (Generic, Eq, Show) + +makeFieldLabelsNoPrefix ''UserName + +data UserCommandError = PersistenceError Text | LogicError Text | NotificationError Text + deriving (Show) + +type UserCommand :: Type -> Type +data UserCommand a + = MakeResetPasswordLink Env UserEmail (Either UserCommandError Text -> a) + | ChangePasswordByEmail Env UserEmail UserPassword (Either UserCommandError () -> a) + | InvalidateResetTokenByEmail Env UserEmail (Either UserCommandError () -> a) + | InviteUser Env WikiMusicUser UserEmail UserName UserRole (Maybe Text) (Either UserCommandError Text -> a) + | DeleteUser Env WikiMusicUser UserEmail (Either UserCommandError () -> a) + deriving (Functor) + +makeResetPasswordLink :: (UserCommand :<: f) => Env -> UserEmail -> Free f (Either UserCommandError Text) +makeResetPasswordLink env userEmail = injectFree (MakeResetPasswordLink env userEmail Pure) + +changePasswordByEmail :: (UserCommand :<: f) => Env -> UserEmail -> UserPassword -> Free f (Either UserCommandError ()) +changePasswordByEmail env userEmail userPass = injectFree (ChangePasswordByEmail env userEmail userPass Pure) + +invalidateResetTokenByEmail :: (UserCommand :<: f) => Env -> UserEmail -> Free f (Either UserCommandError ()) +invalidateResetTokenByEmail env userEmail = injectFree (InvalidateResetTokenByEmail env userEmail Pure) + +inviteUser :: (UserCommand :<: f) => Env -> WikiMusicUser -> UserEmail -> UserName -> UserRole -> Maybe Text -> Free f (Either UserCommandError Text) +inviteUser env authUser userEmail userName userRole desc = injectFree (InviteUser env authUser userEmail userName userRole desc Pure) + +deleteUser :: (UserCommand :<: f) => Env -> WikiMusicUser -> UserEmail -> Free f (Either UserCommandError ()) +deleteUser env authUser userEmail = injectFree (DeleteUser env authUser userEmail Pure) diff --git a/src/WikiMusic/Free/UserQuery.hs b/src/WikiMusic/Free/UserQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Free/UserQuery.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Free.UserQuery + ( UserQuery (..), + doesTokenMatchByEmail, + UserQueryError (..), + UserEmail (..), + UserToken (..), + ) +where + +import WikiMusic.Protolude + +newtype UserEmail = UserEmail {value :: Text} + deriving (Generic, Eq, Show) + +makeFieldLabelsNoPrefix ''UserEmail + +newtype UserToken = UserToken {value :: Text} + deriving (Generic, Eq, Show) + +makeFieldLabelsNoPrefix ''UserToken + +data UserQueryError = PersistenceError Text | LogicError Text deriving (Show) + +data UserQuery a + = DoesTokenMatchByEmail Env UserEmail UserToken (Either UserQueryError Bool -> a) + deriving (Functor) + +doesTokenMatchByEmail :: (UserQuery :<: f) => Env -> UserEmail -> UserToken -> Free f (Either UserQueryError Bool) +doesTokenMatchByEmail env userEmail userToken = injectFree (DoesTokenMatchByEmail env userEmail userToken Pure) diff --git a/src/WikiMusic/Interaction/Artist.hs b/src/WikiMusic/Interaction/Artist.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Interaction/Artist.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE OverloadedLabels #-} + +module WikiMusic.Interaction.Artist + ( fetchArtistsAction, + insertArtistsAction, + insertArtistCommentsAction, + insertArtistArtworksAction, + upsertArtistOpinionsAction, + deleteArtistsByIdentifierAction, + deleteArtistCommentsByIdentifierAction, + deleteArtistOpinionsByIdentifierAction, + deleteArtistArtworksByIdentifierAction, + updateArtistArtworksOrderAction, + updateArtistAction, + fetchArtistAction, + searchArtistsAction, + ) +where + +import Data.Map qualified as Map +import Data.Text (pack, take, unpack) +import Relude +import WikiMusic.Free.ArtistCommand +import WikiMusic.Free.ArtistQuery +import WikiMusic.Interaction.Model.Artist +import WikiMusic.Model.Artist +import WikiMusic.Model.Other +import WikiMusic.PostgreSQL.ArtistCommand () +import WikiMusic.PostgreSQL.ArtistQuery () +import WikiMusic.Protolude + +fetchArtistsAction :: + (ArtistQuery :<: f, ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + Limit -> + Offset -> + Maybe Text -> + Maybe Text -> + Free f (Either ArtistError GetArtistsQueryResponse) +fetchArtistsAction env authUser limit offset maybeSortOrder maybeInclude = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + (artistMap, sortOrderList) <- fetchArtists env sortOrder limit offset + + enrichedArtists <- + enrichedArtistResponse + env + artistMap + (maybe noEnrichment parseInclude maybeInclude) + + pure . Right $ GetArtistsQueryResponse {artists = enrichedArtists, sortOrder = sortOrderList} + where + sortOrder = fromMaybe DescCreatedAt (readMaybe . unpack =<< maybeSortOrder) + +searchArtistsAction :: + (ArtistQuery :<: f, ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + Limit -> + Offset -> + Maybe Text -> + Maybe Text -> + Text -> + Free f (Either ArtistError GetArtistsQueryResponse) +searchArtistsAction env authUser limit offset maybeSortOrder maybeInclude searchInput = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + (artistMap, sortOrderList) <- searchArtists env (SearchInput searchInput) sortOrder limit offset + + enrichedArtists <- + enrichedArtistResponse + env + artistMap + (maybe noEnrichment parseInclude maybeInclude) + + pure . Right $ GetArtistsQueryResponse {artists = enrichedArtists, sortOrder = sortOrderList} + where + sortOrder = fromMaybe DescCreatedAt (readMaybe . unpack =<< maybeSortOrder) + +fetchArtistAction :: + (ArtistQuery :<: f, ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Maybe Text -> + Maybe Text -> + Free f (Either ArtistError GetArtistsQueryResponse) +fetchArtistAction env authUser identifier maybeSortOrder maybeInclude = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + (artistMap, sortOrderList) <- fetchArtistsByUUID env sortOrder [identifier] + + enrichedArtists <- + enrichedArtistResponse + env + artistMap + (maybe noEnrichment parseInclude maybeInclude) + + _ <- incrementViewsByOne env (Map.keys artistMap) + + pure . Right $ GetArtistsQueryResponse {artists = enrichedArtists, sortOrder = sortOrderList} + where + sortOrder = fromMaybe DescCreatedAt (readMaybe . unpack =<< maybeSortOrder) + +insertArtistsAction :: + (ArtistCommand :<: f, ArtistQuery :<: f) => + Env -> + WikiMusicUser -> + InsertArtistsRequest -> + Free f (Either ArtistError InsertArtistsCommandResponse) +insertArtistsAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + newArtists <- mapM (newArtistFromRequest (authUser ^. #identifier)) (request ^. #artists) + + let entityValidation x = (x ^. #displayName, validateArtist x) + validationResults = fromList $ map entityValidation newArtists + newArtistIdentifiers = map (^. #identifier) newArtists + + ifAllValid validationResults $ do + _ <- insertArtists env newArtists + (artistMap, sortOrder) <- fetchArtistsByUUID env DescCreatedAt newArtistIdentifiers + enrichedInsertedArtists <- enrichedArtistResponse env artistMap fullEnrichment + pure + . Right + $ InsertArtistsQueryResponse + { artists = enrichedInsertedArtists, + sortOrder = sortOrder, + validationResults = validationResults + } + +insertArtistCommentsAction :: + (ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + InsertArtistCommentsRequest -> + Free f (Either ArtistError InsertArtistCommentsCommandResponse) +insertArtistCommentsAction env authUser request = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + newComments <- mapM (newArtistCommentFromRequest (authUser ^. #identifier)) (request ^. #artistComments) + + let entityValidation x = (Data.Text.take 20 (x ^. #comment % #contents), validateArtistComment x) + validationResults = fromList $ map entityValidation newComments + + ifAllValid validationResults $ do + insertedComments <- insertArtistComments env newComments + pure + . Right + $ InsertArtistCommentsCommandResponse + { artistComments = insertedComments, + validationResults = validationResults + } + +upsertArtistOpinionsAction :: + (ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + UpsertArtistOpinionsRequest -> + Free f (Either ArtistError UpsertArtistOpinionsCommandResponse) +upsertArtistOpinionsAction env authUser request = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + newOpinions <- mapM (newArtistOpinionFromRequest (authUser ^. #identifier)) (request ^. #artistOpinions) + + let entityValidation x = (x ^. #artistIdentifier, validateArtistOpinion x) + validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) newOpinions + + ifAllValid validationResults $ do + upsertedOpinions <- upsertArtistOpinions env newOpinions + pure + . Right + $ UpsertArtistOpinionsCommandResponse + { artistOpinions = upsertedOpinions, + validationResults = validationResults + } + +insertArtistArtworksAction :: + (ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + InsertArtistArtworksRequest -> + Free f (Either ArtistError InsertArtistArtworksCommandResponse) +insertArtistArtworksAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + newArtworks <- mapM (newArtistArtworkFromRequest (authUser ^. #identifier)) (request ^. #artistArtworks) + + let entityValidation x = (x ^. #artistIdentifier, validateArtistArtwork x) + validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) newArtworks + + ifAllValid validationResults $ do + insertedArtworks <- insertArtistArtworks env newArtworks + pure + . Right + $ InsertArtistArtworksCommandResponse + { artistArtworks = insertedArtworks, + validationResults = validationResults + } + +deleteArtistsByIdentifierAction :: + (ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either ArtistError ()) +deleteArtistsByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteArtists env [identifier] + pure . first (SomeError . pack . Relude.show) $ operationResults + +deleteArtistCommentsByIdentifierAction :: + (ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either ArtistError ()) +deleteArtistCommentsByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteArtistComments env [identifier] + pure . first (SomeError . pack . Relude.show) $ operationResults + +deleteArtistOpinionsByIdentifierAction :: + (ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either ArtistError ()) +deleteArtistOpinionsByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteArtistOpinions env [identifier] + pure . first (SomeError . pack . Relude.show) $ operationResults + +deleteArtistArtworksByIdentifierAction :: + (ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either ArtistError ()) +deleteArtistArtworksByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteArtistArtworks env [identifier] + pure . first (SomeError . pack . Relude.show) $ operationResults + +updateArtistArtworksOrderAction :: + (ArtistCommand :<: f) => + Env -> + WikiMusicUser -> + ArtistArtworkOrderUpdateRequest -> + Free f (Either ArtistError ()) +updateArtistArtworksOrderAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let artistArtworkOrderUpdates = request ^. #artistArtworkOrders + entityValidation x = (x ^. #identifier, validateArtistArtworkOrderUpdate x) + validationResults = + fromList $ + map (first (pack . Relude.show) . entityValidation) artistArtworkOrderUpdates + + ifAllValid validationResults $ do + operationResults <- updateArtistArtworkOrder env artistArtworkOrderUpdates + pure . first SomeError $ operationResults + +updateArtistAction :: + (ArtistCommand :<: f, ArtistQuery :<: f) => + Env -> + WikiMusicUser -> + ArtistDeltaRequest -> + Free f (Either ArtistError ()) +updateArtistAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let entityValidation x = (x ^. #identifier, validateArtistDelta x) + deltas = request ^. #artistDeltas + validationResults = fromList . map (first (pack . Relude.show) . entityValidation) $ deltas + + ifAllValid validationResults $ do + let artistIds = map (^. #identifier) deltas + deltaMap = fromList $ map (\x -> (x ^. #identifier, x)) deltas + + artistRecords <- fst <$> fetchArtistsByUUID env DescCreatedAt artistIds + + let artistRecordAndDeltaPairMap = Map.mapWithKey (\k v -> (v, deltaMap Map.!? k)) artistRecords + + operationResults <- updateArtists env artistRecordAndDeltaPairMap + pure . first SomeError $ operationResults diff --git a/src/WikiMusic/Interaction/Auth.hs b/src/WikiMusic/Interaction/Auth.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Interaction/Auth.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Interaction.Auth + ( fetchMeAction, + ) +where + +import WikiMusic.Free.AuthQuery +import WikiMusic.Interaction.Model.Auth +import WikiMusic.PostgreSQL.AuthQuery () +import WikiMusic.Protolude + +fetchMeAction :: (AuthQuery :<: f) => Env -> UUID -> Free f (Maybe GetMeQueryResponse) +fetchMeAction env identifier = do + maybeUserOrErr <- fetchMe env identifier + case maybeUserOrErr of + Left _ -> do + pure Nothing + Right maybeWikiMusicUser -> do + pure $ userToResponse <$> maybeWikiMusicUser + where + userToResponse x = + GetMeQueryResponse + { identifier = x ^. #identifier, + displayName = x ^. #displayName, + emailAddress = x ^. #emailAddress, + roles = x ^. #roles + } diff --git a/src/WikiMusic/Interaction/Genre.hs b/src/WikiMusic/Interaction/Genre.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Interaction/Genre.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE OverloadedLabels #-} + +module WikiMusic.Interaction.Genre + ( fetchGenresAction, + insertGenresAction, + insertGenreCommentsAction, + insertGenreArtworksAction, + upsertGenreOpinionsAction, + deleteGenresByIdentifierAction, + deleteGenreCommentsByIdentifierAction, + deleteGenreOpinionsByIdentifierAction, + deleteGenreArtworksByIdentifierAction, + updateGenreArtworksOrderAction, + updateGenreAction, + fetchGenreAction, + searchGenresAction, + ) +where + +import Data.Map qualified as Map +import Data.Text (pack, take, unpack) +import Relude +import WikiMusic.Free.GenreCommand +import WikiMusic.Free.GenreQuery +import WikiMusic.Interaction.Model.Genre +import WikiMusic.Model.Genre +import WikiMusic.Model.Other +import WikiMusic.PostgreSQL.GenreCommand () +import WikiMusic.PostgreSQL.GenreQuery () +import WikiMusic.Protolude + +fetchGenresAction :: + (GenreQuery :<: f, GenreCommand :<: f) => + Env -> + WikiMusicUser -> + Limit -> + Offset -> + Maybe Text -> + Maybe Text -> + Free f (Either GenreError GetGenresQueryResponse) +fetchGenresAction env authUser limit offset maybeSortOrder maybeInclude = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + (genreMap, sortOrderList) <- fetchGenres env sortOrder limit offset + + enrichedGenres <- + enrichedGenreResponse + env + genreMap + (maybe noEnrichment parseInclude maybeInclude) + + pure . Right $ GetGenresQueryResponse {genres = enrichedGenres, sortOrder = sortOrderList} + where + sortOrder = fromMaybe DescCreatedAt (readMaybe . unpack =<< maybeSortOrder) + +searchGenresAction :: + (GenreQuery :<: f, GenreCommand :<: f) => + Env -> + WikiMusicUser -> + Limit -> + Offset -> + Maybe Text -> + Maybe Text -> + Text -> + Free f (Either GenreError GetGenresQueryResponse) +searchGenresAction env authUser limit offset maybeSortOrder maybeInclude searchInput = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + (genreMap, sortOrderList) <- searchGenres env (SearchInput searchInput) sortOrder limit offset + + enrichedGenres <- + enrichedGenreResponse + env + genreMap + (maybe noEnrichment parseInclude maybeInclude) + + pure . Right $ GetGenresQueryResponse {genres = enrichedGenres, sortOrder = sortOrderList} + where + sortOrder = fromMaybe DescCreatedAt (readMaybe . unpack =<< maybeSortOrder) + +fetchGenreAction :: + (GenreQuery :<: f, GenreCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Maybe Text -> + Maybe Text -> + Free f (Either GenreError GetGenresQueryResponse) +fetchGenreAction env authUser identifier maybeSortOrder maybeInclude = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + (genreMap, sortOrderList) <- fetchGenresByUUID env sortOrder [identifier] + + enrichedGenres <- + enrichedGenreResponse + env + genreMap + (maybe noEnrichment parseInclude maybeInclude) + + _ <- incrementViewsByOne env (Map.keys genreMap) + + pure . Right $ GetGenresQueryResponse {genres = enrichedGenres, sortOrder = sortOrderList} + where + sortOrder = fromMaybe DescCreatedAt (readMaybe . unpack =<< maybeSortOrder) + +insertGenresAction :: + (GenreCommand :<: f, GenreQuery :<: f) => + Env -> + WikiMusicUser -> + InsertGenresRequest -> + Free f (Either GenreError InsertGenresCommandResponse) +insertGenresAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + newGenres <- mapM (newGenreFromRequest (authUser ^. #identifier)) (request ^. #genres) + + let entityValidation x = (x ^. #displayName, validateGenre x) + validationResults = fromList $ map entityValidation newGenres + newGenreIdentifiers = map (^. #identifier) newGenres + + ifAllValid validationResults $ do + _ <- insertGenres env newGenres + (genreMap, sortOrder) <- fetchGenresByUUID env DescCreatedAt newGenreIdentifiers + enrichedInsertedGenres <- enrichedGenreResponse env genreMap fullEnrichment + pure + . Right + $ InsertGenresQueryResponse + { genres = enrichedInsertedGenres, + sortOrder = sortOrder, + validationResults = validationResults + } + +insertGenreCommentsAction :: + (GenreCommand :<: f) => + Env -> + WikiMusicUser -> + InsertGenreCommentsRequest -> + Free f (Either GenreError InsertGenreCommentsCommandResponse) +insertGenreCommentsAction env authUser request = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + newComments <- mapM (newGenreCommentFromRequest (authUser ^. #identifier)) (request ^. #genreComments) + + let entityValidation x = (Data.Text.take 20 (x ^. #comment % #contents), validateGenreComment x) + validationResults = fromList $ map entityValidation newComments + + ifAllValid validationResults $ do + insertedComments <- insertGenreComments env newComments + pure + . Right + $ InsertGenreCommentsCommandResponse + { genreComments = insertedComments, + validationResults = validationResults + } + +upsertGenreOpinionsAction :: + (GenreCommand :<: f) => + Env -> + WikiMusicUser -> + UpsertGenreOpinionsRequest -> + Free f (Either GenreError UpsertGenreOpinionsCommandResponse) +upsertGenreOpinionsAction env authUser request = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + newOpinions <- mapM (newGenreOpinionFromRequest (authUser ^. #identifier)) (request ^. #genreOpinions) + + let entityValidation x = (x ^. #genreIdentifier, validateGenreOpinion x) + validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) newOpinions + + ifAllValid validationResults $ do + upsertedOpinions <- upsertGenreOpinions env newOpinions + pure + . Right + $ UpsertGenreOpinionsCommandResponse + { genreOpinions = upsertedOpinions, + validationResults = validationResults + } + +insertGenreArtworksAction :: + (GenreCommand :<: f) => + Env -> + WikiMusicUser -> + InsertGenreArtworksRequest -> + Free f (Either GenreError InsertGenreArtworksCommandResponse) +insertGenreArtworksAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + newArtworks <- mapM (newGenreArtworkFromRequest (authUser ^. #identifier)) (request ^. #genreArtworks) + + let entityValidation x = (x ^. #genreIdentifier, validateGenreArtwork x) + validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) newArtworks + + ifAllValid validationResults $ do + insertedArtworks <- insertGenreArtworks env newArtworks + pure + . Right + $ InsertGenreArtworksCommandResponse + { genreArtworks = insertedArtworks, + validationResults = validationResults + } + +deleteGenresByIdentifierAction :: + (GenreCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either GenreError ()) +deleteGenresByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteGenres env [identifier] + pure . void $ first (SomeError . pack . Relude.show) operationResults + +deleteGenreCommentsByIdentifierAction :: + (GenreCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either GenreError ()) +deleteGenreCommentsByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteGenreComments env [identifier] + pure . void $ first (SomeError . pack . Relude.show) operationResults + +deleteGenreOpinionsByIdentifierAction :: + (GenreCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either GenreError ()) +deleteGenreOpinionsByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteGenreOpinions env [identifier] + pure . void $ first (SomeError . pack . Relude.show) operationResults + +deleteGenreArtworksByIdentifierAction :: + (GenreCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either GenreError ()) +deleteGenreArtworksByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteGenreArtworks env [identifier] + pure . void $ first (SomeError . pack . Relude.show) operationResults + +updateGenreArtworksOrderAction :: + (GenreCommand :<: f) => + Env -> + WikiMusicUser -> + GenreArtworkOrderUpdateRequest -> + Free f (Either GenreError ()) +updateGenreArtworksOrderAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let genreArtworkOrderUpdates = request ^. #genreArtworkOrders + entityValidation x = (x ^. #identifier, validateGenreArtworkOrderUpdate x) + validationResults = fromList . map (first (pack . Relude.show) . entityValidation) $ genreArtworkOrderUpdates + + ifAllValid validationResults $ do + operationResults <- updateGenreArtworkOrder env genreArtworkOrderUpdates + pure . void $ first SomeError operationResults + +updateGenreAction :: + (GenreCommand :<: f, GenreQuery :<: f) => + Env -> + WikiMusicUser -> + GenreDeltaRequest -> + Free f (Either GenreError ()) +updateGenreAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let deltas = request ^. #genreDeltas + entityValidation x = (x ^. #identifier, validateGenreDelta x) + validationResults = fromList . map (first (pack . Relude.show) . entityValidation) $ deltas + + ifAllValid validationResults $ do + let genreIds = map (^. #identifier) deltas + deltaMap = fromList $ map (\x -> (x ^. #identifier, x)) deltas + + genreRecords <- fst <$> fetchGenresByUUID env DescCreatedAt genreIds + + let genreRecordAndDeltaPairMap = Map.mapWithKey (\k v -> (v, deltaMap Map.!? k)) genreRecords + + operationResults <- updateGenres env genreRecordAndDeltaPairMap + pure . void $ first SomeError operationResults diff --git a/src/WikiMusic/Interaction/Mail.hs b/src/WikiMusic/Interaction/Mail.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Interaction/Mail.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Interaction.Mail (sendMailAction) where + +import WikiMusic.Free.MailCommand +import WikiMusic.Model.Mail +import WikiMusic.Protolude + +sendMailAction :: + (MailCommand :<: f) => + Env -> + MailSendRequest -> + Free f (Either MailCommandError MailCommandOutcome) +sendMailAction = sendMail diff --git a/src/WikiMusic/Interaction/Song.hs b/src/WikiMusic/Interaction/Song.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Interaction/Song.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Interaction.Song + ( fetchSongsAction, + insertSongsAction, + insertSongCommentsAction, + insertSongArtworksAction, + upsertSongOpinionsAction, + deleteSongsByIdentifierAction, + deleteSongCommentsByIdentifierAction, + deleteSongOpinionsByIdentifierAction, + deleteSongArtworksByIdentifierAction, + updateSongArtworksOrderAction, + updateSongAction, + insertArtistsOfSongAction, + fetchSongAction, + updateSongContentsAction, + deleteSongContentsByIdentifierAction, + insertSongContentsAction, + searchSongsAction, + deleteArtistsOfSongAction, + ) +where + +import Data.Map qualified as Map +import Data.Text (pack, take, unpack) +import Relude +import WikiMusic.Free.Logger +import WikiMusic.Free.SongCommand +import WikiMusic.Free.SongQuery +import WikiMusic.Interaction.Model.Song +import WikiMusic.Model.Other +import WikiMusic.Model.Song +import WikiMusic.Protolude + +fetchSongsAction :: + (SongQuery :<: f, SongCommand :<: f) => + Env -> + WikiMusicUser -> + Limit -> + Offset -> + Maybe Text -> + Maybe Text -> + Free f (Either SongError GetSongsQueryResponse) +fetchSongsAction env authUser limit offset maybeSortOrder maybeInclude = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + (songMap, sortOrderList) <- fetchSongs env sortOrder limit offset + + enrichedSongs <- + enrichedSongResponse + env + songMap + (maybe noEnrichment parseInclude maybeInclude) + + pure . Right $ GetSongsQueryResponse {songs = enrichedSongs, sortOrder = sortOrderList} + where + sortOrder = fromMaybe DescCreatedAt (readMaybe . unpack =<< maybeSortOrder) + +searchSongsAction :: + (SongQuery :<: f, SongCommand :<: f) => + Env -> + WikiMusicUser -> + Limit -> + Offset -> + Maybe Text -> + Maybe Text -> + Text -> + Free f (Either SongError GetSongsQueryResponse) +searchSongsAction env authUser limit offset maybeSortOrder maybeInclude searchInput = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + (songMap, sortOrderList) <- searchSongs env (SearchInput searchInput) sortOrder limit offset + + enrichedSongs <- + enrichedSongResponse + env + songMap + (maybe noEnrichment parseInclude maybeInclude) + + pure . Right $ GetSongsQueryResponse {songs = enrichedSongs, sortOrder = sortOrderList} + where + sortOrder = fromMaybe DescCreatedAt (readMaybe . unpack =<< maybeSortOrder) + +fetchSongAction :: + (SongQuery :<: f, SongCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Maybe Text -> + Maybe Text -> + Free f (Either SongError GetSongsQueryResponse) +fetchSongAction env authUser identifier maybeSortOrder maybeInclude = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + (songMap, sortOrderList) <- fetchSongsByUUID env sortOrder [identifier] + + enrichedSongs <- + enrichedSongResponse + env + songMap + (maybe noEnrichment parseInclude maybeInclude) + + _ <- incrementViewsByOne env (Map.keys songMap) + + pure . Right $ GetSongsQueryResponse {songs = enrichedSongs, sortOrder = sortOrderList} + where + sortOrder = fromMaybe DescCreatedAt (readMaybe . unpack =<< maybeSortOrder) + +insertSongsAction :: + (SongQuery :<: f, SongCommand :<: f, Logger :<: f) => + Env -> + WikiMusicUser -> + InsertSongsRequest -> + Free f (Either SongError InsertSongsCommandResponse) +insertSongsAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + newSongs <- mapM (newSongFromRequest (authUser ^. #identifier)) (request ^. #songs) + + let entityValidation x = (x ^. #displayName, validateSong x) + validationResults = fromList . map (first (pack . Relude.show) . entityValidation) $ newSongs + newSongIdentifiers = map (^. #identifier) newSongs + + ifAllValid validationResults $ do + _ <- insertSongs env newSongs + _ <- logInfo "INSERTING NEW SONGS:" + _ <- logInfo . pack . Relude.show $ newSongs + (songMap, sortOrder) <- fetchSongsByUUID env DescCreatedAt newSongIdentifiers + + enrichedInsertedSongs <- enrichedSongResponse env songMap fullEnrichment + pure + . Right + $ InsertSongsQueryResponse + { songs = enrichedInsertedSongs, + sortOrder = sortOrder, + validationResults = validationResults + } + +insertSongCommentsAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + InsertSongCommentsRequest -> + Free f (Either SongError InsertSongCommentsCommandResponse) +insertSongCommentsAction env authUser request = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + newComments <- mapM (newSongCommentFromRequest (authUser ^. #identifier)) (request ^. #songComments) + let entityValidation x = (Data.Text.take 20 (x ^. #comment % #contents), validateSongComment x) + validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) newComments + + ifAllValid validationResults $ do + insertedComments <- insertSongComments env newComments + pure + . Right + $ InsertSongCommentsCommandResponse + { songComments = insertedComments, + validationResults = validationResults + } + +upsertSongOpinionsAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + UpsertSongOpinionsRequest -> + Free f (Either SongError UpsertSongOpinionsCommandResponse) +upsertSongOpinionsAction env authUser request = + doWithRoles' authUser isAtLeastDemo AccessUnauthorizedError $ do + let entityValidation x = (x ^. #songIdentifier, validateSongOpinion x) + + newOpinions <- mapM (newSongOpinionFromRequest (authUser ^. #identifier)) (request ^. #songOpinions) + let validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) newOpinions + + ifAllValid validationResults $ do + upsertedOpinions <- upsertSongOpinions env newOpinions + pure + . Right + $ UpsertSongOpinionsCommandResponse + { songOpinions = upsertedOpinions, + validationResults = validationResults + } + +insertSongArtworksAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + InsertSongArtworksRequest -> + Free f (Either SongError InsertSongArtworksCommandResponse) +insertSongArtworksAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let entityValidation x = (x ^. #songIdentifier, validateSongArtwork x) + + newArtworks <- mapM (newSongArtworkFromRequest (authUser ^. #identifier)) (request ^. #songArtworks) + + let validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) newArtworks + + ifAllValid validationResults $ do + insertedArtworks <- insertSongArtworks env newArtworks + pure + . Right + $ InsertSongArtworksCommandResponse + { songArtworks = insertedArtworks, + validationResults = validationResults + } + +deleteSongsByIdentifierAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either SongError ()) +deleteSongsByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteSongs env [identifier] + pure . first (SomeError . pack . Relude.show) $ operationResults + +deleteSongCommentsByIdentifierAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either SongError ()) +deleteSongCommentsByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteSongComments env [identifier] + pure . first (SomeError . pack . Relude.show) $ operationResults + +deleteSongOpinionsByIdentifierAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either SongError ()) +deleteSongOpinionsByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteSongOpinions env [identifier] + pure . first (SomeError . pack . Relude.show) $ operationResults + +deleteSongArtworksByIdentifierAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either SongError ()) +deleteSongArtworksByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteSongArtworks env [identifier] + pure . first (SomeError . pack . Relude.show) $ operationResults + +updateSongArtworksOrderAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + SongArtworkOrderUpdateRequest -> + Free f (Either SongError ()) +updateSongArtworksOrderAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let entityValidation x = (x ^. #identifier, validateSongArtworkOrderUpdate x) + songArtworkOrderUpdates = request ^. #songArtworkOrders + validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) songArtworkOrderUpdates + + ifAllValid validationResults $ do + operationResults <- updateSongArtworkOrder env songArtworkOrderUpdates + pure . first SomeError $ operationResults + +updateSongAction :: + (SongQuery :<: f, SongCommand :<: f) => + Env -> + WikiMusicUser -> + SongDeltaRequest -> + Free f (Either SongError ()) +updateSongAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let entityValidation x = (x ^. #identifier, validateSongDelta x) + deltas = request ^. #songDeltas + validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) deltas + + ifAllValid validationResults $ do + let songIds = map (^. #identifier) deltas + deltaMap = fromList $ map (\x -> (x ^. #identifier, x)) deltas + + songRecords <- fst <$> fetchSongsByUUID env DescCreatedAt songIds + + let songRecordAndDeltaPairMap = Map.mapWithKey (\k v -> (v, deltaMap Map.!? k)) songRecords + + operationResults <- updateSongs env songRecordAndDeltaPairMap + pure . first SomeError $ operationResults + +insertArtistsOfSongAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + InsertArtistsOfSongsRequest -> + Free f (Either SongError InsertArtistsOfSongCommandResponse) +insertArtistsOfSongAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let entityValidation x = (x ^. #artistIdentifier, validateArtistOfSong x) + newArtistsOfSong <- mapM (newArtistOfSongFromRequest (authUser ^. #identifier)) (request ^. #songArtists) + let validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) newArtistsOfSong + + ifAllValid validationResults $ do + newArtistsOfSongMap <- insertArtistsOfSongs env newArtistsOfSong + pure + . Right + $ InsertArtistsOfSongCommandResponse + { songArtists = newArtistsOfSongMap, + validationResults = validationResults + } + +deleteArtistsOfSongAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + InsertArtistsOfSongsRequest -> + Free f (Either SongError ()) +deleteArtistsOfSongAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let isN = nonEmpty (request ^. #songArtists) + case isN of + Nothing -> pure . Left . SomeError . pack $ "No valid data provided!" + Just songArtists -> do + let r = head songArtists + operationResults <- deleteArtistOfSong env (r ^. #songIdentifier, r ^. #artistIdentifier) + pure . first (SomeError . pack . Relude.show) $ + operationResults + +updateSongContentsAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + SongContentDeltaRequest -> + Free f (Either SongError ()) +updateSongContentsAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let entityValidation x = (x ^. #identifier, validateSongContentDelta x) + let deltas = request ^. #songContentDeltas + let validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) deltas + + ifAllValid validationResults $ do + operationResults <- updateSongContents env deltas + pure . first SomeError $ operationResults + +deleteSongContentsByIdentifierAction :: + (SongCommand :<: f) => + Env -> + WikiMusicUser -> + UUID -> + Free f (Either SongError ()) +deleteSongContentsByIdentifierAction env authUser identifier = + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + operationResults <- deleteSongContents env [identifier] + pure + . first (SomeError . pack . Relude.show) + $ operationResults + +insertSongContentsAction :: + (SongQuery :<: f, SongCommand :<: f) => + Env -> + WikiMusicUser -> + InsertSongContentsRequest -> + Free f (Either SongError InsertSongContentsCommandResponse) +insertSongContentsAction env authUser request = + doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do + let entityValidation x = ((pack . Relude.show $ x ^. #songIdentifier) <> "-" <> x ^. #versionName, validateSongContent x) + + newSongContents <- mapM (newSongContentFromRequest (authUser ^. #identifier)) (request ^. #songContents) + + let validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) newSongContents + + ifAllValid validationResults $ do + newSongContentsMap <- insertSongContents env newSongContents + pure + . Right + $ InsertSongContentsCommandResponse + { songContents = newSongContentsMap, + validationResults = validationResults + } diff --git a/src/WikiMusic/Interaction/User.hs b/src/WikiMusic/Interaction/User.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Interaction/User.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Interaction.User + ( makeResetPasswordLinkAction, + doPasswordResetAction, + deleteUserAction, + inviteUserAction, + ) +where + +import Data.Text (pack, unpack) +import NeatInterpolation +import Network.HTTP.Base qualified +import Relude +import WikiMusic.Free.MailCommand +import WikiMusic.Free.UserCommand as UC +import WikiMusic.Free.UserQuery as UQ +import WikiMusic.Interaction.Model.User +import WikiMusic.Model.Mail +import WikiMusic.Protolude + +makeResetPasswordLinkAction :: + (UserCommand :<: f, MailCommand :<: f) => + Env -> + Text -> + Free f (Either UserError MakeResetPasswordLinkResponse) +makeResetPasswordLinkAction env userEmail = do + maybeToken <- makeResetPasswordLink env (UC.UserEmail userEmail) + doSendMailFromResetToken env maybeToken userEmail + +doPasswordResetAction :: (UserCommand :<: f, UserQuery :<: f, MailCommand :<: f) => Env -> DoPasswordResetRequest -> Free f (Either UserError ()) +doPasswordResetAction env req + | (req ^. #password) == (req ^. #passwordConfirm) = do + isTokenMatch <- doesTokenMatchByEmail env (UQ.UserEmail $ req ^. #email) (UserToken $ req ^. #token) + case isTokenMatch of + Left e -> pure . Left . SomeError . pack . show $ e + Right doesMatch -> whenTokenMatches env req doesMatch + | otherwise = pure . Left . SomeError $ "Passwords must match!" + +whenTokenMatches :: + (UserCommand :<: f) => + Env -> + DoPasswordResetRequest -> + Bool -> + Free f (Either UserError ()) +whenTokenMatches _ _ False = pure . Left $ AccessUnauthorizedError +whenTokenMatches env req True = do + hasChangedPass <- changePasswordByEmail env (UC.UserEmail $ req ^. #email) (UC.UserPassword $ req ^. #password) + case hasChangedPass of + Left e -> pure . Left . SomeError . pack . show $ e + Right _ -> do + hasInvalidatedToken <- invalidateResetTokenByEmail env (UC.UserEmail $ req ^. #email) + pure $ first (SomeError . pack . show) hasInvalidatedToken + +deleteUserAction :: + (UserCommand :<: f) => + Env -> + WikiMusicUser -> + DeleteUsersRequest -> + Free f (Either UserError ()) +deleteUserAction env authUser req = do + doWithRoles' authUser isAtLeastSuperUser AccessUnauthorizedError $ do + s <- deleteUser env authUser (UC.UserEmail $ req ^. #email) + pure $ first (SomeError . pack . show) s + +inviteUserAction :: + (UserCommand :<: f, MailCommand :<: f) => + Env -> + WikiMusicUser -> + InviteUsersRequest -> + Free f (Either UserError MakeResetPasswordLinkResponse) +inviteUserAction env authUser req = do + doWithRoles' authUser isAtLeastMaintainer AccessUnauthorizedError $ do + maybeToken <- inviteUser env authUser (UC.UserEmail $ req ^. #email) (UC.UserName $ req ^. #displayName) (req ^. #role) (req ^. #description) + doSendMailFromResetToken env maybeToken (req ^. #email) + +doSendMailFromResetToken :: + (UserCommand :<: f, MailCommand :<: f) => + Env -> + Either UserCommandError Text -> + Text -> + Free f (Either UserError MakeResetPasswordLinkResponse) +doSendMailFromResetToken env maybeToken userEmail = do + case maybeToken of + Left e -> pure . Left . SomeError . pack . show $ e + Right token -> do + let resetLink = + (env ^. #cfg % #webFrontend % #baseUrl) + <> "/#/user/reset-password/token?" + <> (pack . Network.HTTP.Base.urlEncodeVars $ [("token", unpack token)]) + mailBody = + [trimming| +

Reset your password on WikiMusic

+

We have received a request to reset the password for your user on WikiMusic.

+ Go reset your password on WikiMusic! +

Feel free to ignore this e-mail if you did not request it

+
+ If you had trouble clicking that link, please manually copy paste it:
$resetLink + |] + mailR <- sendMail env (MailSendRequest {subject = "WikiMusic - Reset Password", email = userEmail, name = Nothing, body = mailBody}) + case mailR of + Left e -> pure . Left . SomeError . pack . show . NotificationError . pack . show $ e + Right _ -> pure . Right $ MakeResetPasswordLinkResponse {user = userEmail} diff --git a/src/WikiMusic/Model/Config.hs b/src/WikiMusic/Model/Config.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Model/Config.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Model.Config + ( AppConfig (..), + PostgreSQLConfig (..), + RedisConfig (..), + ServantConfig (..), + CorsConfig (..), + -- CookieConfig (..), + MailConfig (..), + WebFrontendConfig (..), + appConfigCodec, + ) +where + +import Optics +import Relude +import Toml + +data PostgreSQLConfig = PostgreSQLConfig + { user :: Text, + passwordFile :: Text, + password :: Maybe Text, + port :: Int, + name :: Text, + poolSize :: Int, + host :: Text, + runMigrations :: Bool + } + deriving (Generic, Eq, Show) + +postgreSQLConfigCodec :: TomlCodec PostgreSQLConfig +postgreSQLConfigCodec = + PostgreSQLConfig + <$> Toml.text "user" .= (^. #user) + <*> Toml.text "password-file" .= (^. #passwordFile) + <*> Toml.dioptional (Toml.text "password") .= (^. #password) + <*> Toml.int "port" .= (^. #port) + <*> Toml.text "name" .= (^. #name) + <*> Toml.int "pool-size" .= (^. #poolSize) + <*> Toml.text "host" .= (^. #host) + <*> Toml.bool "run-migrations" .= (^. #runMigrations) + +data RedisConfig = RedisConfig + { port :: Int, + passwordFile :: Text, + password :: Maybe Text + } + deriving (Generic, Eq, Show) + +redisConfigCodec :: TomlCodec RedisConfig +redisConfigCodec = + RedisConfig + <$> Toml.int "port" .= (^. #port) + <*> Toml.text "password-file" .= (^. #passwordFile) + <*> Toml.dioptional (Toml.text "password") .= (^. #password) + +data ServantConfig = ServantConfig + { port :: Int, + host :: Text + } + deriving (Generic, Eq, Show) + +servantConfigCodec :: TomlCodec ServantConfig +servantConfigCodec = + ServantConfig + <$> Toml.int "port" .= (^. #port) + <*> Toml.text "host" .= (^. #host) + +data CorsConfig = CorsConfig + { origins :: [Text], + methods :: [Text], + requestHeaders :: [Text] + } + deriving (Generic, Eq, Show) + +corsConfigCodec :: TomlCodec CorsConfig +corsConfigCodec = + CorsConfig + <$> Toml.arrayOf Toml._Text "origins" .= (^. #origins) + <*> Toml.arrayOf Toml._Text "methods" .= (^. #methods) + <*> Toml.arrayOf Toml._Text "request-headers" .= (^. #requestHeaders) + +-- data CookieConfig = CookieConfig +-- { maxAge :: Int, +-- path :: Text, +-- domain :: Text, +-- sessionCookieName :: Text, +-- secure :: Text, +-- sameSite :: Text +-- } +-- deriving (Generic, Eq, Show) + +-- cookieConfigCodec :: TomlCodec CookieConfig +-- cookieConfigCodec = +-- CookieConfig +-- <$> Toml.int "max-age" .= (^. #maxAge) +-- <*> Toml.text "path" .= (^. #path) +-- <*> Toml.text "domain" .= (^. #domain) +-- <*> Toml.text "session-cookie-name" .= (^. #sessionCookieName) +-- <*> Toml.text "secure" .= (^. #secure) +-- <*> Toml.text "same-site" .= (^. #sameSite) + +data MailConfig = MailConfig + { sendTimeoutSeconds :: Int, + host :: Text, + user :: Text, + passwordFile :: Text, + password :: Maybe Text, + senderName :: Text, + senderMail :: Text + } + deriving (Generic, Eq, Show) + +mailConfigCodec :: TomlCodec MailConfig +mailConfigCodec = + MailConfig + <$> Toml.int "send-timeout-seconds" .= (^. #sendTimeoutSeconds) + <*> Toml.text "host" .= (^. #host) + <*> Toml.text "user" .= (^. #user) + <*> Toml.text "password-file" .= (^. #passwordFile) + <*> Toml.dioptional (Toml.text "password") .= (^. #password) + <*> Toml.text "sender-name" .= (^. #senderName) + <*> Toml.text "sender-mail" .= (^. #senderMail) + +newtype WebFrontendConfig = WebFrontendConfig + { baseUrl :: Text + } + deriving (Generic, Eq, Show) + +webFrontendConfigCodec :: TomlCodec WebFrontendConfig +webFrontendConfigCodec = + WebFrontendConfig + <$> Toml.text "base-url" .= (^. #baseUrl) + +newtype DevConfig = DevConfig + { reportedVersion :: Text + } + deriving (Generic, Eq, Show) + +devCodec :: TomlCodec DevConfig +devCodec = DevConfig <$> Toml.text "reported-version" .= (^. #reportedVersion) + +data AppConfig = AppConfig + { servant :: ServantConfig, + postgresql :: PostgreSQLConfig, + redis :: RedisConfig, + cors :: CorsConfig, + -- cookie :: CookieConfig, + mail :: MailConfig, + webFrontend :: WebFrontendConfig, + dev :: DevConfig + } + deriving (Generic, Eq, Show) + +appConfigCodec :: TomlCodec AppConfig +appConfigCodec = + AppConfig + <$> Toml.table servantConfigCodec "servant" .= (^. #servant) + <*> Toml.table postgreSQLConfigCodec "postgresql" .= (^. #postgresql) + <*> Toml.table redisConfigCodec "redis" .= (^. #redis) + <*> Toml.table corsConfigCodec "cors" .= (^. #cors) + -- <*> Toml.table cookieConfigCodec "cookie" .= (^. #cookie) + <*> Toml.table mailConfigCodec "mail" .= (^. #mail) + <*> Toml.table webFrontendConfigCodec "web-frontend" .= (^. #webFrontend) + <*> Toml.table devCodec "dev" .= (^. #dev) + +makeFieldLabelsNoPrefix ''AppConfig +makeFieldLabelsNoPrefix ''PostgreSQLConfig +makeFieldLabelsNoPrefix ''RedisConfig +makeFieldLabelsNoPrefix ''ServantConfig +makeFieldLabelsNoPrefix ''CorsConfig + +-- makeFieldLabelsNoPrefix ''CookieConfig +makeFieldLabelsNoPrefix ''MailConfig +makeFieldLabelsNoPrefix ''WebFrontendConfig +makeFieldLabelsNoPrefix ''DevConfig diff --git a/src/WikiMusic/Model/Env.hs b/src/WikiMusic/Model/Env.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Model/Env.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Model.Env + ( Env (..), + ) +where + +import Data.Time +import Hasql.Pool qualified +import Optics +import WikiMusic.Model.Config + +data Env = Env + { pool :: Hasql.Pool.Pool, + cfg :: AppConfig, + processStartedAt :: UTCTime + } + +makeFieldLabelsNoPrefix ''Env diff --git a/src/WikiMusic/PostgreSQL/ArtistCommand.hs b/src/WikiMusic/PostgreSQL/ArtistCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/ArtistCommand.hs @@ -0,0 +1,449 @@ +{-# 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 diff --git a/src/WikiMusic/PostgreSQL/ArtistQuery.hs b/src/WikiMusic/PostgreSQL/ArtistQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/ArtistQuery.hs @@ -0,0 +1,280 @@ +{-# 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 {..} diff --git a/src/WikiMusic/PostgreSQL/AuthQuery.hs b/src/WikiMusic/PostgreSQL/AuthQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/AuthQuery.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.PostgreSQL.AuthQuery () where + +import Data.Text (pack, unpack) +import Hasql.Decoders as D +import Hasql.Encoders as E +import Hasql.Pool qualified +import Hasql.Session qualified as Session +import Hasql.Statement (Statement (..)) +import Relude +import WikiMusic.Free.AuthQuery +import WikiMusic.Protolude + +instance Exec AuthQuery where + execAlgebra (FetchUserForAuthCheck env email next) = do + next =<< fetchUserForAuthCheck' env email + execAlgebra (FetchUserFromToken env t next) = do + next =<< fetchUserFromToken' env t + execAlgebra (FetchMe env identifier next) = do + next =<< fetchMe' env identifier + execAlgebra (FetchUserRoles env identifier next) = do + next =<< fetchUserRoles' env identifier + +fetchMe' :: (MonadIO m) => Env -> UUID -> m (Either AuthQueryError (Maybe WikiMusicUser)) +fetchMe' env identifier = do + stmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement identifier stmt) + let u = first fromHasqlUsageError . fmap maybeFromRow $ stmtResult + case u of + Left e -> pure . Left $ e + Right Nothing -> pure . Left $ AuthError "User did not exist" + Right (Just usr) -> do + u' <- withRoles env usr + pure . Right . Just $ u' + where + stmt = Statement query encoder decoder True + query = + encodeUtf8 + [trimming| + SELECT identifier, display_name, email_address, password_hash, auth_token FROM users + WHERE identifier = $$1 LIMIT 1 + |] + encoder = E.param . E.nonNullable $ E.uuid + decoder = + D.rowMaybe $ + (,,,,) + <$> D.column (D.nonNullable D.uuid) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + +fetchAuthUserDecoder :: Result (Maybe (UUID, Text, Text, Maybe Text, Maybe Text)) +fetchAuthUserDecoder = + D.rowMaybe $ + (,,,,) + <$> D.column (D.nonNullable D.uuid) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.text) + <*> D.column (D.nullable D.text) + +fetchUserForAuthCheck' :: (MonadIO m) => Env -> Text -> m (Either AuthQueryError (Maybe WikiMusicUser)) +fetchUserForAuthCheck' env email = do + stmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement email stmt) + let maybeUsr = first fromHasqlUsageError . fmap maybeFromRow $ stmtResult + case maybeUsr of + Left e -> pure . Left $ e + Right Nothing -> pure . Left $ AuthError "User did not exist" + Right (Just usr) -> do + u <- withRoles env usr + pure . Right . Just $ u + where + stmt = Statement query encoder fetchAuthUserDecoder True + query = + encodeUtf8 + [trimming| + SELECT identifier, display_name, email_address, password_hash, auth_token + FROM users + WHERE email_address = $$1 + LIMIT 1 + |] + encoder = E.param . E.nonNullable $ E.text + +fetchUserFromToken' :: (MonadIO m) => Env -> Text -> m (Either AuthQueryError (Maybe WikiMusicUser)) +fetchUserFromToken' env t = do + stmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement t stmt) + let maybeUsr = first fromHasqlUsageError . fmap maybeFromRow $ stmtResult + case maybeUsr of + Left e -> pure . Left $ e + Right Nothing -> pure . Left $ AuthError "User did not exist" + Right (Just usr) -> do + u <- withRoles env usr + pure . Right . Just $ u + where + stmt = Statement query encoder fetchAuthUserDecoder True + query = + encodeUtf8 + [trimming| + SELECT identifier, display_name, email_address, password_hash, auth_token + FROM users + WHERE auth_token = $$1 + LIMIT 1 + |] + encoder = E.param . E.nonNullable $ E.text + +fetchUserRoles' :: (MonadIO m) => Env -> UUID -> m (Either AuthQueryError [UserRole]) +fetchUserRoles' env identifier = do + rolesStmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement identifier stmt) + let roles' = either (const []) (map userRole) rolesStmtResult + pure . Right $ roles' + where + stmt = Statement query encoder decoder True + query = + encodeUtf8 + [trimming| + SELECT role_id FROM user_roles WHERE user_identifier = $$1 + |] + encoder = E.param . E.nonNullable $ E.uuid + decoder = D.rowList . D.column . D.nonNullable $ D.text + +userRole :: Text -> UserRole +userRole = read . unpack + +maybeFromRow :: Maybe (UUID, Text, Text, Maybe Text, Maybe Text) -> Maybe WikiMusicUser +maybeFromRow = + fmap + ( \(identifierr, displayName, emailAddress, passwordHash, authToken) -> + WikiMusicUser + { identifier = identifierr, + displayName = displayName, + emailAddress = emailAddress, + passwordHash = passwordHash, + roles = [], + authToken = authToken + } + ) + +fromHasqlUsageError :: Hasql.Pool.UsageError -> AuthQueryError +fromHasqlUsageError = PersistenceError . pack . show + +withRoles :: (MonadIO m) => Env -> WikiMusicUser -> m WikiMusicUser +withRoles env usr = do + roles' <- fetchUserRoles' env (usr ^. #identifier) + pure $ usr {roles = fromRight [] roles'} diff --git a/src/WikiMusic/PostgreSQL/GenreCommand.hs b/src/WikiMusic/PostgreSQL/GenreCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/GenreCommand.hs @@ -0,0 +1,449 @@ +{-# 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 diff --git a/src/WikiMusic/PostgreSQL/GenreQuery.hs b/src/WikiMusic/PostgreSQL/GenreQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/GenreQuery.hs @@ -0,0 +1,281 @@ +{-# 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 {..} diff --git a/src/WikiMusic/PostgreSQL/Migration.hs b/src/WikiMusic/PostgreSQL/Migration.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/Migration.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.PostgreSQL.Migration + ( runWikiMusicMigrations, + ) +where + +import Hasql.Migration +import Hasql.Pool qualified +import Hasql.Transaction +import Hasql.Transaction.Sessions qualified as TransactionSessions +import WikiMusic.Protolude + +initializeSchema :: Transaction () +initializeSchema = do + sql $ + encodeUtf8 + [trimming| + CREATE TABLE IF NOT EXISTS schema_migrations + (filename varchar(512) NOT NULL, + checksum varchar(32) NOT NULL, + executed_at timestamptz NOT NULL DEFAULT now() + ); + |] + +runMigrationFile :: (MonadIO m) => Hasql.Pool.Pool -> MigrationCommand -> m (Either Hasql.Pool.UsageError (Maybe MigrationError)) +runMigrationFile pool migrationFile = + liftIO $ + Hasql.Pool.use + pool + ( TransactionSessions.transaction + TransactionSessions.Serializable + TransactionSessions.Write + migrationCommand + ) + where + migrationCommand = runMigration migrationFile + +runWikiMusicMigrations :: (MonadIO m) => Hasql.Pool.Pool -> m [Either Hasql.Pool.UsageError (Maybe MigrationError)] +runWikiMusicMigrations pool = do + _ <- + liftIO $ + Hasql.Pool.use + pool + ( TransactionSessions.transaction + TransactionSessions.Serializable + TransactionSessions.Write + initializeSchema + ) + + migrations <- liftIO $ loadMigrationsFromDirectory "resources/postgresql/migrations" + mapM (liftIO . runMigrationFile pool) migrations diff --git a/src/WikiMusic/PostgreSQL/Model/Artist.hs b/src/WikiMusic/PostgreSQL/Model/Artist.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/Model/Artist.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.PostgreSQL.Model.Artist + ( ArtistRow, + ArtistCommentRow, + ArtistArtworkRow, + InsertArtistRow, + ArtistOpinionRow, + InsertArtistCommentRow, + UpsertArtistOpinionRow, + InsertArtistArtworkRow, + InsertArtistExternalSourcesRow, + artistFromRow, + ) +where + +import WikiMusic.Model.Artist +import WikiMusic.Protolude + +type ArtistRow = (UUID, Text, UUID, Int64, Maybe UUID, UTCTime, Maybe UTCTime, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Int64, Maybe Text) + +type InsertArtistCommentRow = (Text, Text, Maybe Text, Text, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) + +type InsertArtistArtworkRow = (Text, Text, Text, Int64, Maybe Text, Text, UTCTime, Maybe UTCTime, Maybe Text, Int64) + +type UpsertArtistOpinionRow = (Text, Text, Text, Bool, Bool, UTCTime, Maybe UTCTime) + +type InsertArtistRow = (Text, Text, Text, Int64, Maybe Text, UTCTime, Maybe UTCTime) + +type ArtistArtworkRow = (UUID, UUID, UUID, Int64, Maybe UUID, Text, Maybe Text, UTCTime, Maybe UTCTime, Int64) + +type ArtistCommentRow = (UUID, UUID, Maybe UUID, UUID, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) + +type ArtistOpinionRow = (UUID, UUID, UUID, Bool, Bool, UTCTime, Maybe UTCTime) + +type InsertArtistExternalSourcesRow = (Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, UTCTime, Maybe UTCTime) + +artistFromRow :: ArtistRow -> Artist +artistFromRow + ( identifier, + displayName, + createdBy, + visibilityStatus, + approvedBy, + createdAt, + lastEditedAt, + spotifyUrl, + youtubeUrl, + soundcloudUrl, + wikipediaUrl, + viewCount, + description + ) = + Artist + { identifier = identifier, + displayName = displayName, + createdBy = createdBy, + visibilityStatus = fromIntegral visibilityStatus, + approvedBy = approvedBy, + createdAt = createdAt, + lastEditedAt = lastEditedAt, + artworks = fromList [], + comments = [], + opinions = fromList [], + spotifyUrl = spotifyUrl, + youtubeUrl = youtubeUrl, + soundcloudUrl = soundcloudUrl, + wikipediaUrl = wikipediaUrl, + viewCount = fromIntegral viewCount, + description = description + } diff --git a/src/WikiMusic/PostgreSQL/Model/Genre.hs b/src/WikiMusic/PostgreSQL/Model/Genre.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/Model/Genre.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.PostgreSQL.Model.Genre + ( GenreRow, + GenreCommentRow, + GenreArtworkRow, + InsertGenreRow, + GenreOpinionRow, + InsertGenreCommentRow, + UpsertGenreOpinionRow, + InsertGenreExternalSourcesRow, + InsertGenreArtworkRow, + genreFromRow, + ) +where + +import WikiMusic.Model.Genre +import WikiMusic.Protolude + +type GenreRow = (UUID, Maybe UUID, Text, UUID, Int64, Maybe UUID, UTCTime, Maybe UTCTime, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Int64, Maybe Text) + +type InsertGenreCommentRow = (Text, Text, Maybe Text, Text, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) + +type InsertGenreArtworkRow = (Text, Text, Text, Int64, Maybe Text, Text, UTCTime, Maybe UTCTime, Maybe Text, Int64) + +type UpsertGenreOpinionRow = (Text, Text, Text, Bool, Bool, UTCTime, Maybe UTCTime) + +type InsertGenreRow = (Text, Text, Text, Int64, Maybe Text, UTCTime, Maybe UTCTime) + +type GenreArtworkRow = (UUID, UUID, UUID, Int64, Maybe UUID, Text, UTCTime, Maybe UTCTime) + +type GenreCommentRow = (UUID, UUID, Maybe UUID, UUID, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) + +type GenreOpinionRow = (UUID, UUID, UUID, Bool, Bool, UTCTime, Maybe UTCTime) + +type InsertGenreExternalSourcesRow = (Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, UTCTime, Maybe UTCTime) + +genreFromRow :: GenreRow -> Genre +genreFromRow + ( identifier, + parentIdentifier, + displayName, + createdBy, + visibilityStatus, + approvedBy, + createdAt, + lastEditedAt, + spotifyUrl, + youtubeUrl, + soundcloudUrl, + wikipediaUrl, + viewCount, + description + ) = + Genre + { identifier = identifier, + parentIdentifier = parentIdentifier, + displayName = displayName, + createdBy = createdBy, + visibilityStatus = fromIntegral visibilityStatus, + approvedBy = approvedBy, + createdAt = createdAt, + lastEditedAt = lastEditedAt, + artworks = fromList [], + comments = [], + opinions = fromList [], + spotifyUrl = spotifyUrl, + youtubeUrl = youtubeUrl, + soundcloudUrl = soundcloudUrl, + wikipediaUrl = wikipediaUrl, + viewCount = fromIntegral viewCount, + description = description + } diff --git a/src/WikiMusic/PostgreSQL/Model/Other.hs b/src/WikiMusic/PostgreSQL/Model/Other.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/Model/Other.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.PostgreSQL.Model.Other + ( UserRow, + toUserRow, + ) +where + +import WikiMusic.Model.Other +import WikiMusic.Protolude + +type UserRow = + ( Text, + Text, + Text, + Text, + Maybe Text, + Maybe UTCTime, + Maybe Text, + Maybe Text, + UTCTime, + Maybe UTCTime + ) + +toUserRow :: User -> UserRow +toUserRow user = + ( user ^. #identifier, + user ^. #displayName, + user ^. #emailAddress, + user ^. #passwordHash, + user ^. #passwordResetToken, + user ^. #latestLoginAt, + user ^. #latestLoginDevice, + user ^. #avatarUrl, + user ^. #createdAt, + user ^. #lastEditedAt + ) diff --git a/src/WikiMusic/PostgreSQL/Model/Song.hs b/src/WikiMusic/PostgreSQL/Model/Song.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/Model/Song.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.PostgreSQL.Model.Song + ( SongRow, + SongCommentRow, + SongArtworkRow, + InsertSongRow, + SongOpinionRow, + InsertSongCommentRow, + UpsertSongOpinionRow, + InsertSongArtworkRow, + SongContentRow, + UpdateArtistsOfSongRow, + InsertSongExternalSourcesRow, + songFromRow, + ) +where + +import WikiMusic.Model.Song +import WikiMusic.Protolude + +type SongRow = + ( UUID, + Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + UUID, + Int64, + Maybe UUID, + UTCTime, + Maybe UTCTime, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Int64, + Maybe Text + ) + +type InsertSongCommentRow = (Text, Text, Maybe Text, Text, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) + +type InsertSongArtworkRow = (Text, Text, Text, Int64, Maybe Text, Text, UTCTime, Maybe UTCTime, Maybe Text, Int64) + +type UpsertSongOpinionRow = (Text, Text, Text, Bool, Bool, UTCTime, Maybe UTCTime) + +type InsertSongRow = (UUID, Text, UUID, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Text, Int64, Maybe Text, UTCTime, Maybe UTCTime) + +type SongArtworkRow = (Text, Text, Text, Int64, Maybe Text, Text, UTCTime, Maybe UTCTime) + +type SongCommentRow = (Text, Text, Maybe Text, Text, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) + +type SongOpinionRow = (Text, Text, Text, Bool, Bool, UTCTime, Maybe UTCTime) + +type SongContentRow = (UUID, UUID, Text, UUID, Int64, Maybe UUID, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, UTCTime, Maybe UTCTime) + +type UpdateArtistsOfSongRow = (UUID, UUID, UUID, UTCTime) + +type InsertSongExternalSourcesRow = (Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, UTCTime, Maybe UTCTime) + +songFromRow :: SongRow -> Song +songFromRow + ( identifier, + displayName, + musicKey, + musicTuning, + musicCreationDate, + albumName, + albumInfoLink, + createdBy, + visibilityStatus, + approvedBy, + createdAt, + lastEditedAt, + spotifyUrl, + youtubeUrl, + soundcloudUrl, + wikipediaUrl, + viewCount, + description + ) = + Song + { identifier = identifier, + displayName = displayName, + musicKey = musicKey, + musicTuning = musicTuning, + musicCreationDate = musicCreationDate, + albumName = albumName, + albumInfoLink = albumInfoLink, + createdBy = createdBy, + visibilityStatus = fromIntegral visibilityStatus, + approvedBy = approvedBy, + createdAt = createdAt, + lastEditedAt = lastEditedAt, + artworks = fromList [], + comments = [], + opinions = fromList [], + contents = fromList [], + spotifyUrl = spotifyUrl, + youtubeUrl = youtubeUrl, + soundcloudUrl = soundcloudUrl, + wikipediaUrl = wikipediaUrl, + artists = fromList [], + viewCount = fromIntegral viewCount, + description = description + } diff --git a/src/WikiMusic/PostgreSQL/ReadAbstraction.hs b/src/WikiMusic/PostgreSQL/ReadAbstraction.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/ReadAbstraction.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.PostgreSQL.ReadAbstraction + ( persistenceReadCall, + fetchOpinions, + fetchArtworks, + fetchComments, + mkSearchConstraints, + bindParams, + ) +where + +import Data.ByteString.Lazy qualified as BL +import Data.Map qualified as Map +import Data.Text hiding (map) +import Data.Time +import Data.UUID hiding (fromString) +import Data.Vector qualified as V +import Hasql.Decoders as D +import Hasql.Encoders as E +import Hasql.Pool qualified +import Hasql.Session qualified +import Hasql.Statement (Statement (..)) +import NeatInterpolation +import Relude + +bindParams :: Int -> Text +bindParams size = Data.Text.intercalate ", " (["$" <> show x | x <- [1 .. size]]) + +persistenceReadCall :: + (MonadIO m) => + Hasql.Pool.Pool -> + Hasql.Session.Session b1 -> + ([a] -> b2) -> + (b1 -> [a]) -> + m b2 +persistenceReadCall pool sessionCreateF responseCreateF vectorParseF = do + eitherItems <- liftIO $ Hasql.Pool.use pool sessionCreateF + either + ( \err -> do + liftIO . BL.putStr . fromString . show $ err + pure $ responseCreateF [] + ) + (pure . responseCreateF . vectorParseF) + eitherItems + +fetchOpinions :: + (MonadIO m, Ord k, Foldable foldable) => + Hasql.Pool.Pool -> + ( [ ( UUID, + UUID, + UUID, + Bool, + Bool, + UTCTime, + Maybe UTCTime + ) + ] -> + [(k, a)] + ) -> + Text -> + Text -> + foldable UUID -> + m (Map k a) +fetchOpinions pool parseRow entityTable entityIdentifier identifiers = do + persistenceReadCall + pool + (Hasql.Session.statement identifiers preparedStmt) + Map.fromList + (parseRow . V.toList) + where + preparedStmt = Statement query encoder decoder True + query = + encodeUtf8 + [untrimming| + SELECT identifier, $entityIdentifier, created_by, is_like, is_dislike, + created_at, last_edited_at FROM $entityTable WHERE $entityIdentifier = ANY($$1) + |] + encoder = + E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) + + decoder = D.rowVector vector + where + vector = + (,,,,,,) + <$> D.column (D.nonNullable D.uuid) + <*> D.column (D.nonNullable D.uuid) + <*> D.column (D.nonNullable D.uuid) + <*> D.column (D.nonNullable D.bool) + <*> D.column (D.nonNullable D.bool) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) + +fetchArtworks :: + (MonadIO m, Ord k, Foldable foldable) => + Hasql.Pool.Pool -> + ( [ ( UUID, + UUID, + UUID, + Int64, + Maybe UUID, + Text, + Maybe Text, + UTCTime, + Maybe UTCTime, + Int64 + ) + ] -> + [(k, a)] + ) -> + Text -> + Text -> + foldable UUID -> + m (Map k a) +fetchArtworks pool parseRow entityTable entityIdentifier identifiers = do + persistenceReadCall + pool + (Hasql.Session.statement identifiers preparedStmt) + Map.fromList + (parseRow . V.toList) + where + preparedStmt = Statement query encoder decoder True + query = + encodeUtf8 + [untrimming| + SELECT identifier, $entityIdentifier, created_by, visibility_status, approved_by, content_url, content_caption, + created_at, last_edited_at, order_value FROM $entityTable WHERE $entityIdentifier = ANY($$1) ORDER BY ${entityTable}.order_value ASC + |] + encoder = E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) + decoder = D.rowVector vector + where + vector = + (,,,,,,,,,) + <$> D.column (D.nonNullable D.uuid) + <*> D.column (D.nonNullable D.uuid) + <*> 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.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nonNullable D.int8) + +fetchComments :: + (MonadIO m, Ord k, Foldable foldable) => + Hasql.Pool.Pool -> + ( [ ( UUID, + UUID, + Maybe UUID, + UUID, + Int64, + Text, + Maybe UUID, + UTCTime, + Maybe UTCTime + ) + ] -> + [(k, a)] + ) -> + Text -> + Text -> + foldable UUID -> + m (Map k a) +fetchComments pool parseRow entityTable entityIdentifier identifiers = do + persistenceReadCall + pool + (Hasql.Session.statement identifiers preparedStmt) + Map.fromList + (parseRow . V.toList) + where + preparedStmt = Statement query encoder decoder True + query = + encodeUtf8 + [untrimming| + SELECT identifier, $entityIdentifier, parent_identifier, created_by, visibility_status, + contents, approved_by, created_at, last_edited_at FROM $entityTable + WHERE $entityIdentifier = ANY($$1) ORDER BY ${entityTable}.created_at ASC + |] + encoder = + E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) + decoder = D.rowVector vector + where + vector = + (,,,,,,,,) + <$> D.column (D.nonNullable D.uuid) + <*> D.column (D.nonNullable D.uuid) + <*> D.column (D.nullable D.uuid) + <*> D.column (D.nonNullable D.uuid) + <*> D.column (D.nonNullable D.int8) + <*> D.column (D.nonNullable D.text) + <*> D.column (D.nullable D.uuid) + <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nullable D.timestamptz) + +mkSearchConstraints :: Text -> Text +mkSearchConstraints searchInput = Data.Text.intercalate " AND " inputs + where + cleanWords = map (Data.Text.filter (\x -> x /= '\'' && x /= '%' && x /= ';' && x /= '"') . strip) (Data.Text.words searchInput) + inputs = map (\x -> [untrimming|artists.display_name ILIKE '%$x%'|]) cleanWords diff --git a/src/WikiMusic/PostgreSQL/SongCommand.hs b/src/WikiMusic/PostgreSQL/SongCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/SongCommand.hs @@ -0,0 +1,653 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.PostgreSQL.SongCommand () where + +import Data.Map qualified as Map +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.SongCommand +import WikiMusic.Interaction.Model.Song +import WikiMusic.Model.Artwork +import WikiMusic.Model.Comment +import WikiMusic.Model.Opinion +import WikiMusic.Model.Song +import WikiMusic.PostgreSQL.ReadAbstraction +import WikiMusic.PostgreSQL.WriteAbstraction +import WikiMusic.Protolude + +insertArtistsOfSongs' :: (MonadIO m) => Env -> [ArtistOfSong] -> m (Map UUID ArtistOfSong) +insertArtistsOfSongs' env items = do + mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) items + pure $ Map.fromList $ map (\x -> (x ^. #identifier, x)) items + where + toRow x = + ( x ^. #identifier, + x ^. #songIdentifier, + x ^. #artistIdentifier, + x ^. #createdAt, + x ^. #createdBy + ) + bindParams' = bindParams 5 + encoder = + contrazip5 + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.timestamptz) + (E.param . E.nonNullable $ E.uuid) + stmt = Statement query encoder D.noResult True + query = + encodeUtf8 + [trimming| + INSERT INTO song_artists + (identifier, song_identifier, artist_identifier, created_at, created_by) + VALUES ($bindParams') + |] + +insertSongs' :: (MonadIO m) => Env -> [Song] -> m (Map UUID Song) +insertSongs' env songs = do + mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) songs + now <- liftIO getCurrentTime + mapM_ + ( \x -> do + newUUID <- liftIO nextRandom + liftIO $ exec @SongCommand $ insertSongExternalSources env [toExternalSource x now newUUID] + ) + songs + pure $ Map.fromList $ map (\x -> (x ^. #identifier, x)) songs + where + toExternalSource x now newUUID = + SongExternalSources + { identifier = newUUID, + songIdentifier = 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 ^. #musicKey, + x ^. #musicTuning, + x ^. #musicCreationDate, + x ^. #albumName, + x ^. #albumInfoLink, + x ^. #createdBy, + fromIntegral $ x ^. #visibilityStatus, + x ^. #approvedBy, + x ^. #createdAt, + x ^. #lastEditedAt, + x ^. #description + ) + bindParams' = bindParams 13 + stmt = Statement query encoder D.noResult True + encoder = + contrazip13 + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.text) + (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.nullable $ 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) + query = + encodeUtf8 + [trimming| + INSERT INTO songs + (identifier, display_name, music_key, music_tuning, + music_creation_date, album_name, album_info_link, created_by, visibility_status, + approved_by, created_at, last_edited_at, description) + VALUES ($bindParams') + |] + +insertSongComments' :: (MonadIO m) => Env -> [SongComment] -> m (Map UUID SongComment) +insertSongComments' 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 ^. #songIdentifier, + 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 song_comments + (identifier, song_identifier, parent_identifier, created_by, + visibility_status, contents, approved_by, created_at, last_edited_at) + VALUES ($bindParams') + |] + +insertSongExternalSources' :: (MonadIO m) => Env -> [SongExternalSources] -> m (Map UUID SongExternalSources) +insertSongExternalSources' 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 song_external_sources + (identifier, song_identifier, spotify_url, youtube_url, + soundcloud_url, wikipedia_url, created_at, last_edited_at, created_by) + VALUES ($bindParams') + |] + toRow x = + ( x ^. #identifier, + x ^. #songIdentifier, + x ^. #spotifyUrl, + x ^. #youtubeUrl, + x ^. #soundcloudUrl, + x ^. #wikipediaUrl, + x ^. #createdAt, + x ^. #lastEditedAt, + x ^. #createdBy + ) + +insertSongArtworks' :: (MonadIO m) => Env -> [SongArtwork] -> m (Map UUID SongArtwork) +insertSongArtworks' 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 ^. #songIdentifier, + 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 song_artworks + (identifier, song_identifier, created_by, visibility_status, + approved_by, content_url, created_at, last_edited_at, content_caption, order_value) + VALUES ($bindParams') + |] + +upsertSongOpinions' :: (MonadIO m) => Env -> [SongOpinion] -> m (Map UUID SongOpinion) +upsertSongOpinions' 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 song_opinions + (identifier, song_identifier, created_by, is_like, is_dislike, + created_at, last_edited_at) + VALUES ( $bindParams' ) + ON CONFLICT (song_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 ^. #songIdentifier, + x ^. #opinion % #createdBy, + x ^. #opinion % #isLike, + not $ x ^. #opinion % #isLike, + x ^. #opinion % #createdAt, + x ^. #opinion % #lastEditedAt + ) + +deleteSongs' :: (MonadIO m) => Env -> [UUID] -> m (Either SongCommandError ()) +deleteSongs' env identifiers = do + deleteArtworksOfSongsResult <- liftIO . exec @SongCommand $ deleteArtworksOfSongs env identifiers + deleteOpinionsOfSongsResult <- liftIO . exec @SongCommand $ deleteOpinionsOfSongs env identifiers + deleteCommentsOfSongsResult <- liftIO . exec @SongCommand $ deleteCommentsOfSongs env identifiers + deleteSongExternalSourcesResult <- liftIO . exec @SongCommand $ deleteSongExternalSources env identifiers + deleteSongsResult <- deleteStuffByUUID (env ^. #pool) "songs" "identifier" identifiers + deleteArtistsOfSongResult <- liftIO . exec @SongCommand $ deleteArtistsOfSongs env identifiers + deleteContentsOfSongResult <- liftIO . exec @SongCommand $ deleteContentsOfSongs env identifiers + pure $ + deleteArtworksOfSongsResult + <> deleteOpinionsOfSongsResult + <> deleteSongExternalSourcesResult + <> deleteCommentsOfSongsResult + <> deleteArtistsOfSongResult + <> deleteContentsOfSongResult + <> first fromHasqlUsageError deleteSongsResult + +updateSongArtworkOrder' :: (MonadIO m) => Env -> [SongArtworkOrderUpdate] -> m (Either a ()) +updateSongArtworkOrder' env orderUpdates = + Right <$> mapM_ performUpdate orderUpdates + where + stmt = Statement query encoder D.noResult True + query = + encodeUtf8 + [trimming| + UPDATE song_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 + +updateSongs' :: (MonadIO m) => Env -> Map UUID (Song, Maybe SongDelta) -> m (Either Text ()) +updateSongs' env deltas = do + liftIO $ mapM_ performUpdate deltas + exUpdate <- liftIO $ exec @SongCommand $ updateSongExternalSources env deltas + pure $ exUpdate <> Right () + where + stmt = Statement query encoder D.noResult True + query = + encodeUtf8 + [trimming| + UPDATE songs 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 + +updateSongExternalSources' :: (MonadIO m) => Env -> Map UUID (Song, Maybe SongDelta) -> m (Either Text ()) +updateSongExternalSources' env deltas = + Right <$> mapM_ performUpdate deltas + where + stmt = Statement query encoder D.noResult True + query = + encodeUtf8 + [trimming| + UPDATE song_external_sources SET + spotify_url = $$2, + youtube_url = $$3, + wikipedia_url = $$4, + soundcloud_url = $$5 + WHERE song_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 + +newSongArtworkFromRequest' :: (MonadIO m) => UUID -> InsertSongArtworksRequestItem -> m SongArtwork +newSongArtworkFromRequest' createdBy req = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure $ + SongArtwork + { songIdentifier = req ^. #songIdentifier, + artwork = + Artwork + { identifier = newUUID, + createdBy = createdBy, + contentUrl = req ^. #contentUrl, + contentCaption = req ^. #contentCaption, + createdAt = now, + lastEditedAt = Nothing, + visibilityStatus = 0, + approvedBy = Nothing, + orderValue = req ^. #orderValue + } + } + +newSongOpinionFromRequest' :: (MonadIO m) => UUID -> UpsertSongOpinionsRequestItem -> m SongOpinion +newSongOpinionFromRequest' createdBy req = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure $ + SongOpinion + { songIdentifier = req ^. #songIdentifier, + opinion = + Opinion + { identifier = newUUID, + createdBy = createdBy, + isLike = req ^. #isLike, + isDislike = not $ req ^. #isLike, + createdAt = now, + lastEditedAt = Nothing + } + } + +updateSongContents' :: (MonadIO m) => Env -> [SongContentDelta] -> m (Either Text ()) +updateSongContents' env songContentDeltas = do + now <- liftIO getCurrentTime + out <- mapM (performUpdate now) songContentDeltas + let outt = lefts out + if null outt + then pure . Right $ () + else pure . Left $ unlines outt + where + stmt = Statement query encoder decoder True + query = + encodeUtf8 + [trimming| + UPDATE song_contents SET version_name = $$2, instrument_type = $$3, ascii_legend = $$4, ascii_contents = $$5, + pdf_contents = $$6, guitarpro_contents = $$7, last_edited_at = $$8 WHERE identifier = $$1 + |] + encoder = + contrazip8 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nonNullable E.text)) + (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.nullable E.text)) + (E.param (E.nullable E.timestamptz)) + decoder = D.noResult + toRow now x = + ( x ^. #identifier, + x ^. #versionName, + x ^. #instrumentType, + x ^. #asciiLegend, + x ^. #asciiContents, + x ^. #pdfContents, + x ^. #guitarProContents, + Just now + ) + performUpdate now x = do + operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow now x) + pure $ first (pack . WikiMusic.Model.Song.show) operationResults + +deleteArtistOfSong' :: (MonadIO m) => Env -> (UUID, UUID) -> m (Either SongCommandError ()) +deleteArtistOfSong' env identifiers = do + stmtResult <- hasqlTransaction (env ^. #pool) stmt identifiers + pure $ first fromHasqlUsageError stmtResult + where + query = + encodeUtf8 + [trimming| + DELETE FROM song_artists WHERE song_identifier = $$1 AND artist_identifier = $$2 + |] + encoder = + contrazip2 + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.uuid) + stmt = Statement query encoder D.noResult True + +newSongCommentFromRequest' :: (MonadIO m) => UUID -> InsertSongCommentsRequestItem -> m SongComment +newSongCommentFromRequest' createdBy x = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure $ + SongComment + { songIdentifier = x ^. #songIdentifier, + comment = + Comment + { identifier = newUUID, + parentIdentifier = x ^. #parentIdentifier, + createdBy = createdBy, + visibilityStatus = 0, + contents = x ^. #contents, + approvedBy = Nothing, + createdAt = now, + lastEditedAt = Nothing + } + } + +insertSongContents' :: (MonadIO m) => Env -> [SongContent] -> m (Map UUID SongContent) +insertSongContents' env contents = do + mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) contents + pure $ Map.fromList $ map (\x -> (x ^. #identifier, x)) contents + where + decoder = D.noResult + encoder = + contrazip13 + (E.param . E.nonNullable $ E.uuid) + (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.text) + (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) + + stmt = Statement query encoder decoder True + bindParams' = bindParams 13 + toRow x = + ( x ^. #identifier, + x ^. #songIdentifier, + x ^. #versionName, + x ^. #createdBy, + fromIntegral $ x ^. #visibilityStatus, + x ^. #approvedBy, + x ^. #instrumentType, + x ^. #asciiLegend, + x ^. #asciiContents, + x ^. #pdfContents, + x ^. #guitarProContents, + x ^. #createdAt, + x ^. #lastEditedAt + ) + + query = + encodeUtf8 + [trimming| + INSERT INTO song_contents + (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) + VALUES ($bindParams') + |] + +newSongFromRequest' :: (MonadIO m) => UUID -> InsertSongsRequestItem -> m Song +newSongFromRequest' createdBy song = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure $ + Song + { identifier = newUUID, + displayName = song ^. #displayName, + musicKey = song ^. #musicKey, + musicTuning = song ^. #musicTuning, + musicCreationDate = song ^. #musicCreationDate, + albumName = song ^. #albumName, + albumInfoLink = song ^. #albumInfoLink, + createdBy = createdBy, + visibilityStatus = 0, + approvedBy = Nothing, + createdAt = now, + lastEditedAt = Nothing, + artworks = Map.empty, + comments = [], + opinions = Map.empty, + contents = Map.empty, + spotifyUrl = song ^. #spotifyUrl, + youtubeUrl = song ^. #youtubeUrl, + soundcloudUrl = song ^. #soundcloudUrl, + wikipediaUrl = song ^. #wikipediaUrl, + artists = Map.empty, + viewCount = 0, + description = song ^. #description + } + +newArtistOfSongFromRequest' :: (MonadIO m) => UUID -> InsertArtistsOfSongsRequestItem -> m ArtistOfSong +newArtistOfSongFromRequest' createdBy x = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure $ + ArtistOfSong + { identifier = newUUID, + songIdentifier = x ^. #songIdentifier, + artistIdentifier = x ^. #artistIdentifier, + createdAt = now, + createdBy = createdBy + } + +newSongContentFromRequest' :: (MonadIO m) => UUID -> InsertSongContentsRequestItem -> m SongContent +newSongContentFromRequest' createdBy x = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure $ + SongContent + { identifier = newUUID, + songIdentifier = x ^. #songIdentifier, + versionName = x ^. #versionName, + visibilityStatus = 0, + approvedBy = Nothing, + instrumentType = x ^. #instrumentType, + asciiLegend = x ^. #asciiLegend, + asciiContents = x ^. #asciiContents, + pdfContents = x ^. #pdfContents, + guitarProContents = x ^. #guitarProContents, + createdAt = now, + createdBy = createdBy, + lastEditedAt = Nothing + } + +instance Exec SongCommand where + execAlgebra (IncrementViewsByOne env identifiers next) = next =<< incrementViewsByOne' env identifiers "songs" + execAlgebra (InsertSongs env songs next) = next =<< insertSongs' env songs + execAlgebra (InsertSongComments env comments next) = next =<< insertSongComments' env comments + execAlgebra (InsertSongExternalSources env externalSources next) = next =<< insertSongExternalSources' env externalSources + execAlgebra (InsertSongArtworks env artworks next) = next =<< insertSongArtworks' env artworks + execAlgebra (UpsertSongOpinions env opinions next) = next =<< upsertSongOpinions' env opinions + execAlgebra (DeleteSongs env identifiers next) = next =<< deleteSongs' env identifiers + execAlgebra (DeleteSongComments env identifiers next) = + next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_comments" "identifier" identifiers + execAlgebra (DeleteSongArtworks env identifiers next) = + next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_artworks" "identifier" identifiers + execAlgebra (DeleteSongOpinions env identifiers next) = + next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_opinions" "identifier" identifiers + execAlgebra (DeleteCommentsOfSongs env identifiers next) = + next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_comments" "song_identifier" identifiers + execAlgebra (DeleteSongExternalSources env identifiers next) = + next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_external_sources" "song_identifier" identifiers + execAlgebra (DeleteArtworksOfSongs env identifiers next) = + next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_artworks" "song_identifier" identifiers + execAlgebra (DeleteOpinionsOfSongs env identifiers next) = + next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_opinions" "song_identifier" identifiers + execAlgebra (UpdateSongArtworkOrder env orderUpdates next) = next =<< updateSongArtworkOrder' env orderUpdates + execAlgebra (UpdateSongs env deltas next) = next =<< updateSongs' env deltas + execAlgebra (UpdateSongContents env deltas next) = next =<< updateSongContents' env deltas + execAlgebra (UpdateSongExternalSources env deltas next) = next =<< updateSongExternalSources' env deltas + execAlgebra (NewSongCommentFromRequest createdBy req next) = next =<< newSongCommentFromRequest' createdBy req + execAlgebra (NewSongOpinionFromRequest createdBy req next) = next =<< newSongOpinionFromRequest' createdBy req + execAlgebra (NewSongArtworkFromRequest createdBy req next) = next =<< newSongArtworkFromRequest' createdBy req + execAlgebra (InsertSongContents env contents next) = next =<< insertSongContents' env contents + execAlgebra (InsertArtistsOfSongs env items next) = next =<< insertArtistsOfSongs' env items + execAlgebra (DeleteArtistsOfSongs env identifiers next) = + next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_artists" "song_identifier" identifiers + execAlgebra (DeleteArtistOfSong env identifiers next) = next =<< deleteArtistOfSong' env identifiers + execAlgebra (NewSongFromRequest createdBy song next) = next =<< newSongFromRequest' createdBy song + execAlgebra (NewArtistOfSongFromRequest createdBy x next) = next =<< newArtistOfSongFromRequest' createdBy x + execAlgebra (NewSongContentFromRequest createdBy x next) = next =<< newSongContentFromRequest' createdBy x + execAlgebra (DeleteContentsOfSongs env identifiers next) = do + stmtResult <- deleteStuffByUUID (env ^. #pool) "song_contents" "song_identifier" identifiers + next $ first fromHasqlUsageError stmtResult + execAlgebra (DeleteSongContents env identifiers next) = do + stmtResult <- deleteStuffByUUID (env ^. #pool) "song_contents" "identifier" identifiers + next $ first fromHasqlUsageError stmtResult + +fromHasqlUsageError :: Hasql.Pool.UsageError -> SongCommandError +fromHasqlUsageError = PersistenceError . pack . Relude.show diff --git a/src/WikiMusic/PostgreSQL/SongQuery.hs b/src/WikiMusic/PostgreSQL/SongQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/SongQuery.hs @@ -0,0 +1,380 @@ +{-# 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 diff --git a/src/WikiMusic/PostgreSQL/UserCommand.hs b/src/WikiMusic/PostgreSQL/UserCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/UserCommand.hs @@ -0,0 +1,206 @@ +{-# 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.UserCommand () where + +import Data.ByteString.Base64 qualified +import Data.Password.Bcrypt +import Data.Text (pack) +import Data.UUID.V4 +import Hasql.Decoders as D +import Hasql.Encoders as E +import Hasql.Pool qualified +import Hasql.Session qualified as Session +import Hasql.Statement (Statement (..)) +import Relude +import WikiMusic.Free.UserCommand +import WikiMusic.Model.Auth +import WikiMusic.Model.Env +import WikiMusic.PostgreSQL.ReadAbstraction +import WikiMusic.PostgreSQL.WriteAbstraction +import WikiMusic.Protolude + +instance Exec UserCommand where + execAlgebra (MakeResetPasswordLink env email next) = doIfUserFoundByEmail env email (makeToken env) >>= next + execAlgebra (ChangePasswordByEmail env email password next) = do + next =<< doIfUserFoundByEmail env email (changePassword env password) + execAlgebra (InvalidateResetTokenByEmail env email next) = next =<< doIfUserFoundByEmail env email (invalidateToken env) + execAlgebra (InviteUser env _ email name' role desc next) = next =<< addUser env email name' role desc + execAlgebra (DeleteUser env _ email next) = next =<< doIfUserFoundByEmail env email (deleteU env) + +makeToken :: (MonadIO m) => Env -> UUID -> m (Either UserCommandError Text) +makeToken env identifier = do + now <- liftIO getCurrentTime + maybeToken <- maybeGenToken + first (PersistenceError . pack . Relude.show) maybeToken & either (pure . Left) (doWithToken now) + where + doWithToken now token = do + maybeRowsAff <- hasqlTransaction (env ^. #pool) stmt (identifier, token, now) + pure $ first fromHasqlUsageError $ token <$ maybeRowsAff + encoder = + contrazip3 + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.text) + (E.param . E.nonNullable $ E.timestamptz) + stmt = Statement query encoder D.noResult True + query = + encodeUtf8 + [trimming| + UPDATE users SET password_reset_token = $$2, last_edited_at = $$3 + WHERE identifier = $$1 + |] + +maybeGenToken :: (MonadIO m) => m (Either UnicodeException Text) +maybeGenToken = do + l <- pack . Relude.show <$> liftIO nextRandom + r <- pack . Relude.show <$> liftIO nextRandom + pure $ decodeUtf8' . Data.ByteString.Base64.encode . encodeUtf8 $ tokenConcat l r + where + tokenConcat l r = l <> "$" <> r + +invalidateToken :: (MonadIO m) => Env -> UUID -> m (Either UserCommandError ()) +invalidateToken env identifier = do + now <- liftIO getCurrentTime + maybeRowsAff <- liftIO $ hasqlTransaction (env ^. #pool) stmt (identifier, now) + pure $ bimap fromHasqlUsageError (const ()) maybeRowsAff + where + stmt = Statement query encoder D.noResult True + encoder = + contrazip2 + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.timestamptz) + query = + encodeUtf8 + [trimming| + UPDATE users SET password_reset_token = NULL, + last_edited_at = $$2 WHERE identifier = $$1 + |] + +fromHasqlUsageError :: Hasql.Pool.UsageError -> UserCommandError +fromHasqlUsageError = PersistenceError . pack . Relude.show + +changePassword :: (MonadIO m) => Env -> UserPassword -> UUID -> m (Either UserCommandError ()) +changePassword env password identifier = do + hashed <- hashPassword (mkPassword (password ^. #value)) + now <- liftIO getCurrentTime + new <- liftIO nextRandom + + maybeRowsAff <- liftIO $ hasqlTransaction (env ^. #pool) stmt (unPasswordHash hashed, identifier, now, newToken now new) + pure $ bimap fromHasqlUsageError (const ()) maybeRowsAff + where + stmt = Statement query encoder D.noResult True + encoder = + contrazip4 + (E.param . E.nonNullable $ E.text) + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.timestamptz) + (E.param . E.nonNullable $ E.text) + query = + encodeUtf8 + [trimming| + UPDATE users SET password_hash = $$1, last_edited_at = $$3, + auth_token = $$4 WHERE identifier = $$2 + |] + +newToken :: UTCTime -> UUID -> Text +newToken now new = + decodeUtf8 + . Data.ByteString.Base64.encode + . encodeUtf8 + $ (pack . WikiMusic.Protolude.show $ now) + <> "--" + <> (pack . WikiMusic.Protolude.show $ new) + +addUser :: (MonadIO m) => Env -> UserEmail -> UserName -> UserRole -> Maybe Text -> m (Either UserCommandError Text) +addUser env email name' role desc = do + now <- liftIO getCurrentTime + identifier <- liftIO nextRandom + new <- liftIO nextRandom + maybeRowsAff <- + liftIO $ + hasqlTransaction (env ^. #pool) stmt (identifier, name' ^. #value, email ^. #value, Nothing, now, Just (newToken now new), desc) + let creation = bimap fromHasqlUsageError (const ()) maybeRowsAff + case creation of + Left e -> pure . Left $ e + Right _ -> do + someUUID <- liftIO nextRandom + maybeRowsAff' <- + liftIO $ + hasqlTransaction (env ^. #pool) roleStmt (someUUID, identifier, pack . Relude.show $ role, now) + let rol = bimap fromHasqlUsageError (const ()) maybeRowsAff' + case rol of + Left e -> pure . Left $ e + Right _ -> doIfUserFoundByEmail env email (makeToken env) + where + stmt = Statement query encoder D.noResult True + roleStmt = Statement roleQuery roleEncoder D.noResult True + encoder = + contrazip7 + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.text) + (E.param . E.nonNullable $ E.text) + (E.param . E.nullable $ E.text) + (E.param . E.nonNullable $ E.timestamptz) + (E.param . E.nullable $ E.text) + (E.param . E.nullable $ E.text) + roleEncoder = + contrazip4 + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.text) + (E.param . E.nonNullable $ E.timestamptz) + bindParams' = bindParams 7 + roleBindParams' = bindParams 4 + query = + encodeUtf8 + [trimming| + INSERT INTO users (identifier, display_name, email_address, password_hash, created_at, auth_token, description) + VALUES ( $bindParams' ) + |] + roleQuery = + encodeUtf8 + [trimming| + INSERT INTO user_roles (identifier, user_identifier, role_id, created_at) + VALUES( $roleBindParams' ) + |] + +doIfUserFoundByEmail :: (MonadIO m) => Env -> UserEmail -> (UUID -> m (Either UserCommandError a)) -> m (Either UserCommandError a) +doIfUserFoundByEmail env email eff = do + maybeFoundByEmail <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement (email ^. #value) stmt) + first fromHasqlUsageError maybeFoundByEmail & either (pure . Left) doWithMaybeIdentifier + where + doWithMaybeIdentifier = maybe (pure . Left . LogicError $ "User could not be found!") eff + encoder = E.param . E.nonNullable $ E.text + stmt = Statement query encoder (D.rowMaybe . D.column . D.nonNullable $ D.uuid) True + query = + encodeUtf8 + [trimming| + SELECT identifier FROM users WHERE email_address = $$1 LIMIT 1 + |] + +deleteU :: (MonadIO m) => Env -> UUID -> m (Either UserCommandError ()) +deleteU env identifier = do + newUid <- liftIO nextRandom + maybeRowsAff <- liftIO $ hasqlTransaction (env ^. #pool) stmt (identifier, Relude.show newUid) + pure $ bimap fromHasqlUsageError (const ()) maybeRowsAff + where + encoder = + contrazip2 + (E.param . E.nonNullable $ E.uuid) + (E.param . E.nonNullable $ E.text) + stmt = Statement query encoder D.noResult True + query = + encodeUtf8 + [trimming| + UPDATE users SET password_hash = '', auth_token = '', email_address = $$2 + WHERE identifier = $$1 + |] diff --git a/src/WikiMusic/PostgreSQL/UserQuery.hs b/src/WikiMusic/PostgreSQL/UserQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/UserQuery.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.PostgreSQL.UserQuery () where + +import Data.Text qualified as T +import Hasql.Decoders as D +import Hasql.Encoders as E +import Hasql.Pool qualified +import Hasql.Session qualified as Session +import Hasql.Statement (Statement (..)) +import NeatInterpolation +import Optics +import Relude +import WikiMusic.Free.UserQuery +import WikiMusic.Protolude + +instance Exec UserQuery where + execAlgebra (DoesTokenMatchByEmail env email token next) = next =<< doesTokenMatchByEmail' env email token + +doesTokenMatchByEmail' :: (MonadIO m) => Env -> UserEmail -> UserToken -> m (Either UserQueryError Bool) +doesTokenMatchByEmail' env email token = do + maybeFoundByEmail <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement (email ^. #value) stmt) + let maybeTokenToCompare = first (PersistenceError . T.pack . show) maybeFoundByEmail + maybeTokenToCompare & either (pure . Left) (pure . Right . (Just (token ^. #value) ==)) + where + stmt = Statement query encoder decoder True + encoder = E.param . E.nonNullable $ E.text + decoder = D.rowMaybe $ D.column . D.nonNullable $ D.text + query = + encodeUtf8 + [trimming| + SELECT password_reset_token FROM users WHERE email_address = $$1 LIMIT 1 + |] diff --git a/src/WikiMusic/PostgreSQL/WriteAbstraction.hs b/src/WikiMusic/PostgreSQL/WriteAbstraction.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/PostgreSQL/WriteAbstraction.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.PostgreSQL.WriteAbstraction + ( deleteStuffByUUID, + hasqlTransaction, + incrementViewsByOne', + ) +where + +import Control.Concurrent +import Data.Text +import Data.UUID hiding (fromString) +import Data.Vector qualified as V +import Hasql.Decoders as D +import Hasql.Encoders as E +import Hasql.Pool qualified +import Hasql.Statement (Statement (..)) +import Hasql.Transaction +import Hasql.Transaction.Sessions +import NeatInterpolation +import Relude +import WikiMusic.Protolude + +deleteStuffByUUID :: (MonadIO m) => Hasql.Pool.Pool -> Text -> Text -> [UUID] -> m (Either Hasql.Pool.UsageError ()) +deleteStuffByUUID pool entityTable entityIdentifier identifiers = do + hasqlTransaction pool stmt (V.fromList identifiers) + where + stmt = Statement query encoder decoder True + query = + encodeUtf8 + [trimming| + DELETE FROM $entityTable WHERE ${entityTable}.${entityIdentifier} = ANY($$1) + |] + encoder = E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) + decoder = D.noResult + +hasqlTransaction :: + (MonadIO m) => + Hasql.Pool.Pool -> + Statement row model -> + row -> + m (Either Hasql.Pool.UsageError model) +hasqlTransaction pool stmt row = liftIO $ Hasql.Pool.use pool transaction' + where + stmt' = Hasql.Transaction.statement row stmt + transaction' = transaction Serializable Write stmt' + +incrementViewsByOne' :: (MonadIO m) => Env -> [UUID] -> Text -> m (Either a ()) +incrementViewsByOne' env identifiers entityTable = do + Right <$> (void . liftIO . forkIO $ mapM_ performUpdate identifiers) + where + stmt = Statement query encoder D.noResult True + encoder = E.param . E.nonNullable $ E.uuid + performUpdate x = do + operationResults <- hasqlTransaction (env ^. #pool) stmt x + pure $ first (pack . show) operationResults + query = + encodeUtf8 + [trimming| + UPDATE $entityTable SET views = views + 1 WHERE identifier = $$1 + |] diff --git a/src/WikiMusic/Protolude.hs b/src/WikiMusic/Protolude.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Protolude.hs @@ -0,0 +1,51 @@ +module WikiMusic.Protolude + ( module Relude, + module Data.UUID, + module Optics, + module WikiMusic.Model.Env, + module WikiMusic.Model.Auth, + module Data.Time, + module Data.UUID.V4, + module Contravariant.Extras.Contrazip, + module Free.AlaCarte, + mapMap, + filterMap, + filterText, + module NeatInterpolation, + vectorToList, + V.Vector, + vectorFromList, + ) +where + +import Contravariant.Extras.Contrazip +import Data.Map (Map, elems, filter, filterWithKey, fromList, keys, mapWithKey, toList, (!?)) +import Data.Map qualified as Map +import Data.Text (intercalate, pack, splitAt, strip, take, unpack, unwords, words) +import Data.Text qualified as T +import Data.Time (UTCTime (..), ZonedTime, getCurrentTime, secondsToDiffTime) +import Data.UUID (UUID) +import Data.UUID.V4 (nextRandom) +import Data.Vector qualified as V +import Free.AlaCarte +import NeatInterpolation +import Optics hiding (uncons) +import Relude +import WikiMusic.Model.Auth hiding (show) +import WikiMusic.Model.Env +import Prelude qualified + +mapMap :: (a -> b) -> Map k a -> Map k b +mapMap = Map.map + +filterMap :: (a -> Bool) -> Map k a -> Map k a +filterMap = Map.filter + +vectorToList :: V.Vector a -> [a] +vectorToList = V.toList + +filterText :: (Char -> Bool) -> Text -> Text +filterText = T.filter + +vectorFromList :: [a] -> V.Vector a +vectorFromList = V.fromList diff --git a/src/WikiMusic/SMTP/MailCommandSES.hs b/src/WikiMusic/SMTP/MailCommandSES.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SMTP/MailCommandSES.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.SMTP.MailCommandSES () where + +import Data.Text qualified as T +import Network.Mail.Mime hiding (simpleMail) +import Network.Mail.SMTP hiding (htmlPart) +import Optics +import Relude +import System.Timeout +import WikiMusic.Free.MailCommand +import WikiMusic.Model.Env +import WikiMusic.Model.Mail +import WikiMusic.Protolude + +instance Exec MailCommand where + execAlgebra (SendMail env req next) = mailSend env req >>= next + +mailSend :: (MonadIO m) => Env -> MailSendRequest -> m (Either MailCommandError MailCommandOutcome) +mailSend env req = do + mailSendingResult <- liftIO $ timeout timeoutSeconds doSendMail + case mailSendingResult of + Nothing -> pure . Left $ MailError "" + Just _ -> pure $ Right MailSent + where + mailCfg = env ^. #cfg % #mail + timeoutSeconds = (mailCfg ^. #sendTimeoutSeconds) * 1000000 + preparedMail = + simpleMail + (Address (Just (mailCfg ^. #senderName)) (mailCfg ^. #senderMail)) + [Address (req ^. #name) (req ^. #email)] -- to + [] -- cc + [] -- bcc + (req ^. #subject) + [ htmlPart (fromString . T.unpack $ req ^. #body) + ] -- body + doSendMail = + sendMailWithLoginSTARTTLS + (T.unpack $ mailCfg ^. #host) + (T.unpack $ mailCfg ^. #user) + (maybe "" T.unpack (mailCfg ^. #password)) + preparedMail diff --git a/src/WikiMusic/Servant/ApiSetup.hs b/src/WikiMusic/Servant/ApiSetup.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Servant/ApiSetup.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Servant.ApiSetup + ( mkApp, + WikiMusicPrivateAPI, + WikiMusicPublicAPI, + WikiMusicAPIServer, + wiredUpPrivateServer, + wiredUpPublicServer, + ) +where + +import Data.ByteString.Char8 qualified as C8 +import Data.OpenApi qualified +import Data.Proxy +import Data.Text (unpack) +import Database.Redis qualified as Redis +import Hasql.Pool qualified +import Network.Wai +import Network.Wai.Middleware.Cors +import Network.Wai.RateLimit +import Network.Wai.RateLimit.Redis +import Network.Wai.RateLimit.Strategy +import Relude +import Servant +import Servant.OpenApi +import WikiMusic.Model.Config +import WikiMusic.Model.Env +import WikiMusic.Protolude +import WikiMusic.Servant.ApiSpec +import WikiMusic.Servant.ArtistRoutes +import WikiMusic.Servant.AuthRoutes +import WikiMusic.Servant.GenreRoutes +import WikiMusic.Servant.SongRoutes +import WikiMusic.Servant.UserRoutes +import WikiMusic.Servant.Utilities + +swagger :: Servant.Handler Data.OpenApi.OpenApi +swagger = pure $ toOpenApi docsProxy + +apiProxy :: Proxy WikiMusicAPIServer +apiProxy = Proxy + +docsProxy :: Proxy WikiMusicAPIDocsServer +docsProxy = Proxy + +myCors :: CorsConfig -> Middleware +myCors cfg = cors (const $ Just policy) + where + policy = + CorsResourcePolicy + { corsOrigins = Just (map (fromString . unpack) (cfg ^. #origins), True), + corsMethods = map (fromString . unpack) (cfg ^. #methods), + corsRequestHeaders = map (fromString . unpack) (cfg ^. #requestHeaders), + corsExposedHeaders = + Just + [ "x-wikimusic-auth", + "content-type", + "date", + "content-length", + "access-control-allow-origin", + "access-control-allow-methods", + "access-control-allow-headers", + "access-control-request-method", + "access-control-request-headers" + ], + corsMaxAge = Nothing, + corsVaryOrigin = False, + corsRequireOrigin = False, + corsIgnoreFailures = False + } + +-- cookieSettings :: CookieConfig -> CookieSettings +-- cookieSettings cfg = +-- CookieSettings +-- { cookieIsSecure = fromMaybe NotSecure $ readMaybe (unpack $ cfg ^. #secure), +-- cookieMaxAge = Just $ secondsToDiffTime (fromIntegral $ cfg ^. #maxAge), +-- cookieExpires = Nothing, +-- cookiePath = Just (fromString . unpack $ cfg ^. #path), +-- cookieDomain = Just (fromString . unpack $ cfg ^. #domain), +-- cookieSameSite = fromMaybe AnySite $ readMaybe (unpack $ cfg ^. #sameSite), +-- sessionCookieName = fromString . unpack $ cfg ^. #sessionCookieName, +-- cookieXsrfSetting = Nothing +-- } + +mkApp :: AppConfig -> Hasql.Pool.Pool -> Redis.Connection -> IO Application +mkApp cfg pool redisConn = do + now <- getCurrentTime + + let env = Env {pool = pool, cfg = cfg, processStartedAt = now} + authCfg = authCheckIO env + apiCfg = authCfg :. EmptyContext + apiItself = + wiredUpPrivateServer env + :<|> ( swagger + :<|> wiredUpPublicServer env + ) + + pure + . myCors (cfg ^. #cors) + . rateLimitingMiddleware redisConn + $ serveWithContext apiProxy apiCfg apiItself + +wiredUpPrivateServer :: Env -> Server WikiMusicPrivateAPI +wiredUpPrivateServer env = + artistHandlers env :<|> genreHandlers env :<|> songHandlers env :<|> authHandlers env + +artistHandlers :: Env -> Server WikiMusicPrivateArtistsAPI +artistHandlers env = + fetchArtistsRoute env + :<|> searchArtistsRoute env + :<|> fetchArtistRoute env + :<|> insertArtistsRoute env + :<|> insertArtistCommentsRoute env + :<|> upsertArtistOpinionsRoute env + :<|> insertArtistArtworksRoute env + :<|> deleteArtistsByIdentifierRoute env + :<|> deleteArtistCommentsByIdentifierRoute env + :<|> deleteArtistOpinionsByIdentifierRoute env + :<|> deleteArtistArtworksByIdentifierRoute env + :<|> updateArtistArtworksOrderRoute env + :<|> updateArtistRoute env + +genreHandlers :: Env -> Server WikiMusicPrivateGenresAPI +genreHandlers env = + fetchGenresRoute env + :<|> searchGenresRoute env + :<|> fetchGenreRoute env + :<|> insertGenresRoute env + :<|> insertGenreCommentsRoute env + :<|> upsertGenreOpinionsRoute env + :<|> insertGenreArtworksRoute env + :<|> deleteGenresByIdentifierRoute env + :<|> deleteGenreCommentsByIdentifierRoute env + :<|> deleteGenreOpinionsByIdentifierRoute env + :<|> deleteGenreArtworksByIdentifierRoute env + :<|> updateGenreArtworksOrderRoute env + :<|> updateGenreRoute env + +songHandlers :: Env -> Server WikiMusicPrivateSongsAPI +songHandlers env = + fetchSongsRoute env + :<|> searchSongsRoute env + :<|> fetchSongRoute env + :<|> insertSongsRoute env + :<|> insertSongCommentsRoute env + :<|> upsertSongOpinionsRoute env + :<|> insertSongArtworksRoute env + :<|> insertArtistOfSongRoute env + :<|> deleteArtistOfSongRoute env + :<|> deleteSongsByIdentifierRoute env + :<|> deleteSongCommentsByIdentifierRoute env + :<|> deleteSongOpinionsByIdentifierRoute env + :<|> deleteSongArtworksByIdentifierRoute env + :<|> updateSongArtworksOrderRoute env + :<|> updateSongRoute env + :<|> insertSongContentsRoute env + :<|> deleteSongContentsByIdentifierRoute env + :<|> updateSongContentsRoute env + +authHandlers :: Env -> Server WikiMusicPrivateAuthAPI +authHandlers env = + fetchMeRoute env + :<|> inviteUserRoute env + :<|> deleteUserRoute env + +wiredUpPublicServer :: Env -> Server WikiMusicPublicAPI +wiredUpPublicServer env = + loginRoute env + :<|> makeResetPasswordLinkRoute env + :<|> doPasswordResetRoute env + :<|> systemInformationRoute env + +rateLimitingMiddleware :: Redis.Connection -> Middleware +rateLimitingMiddleware conn = rateLimiting strategy {strategyOnRequest = customController} + where + backend = redisBackend conn + getKey = pure . C8.pack . Relude.show . remoteHost + strategy = slidingWindow backend 30 15 getKey + customController req = + if rawPathInfo req == "/login" + then strategyOnRequest strategy req + else pure True diff --git a/src/WikiMusic/Servant/ArtistRoutes.hs b/src/WikiMusic/Servant/ArtistRoutes.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Servant/ArtistRoutes.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Servant.ArtistRoutes + ( fetchArtistsRoute, + fetchArtistRoute, + insertArtistsRoute, + insertArtistCommentsRoute, + insertArtistArtworksRoute, + upsertArtistOpinionsRoute, + deleteArtistsByIdentifierRoute, + deleteArtistCommentsByIdentifierRoute, + deleteArtistOpinionsByIdentifierRoute, + deleteArtistArtworksByIdentifierRoute, + updateArtistArtworksOrderRoute, + updateArtistRoute, + searchArtistsRoute, + ) +where + +import Servant +import WikiMusic.Free.ArtistCommand +import WikiMusic.Free.ArtistQuery +import WikiMusic.Interaction.Artist +import WikiMusic.Interaction.Model.Artist +import WikiMusic.Model.Other +import WikiMusic.PostgreSQL.ArtistCommand () +import WikiMusic.PostgreSQL.ArtistQuery () +import WikiMusic.Protolude +import WikiMusic.Servant.Utilities + +fetchArtistsRoute :: Env -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetArtistsQueryResponse +fetchArtistsRoute env authToken limit offset sort' include = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(ArtistQuery :+: ArtistCommand) $ fetchArtistsAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include) >>= maybe200 + ) + +searchArtistsRoute :: Env -> Maybe Text -> Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetArtistsQueryResponse +searchArtistsRoute env authToken searchInput limit offset sort' include = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(ArtistQuery :+: ArtistCommand) $ searchArtistsAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include searchInput) >>= maybe200 + ) + +fetchArtistRoute :: Env -> Maybe Text -> UUID -> Maybe Text -> Maybe Text -> Handler GetArtistsQueryResponse +fetchArtistRoute env authToken identifier sort' include = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(ArtistQuery :+: ArtistCommand) $ fetchArtistAction env authUser identifier sort' include) >>= maybe200 + ) + +insertArtistsRoute :: Env -> Maybe Text -> InsertArtistsRequest -> Handler InsertArtistsCommandResponse +insertArtistsRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(ArtistCommand :+: ArtistQuery) $ insertArtistsAction env authUser req) >>= maybe204 + ) + +insertArtistCommentsRoute :: Env -> Maybe Text -> InsertArtistCommentsRequest -> Handler InsertArtistCommentsCommandResponse +insertArtistCommentsRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @ArtistCommand $ insertArtistCommentsAction env authUser req) >>= maybe204 + ) + +upsertArtistOpinionsRoute :: Env -> Maybe Text -> UpsertArtistOpinionsRequest -> Handler UpsertArtistOpinionsCommandResponse +upsertArtistOpinionsRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @ArtistCommand $ upsertArtistOpinionsAction env authUser req) >>= maybe204 + ) + +insertArtistArtworksRoute :: Env -> Maybe Text -> InsertArtistArtworksRequest -> Handler InsertArtistArtworksCommandResponse +insertArtistArtworksRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @ArtistCommand $ insertArtistArtworksAction env authUser req) >>= maybe204 + ) + +deleteArtistsByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteArtistsByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @ArtistCommand $ deleteArtistsByIdentifierAction env authUser uid) >>= maybe204 + ) + +deleteArtistCommentsByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteArtistCommentsByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @ArtistCommand $ deleteArtistCommentsByIdentifierAction env authUser uid) >>= maybe204 + ) + +deleteArtistOpinionsByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteArtistOpinionsByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @ArtistCommand $ deleteArtistOpinionsByIdentifierAction env authUser uid) >>= maybe204 + ) + +deleteArtistArtworksByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteArtistArtworksByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @ArtistCommand $ deleteArtistArtworksByIdentifierAction env authUser uid) >>= maybe204 + ) + +updateArtistArtworksOrderRoute :: Env -> Maybe Text -> ArtistArtworkOrderUpdateRequest -> Handler () +updateArtistArtworksOrderRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @ArtistCommand $ updateArtistArtworksOrderAction env authUser req) >>= maybe204 + ) + +updateArtistRoute :: Env -> Maybe Text -> ArtistDeltaRequest -> Handler () +updateArtistRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(ArtistCommand :+: ArtistQuery) $ updateArtistAction env authUser req) >>= maybe204 + ) diff --git a/src/WikiMusic/Servant/AuthRoutes.hs b/src/WikiMusic/Servant/AuthRoutes.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Servant/AuthRoutes.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Servant.AuthRoutes + ( fetchMeRoute, + ) +where + +import Servant +import WikiMusic.Free.AuthQuery +import WikiMusic.Interaction.Auth +import WikiMusic.Interaction.Model.Auth +import WikiMusic.Model.Env +import WikiMusic.PostgreSQL.AuthQuery () +import WikiMusic.Protolude +import WikiMusic.Servant.Utilities + +fetchMeRoute :: Env -> Maybe Text -> Handler GetMeQueryResponse +fetchMeRoute env authToken = do + doWithAuth + env + authToken + ( \authUser -> do + maybeUser <- liftIO (exec @AuthQuery $ fetchMeAction env (authUser ^. #identifier)) + maybe (throwError err404) pure maybeUser + ) diff --git a/src/WikiMusic/Servant/GenreRoutes.hs b/src/WikiMusic/Servant/GenreRoutes.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Servant/GenreRoutes.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Servant.GenreRoutes + ( fetchGenresRoute, + fetchGenreRoute, + insertGenresRoute, + insertGenreCommentsRoute, + insertGenreArtworksRoute, + upsertGenreOpinionsRoute, + deleteGenresByIdentifierRoute, + deleteGenreCommentsByIdentifierRoute, + deleteGenreOpinionsByIdentifierRoute, + deleteGenreArtworksByIdentifierRoute, + updateGenreArtworksOrderRoute, + updateGenreRoute, + searchGenresRoute, + ) +where + +import Servant +import WikiMusic.Free.GenreCommand +import WikiMusic.Free.GenreQuery +import WikiMusic.Interaction.Genre +import WikiMusic.Interaction.Model.Genre +import WikiMusic.Model.Other +import WikiMusic.PostgreSQL.GenreCommand () +import WikiMusic.PostgreSQL.GenreQuery () +import WikiMusic.Protolude +import WikiMusic.Servant.Utilities + +fetchGenresRoute :: Env -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetGenresQueryResponse +fetchGenresRoute env authToken limit offset sort' include = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(GenreQuery :+: GenreCommand) $ fetchGenresAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include) >>= maybe200 + ) + +searchGenresRoute :: Env -> Maybe Text -> Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetGenresQueryResponse +searchGenresRoute env authToken searchInput limit offset sort' include = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(GenreQuery :+: GenreCommand) $ searchGenresAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include searchInput) >>= maybe200 + ) + +fetchGenreRoute :: Env -> Maybe Text -> UUID -> Maybe Text -> Maybe Text -> Handler GetGenresQueryResponse +fetchGenreRoute env authToken identifier sort' include = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(GenreQuery :+: GenreCommand) $ fetchGenreAction env authUser identifier sort' include) >>= maybe200 + ) + +insertGenresRoute :: Env -> Maybe Text -> InsertGenresRequest -> Handler InsertGenresCommandResponse +insertGenresRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(GenreCommand :+: GenreQuery) $ insertGenresAction env authUser req) >>= maybe204 + ) + +insertGenreCommentsRoute :: Env -> Maybe Text -> InsertGenreCommentsRequest -> Handler InsertGenreCommentsCommandResponse +insertGenreCommentsRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @GenreCommand $ insertGenreCommentsAction env authUser req) >>= maybe204 + ) + +upsertGenreOpinionsRoute :: Env -> Maybe Text -> UpsertGenreOpinionsRequest -> Handler UpsertGenreOpinionsCommandResponse +upsertGenreOpinionsRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @GenreCommand $ upsertGenreOpinionsAction env authUser req) >>= maybe204 + ) + +insertGenreArtworksRoute :: Env -> Maybe Text -> InsertGenreArtworksRequest -> Handler InsertGenreArtworksCommandResponse +insertGenreArtworksRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @GenreCommand $ insertGenreArtworksAction env authUser req) >>= maybe204 + ) + +deleteGenresByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteGenresByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @GenreCommand $ deleteGenresByIdentifierAction env authUser uid) >>= maybe204 + ) + +deleteGenreCommentsByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteGenreCommentsByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @GenreCommand $ deleteGenreCommentsByIdentifierAction env authUser uid) >>= maybe204 + ) + +deleteGenreOpinionsByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteGenreOpinionsByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @GenreCommand $ deleteGenreOpinionsByIdentifierAction env authUser uid) >>= maybe204 + ) + +deleteGenreArtworksByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteGenreArtworksByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @GenreCommand $ deleteGenreArtworksByIdentifierAction env authUser uid) >>= maybe204 + ) + +updateGenreArtworksOrderRoute :: Env -> Maybe Text -> GenreArtworkOrderUpdateRequest -> Handler () +updateGenreArtworksOrderRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @GenreCommand $ updateGenreArtworksOrderAction env authUser req) >>= maybe204 + ) + +updateGenreRoute :: Env -> Maybe Text -> GenreDeltaRequest -> Handler () +updateGenreRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(GenreCommand :+: GenreQuery) $ updateGenreAction env authUser req) >>= maybe204 + ) diff --git a/src/WikiMusic/Servant/SongRoutes.hs b/src/WikiMusic/Servant/SongRoutes.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Servant/SongRoutes.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Servant.SongRoutes + ( fetchSongsRoute, + insertSongsRoute, + insertSongCommentsRoute, + insertSongArtworksRoute, + upsertSongOpinionsRoute, + deleteSongsByIdentifierRoute, + deleteSongCommentsByIdentifierRoute, + deleteSongOpinionsByIdentifierRoute, + deleteSongArtworksByIdentifierRoute, + updateSongArtworksOrderRoute, + updateSongRoute, + insertArtistOfSongRoute, + fetchSongRoute, + updateSongContentsRoute, + insertSongContentsRoute, + deleteSongContentsByIdentifierRoute, + searchSongsRoute, + deleteArtistOfSongRoute, + ) +where + +import Servant +import WikiMusic.Console.Logger () +import WikiMusic.Free.Logger +import WikiMusic.Free.SongCommand +import WikiMusic.Free.SongQuery +import WikiMusic.Interaction.Model.Song +import WikiMusic.Interaction.Song +import WikiMusic.Model.Env +import WikiMusic.Model.Other +import WikiMusic.PostgreSQL.SongCommand () +import WikiMusic.PostgreSQL.SongQuery () +import WikiMusic.Protolude +import WikiMusic.Servant.Utilities + +fetchSongsRoute :: Env -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetSongsQueryResponse +fetchSongsRoute env authToken limit offset sort' include = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(SongQuery :+: SongCommand) $ fetchSongsAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include) >>= maybe200 + ) + +searchSongsRoute :: Env -> Maybe Text -> Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetSongsQueryResponse +searchSongsRoute env authToken searchInput limit offset sort' include = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(SongQuery :+: SongCommand) $ searchSongsAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include searchInput) >>= maybe200 + ) + +fetchSongRoute :: Env -> Maybe Text -> UUID -> Maybe Text -> Maybe Text -> Handler GetSongsQueryResponse +fetchSongRoute env authToken identifier sort' include = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(SongQuery :+: SongCommand) $ fetchSongAction env authUser identifier sort' include) >>= maybe200 + ) + +insertSongsRoute :: Env -> Maybe Text -> InsertSongsRequest -> Handler InsertSongsCommandResponse +insertSongsRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(SongCommand :+: SongQuery :+: Logger) $ insertSongsAction env authUser req) >>= maybe204 + ) + +insertSongCommentsRoute :: Env -> Maybe Text -> InsertSongCommentsRequest -> Handler InsertSongCommentsCommandResponse +insertSongCommentsRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ insertSongCommentsAction env authUser req) >>= maybe204 + ) + +upsertSongOpinionsRoute :: Env -> Maybe Text -> UpsertSongOpinionsRequest -> Handler UpsertSongOpinionsCommandResponse +upsertSongOpinionsRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ upsertSongOpinionsAction env authUser req) >>= maybe204 + ) + +insertSongArtworksRoute :: Env -> Maybe Text -> InsertSongArtworksRequest -> Handler InsertSongArtworksCommandResponse +insertSongArtworksRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ insertSongArtworksAction env authUser req) >>= maybe204 + ) + +deleteSongsByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteSongsByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ deleteSongsByIdentifierAction env authUser uid) >>= maybe204 + ) + +deleteSongCommentsByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteSongCommentsByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ deleteSongCommentsByIdentifierAction env authUser uid) >>= maybe204 + ) + +deleteSongOpinionsByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteSongOpinionsByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ deleteSongOpinionsByIdentifierAction env authUser uid) >>= maybe204 + ) + +deleteSongArtworksByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteSongArtworksByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ deleteSongArtworksByIdentifierAction env authUser uid) >>= maybe204 + ) + +updateSongArtworksOrderRoute :: Env -> Maybe Text -> SongArtworkOrderUpdateRequest -> Handler () +updateSongArtworksOrderRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ updateSongArtworksOrderAction env authUser req) >>= maybe204 + ) + +updateSongRoute :: Env -> Maybe Text -> SongDeltaRequest -> Handler () +updateSongRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(SongCommand :+: SongQuery) $ updateSongAction env authUser req) >>= maybe204 + ) + +insertArtistOfSongRoute :: Env -> Maybe Text -> InsertArtistsOfSongsRequest -> Handler InsertArtistsOfSongCommandResponse +insertArtistOfSongRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ insertArtistsOfSongAction env authUser req) >>= maybe204 + ) + +deleteArtistOfSongRoute :: Env -> Maybe Text -> InsertArtistsOfSongsRequest -> Handler () +deleteArtistOfSongRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ deleteArtistsOfSongAction env authUser req) >>= maybe204 + ) + +insertSongContentsRoute :: Env -> Maybe Text -> InsertSongContentsRequest -> Handler InsertSongContentsCommandResponse +insertSongContentsRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(SongCommand :+: SongQuery) $ insertSongContentsAction env authUser req) >>= maybe204 + ) + +deleteSongContentsByIdentifierRoute :: Env -> Maybe Text -> UUID -> Handler () +deleteSongContentsByIdentifierRoute env authToken uid = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ deleteSongContentsByIdentifierAction env authUser uid) >>= maybe204 + ) + +updateSongContentsRoute :: Env -> Maybe Text -> SongContentDeltaRequest -> Handler () +updateSongContentsRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @SongCommand $ updateSongContentsAction env authUser req) >>= maybe204 + ) diff --git a/src/WikiMusic/Servant/UserRoutes.hs b/src/WikiMusic/Servant/UserRoutes.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Servant/UserRoutes.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Servant.UserRoutes + ( makeResetPasswordLinkRoute, + doPasswordResetRoute, + inviteUserRoute, + deleteUserRoute, + ) +where + +import Servant +import WikiMusic.Free.MailCommand +import WikiMusic.Free.UserCommand +import WikiMusic.Free.UserQuery +import WikiMusic.Interaction.Model.User +import WikiMusic.Interaction.User +import WikiMusic.Model.Env +import WikiMusic.PostgreSQL.UserCommand () +import WikiMusic.PostgreSQL.UserQuery () +import WikiMusic.Protolude +import WikiMusic.SMTP.MailCommandSES () +import WikiMusic.Servant.Utilities + +makeResetPasswordLinkRoute :: Env -> Text -> Handler MakeResetPasswordLinkResponse +makeResetPasswordLinkRoute env userEmail = liftIO (exec @(UserCommand :+: MailCommand) $ makeResetPasswordLinkAction env userEmail) >>= maybe200 + +doPasswordResetRoute :: Env -> DoPasswordResetRequest -> Handler () +doPasswordResetRoute env req = liftIO (exec @(UserCommand :+: UserQuery :+: MailCommand) $ doPasswordResetAction env req) >>= maybe204 + +inviteUserRoute :: Env -> Maybe Text -> InviteUsersRequest -> Handler MakeResetPasswordLinkResponse +inviteUserRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @(UserCommand :+: MailCommand) $ inviteUserAction env authUser req) >>= maybe200 + ) + +deleteUserRoute :: Env -> Maybe Text -> DeleteUsersRequest -> Handler () +deleteUserRoute env authToken req = + doWithAuth + env + authToken + ( \authUser -> + liftIO (exec @UserCommand $ deleteUserAction env authUser req) >>= maybe204 + ) diff --git a/src/WikiMusic/Servant/Utilities.hs b/src/WikiMusic/Servant/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Servant/Utilities.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.Servant.Utilities + ( err204, + loginRoute, + authCheckIO, + maybe200, + maybe204, + systemInformationRoute, + doWithAuth, + ) +where + +import Data.Password.Bcrypt +import Data.Text qualified as T +import Servant as S +import WikiMusic.Free.AuthQuery +import WikiMusic.Model.Auth +import WikiMusic.Model.Env +import WikiMusic.Model.Other +import WikiMusic.PostgreSQL.AuthQuery () +import WikiMusic.Protolude + +loginRoute :: + Env -> + LoginRequest -> + Handler + ( Headers + '[ S.Header "x-wikimusic-auth" Text + ] + NoContent + ) +loginRoute env (LoginRequest inputEmail inputPassword) = do + eitherWikiMusicUser <- liftIO (exec @AuthQuery $ fetchUserForAuthCheck env (T.pack inputEmail)) + either + (const $ throwError err401) + (`verifyUserLogin` inputPassword) + eitherWikiMusicUser + +verifyUserLogin :: + Maybe WikiMusicUser -> + String -> + Handler + ( Headers + '[ S.Header "x-wikimusic-auth" Text + ] + NoContent + ) +verifyUserLogin Nothing _ = throwError err401 +verifyUserLogin (Just wikimusicUser) inputPassword = do + doAfterPasswordCheck wikimusicUser passwordCheckResult + where + inputPass = mkPassword (T.pack inputPassword) + passwordCheckResult = + maybe + PasswordCheckFail + (checkPassword inputPass . PasswordHash) + (wikimusicUser ^. #passwordHash) + +doAfterPasswordCheck :: + WikiMusicUser -> + PasswordCheck -> + Handler + ( Headers + '[ S.Header "x-wikimusic-auth" Text + ] + NoContent + ) +doAfterPasswordCheck _ PasswordCheckFail = throwError err401 +doAfterPasswordCheck wikimusicUser' PasswordCheckSuccess = do + let tok = fromMaybe "" (wikimusicUser' ^. #authToken) + throwError $ + ServerError + { errHTTPCode = 204, + errReasonPhrase = "No Content", + errBody = "", + errHeaders = + [ ("x-wikimusic-auth", WikiMusic.Protolude.encodeUtf8 tok) + ] + } + +systemInformationRoute :: + Env -> + Handler SystemInformationResponse +systemInformationRoute env = do + pure + SystemInformationResponse + { reportedVersion = env ^. #cfg % #dev % #reportedVersion, + processStartedAt = env ^. #processStartedAt + } + +authCheckIO :: + Env -> + Text -> + IO (Maybe WikiMusicUser) +authCheckIO env token = do + eitherWikiMusicUser <- liftIO (exec @AuthQuery $ fetchUserFromToken env token) + case eitherWikiMusicUser of + Left _ -> do + pure Nothing + Right maybeWikiMusicUser -> do + case maybeWikiMusicUser of + Nothing -> pure Nothing + Just u -> do + pure $ Just u + +err204 :: ServerError +err204 = + ServerError + { errHTTPCode = 204, + errReasonPhrase = "No Content", + errBody = "", + errHeaders = [] + } + +maybe204 :: (Show s) => Either s b -> Handler b +maybe204 (Left err) = throwError $ err500 {errBody = fromString . WikiMusic.Protolude.show $ err} +maybe204 _ = throwError err204 + +maybe200 :: (Show s) => Either s b -> Handler b +maybe200 (Left err) = throwError $ err500 {errBody = fromString . WikiMusic.Protolude.show $ err} +maybe200 (Right x) = pure x + +doWithAuth :: Env -> Maybe Text -> (WikiMusicUser -> Handler a) -> Handler a +doWithAuth env authToken eff = do + authUser <- liftIO $ authCheckIO env (fromMaybe "" authToken) + case authUser of + Nothing -> throwError err401 + Just auth -> eff auth diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main (main) where + +import Data.ByteString.Lazy qualified as BL +import Optics +import Relude +import System.Process +import Test.Tasty qualified as Tasty +import Test.Tasty.HUnit qualified as Tasty +import TestContainers.Tasty qualified as TC + +data TestConfig = TestConfig + { redisHost :: String, + redisPort :: Int, + postgreSQLHost :: String, + postgreSQLPort :: Int + } + deriving (Eq, Show, Generic) + +makeFieldLabelsNoPrefix ''TestConfig + +-- | Sets up and runs the containers required for this test suite. +setupContainers :: (TC.MonadDocker m) => m TestConfig +setupContainers = do + redisContainer <- + TC.run $ + TC.containerRequest (TC.fromTag "redis:6.2-alpine") + -- Expose the port 6379 from within the container. The respective port + -- on the host machine can be looked up using `containerPort` (see below). + TC.& TC.setExpose [6379] + -- Wait until the container is ready to accept requests. `run` blocks until + -- readiness can be established. + TC.& TC.setWaitingFor (TC.waitUntilMappedPortReachable 6379) + postgreSQLContainer <- + TC.run $ + TC.containerRequest (TC.fromTag "postgres:15.5") + TC.& TC.setExpose [5432] + TC.& TC.setWaitingFor (TC.waitUntilMappedPortReachable 5432) + + pure $ + TestConfig + { redisHost = "0.0.0.0", + redisPort = + -- Look up the corresponding port on the host machine for the exposed + -- port 6379. + TC.containerPort redisContainer 6379, + postgreSQLHost = "0.0.0.0", + postgreSQLPort = TC.containerPort postgreSQLContainer 5432 + } + +main :: IO () +main = + Tasty.defaultMain $ + -- Use `withContainers` to make the containers available in the closed over + -- tests. Due to how Tasty handles resources `withContainers` passes down + -- an IO action `start` to actually start up the containers. `start` can be + -- invoked multiple times, Tasty makes sure to only start up the containrs + -- once. + -- + -- `withContainers` ensures the started containers are shut down correctly + -- once execution leaves its scope. + TC.withContainers setupContainers $ + \start -> + Tasty.testGroup + "Some test group" + [ Tasty.testCase "Redis + PostgreSQL test" $ do + -- Actually start the containers!! + TestConfig {..} <- start + -- ... assert some properties + pure (), + Tasty.testCase "Another Redis + PostgreSQL test" $ do + -- Invoking `start` twice gives the same Endpoints! + TestConfig {..} <- start + (code, stdout, stderr) <- readProcess "ls -l /home" -- >>= BL.putStr + _ <- BL.putStr stdout + -- ... assert some properties + pure (), + Tasty.testCase "Another Redis + PostgreSQL test 2" $ do + -- Invoking `start` twice gives the same Endpoints! + TestConfig {..} <- start + (code, stdout, stderr) <- readProcess "timeout 20s make dev" -- >>= BL.putStr + _ <- BL.putStr stdout + -- ... assert some properties + pure () + ] diff --git a/wikimusic-api.cabal b/wikimusic-api.cabal new file mode 100644 --- /dev/null +++ b/wikimusic-api.cabal @@ -0,0 +1,242 @@ +cabal-version: 1.12 + +name: wikimusic-api +version: 1.1.0.1 +description: Please see the README at +homepage: https://gitlab.com/jjba-projects/wikimusic-api +bug-reports: https://gitlab.com/jjba-projects/wikimusic-api/-/issues +author: Josep Bigorra +maintainer: Josep Bigorra +copyright: 2023 Josep Bigorra +license: GPL-3 +build-type: Simple + +extra-source-files: + README.org + CHANGELOG.org + +source-repository head + type: git + location: https://gitlab.com/jjba-projects/wikimusic-api + subdir: wikimusic-api + +library + exposed-modules: + -- λ main + WikiMusic.Config + WikiMusic.Boot + + -- λ servant + WikiMusic.Servant.ApiSetup + WikiMusic.Servant.ArtistRoutes + WikiMusic.Servant.AuthRoutes + WikiMusic.Servant.GenreRoutes + WikiMusic.Servant.SongRoutes + WikiMusic.Servant.UserRoutes + WikiMusic.Servant.Utilities + + -- λ interactions with wikimusic's system + WikiMusic.Interaction.Artist + WikiMusic.Interaction.Auth + WikiMusic.Interaction.User + WikiMusic.Interaction.Genre + WikiMusic.Interaction.Mail + WikiMusic.Interaction.Song + + -- λ free monadic definition of wikimusic's system and possible interactions + WikiMusic.Free.ArtistCommand + WikiMusic.Free.ArtistQuery + WikiMusic.Free.AuthQuery + WikiMusic.Free.GenreCommand + WikiMusic.Free.GenreQuery + WikiMusic.Free.SongCommand + WikiMusic.Free.SongQuery + WikiMusic.Free.UserCommand + WikiMusic.Free.MailCommand + WikiMusic.Free.UserQuery + WikiMusic.Free.Clock + WikiMusic.Free.Logger + + WikiMusic.Model.Config + WikiMusic.Model.Env + + -- λ postgresql implementations + WikiMusic.PostgreSQL.ArtistCommand + WikiMusic.PostgreSQL.ArtistQuery + WikiMusic.PostgreSQL.AuthQuery + WikiMusic.PostgreSQL.GenreCommand + WikiMusic.PostgreSQL.GenreQuery + WikiMusic.PostgreSQL.Migration + WikiMusic.PostgreSQL.WriteAbstraction + WikiMusic.PostgreSQL.ReadAbstraction + WikiMusic.PostgreSQL.SongCommand + WikiMusic.PostgreSQL.SongQuery + WikiMusic.PostgreSQL.UserQuery + WikiMusic.PostgreSQL.UserCommand + + -- λ postgresql data models + WikiMusic.PostgreSQL.Model.Artist + WikiMusic.PostgreSQL.Model.Genre + WikiMusic.PostgreSQL.Model.Other + WikiMusic.PostgreSQL.Model.Song + + -- λ clock + WikiMusic.Clock.LiveClock + + -- λ logging + WikiMusic.Console.Logger + + -- λ mail + WikiMusic.SMTP.MailCommandSES + + -- λ custom prelude + WikiMusic.Protolude + + other-modules: + Paths_wikimusic_api + hs-source-dirs: + src + ghc-options: -Wall -threaded + default-extensions: + DataKinds + DefaultSignatures + DuplicateRecordFields + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + RecordWildCards + TypeFamilies + ViewPatterns + + build-depends: + aeson + , async + , base < 5 + , bytestring + , contravariant-extras + , postgresql-libpq + , hasql + , hasql-implicits + , hasql-migration + , hasql-optparse-applicative + , hasql-pool + , hasql-transaction + , hedis + , keuringsdienst + , keys + , mtl + , openapi3 + , optics + , optparse-applicative + , password + , password-types + , relude + , time + , servant + , servant-openapi3 + , servant-rate-limit + , servant-server + , text + , containers + , filepath + , directory + , uuid + , vector + , wai + , wai-cors + , wai-extra + , wai-rate-limit + , wai-rate-limit-redis + , warp + , smtp-mail + , mime-mail + , base64-bytestring + , neat-interpolation + , HTTP + , free-alacarte + , tomland + , wikimusic-model-hs + , wikimusic-api-spec + default-language: GHC2021 + +executable wikimusic-api-exe + main-is: Main.hs + other-modules: + Paths_wikimusic_api + hs-source-dirs: + app + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-extensions: + DataKinds + DefaultSignatures + DuplicateRecordFields + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + RecordWildCards + TypeFamilies + ViewPatterns + + build-depends: + base + , wikimusic-api + default-language: GHC2021 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_wikimusic_api + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-extensions: + DataKinds + DefaultSignatures + DuplicateRecordFields + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + RecordWildCards + TypeFamilies + ViewPatterns + + build-depends: + wikimusic-api + , base + , tasty + , tasty-hunit + default-language: GHC2021