packages feed

wikimusic-api (empty) → 1.1.0.1

raw patch · 55 files changed

+7295/−0 lines, 55 filesdep +HTTPdep +aesondep +asyncsetup-changed

Dependencies added: HTTP, aeson, async, base, base64-bytestring, bytestring, containers, contravariant-extras, directory, filepath, free-alacarte, hasql, hasql-implicits, hasql-migration, hasql-optparse-applicative, hasql-pool, hasql-transaction, hedis, keuringsdienst, keys, mime-mail, mtl, neat-interpolation, openapi3, optics, optparse-applicative, password, password-types, postgresql-libpq, relude, servant, servant-openapi3, servant-rate-limit, servant-server, smtp-mail, tasty, tasty-hunit, text, time, tomland, uuid, vector, wai, wai-cors, wai-extra, wai-rate-limit, wai-rate-limit-redis, warp, wikimusic-api, wikimusic-api-spec, wikimusic-model-hs

Files

+ CHANGELOG.org view
@@ -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.
+ README.org view
@@ -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+<div>+<img src="https://img.shields.io/badge/Haskell-5D4F85?logo=haskell&logoColor=fff&style=plastic" alt="Haskell"/>+<img src="https://img.shields.io/badge/PostgreSQL-4169E1?logo=postgresql&logoColor=fff&style=plastic" alt="PostgreSQL"/>+<img src="https://img.shields.io/badge/GNU%20Emacs-7F5AB6?logo=gnuemacs&logoColor=fff&style=plastic" alt="GNU Emacs"/>+<img src="https://img.shields.io/badge/NixOS-5277C3?logo=nixos&logoColor=fff&style=plastic" alt="NixOS"/>+<img src="https://img.shields.io/badge/Redis-DC382D?logo=redis&logoColor=fff&style=plastic" alt="Redis"/>+</div>+#+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 ~<url where you serve it>/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]]
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import WikiMusic.Boot qualified+import WikiMusic.Protolude++main :: (MonadIO m) => m ()+main = liftIO $ WikiMusic.Boot.boot
+ src/WikiMusic/Boot.hs view
@@ -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)
+ src/WikiMusic/Clock/LiveClock.hs view
@@ -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
+ src/WikiMusic/Config.hs view
@@ -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
+ src/WikiMusic/Console/Logger.hs view
@@ -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 <http://en.wikipedia.org/wiki/ISO_8601 ISO-8601>.+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
+ src/WikiMusic/Free/ArtistCommand.hs view
@@ -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)
+ src/WikiMusic/Free/ArtistQuery.hs view
@@ -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)
+ src/WikiMusic/Free/AuthQuery.hs view
@@ -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)
+ src/WikiMusic/Free/Clock.hs view
@@ -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)
+ src/WikiMusic/Free/GenreCommand.hs view
@@ -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)
+ src/WikiMusic/Free/GenreQuery.hs view
@@ -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)
+ src/WikiMusic/Free/Logger.hs view
@@ -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 ()))
+ src/WikiMusic/Free/MailCommand.hs view
@@ -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)
+ src/WikiMusic/Free/SongCommand.hs view
@@ -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)
+ src/WikiMusic/Free/SongQuery.hs view
@@ -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)
+ src/WikiMusic/Free/UserCommand.hs view
@@ -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)
+ src/WikiMusic/Free/UserQuery.hs view
@@ -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)
+ src/WikiMusic/Interaction/Artist.hs view
@@ -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
+ src/WikiMusic/Interaction/Auth.hs view
@@ -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+        }
+ src/WikiMusic/Interaction/Genre.hs view
@@ -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
+ src/WikiMusic/Interaction/Mail.hs view
@@ -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
+ src/WikiMusic/Interaction/Song.hs view
@@ -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+          }
+ src/WikiMusic/Interaction/User.hs view
@@ -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|+                       <h1>Reset your password on WikiMusic</h1>                  +                       <p>We have received a request to reset the password for your user on WikiMusic.</p>+                       <a href="$resetLink">Go reset your password on WikiMusic!</a>+                       <p>Feel free to ignore this e-mail if you did not request it</p>+                       <br/>+                       <small>If you had trouble clicking that link, please manually copy paste it:<br/>$resetLink</small>+                     |]+      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}
+ src/WikiMusic/Model/Config.hs view
@@ -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
+ src/WikiMusic/Model/Env.hs view
@@ -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
+ src/WikiMusic/PostgreSQL/ArtistCommand.hs view
@@ -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
+ src/WikiMusic/PostgreSQL/ArtistQuery.hs view
@@ -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 {..}
+ src/WikiMusic/PostgreSQL/AuthQuery.hs view
@@ -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'}
+ src/WikiMusic/PostgreSQL/GenreCommand.hs view
@@ -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
+ src/WikiMusic/PostgreSQL/GenreQuery.hs view
@@ -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 {..}
+ src/WikiMusic/PostgreSQL/Migration.hs view
@@ -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
+ src/WikiMusic/PostgreSQL/Model/Artist.hs view
@@ -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+      }
+ src/WikiMusic/PostgreSQL/Model/Genre.hs view
@@ -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+      }
+ src/WikiMusic/PostgreSQL/Model/Other.hs view
@@ -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+  )
+ src/WikiMusic/PostgreSQL/Model/Song.hs view
@@ -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+      }
+ src/WikiMusic/PostgreSQL/ReadAbstraction.hs view
@@ -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
+ src/WikiMusic/PostgreSQL/SongCommand.hs view
@@ -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
+ src/WikiMusic/PostgreSQL/SongQuery.hs view
@@ -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
+ src/WikiMusic/PostgreSQL/UserCommand.hs view
@@ -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+     |]
+ src/WikiMusic/PostgreSQL/UserQuery.hs view
@@ -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+          |]
+ src/WikiMusic/PostgreSQL/WriteAbstraction.hs view
@@ -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+        |]
+ src/WikiMusic/Protolude.hs view
@@ -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
+ src/WikiMusic/SMTP/MailCommandSES.hs view
@@ -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
+ src/WikiMusic/Servant/ApiSetup.hs view
@@ -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
+ src/WikiMusic/Servant/ArtistRoutes.hs view
@@ -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+    )
+ src/WikiMusic/Servant/AuthRoutes.hs view
@@ -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+    )
+ src/WikiMusic/Servant/GenreRoutes.hs view
@@ -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+    )
+ src/WikiMusic/Servant/SongRoutes.hs view
@@ -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+    )
+ src/WikiMusic/Servant/UserRoutes.hs view
@@ -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+    )
+ src/WikiMusic/Servant/Utilities.hs view
@@ -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
+ test/Spec.hs view
@@ -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 ()+          ]
+ wikimusic-api.cabal view
@@ -0,0 +1,242 @@+cabal-version: 1.12++name:           wikimusic-api+version:        1.1.0.1+description:    Please see the README at <https://gitlab.com/jjba-projects/wikimusic-api>+homepage:       https://gitlab.com/jjba-projects/wikimusic-api+bug-reports:    https://gitlab.com/jjba-projects/wikimusic-api/-/issues+author:         Josep Bigorra+maintainer:     Josep Bigorra <jjbigorra@gmail.com>+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