wikimusic-ssr 0.6.0.1 → 1.0.1.6

raw patch · 36 files changed

+2476/−1273 lines, 36 filesdep +blaze-markupdep +prometheus-clientdep +prometheus-metrics-ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-markup, prometheus-client, prometheus-metrics-ghc, wai-logger, wai-middleware-prometheus

API changes (from Hackage documentation)

Files

• CHANGELOG.org +0/−0
• README.org +48/−0
• src/Principium.hs +106/−0
• src/WikiMusic/SSR/Backend/Rest.hs +43/−40
• src/WikiMusic/SSR/Boot.hs +17/−15
• src/WikiMusic/SSR/Free/Backend.hs +9/−9
• src/WikiMusic/SSR/Free/View.hs +56/−65
• src/WikiMusic/SSR/Language.hs +38/−8
• src/WikiMusic/SSR/Model/Api.hs +1/−1
• src/WikiMusic/SSR/Model/Config.hs +27/−3
• src/WikiMusic/SSR/Model/Env.hs +5/−18
• src/WikiMusic/SSR/Prelude.hs +0/−1
• src/WikiMusic/SSR/Servant/ApiSetup.hs +74/−44
• src/WikiMusic/SSR/Servant/ApiSpec.hs +52/−16
• src/WikiMusic/SSR/Servant/ArtistRoutes.hs +170/−97
• src/WikiMusic/SSR/Servant/GenreRoutes.hs +169/−96
• src/WikiMusic/SSR/Servant/LoginRoutes.hs +89/−18
• src/WikiMusic/SSR/Servant/PreferenceRoutes.hs +9/−14
• src/WikiMusic/SSR/Servant/SongRoutes.hs +250/−96
• src/WikiMusic/SSR/Servant/Utilities.hs +102/−36
• src/WikiMusic/SSR/View/ArtistHtml.hs +52/−64
• src/WikiMusic/SSR/View/Components/DetailList.hs +23/−16
• src/WikiMusic/SSR/View/Components/Footer.hs +30/−0
• src/WikiMusic/SSR/View/Components/Forms.hs +168/−71
• src/WikiMusic/SSR/View/Components/Icons.hs +15/−0
• src/WikiMusic/SSR/View/Components/Meta.hs +0/−37
• src/WikiMusic/SSR/View/Components/Other.hs +138/−190
• src/WikiMusic/SSR/View/Components/PageTop.hs +125/−55
• src/WikiMusic/SSR/View/Css.hs +118/−0
• src/WikiMusic/SSR/View/ErrorHtml.hs +23/−0
• src/WikiMusic/SSR/View/GenreHtml.hs +51/−65
• src/WikiMusic/SSR/View/Html.hs +39/−69
• src/WikiMusic/SSR/View/HtmlUtil.hs +163/−0
• src/WikiMusic/SSR/View/OtherHtml.hs +68/−0
• src/WikiMusic/SSR/View/SongHtml.hs +177/−118
• wikimusic-ssr.cabal +21/−11

@@ -24,3 +24,51 @@ [[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 frontend.++* Project management++Find below a list ideas and work being done on this project by all our contributors.++** Work in progress+*** TODO Invite users functionality+*** WIP Create and optimize custom Prelude, and clean all files imports+++** Project backlog++*** TODO Automated Cabal Hackage release in CI and version bumps+*** TODO Recently viewed functionality+*** TODO Add optional lyrics for song textfield+*** TODO Improve reusability in ~fromString . T.unpack $ x~+*** TODO  Extract language and DictTerm into its own package+*** TODO Add better error handling and logging+*** TODO Add back button in some pages, and redirect to logical places+*** TODO Liked items list view (liked songs, liked genres)+*** TODO Create "for profit" version (premium offline pre-rendered) of WikiMusic, as app, embedded SQLite+*** TODO Use more non-empty types and sets if possible+*** TODO Create black box tests for basic system functioning (with Mock REST API generated from the API Spec)+*** TODO Genre <> Song <> Artist relation+*** TODO Add forums +*** TODO More reusable forms, with validations applied in Javascript+*** TODO More separation of HTML components+*** TODO Accessibility best practices+*** TODO Validate and limit size and type of files being uploaded+**** TODO GP5 support (song file upload)+*** TODO Prometheus metrics and visualizations, use Grafana in Docker, also in production server+*** TODO Upon resetting password, reset to a page that explains you should have received an e-mail or add notification balloon+*** TODO Notification system via ViewVars (vv) URL params, to show balloons with notifications like Done, Deleted, You Should have received email+*** Share minify CSS and miniify JS functions into principium as well++** Javascript+*** TODO ASCII Tab editing and creating helpers+*** TODO Chord highlighter and auto scroller as song view tools++++** Done+*** DONE Prometheus metrics and visualizations, use Grafana in Docker, also in production server+CLOSED: [2024-09-09 ma 16:47]+*** DONE Migration to GitHub+CLOSED: [2024-09-05 do 22:43]+*** DONE Remove unused dependencies+CLOSED: [2024-09-05 do 22:43]

@@ -0,0 +1,106 @@+module Principium+  ( --+    module Relude,+    module Optics,+    module WikiMusic.Model.Other,+    module NeatInterpolation,+    BlazeHtml.Html,+    module WikiMusic.SSR.Language,+    module WikiMusic.SSR.Model.Api,+    module WikiMusic.SSR.Model.Env,+    module Free.AlaCarte,+    module WikiMusic.SSR.Model.Config,+    module Data.Time,+    module WikiMusic.SSR.View.Css,+    UUID.UUID,+    --+    maybeDecodeUtf8,+    textToAttrValue,+    maybeDecodeBase16,+    uuidToText,+    intToText,+    unpackText,+    packText,+    filterText,+    MonadError,+    replaceText,+    mapElems,+    mapFromList,+    emptyMap,+    (Map.!?),+    mapFilter,+    setUnion,+    takeText,+  )+where++--++--++import Control.Monad.Error.Class (MonadError)+import Data.ByteString.Base16.Lazy qualified as B16+import Data.ByteString.Lazy qualified as BL+import Data.Map qualified as Map+import Data.Set qualified+import Data.Text qualified as T+import Data.Time+import Data.UUID qualified as UUID+import Free.AlaCarte+import NeatInterpolation hiding (text)+import Optics hiding (uncons)+import Relude+import Text.Blaze.Html as BlazeHtml+import WikiMusic.Model.Other+import WikiMusic.SSR.Language+import WikiMusic.SSR.Model.Api+import WikiMusic.SSR.Model.Config+import WikiMusic.SSR.Model.Env+import WikiMusic.SSR.View.Css++--++maybeDecodeUtf8 :: ByteString -> Either UnicodeException Text+maybeDecodeUtf8 = decodeUtf8'++textToAttrValue :: Text -> BlazeHtml.AttributeValue+textToAttrValue = fromString . T.unpack++maybeDecodeBase16 :: Text -> Either String BL.ByteString+maybeDecodeBase16 = B16.decode . fromString . T.unpack++uuidToText :: UUID.UUID -> Text+uuidToText = UUID.toText++intToText :: Int -> Text+intToText = T.pack . show++unpackText :: Text -> String+unpackText = T.unpack++packText :: String -> Text+packText = T.pack++filterText :: (Char -> Bool) -> Text -> Text+filterText = T.filter++replaceText :: Text -> Text -> Text -> Text+replaceText = T.replace++mapElems :: Map k a -> [a]+mapElems = Map.elems++mapFromList :: (Ord a) => [(a, b)] -> Map a b+mapFromList = Map.fromList++emptyMap :: Map k a+emptyMap = Map.empty++mapFilter :: (a -> Bool) -> Map k a -> Map k a+mapFilter = Map.filter++setUnion :: (Ord a) => Set a -> Set a -> Set a+setUnion a b = a `Data.Set.union` b++takeText :: Int -> Text -> Text+takeText = T.take

@@ -31,8 +31,8 @@     next =<< getArtists' env authToken limit offset sortOrder include   execAlgebra (SearchArtists env authToken search limit offset sortOrder include next) =     next =<< searchArtists' env authToken search limit offset sortOrder include-  execAlgebra (GetArtist env authToken identifier include next) =-    next =<< getArtist' env authToken identifier include+  execAlgebra (GetArtist env authToken identifier next) =+    next =<< getArtist' env authToken identifier   execAlgebra (CreateArtist env authToken r next) =     next =<< createArtist' env authToken r   execAlgebra (CreateArtistComment env authToken r next) =@@ -58,8 +58,8 @@     next =<< getGenres' env authToken limit offset sortOrder include   execAlgebra (SearchGenres env authToken search limit offset sortOrder include next) =     next =<< searchGenres' env authToken search limit offset sortOrder include-  execAlgebra (GetGenre env authToken identifier include next) =-    next =<< getGenre' env authToken identifier include+  execAlgebra (GetGenre env authToken identifier next) =+    next =<< getGenre' env authToken identifier   execAlgebra (CreateGenre env authToken r next) =     next =<< createGenre' env authToken r   execAlgebra (CreateGenreComment env authToken r next) =@@ -85,8 +85,8 @@     next =<< getSongs' env authToken limit offset sortOrder include   execAlgebra (SearchSongs env authToken search limit offset sortOrder include next) =     next =<< searchSongs' env authToken search limit offset sortOrder include-  execAlgebra (GetSong env authToken identifier include next) =-    next =<< getSong' env authToken identifier include+  execAlgebra (GetSong env authToken identifier next) =+    next =<< getSong' env authToken identifier   execAlgebra (CreateSong env authToken r next) =     next =<< createSong' env authToken r   execAlgebra (CreateSongComment env authToken r next) =@@ -146,10 +146,10 @@   doRest env     $ searchArtistsHTTP (Just $ authToken ^. #value) search (Just limit) (Just offset) (Just $ sortOrder ^. #value) (Just $ include ^. #value) -getArtist' :: (MonadIO m) => Env -> AuthToken -> UUID -> Include -> m (Either Text GetArtistsQueryResponse)-getArtist' env authToken identifier include = do+getArtist' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text GetArtistsQueryResponse)+getArtist' env authToken identifier = do   doRest env-    $ getArtistHTTP (Just $ authToken ^. #value) identifier Nothing (Just $ include ^. #value)+    $ getArtistHTTP (Just $ authToken ^. #value) identifier  createArtist' :: (MonadIO m) => Env -> AuthToken -> InsertArtistsRequest -> m (Either Text InsertArtistsCommandResponse) createArtist' env authToken r = do@@ -213,10 +213,10 @@   doRest env     $ searchGenresHTTP (Just $ authToken ^. #value) search (Just limit) (Just offset) (Just $ sortOrder ^. #value) (Just $ include ^. #value) -getGenre' :: (MonadIO m) => Env -> AuthToken -> UUID -> Include -> m (Either Text GetGenresQueryResponse)-getGenre' env authToken identifier include = do+getGenre' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text GetGenresQueryResponse)+getGenre' env authToken identifier = do   doRest env-    $ getGenreHTTP (Just $ authToken ^. #value) identifier Nothing (Just $ include ^. #value)+    $ getGenreHTTP (Just $ authToken ^. #value) identifier  createGenre' :: (MonadIO m) => Env -> AuthToken -> InsertGenresRequest -> m (Either Text InsertGenresCommandResponse) createGenre' env authToken r = do@@ -280,10 +280,10 @@   doRest env     $ searchSongsHTTP (Just $ authToken ^. #value) search (Just limit) (Just offset) (Just $ sortOrder ^. #value) (Just $ include ^. #value) -getSong' :: (MonadIO m) => Env -> AuthToken -> UUID -> Include -> m (Either Text GetSongsQueryResponse)-getSong' env authToken identifier include = do+getSong' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text GetSongsQueryResponse)+getSong' env authToken identifier = do   doRest env-    $ getSongHTTP (Just $ authToken ^. #value) identifier Nothing (Just $ include ^. #value)+    $ getSongHTTP (Just $ authToken ^. #value) identifier  createSong' :: (MonadIO m) => Env -> AuthToken -> InsertSongsRequest -> m (Either Text InsertSongsCommandResponse) createSong' env authToken r = do@@ -403,16 +403,16 @@ backendAPI = Proxy  type BackendAPI =-  WikiMusicPrivateArtistsAPI-    :<|> WikiMusicPrivateGenresAPI-    :<|> WikiMusicPrivateSongsAPI-    :<|> WikiMusicPrivateAuthAPI-    :<|> WikiMusicPublicAPI+  ArtistsAPI+    :<|> GenresAPI+    :<|> SongsAPI+    :<|> AuthAPI+    :<|> PublicAPI  -- getArtistsHTTP :: Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> ClientM GetArtistsQueryResponse searchArtistsHTTP :: Maybe Text -> Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> ClientM GetArtistsQueryResponse-getArtistHTTP :: Maybe Text -> UUID -> Maybe Text -> Maybe Text -> ClientM GetArtistsQueryResponse+getArtistHTTP :: Maybe Text -> UUID -> ClientM GetArtistsQueryResponse createArtistHTTP :: Maybe Text -> InsertArtistsRequest -> ClientM InsertArtistsCommandResponse createArtistCommentHTTP :: Maybe Text -> InsertArtistCommentsRequest -> ClientM InsertArtistCommentsCommandResponse upsertArtistOpinionHTTP :: Maybe Text -> UpsertArtistOpinionsRequest -> ClientM UpsertArtistOpinionsCommandResponse@@ -426,7 +426,7 @@ -- getGenresHTTP :: Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> ClientM GetGenresQueryResponse searchGenresHTTP :: Maybe Text -> Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> ClientM GetGenresQueryResponse-getGenreHTTP :: Maybe Text -> UUID -> Maybe Text -> Maybe Text -> ClientM GetGenresQueryResponse+getGenreHTTP :: Maybe Text -> UUID -> ClientM GetGenresQueryResponse createGenreHTTP :: Maybe Text -> InsertGenresRequest -> ClientM InsertGenresCommandResponse createGenreCommentHTTP :: Maybe Text -> InsertGenreCommentsRequest -> ClientM InsertGenreCommentsCommandResponse upsertGenreOpinionHTTP :: Maybe Text -> UpsertGenreOpinionsRequest -> ClientM UpsertGenreOpinionsCommandResponse@@ -440,7 +440,7 @@ -- getSongsHTTP :: Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> ClientM GetSongsQueryResponse searchSongsHTTP :: Maybe Text -> Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> ClientM GetSongsQueryResponse-getSongHTTP :: Maybe Text -> UUID -> Maybe Text -> Maybe Text -> ClientM GetSongsQueryResponse+getSongHTTP :: Maybe Text -> UUID -> ClientM GetSongsQueryResponse createSongHTTP :: Maybe Text -> InsertSongsRequest -> ClientM InsertSongsCommandResponse createSongCommentHTTP :: Maybe Text -> InsertSongCommentsRequest -> ClientM InsertSongCommentsCommandResponse upsertSongOpinionHTTP :: Maybe Text -> UpsertSongOpinionsRequest -> ClientM UpsertSongOpinionsCommandResponse@@ -472,37 +472,44 @@ resetPasswordDoHTTP :: DoPasswordResetRequest -> ClientM () systemInformationHTTP :: ClientM SystemInformationResponse -- artists-( getArtistsHTTP+( ( deleteArtistHTTP+      :<|> deleteArtistCommentHTTP+      :<|> deleteArtistOpinionHTTP+      :<|> deleteArtistArtworkHTTP+    )+    :<|> getArtistsHTTP     :<|> searchArtistsHTTP     :<|> getArtistHTTP     :<|> createArtistHTTP     :<|> createArtistCommentHTTP     :<|> upsertArtistOpinionHTTP     :<|> createArtistArtworkHTTP-    :<|> deleteArtistHTTP-    :<|> deleteArtistCommentHTTP-    :<|> deleteArtistOpinionHTTP-    :<|> deleteArtistArtworkHTTP     :<|> updateArtistArtworkOrderHTTP     :<|> editArtistHTTP   )   -- genres-  :<|> ( getGenresHTTP+  :<|> ( ( deleteGenreHTTP+             :<|> deleteGenreCommentHTTP+             :<|> deleteGenreOpinionHTTP+             :<|> deleteGenreArtworkHTTP+           )+           :<|> getGenresHTTP            :<|> searchGenresHTTP            :<|> getGenreHTTP            :<|> createGenreHTTP            :<|> createGenreCommentHTTP            :<|> upsertGenreOpinionHTTP            :<|> createGenreArtworkHTTP-           :<|> deleteGenreHTTP-           :<|> deleteGenreCommentHTTP-           :<|> deleteGenreOpinionHTTP-           :<|> deleteGenreArtworkHTTP            :<|> updateGenreArtworkOrderHTTP            :<|> editGenreHTTP          )   -- songs-  :<|> ( getSongsHTTP+  :<|> ( ( deleteSongHTTP+             :<|> deleteSongCommentHTTP+             :<|> deleteSongOpinionHTTP+             :<|> deleteSongArtworkHTTP+           )+           :<|> getSongsHTTP            :<|> searchSongsHTTP            :<|> getSongHTTP            :<|> createSongHTTP@@ -511,10 +518,6 @@            :<|> createSongArtworkHTTP            :<|> createArtistOfSongHTTP            :<|> deleteArtistOfSongHTTP-           :<|> deleteSongHTTP-           :<|> deleteSongCommentHTTP-           :<|> deleteSongOpinionHTTP-           :<|> deleteSongArtworkHTTP            :<|> updateSongArtworkOrderHTTP            :<|> editSongHTTP            :<|> createSongContentsHTTP@@ -522,7 +525,7 @@            :<|> editSongContentsHTTP          )   -- auth-  :<|> (meHTTP :<|> userInviteHTTP :<|> userDeleteHTTP)+  :<|> (meHTTP :<|> (userInviteHTTP :<|> userDeleteHTTP))   -- public-  :<|> (loginHTTP :<|> resetPasswordHTTP :<|> resetPasswordDoHTTP :<|> systemInformationHTTP) =+  :<|> (loginHTTP :<|> (resetPasswordHTTP :<|> resetPasswordDoHTTP) :<|> systemInformationHTTP) =     client backendAPI

@@ -4,30 +4,32 @@  module WikiMusic.SSR.Boot (boot) where -import Control.Monad-import Data.ByteString.Lazy qualified as BL-import Data.Text (pack) import Network.Wai.Handler.Warp-import Optics-import Relude+import Network.Wai.Logger (ApacheLogger, withStdoutLogger)+import Principium+import Prometheus qualified as P+import Prometheus.Metric.GHC qualified as P import WikiMusic.SSR.Config-import WikiMusic.SSR.Model.Config import WikiMusic.SSR.Servant.ApiSetup  boot :: (MonadIO m) => m ()-boot = do-  args <- liftIO getArgs-  maybeCfg <- readConfig (cfg args)-  liftIO $ either crashWithBadConfig startWikiMusicSSR maybeCfg+boot = liftIO $ withStdoutLogger $ \logger' ->+  ( do+      _ <- liftIO $ P.register P.ghcMetrics+      args <- liftIO getArgs+      maybeCfg <- readConfig (cfg args)+      liftIO $ either crashWithBadConfig (startWikiMusicSSR logger') maybeCfg+  )   where     crashWithBadConfig e = error ("Bad config could not be parsed! " <> show e)     cfg args = case nonEmpty args of-      Just (x :| []) -> pack x+      Just (x :| []) -> packText x       _ -> "resources/config/run-local.toml" -startWikiMusicSSR :: (MonadIO m) => AppConfig -> m ()-startWikiMusicSSR cfg = do-  liftIO . BL.putStr $ "Starting WikiMusic SSR ..."-  liftIO $ runSettings apiSettings =<< mkApp cfg+startWikiMusicSSR :: (MonadIO m) => ApacheLogger -> AppConfig -> m ()+startWikiMusicSSR logger' cfg = do+  liftIO . putTextLn $ "Starting WikiMusic SSR..."+  app <- liftIO $ mkApp logger' cfg+  liftIO $ runSettings apiSettings app   where     apiSettings = setPort (cfg ^. #servant % #port) defaultSettings

@@ -72,7 +72,7 @@   = -- artists     GetArtists Env AuthToken Limit Offset SortOrder Include (Either Text GetArtistsQueryResponse -> a)   | SearchArtists Env AuthToken Text Limit Offset SortOrder Include (Either Text GetArtistsQueryResponse -> a)-  | GetArtist Env AuthToken UUID Include (Either Text GetArtistsQueryResponse -> a)+  | GetArtist Env AuthToken UUID (Either Text GetArtistsQueryResponse -> a)   | CreateArtist Env AuthToken InsertArtistsRequest (Either Text InsertArtistsCommandResponse -> a)   | CreateArtistComment Env AuthToken InsertArtistCommentsRequest (Either Text InsertArtistCommentsCommandResponse -> a)   | UpsertArtistOpinion Env AuthToken UpsertArtistOpinionsRequest (Either Text UpsertArtistOpinionsCommandResponse -> a)@@ -86,7 +86,7 @@   | -- genres     GetGenres Env AuthToken Limit Offset SortOrder Include (Either Text GetGenresQueryResponse -> a)   | SearchGenres Env AuthToken Text Limit Offset SortOrder Include (Either Text GetGenresQueryResponse -> a)-  | GetGenre Env AuthToken UUID Include (Either Text GetGenresQueryResponse -> a)+  | GetGenre Env AuthToken UUID (Either Text GetGenresQueryResponse -> a)   | CreateGenre Env AuthToken InsertGenresRequest (Either Text InsertGenresCommandResponse -> a)   | CreateGenreComment Env AuthToken InsertGenreCommentsRequest (Either Text InsertGenreCommentsCommandResponse -> a)   | UpsertGenreOpinion Env AuthToken UpsertGenreOpinionsRequest (Either Text UpsertGenreOpinionsCommandResponse -> a)@@ -100,7 +100,7 @@   | -- songs     GetSongs Env AuthToken Limit Offset SortOrder Include (Either Text GetSongsQueryResponse -> a)   | SearchSongs Env AuthToken Text Limit Offset SortOrder Include (Either Text GetSongsQueryResponse -> a)-  | GetSong Env AuthToken UUID Include (Either Text GetSongsQueryResponse -> a)+  | GetSong Env AuthToken UUID (Either Text GetSongsQueryResponse -> a)   | CreateSong Env AuthToken InsertSongsRequest (Either Text InsertSongsCommandResponse -> a)   | CreateSongComment Env AuthToken InsertSongCommentsRequest (Either Text InsertSongCommentsCommandResponse -> a)   | UpsertSongOpinion Env AuthToken UpsertSongOpinionsRequest (Either Text UpsertSongOpinionsCommandResponse -> a)@@ -135,8 +135,8 @@ searchArtists :: (Backend :<: f) => Env -> AuthToken -> Text -> Limit -> Offset -> SortOrder -> Include -> Free f (Either Text GetArtistsQueryResponse) searchArtists env authToken search limit offset sortOrder include = injectFree (SearchArtists env authToken search limit offset sortOrder include Pure) -getArtist :: (Backend :<: f) => Env -> AuthToken -> UUID -> Include -> Free f (Either Text GetArtistsQueryResponse)-getArtist env authToken identifier include = injectFree (GetArtist env authToken identifier include Pure)+getArtist :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text GetArtistsQueryResponse)+getArtist env authToken identifier = injectFree (GetArtist env authToken identifier Pure)  createArtist :: (Backend :<: f) => Env -> AuthToken -> InsertArtistsRequest -> Free f (Either Text InsertArtistsCommandResponse) createArtist env authToken r = injectFree (CreateArtist env authToken r Pure)@@ -176,8 +176,8 @@ searchGenres :: (Backend :<: f) => Env -> AuthToken -> Text -> Limit -> Offset -> SortOrder -> Include -> Free f (Either Text GetGenresQueryResponse) searchGenres env authToken search limit offset sortOrder include = injectFree (SearchGenres env authToken search limit offset sortOrder include Pure) -getGenre :: (Backend :<: f) => Env -> AuthToken -> UUID -> Include -> Free f (Either Text GetGenresQueryResponse)-getGenre env authToken identifier include = injectFree (GetGenre env authToken identifier include Pure)+getGenre :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text GetGenresQueryResponse)+getGenre env authToken identifier = injectFree (GetGenre env authToken identifier Pure)  createGenre :: (Backend :<: f) => Env -> AuthToken -> InsertGenresRequest -> Free f (Either Text InsertGenresCommandResponse) createGenre env authToken r = injectFree (CreateGenre env authToken r Pure)@@ -217,8 +217,8 @@ searchSongs :: (Backend :<: f) => Env -> AuthToken -> Text -> Limit -> Offset -> SortOrder -> Include -> Free f (Either Text GetSongsQueryResponse) searchSongs env authToken search limit offset sortOrder include = injectFree (SearchSongs env authToken search limit offset sortOrder include Pure) -getSong :: (Backend :<: f) => Env -> AuthToken -> UUID -> Include -> Free f (Either Text GetSongsQueryResponse)-getSong env authToken identifier include = injectFree (GetSong env authToken identifier include Pure)+getSong :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text GetSongsQueryResponse)+getSong env authToken identifier = injectFree (GetSong env authToken identifier Pure)  createSong :: (Backend :<: f) => Env -> AuthToken -> InsertSongsRequest -> Free f (Either Text InsertSongsCommandResponse) createSong env authToken r = injectFree (CreateSong env authToken r Pure)

@@ -1,87 +1,78 @@-module WikiMusic.SSR.Free.View-  ( artistListPage,-    View (..),-    errorPage,-    loginPage,-    genreListPage,-    artistDetailPage,-    genreDetailPage,-    songListPage,-    songDetailPage,-    artistCreatePage,-    genreCreatePage,-    songCreatePage,-    artistEditPage,-    genreEditPage,-    songEditPage,-  )-where+module WikiMusic.SSR.Free.View where -import Free.AlaCarte-import Relude-import Text.Blaze.Html+import Principium import WikiMusic.Interaction.Model.Artist import WikiMusic.Interaction.Model.Genre import WikiMusic.Interaction.Model.Song-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env  type View :: Type -> Type data View a-  = ArtistListPage Env UiMode Language Palette SortOrder GetArtistsQueryResponse (Html -> a)-  | ArtistDetailPage Env UiMode Language Palette GetArtistsQueryResponse (Html -> a)-  | ArtistCreatePage Env UiMode Language Palette (Html -> a)-  | ArtistEditPage Env UiMode Language Palette Artist (Html -> a)-  | GenreListPage Env UiMode Language Palette SortOrder GetGenresQueryResponse (Html -> a)-  | GenreDetailPage Env UiMode Language Palette GetGenresQueryResponse (Html -> a)-  | GenreCreatePage Env UiMode Language Palette (Html -> a)-  | GenreEditPage Env UiMode Language Palette Genre (Html -> a)-  | SongListPage Env UiMode Language Palette SortOrder GetSongsQueryResponse (Html -> a)-  | SongDetailPage Env UiMode Language Palette SongAsciiSize GetSongsQueryResponse (Html -> a)-  | SongCreatePage Env UiMode Language Palette (Html -> a)-  | SongEditPage Env UiMode Language Palette Song (Html -> a)-  | ErrorPage Env UiMode Language Palette Text (Html -> a)-  | LoginPage Env UiMode Language Palette (Html -> a)+  = ArtistListPage Limit Offset Env ViewVars GetArtistsQueryResponse (Html -> a)+  | ArtistDetailPage Env ViewVars GetArtistsQueryResponse (Html -> a)+  | ArtistCreatePage Env ViewVars (Html -> a)+  | ArtistEditPage Env ViewVars Artist (Html -> a)+  | GenreListPage Limit Offset Env ViewVars GetGenresQueryResponse (Html -> a)+  | GenreDetailPage Env ViewVars GetGenresQueryResponse (Html -> a)+  | GenreCreatePage Env ViewVars (Html -> a)+  | GenreEditPage Env ViewVars Genre (Html -> a)+  | SongListPage Limit Offset Env ViewVars GetSongsQueryResponse (Html -> a)+  | SongDetailPage Env ViewVars GetSongsQueryResponse (Html -> a)+  | SongCreatePage Env ViewVars (Html -> a)+  | SongEditPage Env ViewVars Song (Html -> a)+  | ErrorPage Env ViewVars (Maybe Int) (Maybe Text) (Html -> a)+  | LoginPage Env ViewVars (Html -> a)+  | RequestPasswordResetPage Env ViewVars (Html -> a)+  | DoPasswordResetPage Env ViewVars (Maybe Text) (Html -> a)+  | InviteUsersPage Env ViewVars (Html -> a)   deriving (Functor) -artistListPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> SortOrder -> GetArtistsQueryResponse -> Free f Html-artistListPage env mode language palette sortOrder artists = injectFree (ArtistListPage env mode language palette sortOrder artists Pure)+artistListPage :: (View :<: f) => Limit -> Offset -> Env -> ViewVars -> GetArtistsQueryResponse -> Free f Html+artistListPage limit offset env vv artists = injectFree (ArtistListPage limit offset env vv artists Pure) -artistDetailPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> GetArtistsQueryResponse -> Free f Html-artistDetailPage env mode language palette artists = injectFree (ArtistDetailPage env mode language palette artists Pure)+artistDetailPage :: (View :<: f) => Env -> ViewVars -> GetArtistsQueryResponse -> Free f Html+artistDetailPage env vv artists = injectFree (ArtistDetailPage env vv artists Pure) -artistCreatePage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Free f Html-artistCreatePage env mode language palette = injectFree (ArtistCreatePage env mode language palette Pure)+artistCreatePage :: (View :<: f) => Env -> ViewVars -> Free f Html+artistCreatePage env vv = injectFree (ArtistCreatePage env vv Pure) -artistEditPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Artist -> Free f Html-artistEditPage env mode language palette artist = injectFree (ArtistEditPage env mode language palette artist Pure)+artistEditPage :: (View :<: f) => Env -> ViewVars -> Artist -> Free f Html+artistEditPage env vv artist = injectFree (ArtistEditPage env vv artist Pure) -genreListPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> SortOrder -> GetGenresQueryResponse -> Free f Html-genreListPage env mode language palette sortOrder genres = injectFree (GenreListPage env mode language palette sortOrder genres Pure)+genreListPage :: (View :<: f) => Limit -> Offset -> Env -> ViewVars -> GetGenresQueryResponse -> Free f Html+genreListPage limit offset env vv genres = injectFree (GenreListPage limit offset env vv genres Pure) -genreDetailPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> GetGenresQueryResponse -> Free f Html-genreDetailPage env mode language palette genres = injectFree (GenreDetailPage env mode language palette genres Pure)+genreDetailPage :: (View :<: f) => Env -> ViewVars -> GetGenresQueryResponse -> Free f Html+genreDetailPage env vv genres = injectFree (GenreDetailPage env vv genres Pure) -genreCreatePage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Free f Html-genreCreatePage env mode language palette = injectFree (GenreCreatePage env mode language palette Pure)+genreCreatePage :: (View :<: f) => Env -> ViewVars -> Free f Html+genreCreatePage env vv = injectFree (GenreCreatePage env vv Pure) -genreEditPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Genre -> Free f Html-genreEditPage env mode language palette genre = injectFree (GenreEditPage env mode language palette genre Pure)+genreEditPage :: (View :<: f) => Env -> ViewVars -> Genre -> Free f Html+genreEditPage env vv genre = injectFree (GenreEditPage env vv genre Pure) -songListPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> SortOrder -> GetSongsQueryResponse -> Free f Html-songListPage env mode language palette sortOrder songs = injectFree (SongListPage env mode language palette sortOrder songs Pure)+songListPage :: (View :<: f) => Limit -> Offset -> Env -> ViewVars -> GetSongsQueryResponse -> Free f Html+songListPage limit offset env vv songs = injectFree (SongListPage limit offset env vv songs Pure) -songDetailPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> SongAsciiSize -> GetSongsQueryResponse -> Free f Html-songDetailPage env mode language palette songAsciiSize songs = injectFree (SongDetailPage env mode language palette songAsciiSize songs Pure)+songDetailPage :: (View :<: f) => Env -> ViewVars -> GetSongsQueryResponse -> Free f Html+songDetailPage env vv songs = injectFree (SongDetailPage env vv songs Pure) -songCreatePage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Free f Html-songCreatePage env mode language palette = injectFree (SongCreatePage env mode language palette Pure)+songCreatePage :: (View :<: f) => Env -> ViewVars -> Free f Html+songCreatePage env vv = injectFree (SongCreatePage env vv Pure) -songEditPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Song -> Free f Html-songEditPage env mode language palette song = injectFree (SongEditPage env mode language palette song Pure)+songEditPage :: (View :<: f) => Env -> ViewVars -> Song -> Free f Html+songEditPage env vv song = injectFree (SongEditPage env vv song Pure) -errorPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Text -> Free f Html-errorPage env mode message l palette = injectFree (ErrorPage env mode message l palette Pure)+errorPage :: (View :<: f) => Env -> ViewVars -> Maybe Int -> Maybe Text -> Free f Html+errorPage env vv maybeCode maybeMessage = injectFree (ErrorPage env vv maybeCode maybeMessage Pure) -loginPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Free f Html-loginPage env mode language palette = injectFree (LoginPage env mode language palette Pure)+loginPage :: (View :<: f) => Env -> ViewVars -> Free f Html+loginPage env vv = injectFree (LoginPage env vv Pure)++requestPasswordResetPage :: (View :<: f) => Env -> ViewVars -> Free f Html+requestPasswordResetPage env vv = injectFree (RequestPasswordResetPage env vv Pure)++doPasswordResetPage :: (View :<: f) => Env -> ViewVars -> Maybe Text -> Free f Html+doPasswordResetPage env vv t = injectFree (DoPasswordResetPage env vv t Pure)++inviteUsersPage :: (View :<: f) => Env -> ViewVars -> Free f Html+inviteUsersPage env vv = injectFree (InviteUsersPage env vv Pure)

@@ -67,7 +67,11 @@     musicKey :: DictTerm,     musicCreationDate :: DictTerm,     albumName :: DictTerm,-    albumInfoLink :: DictTerm+    albumInfoLink :: DictTerm,+    irreversibleAction :: DictTerm,+    copyright0 :: DictTerm,+    copyright1 :: DictTerm,+    copyright2 :: DictTerm   }   deriving (Eq, Generic, Show) @@ -83,7 +87,8 @@ data Forms = Forms   { email :: DictTerm,     password :: DictTerm,-    submit :: DictTerm+    submit :: DictTerm,+    delete :: DictTerm   }   deriving (Eq, Generic, Show) @@ -93,7 +98,9 @@   { alphabeticalAsc :: DictTerm,     alphabeticalDesc :: DictTerm,     createdAtAsc :: DictTerm,-    createdAtDesc :: DictTerm+    createdAtDesc :: DictTerm,+    lastEditedAtAsc :: DictTerm,+    lastEditedAtDesc :: DictTerm   }   deriving (Eq, Generic, Show) @@ -138,7 +145,8 @@         Forms           { email = DictTerm {en = "email address:", nl = "emailadres:"},             password = DictTerm {en = "password:", nl = "wachtwoord:"},-            submit = DictTerm {en = "submit", nl = "indienen"}+            submit = DictTerm {en = "submit", nl = "indienen"},+            delete = DictTerm {en = "delete", nl = "verwijderen"}           },       errors =         Errors@@ -146,7 +154,7 @@           },       buttons =         Buttons-          { edit = DictTerm {en = "edit", nl = "bewerken"},+          { edit = DictTerm {en = "edit", nl = "bijwerken"},             delete = DictTerm {en = "delete", nl = "verwijderen"},             like = DictTerm {en = "like", nl = "leuk"},             dislike = DictTerm {en = "dislike", nl = "niet leuk"}@@ -164,7 +172,9 @@           { alphabeticalAsc = DictTerm {en = "alphabetical - asc", nl = "alfabetisch - opl"},             alphabeticalDesc = DictTerm {en = "alphabetical - desc", nl = "alfabetisch - afl"},             createdAtAsc = DictTerm {en = "created at - asc", nl = "datum gemaakt - opl"},-            createdAtDesc = DictTerm {en = "created at - desc", nl = "datum gemaakt - afl"}+            createdAtDesc = DictTerm {en = "created at - desc", nl = "datum gemaakt - afl"},+            lastEditedAtAsc = DictTerm {en = "last edited - asc", nl = "laatst bijgewerkt - opl"},+            lastEditedAtDesc = DictTerm {en = "last edited - desc", nl = "laatst bijgewerkt - afl"}           },       more =         More@@ -206,7 +216,7 @@             createdBy =               DictTerm                 { en = "added by:",-                  nl = "toegevoeg door:"+                  nl = "toegevoegd door:"                 },             createdAt =               DictTerm@@ -223,7 +233,27 @@             musicKey = DictTerm {en = "music key:", nl = "muziek key:"},             musicCreationDate = DictTerm {en = "music creation:", nl = "muziek geschreven:"},             albumName = DictTerm {en = "album name:", nl = "album naam:"},-            albumInfoLink = DictTerm {en = "album info:", nl = "info over album:"}+            albumInfoLink = DictTerm {en = "album info:", nl = "info over album:"},+            irreversibleAction =+              DictTerm+                { en = "Are you sure you wish to proceed with this irreversible action?",+                  nl = "Wilt u zeker dat u verder wil gaan? Deze actie kan niet terug worden gedraaid!"+                },+            copyright0 =+              DictTerm+                { en = "Copyright - J.J. Bigorra (jjbigorra@gmail.com)",+                  nl = "Copyright - J.J. Bigorra (jjbigorra@gmail.com)"+                },+            copyright1 =+              DictTerm+                { en = "See the source code behind WikiMusic here",+                  nl = "Zie hier de broncode achter WikiMusic"+                },+            copyright2 =+              DictTerm+                { en = "WikiMusic is completely licensed under the GNU General Public License v3 or later",+                  nl = "WikiMusic is volledig onder de GNU General Public License v3 of nieuwer gelicensieerd"+                }           }     } 

@@ -77,7 +77,7 @@ paletteCookieName = "wikimusic-palette"  data ViewVars = ViewVars-  { locale :: Language,+  { language :: Language,     uiMode :: UiMode,     authToken :: AuthToken,     songSorting :: SortOrder,

@@ -80,8 +80,9 @@ devCodec :: TomlCodec DevConfig devCodec = DevConfig <$> Toml.text "reported-version" .= (^. #reportedVersion) -newtype WebFrontendConfig = WebFrontendConfig-  { baseUrl :: Text+data WebFrontendConfig = WebFrontendConfig+  { baseUrl :: Text,+    staticFileDir :: Text   }   deriving (Generic, Eq, Show) @@ -90,13 +91,33 @@   WebFrontendConfig     <$> Toml.text "base-url"     .= (^. #baseUrl)+    <*> Toml.text "static-file-dir"+    .= (^. #staticFileDir) +data ApiConfig = ApiConfig+  { host :: Text,+    port :: Int,+    protocol :: Text+  }+  deriving (Generic, Eq, Show)++apiConfigCodec :: TomlCodec ApiConfig+apiConfigCodec =+  ApiConfig+    <$> Toml.text "host"+    .= (^. #host)+    <*> Toml.int "port"+    .= (^. #port)+    <*> Toml.text "protocol"+    .= (^. #protocol)+ data AppConfig = AppConfig   { servant :: ServantConfig,     cors :: CorsConfig,     cookie :: CookieConfig,     webFrontend :: WebFrontendConfig,-    dev :: DevConfig+    dev :: DevConfig,+    api :: ApiConfig   }   deriving (Generic, Eq, Show) @@ -113,6 +134,8 @@     .= (^. #webFrontend)     <*> Toml.table devCodec "dev"     .= (^. #dev)+    <*> Toml.table apiConfigCodec "api"+    .= (^. #api)  makeFieldLabelsNoPrefix ''AppConfig makeFieldLabelsNoPrefix ''ServantConfig@@ -120,3 +143,4 @@ makeFieldLabelsNoPrefix ''CookieConfig makeFieldLabelsNoPrefix ''WebFrontendConfig makeFieldLabelsNoPrefix ''DevConfig+makeFieldLabelsNoPrefix ''ApiConfig

@@ -3,34 +3,21 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoFieldSelectors #-} -module WikiMusic.SSR.Model.Env-  ( Env (..),-    PalettesCss (..),-  )-where+module WikiMusic.SSR.Model.Env where  import Data.Text import Data.Time+import Network.Wai.Logger (ApacheLogger) import Optics import Servant.Client import WikiMusic.SSR.Model.Config -data PalettesCss = PalettesCss-  { green :: Text,-    mauve :: Text-  }--makeFieldLabelsNoPrefix ''PalettesCss- data Env = Env-  { cfg :: AppConfig,+  { logger :: ApacheLogger,+    cfg :: AppConfig,     processStartedAt :: ZonedTime,     reportedVersion :: Text,-    mainCss :: Text,-    darkCss :: Text,-    lightCss :: Text,-    clientEnv :: ClientEnv,-    palettes :: PalettesCss+    clientEnv :: ClientEnv   }  makeFieldLabelsNoPrefix ''Env

@@ -1,1 +0,0 @@-module WikiMusic.SSR.Prelude where

@@ -2,37 +2,36 @@  module WikiMusic.SSR.Servant.ApiSetup (mkApp) where -import Data.Text qualified as T-import Data.Time import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Wai+import Network.Wai.Logger (ApacheLogger) import Network.Wai.Middleware.Cors-import Optics-import Relude+import Network.Wai.Middleware.Prometheus qualified as P+import Network.Wai.Middleware.RequestLogger+import Principium import Servant import Servant.Client import WikiMusic.SSR.Backend.Rest ()-import WikiMusic.SSR.Model.Config-import WikiMusic.SSR.Model.Env import WikiMusic.SSR.Servant.ApiSpec import WikiMusic.SSR.Servant.ArtistRoutes import WikiMusic.SSR.Servant.GenreRoutes import WikiMusic.SSR.Servant.LoginRoutes import WikiMusic.SSR.Servant.PreferenceRoutes import WikiMusic.SSR.Servant.SongRoutes+import WikiMusic.SSR.Servant.Utilities import WikiMusic.SSR.View.Html () -newClientEnv :: (MonadIO m) => m ClientEnv-newClientEnv = do+newClientEnv :: (MonadIO m) => AppConfig -> m ClientEnv+newClientEnv cfg = do   manager <- liftIO $ newManager tlsManagerSettings   pure $ clientEnv manager Nothing   where     baseUrl' =       BaseUrl-        { baseUrlScheme = Https,-          baseUrlHost = "api.wikimusic.jointhefreeworld.org",-          baseUrlPort = 443,+        { baseUrlScheme = if (cfg ^. #api % #protocol) == "https" then Https else Http,+          baseUrlHost = unpackText $ cfg ^. #api % #host,+          baseUrlPort = cfg ^. #api % #port,           baseUrlPath = ""         }     clientEnv manager cookieJar =@@ -40,39 +39,30 @@         { manager = manager,           baseUrl = baseUrl',           cookieJar = cookieJar,-          makeClientRequest = defaultMakeClientRequest+          makeClientRequest = defaultMakeClientRequest,+          middleware = id         } -mkApp :: AppConfig -> IO Application-mkApp cfg = do+mkApp :: ApacheLogger -> AppConfig -> IO Application+mkApp logger' cfg = do   let apiCfg = EmptyContext+   now <- getZonedTime-  mainCss <- liftIO (readFileBS "resources/css/main.css")-  lightCss <- liftIO (readFileBS "resources/css/light.css")-  darkCss <- liftIO (readFileBS "resources/css/dark.css")-  greenPaletteCss <- liftIO (readFileBS "resources/css/palettes/green.css")-  mauvePaletteCss <- liftIO (readFileBS "resources/css/palettes/mauve.css")-  clientEnv <- newClientEnv+  clientEnv <- newClientEnv cfg+   let env =         Env-          { cfg = cfg,+          { logger = logger',+            cfg = cfg,             processStartedAt = now,             reportedVersion = cfg ^. #dev % #reportedVersion,-            mainCss = prepareCSS mainCss,-            darkCss = prepareCSS darkCss,-            lightCss = prepareCSS lightCss,-            clientEnv = clientEnv,-            palettes =-              PalettesCss-                { green = prepareCSS greenPaletteCss,-                  mauve = prepareCSS mauvePaletteCss-                }+            clientEnv = clientEnv           }   pure+    . (if (cfg ^. #dev % #reportedVersion) == "dev" then logStdoutDev else logStdout)     . myCors (cfg ^. #cors)+    . P.prometheus P.def     $ serveWithContext wikimusicSSRServant apiCfg (server env)-  where-    prepareCSS = T.filter (\x -> x /= '\n' && x /= '\t') . decodeUtf8  artistBaseEntityRoutes :: Env -> Server BaseEntityRoutes artistBaseEntityRoutes env =@@ -83,6 +73,10 @@     :<|> artistLikeRoute env     :<|> artistDislikeRoute env     :<|> artistEditRoute env+    :<|> artistEditFormRoute env+    :<|> searchArtistRoute env+    :<|> (createArtistArtworkRoute env :<|> artistArtworkDeleteRoute env :<|> updateArtistArtworkOrderRoute env)+    :<|> artistDeleteRoute env  genreBaseEntityRoutes :: Env -> Server BaseEntityRoutes genreBaseEntityRoutes env =@@ -93,6 +87,10 @@     :<|> genreLikeRoute env     :<|> genreDislikeRoute env     :<|> genreEditRoute env+    :<|> genreEditFormRoute env+    :<|> searchGenreRoute env+    :<|> (createGenreArtworkRoute env :<|> genreArtworkDeleteRoute env :<|> updateGenreArtworkOrderRoute env)+    :<|> genreDeleteRoute env  songBaseEntityRoutes :: Env -> Server BaseEntityRoutes songBaseEntityRoutes env =@@ -103,6 +101,10 @@     :<|> songLikeRoute env     :<|> songDislikeRoute env     :<|> songEditRoute env+    :<|> songEditFormRoute env+    :<|> searchSongRoute env+    :<|> (createSongArtworkRoute env :<|> songArtworkDeleteRoute env :<|> updateSongArtworkOrderRoute env)+    :<|> songDeleteRoute env  preferenceRoutes :: Env -> Server PreferenceRoutes preferenceRoutes env =@@ -119,24 +121,53 @@   loginFormRoute env     :<|> submitLoginRoute env +songContentsRoutes :: Env -> Server SongContentsRoutes+songContentsRoutes env =+  songContentCreateFormRoute env+    :<|> songContentEditFormRoute env+    :<|> songContentDeleteRoute env++passwordRoutes :: Env -> Server PasswordRoutes+passwordRoutes env =+  requestPasswordResetRoute env+    :<|> doRequestPasswordResetRoute env+    :<|> doPasswordResetFormRoute env+    :<|> doPasswordResetRoute env++userRoutes :: Env -> Server UserRoutes+userRoutes env =+  inviteUsersRoute env+    :<|> inviteUsersFormRoute env++staticFilesRoute :: Env -> Server StaticFilesRoute+staticFilesRoute env =+  serveDirectoryFileServer+    . unpackText+    $ (env ^. #cfg % #webFrontend % #staticFileDir)+ server :: Env -> Server WikiMusicSSRServant server env =   fallbackRoute     :<|> artistBaseEntityRoutes env     :<|> genreBaseEntityRoutes env-    :<|> songBaseEntityRoutes env+    :<|> ( songBaseEntityRoutes env+             :<|> songContentsRoutes env+         )     :<|> preferenceRoutes env     :<|> loginRoutes env+    :<|> errorRoute env+    :<|> passwordRoutes env+    :<|> userRoutes env+    :<|> staticFilesRoute env  fallbackRoute :: Handler a fallbackRoute =-  do-    throwError-    $ ServerError-      { errHTTPCode = 302,-        errReasonPhrase = "Found",-        errBody = "",-        errHeaders = [("Location", "/songs")]+  respondWithHttp+    httpFound+      { cause = Just "Fallback page!",+        headers =+          [ withLocation "/songs"+          ]       }  wikimusicSSRServant :: Proxy WikiMusicSSRServant@@ -147,9 +178,9 @@   where     policy =       CorsResourcePolicy-        { corsOrigins = Just (map (fromString . T.unpack) (cfg ^. #origins), True),-          corsMethods = map (fromString . T.unpack) (cfg ^. #methods),-          corsRequestHeaders = map (fromString . T.unpack) (cfg ^. #requestHeaders),+        { corsOrigins = Just (map encodeUtf8 (cfg ^. #origins), True),+          corsMethods = map encodeUtf8 (cfg ^. #methods),+          corsRequestHeaders = map (fromString . unpackText) (cfg ^. #requestHeaders),           corsExposedHeaders =             Just               [ "content-type",@@ -166,4 +197,3 @@           corsRequireOrigin = False,           corsIgnoreFailures = False         }-

@@ -1,17 +1,9 @@-module WikiMusic.SSR.Servant.ApiSpec-  ( WikiMusicSSRServant,-    BaseEntityRoutes,-    PreferenceRoutes,-    LoginRoutes,-  )-where+module WikiMusic.SSR.Servant.ApiSpec where -import Data.UUID (UUID)-import Relude+import Principium import Servant import Servant.HTML.Blaze as ServantBlaze import Servant.Multipart-import Text.Blaze.Html as Html import WikiMusic.SSR.Backend.Rest () import WikiMusic.SSR.View.Html () @@ -22,11 +14,27 @@     :<|> "genres"       :> BaseEntityRoutes     :<|> "songs"-      :> BaseEntityRoutes+      :> ( BaseEntityRoutes+             :<|> SongContentsRoutes+         )     :<|> "user-preferences"       :> PreferenceRoutes     :<|> "login" :> LoginRoutes+    :<|> "error" :> ErrorRoute+    :<|> "passwords" :> PasswordRoutes+    :<|> "users" :> UserRoutes+    :<|> StaticFilesRoute +type PasswordRoutes =+  "request-reset" :> WithCookie :> HtmlDoc+    :<|> "request-reset" :> PostDataForm+    :<|> "do-reset" :> WithCookie :> QueryParam "token" Text :> HtmlDoc+    :<|> "do-reset" :> PostDataForm++type UserRoutes =+  "invite" :> WithCookie :> HtmlDoc+    :<|> "invite" :> WithCookie :> PostDataForm+ type PostDataForm =   MultipartForm Mem (MultipartData Mem)     :> Post '[ServantBlaze.HTML] (Headers '[Header "Location" Text] NoContent)@@ -49,15 +57,37 @@     :> QueryParam "sort-order" Text     :> QueryParam "limit" Int     :> QueryParam "offset" Int+    :> QueryParam "searchInput" Text     :> HtmlDoc-    :<|> WithCookie :> Capture "identifier" UUID :> HtmlDoc+    :<|> WithCookie :> WithEntityIdentifier :> HtmlDoc     :<|> "create" :> WithCookie :> HtmlDoc     :<|> "create" :> WithCookie :> PostDataForm-    :<|> "like" :> WithCookie :> WithReferer :> Capture "identifier" UUID :> PostNoFields-    :<|> "dislike" :> WithCookie :> WithReferer :> Capture "identifier" UUID :> PostNoFields-    :<|> "edit" :> WithCookie :> Capture "identifier" UUID :> HtmlDoc-    +    :<|> "like" :> WithCookie :> WithReferer :> WithEntityIdentifier :> PostNoFields+    :<|> "dislike" :> WithCookie :> WithReferer :> WithEntityIdentifier :> PostNoFields+    :<|> "edit" :> WithCookie :> WithEntityIdentifier :> HtmlDoc+    :<|> "edit" :> WithCookie :> WithReferer :> WithEntityIdentifier :> PostDataForm+    :<|> "search" :> PostDataForm+    :<|> "artworks"+      :> ( "create" :> WithCookie :> WithReferer :> WithEntityIdentifier :> PostDataForm+             :<|> "delete" :> WithCookie :> WithReferer :> WithEntityIdentifier :> PostNoFields+             :<|> "order" :> WithCookie :> WithReferer :> WithEntityIdentifier :> PostDataForm+         )+    :<|> "delete" :> WithCookie :> WithEntityIdentifier :> PostNoFields +type SongContentsRoutes =+  WithCookie+    :> WithReferer+    :> WithEntityIdentifier+    :> "contents"+    :> PostDataForm+    :<|> WithCookie+      :> WithReferer+      :> WithEntityIdentifier+      :> "contents"+      :> Capture "songContentIdentifier" UUID+      :> PostDataForm+    :<|> "contents" :> WithEntityIdentifier :> "delete" :> WithCookie :> WithReferer :> PostNoFields+ type PreferenceRoutes =   "locale" :> CookieForm     :<|> "artist-sorting" :> CookieForm@@ -68,3 +98,9 @@     :<|> "palette" :> CookieForm  type LoginRoutes = WithCookie :> HtmlDoc :<|> PostDataForm++type WithEntityIdentifier = Capture "identifier" UUID++type ErrorRoute = WithCookie :> WithReferer :> QueryParam "code" Int :> QueryParam "message" Text :> HtmlDoc++type StaticFilesRoute = "static" :> Raw

@@ -1,103 +1,86 @@ {-# LANGUAGE OverloadedLabels #-} -module WikiMusic.SSR.Servant.ArtistRoutes-  ( artistsRoute,-    artistRoute,-    artistCreateRoute,-    artistCreateFormRoute,-    artistLikeRoute,-    artistEditRoute,-    artistDislikeRoute,-  )-where+module WikiMusic.SSR.Servant.ArtistRoutes where -import Data.Maybe qualified-import Control.Monad.Error.Class-import Data.ByteString.Lazy qualified as BL-import Data.Map qualified as Map-import Data.Text qualified as T-import Data.UUID (UUID)-import Free.AlaCarte-import Optics-import Relude+import Principium import Servant import Servant.Multipart-import Text.Blaze.Html as Html import WikiMusic.Interaction.Model.Artist+import WikiMusic.Model.Artist import WikiMusic.Model.Other import WikiMusic.SSR.Backend.Rest () import WikiMusic.SSR.Free.Backend import WikiMusic.SSR.Free.View-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env import WikiMusic.SSR.Servant.Utilities import WikiMusic.SSR.View.Html () -artistsRoute :: (MonadIO m) => Env -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Int -> m Html-artistsRoute env cookie givenSortOrder limit offset = do-  maybeArtists <--    liftIO-      $ exec @Backend-        ( getArtists-            env-            (viewVars ^. #authToken)-            (maybe (Limit 50) Limit limit)-            (maybe (Offset 0) Offset offset)-            sortOrder-            (Include {value = "artworks,comments,opinions"})-        )-  eitherView-    env-    (viewVars ^. #uiMode)-    (viewVars ^. #locale)-    (viewVars ^. #palette)+artistsRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> m Html+artistsRoute env cookie givenSortOrder limit offset searchInput = do+  maybeArtists <- case searchInput of+    Nothing ->+      liftIO+        $ exec @Backend+          ( getArtists+              env+              (vv ^. #authToken)+              limit'+              offset'+              sortOrder+              (Include {value = "artworks,comments,opinions"})+          )+    Just search ->+      liftIO+        $ exec @Backend+          ( searchArtists+              env+              (vv ^. #authToken)+              search+              limit'+              offset'+              sortOrder+              (Include {value = "artworks,comments,opinions"})+          )+  respondWithViewOrErr     maybeArtists-    (exec @View . artistListPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette) sortOrder)+    (exec @View . artistListPage limit' offset' env vv)   where-    viewVars = viewVarsFromCookies cookie-    sortOrder = maybe (viewVars ^. #artistSorting) SortOrder givenSortOrder+    vv = vvFromCookies cookie+    sortOrder = maybe (vv ^. #artistSorting) SortOrder givenSortOrder+    limit' = maybe (Limit 50) Limit limit+    offset' = maybe (Offset 0) Offset offset -artistRoute :: (MonadIO m) => Env -> Maybe Text -> UUID -> m Html+artistRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> UUID -> m Html artistRoute env cookie identifier = do   maybeArtists <-     liftIO       $ exec @Backend         ( getArtist             env-            (viewVars ^. #authToken)+            (vv ^. #authToken)             identifier-            (Include {value = "artworks,comments,opinions"})         )-  eitherView-    env-    (viewVars ^. #uiMode)-    (viewVars ^. #locale)-    (viewVars ^. #palette)+  respondWithViewOrErr     maybeArtists-    (exec @View . artistDetailPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette))+    (exec @View . artistDetailPage env vv)   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie  artistCreateRoute :: (MonadIO m) => Env -> Maybe Text -> m Html artistCreateRoute env cookie = do-  liftIO $ exec @View (artistCreatePage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette))+  liftIO $ exec @View (artistCreatePage env vv)   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie  artistCreateFormRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a artistCreateFormRoute env cookie multipartData = do-  createResult <- liftIO $ exec @Backend (createArtist env (viewVars ^. #authToken) r)-  _ <- liftIO $ BL.putStr (fromString . show $ createResult)-  throwError-    $ ServerError-      { errHTTPCode = 302,-        errReasonPhrase = "Found",-        errBody = "",-        errHeaders =-          [("Location", "/artists")]+  _ <- liftIO $ exec @Backend (createArtist env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Created artist!",+        headers = [withLocation "/artists"]       }   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie     r =       InsertArtistsRequest         { artists =@@ -114,18 +97,15 @@  artistLikeRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> m a artistLikeRoute env cookie maybeReferer identifier = do-  res <- liftIO $ exec @Backend (upsertArtistOpinion env (viewVars ^. #authToken) r)-  _ <- liftIO $ BL.putStr (fromString . show $ res)-  throwError-    $ ServerError-      { errHTTPCode = 302,-        errReasonPhrase = "Found",-        errBody = "",-        errHeaders =-          [("Location", fromString . T.unpack $ fromMaybe "/artists" maybeReferer)]+  _ <- liftIO $ exec @Backend (upsertArtistOpinion env (vv ^. #authToken) r)++  respondWithHttp+    httpFound+      { cause = Just "Liked artist!",+        headers = [withLocation (fromMaybe "/artists" maybeReferer)]       }   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie     r =       UpsertArtistOpinionsRequest         { artistOpinions =@@ -138,18 +118,14 @@  artistDislikeRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> m a artistDislikeRoute env cookie maybeReferer identifier = do-  res <- liftIO $ exec @Backend (upsertArtistOpinion env (viewVars ^. #authToken) r)-  _ <- liftIO $ BL.putStr (fromString . show $ res)-  throwError-    $ ServerError-      { errHTTPCode = 302,-        errReasonPhrase = "Found",-        errBody = "",-        errHeaders =-          [("Location", fromString . T.unpack $ fromMaybe "/artists" maybeReferer)]+  _ <- liftIO $ exec @Backend (upsertArtistOpinion env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Disliked artist!",+        headers = [withLocation (fromMaybe "/artists" maybeReferer)]       }   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie     r =       UpsertArtistOpinionsRequest         { artistOpinions =@@ -160,24 +136,121 @@             ]         } -artistEditRoute :: (MonadIO m) => Env -> Maybe Text -> UUID -> m Html+artistEditRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> UUID -> m Html artistEditRoute env cookie identifier = do   maybeArtists <-     liftIO       $ exec @Backend         ( getArtist             env-            (viewVars ^. #authToken)+            (vv ^. #authToken)             identifier-            (Include {value = "artworks,comments,opinions"})         )-  let a = second (\x -> (head . Data.Maybe.fromJust . nonEmpty) $ Map.elems $ x ^. #artists) maybeArtists-  eitherView-    env-    (viewVars ^. #uiMode)-    (viewVars ^. #locale)-    (viewVars ^. #palette)-    a-    (exec @View . artistEditPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette))+  let maybeArtistList = second (\x -> nonEmpty $ mapElems $ x ^. #artists) maybeArtists++  respondWithViewOrErr'+    maybeArtistList+    (exec @View . artistEditPage env vv . head)   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie++artistEditFormRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> MultipartData tag -> m a+artistEditFormRoute env cookie maybeReferer identifier multipartData = do+  _ <- liftIO $ exec @Backend (editArtist env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Updated artist!",+        headers = [withLocation (maybe "/artists" (replaceText "/edit" "") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      ArtistDeltaRequest+        { artistDeltas =+            [ ArtistDelta+                { identifier = identifier,+                  displayName = maybeFromForm multipartData "displayName",+                  spotifyUrl = maybeFromForm multipartData "spotifyUrl",+                  youtubeUrl = maybeFromForm multipartData "youtubeUrl",+                  soundcloudUrl = maybeFromForm multipartData "soundcloudUrl",+                  wikipediaUrl = maybeFromForm multipartData "wikipediaUrl",+                  description = maybeFromForm multipartData "description"+                }+            ]+        }++searchArtistRoute :: (MonadIO m, MonadError ServerError m) => Env -> MultipartData tag -> m a+searchArtistRoute _ multipartData =+  respondWithHttp+    httpFound+      { cause = Just "Go to search artist page!",+        headers = [withLocation newRoute]+      }+  where+    searchData = fromForm multipartData "" "searchInput"+    newRoute = "/artists?searchInput=" <> searchData++createArtistArtworkRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> MultipartData tag -> m a+createArtistArtworkRoute env cookie maybeReferer identifier multipartData = do+  _ <- liftIO $ exec @Backend (createArtistArtwork env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Created artist!",+        headers = [withLocation (maybe "/artists" (<> "#edit-artwork") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      InsertArtistArtworksRequest+        { artistArtworks =+            [ InsertArtistArtworksRequestItem+                { artistIdentifier = identifier,+                  orderValue = fromMaybe 0 $ readMaybe (unpackText . fromMaybe "0" $ maybeFromForm multipartData "orderValue"),+                  contentUrl = fromMaybe "" $ maybeFromForm multipartData "contentUrl",+                  contentCaption = maybeFromForm multipartData "contentCaption"+                }+            ]+        }++artistDeleteRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> UUID -> m a+artistDeleteRoute env cookie identifier = do+  _ <- liftIO $ exec @Backend (deleteArtist env (vv ^. #authToken) identifier)++  respondWithHttp+    httpFound+      { cause = Just "Deleted artist!",+        headers = [withLocation "/artists"]+      }+  where+    vv = vvFromCookies cookie++artistArtworkDeleteRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> m a+artistArtworkDeleteRoute env cookie maybeReferer identifier = do+  _ <- liftIO $ exec @Backend (deleteArtistArtwork env (vv ^. #authToken) identifier)+  respondWithHttp+    httpFound+      { cause = Just "",+        headers = [withLocation (maybe "/artists" (<> "#edit-artwork") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie++updateArtistArtworkOrderRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> MultipartData tag -> m a+updateArtistArtworkOrderRoute env cookie maybeReferer identifier multipartData = do+  _ <- liftIO $ exec @Backend (updateArtistArtworkOrder env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Updated artist!",+        headers = [withLocation (maybe "/artists" (<> "#edit-artwork") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      ArtistArtworkOrderUpdateRequest+        { artistArtworkOrders =+            [ ArtistArtworkOrderUpdate+                { identifier = identifier,+                  orderValue = fromMaybe 0 $ readMaybe (unpackText . fromMaybe "0" $ maybeFromForm multipartData "orderValue")+                }+            ]+        }

@@ -1,103 +1,87 @@ {-# LANGUAGE OverloadedLabels #-} -module WikiMusic.SSR.Servant.GenreRoutes-  ( genresRoute,-    genreRoute,-    genreCreateRoute,-    genreCreateFormRoute,-    genreLikeRoute,-    genreDislikeRoute,-    genreEditRoute-  )-where+module WikiMusic.SSR.Servant.GenreRoutes where -import Data.Map qualified as Map-import Data.Maybe qualified -import Control.Monad.Error.Class-import Data.ByteString.Lazy qualified as BL-import Data.Text qualified as T-import Data.UUID (UUID)-import Free.AlaCarte-import Optics-import Relude+import Principium import Servant import Servant.Multipart-import Text.Blaze.Html as Html import WikiMusic.Interaction.Model.Genre+import WikiMusic.Model.Genre import WikiMusic.Model.Other import WikiMusic.SSR.Backend.Rest () import WikiMusic.SSR.Free.Backend import WikiMusic.SSR.Free.View-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env import WikiMusic.SSR.Servant.Utilities import WikiMusic.SSR.View.Html () -genresRoute :: (MonadIO m) => Env -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Int -> m Html-genresRoute env cookie givenSortOrder limit offset = do-  maybeGenres <--    liftIO-      $ exec @Backend-        ( getGenres-            env-            (viewVars ^. #authToken)-            (maybe (Limit 50) Limit limit)-            (maybe (Offset 0) Offset offset)-            sortOrder-            (Include {value = "artworks,comments,opinions"})-        )-  eitherView-    env-    (viewVars ^. #uiMode)-    (viewVars ^. #locale)-    (viewVars ^. #palette)+genresRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> m Html+genresRoute env cookie givenSortOrder limit offset searchInput = do+  maybeGenres <- case searchInput of+    Nothing ->+      liftIO+        $ exec @Backend+          ( getGenres+              env+              (vv ^. #authToken)+              limit'+              offset'+              sortOrder+              (Include {value = "artworks,comments,opinions"})+          )+    Just search ->+      liftIO+        $ exec @Backend+          ( searchGenres+              env+              (vv ^. #authToken)+              search+              limit'+              offset'+              sortOrder+              (Include {value = "artworks,comments,opinions"})+          )++  respondWithViewOrErr     maybeGenres-    (exec @View . genreListPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette) sortOrder)+    (exec @View . genreListPage limit' offset' env vv)   where-    viewVars = viewVarsFromCookies cookie-    sortOrder = maybe (viewVars ^. #genreSorting) SortOrder givenSortOrder+    vv = vvFromCookies cookie+    sortOrder = maybe (vv ^. #genreSorting) SortOrder givenSortOrder+    limit' = maybe (Limit 50) Limit limit+    offset' = maybe (Offset 0) Offset offset -genreRoute :: (MonadIO m) => Env -> Maybe Text -> UUID -> m Html+genreRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> UUID -> m Html genreRoute env cookie identifier = do   maybeGenres <-     liftIO       $ exec @Backend         ( getGenre             env-            (viewVars ^. #authToken)+            (vv ^. #authToken)             identifier-            (Include {value = "artworks,comments,opinions"})         )-  eitherView-    env-    (viewVars ^. #uiMode)-    (viewVars ^. #locale)-    (viewVars ^. #palette)+  respondWithViewOrErr     maybeGenres-    (exec @View . genreDetailPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette))+    (exec @View . genreDetailPage env vv)   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie  genreCreateRoute :: (MonadIO m) => Env -> Maybe Text -> m Html genreCreateRoute env cookie = do-  liftIO $ exec @View (genreCreatePage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette))+  liftIO $ exec @View (genreCreatePage env vv)   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie  genreCreateFormRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a genreCreateFormRoute env cookie multipartData = do-  createResult <- liftIO $ exec @Backend (createGenre env (viewVars ^. #authToken) r)-  _ <- liftIO $ BL.putStr (fromString . show $ createResult)-  throwError-    $ ServerError-      { errHTTPCode = 302,-        errReasonPhrase = "Found",-        errBody = "",-        errHeaders =-          [("Location", "/genres")]+  _ <- liftIO $ exec @Backend (createGenre env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Created genre!",+        headers = [withLocation "/genres"]       }   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie     r =       InsertGenresRequest         { genres =@@ -114,18 +98,14 @@  genreLikeRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> m a genreLikeRoute env cookie maybeReferer identifier = do-  res <- liftIO $ exec @Backend (upsertGenreOpinion env (viewVars ^. #authToken) r)-  _ <- liftIO $ BL.putStr (fromString . show $ res)-  throwError-    $ ServerError-      { errHTTPCode = 302,-        errReasonPhrase = "Found",-        errBody = "",-        errHeaders =-          [("Location", fromString . T.unpack $ fromMaybe "/genres" maybeReferer)]+  _ <- liftIO $ exec @Backend (upsertGenreOpinion env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Liked genre!",+        headers = [withLocation (fromMaybe "/genres" maybeReferer)]       }   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie     r =       UpsertGenreOpinionsRequest         { genreOpinions =@@ -138,18 +118,14 @@  genreDislikeRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> m a genreDislikeRoute env cookie maybeReferer identifier = do-  res <- liftIO $ exec @Backend (upsertGenreOpinion env (viewVars ^. #authToken) r)-  _ <- liftIO $ BL.putStr (fromString . show $ res)-  throwError-    $ ServerError-      { errHTTPCode = 302,-        errReasonPhrase = "Found",-        errBody = "",-        errHeaders =-          [("Location", fromString . T.unpack $ fromMaybe "/genres" maybeReferer)]+  _ <- liftIO $ exec @Backend (upsertGenreOpinion env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Disliked genre!",+        headers = [withLocation (fromMaybe "/genres" maybeReferer)]       }   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie     r =       UpsertGenreOpinionsRequest         { genreOpinions =@@ -160,24 +136,121 @@             ]         } -genreEditRoute :: (MonadIO m) => Env -> Maybe Text -> UUID -> m Html+genreEditRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> UUID -> m Html genreEditRoute env cookie identifier = do   maybeGenres <-     liftIO       $ exec @Backend         ( getGenre             env-            (viewVars ^. #authToken)+            (vv ^. #authToken)             identifier-            (Include {value = "artworks,comments,opinions"})         )-  let a = second (\x -> (head . Data.Maybe.fromJust . nonEmpty) $ Map.elems $ x ^. #genres) maybeGenres-  eitherView-    env-    (viewVars ^. #uiMode)-    (viewVars ^. #locale)-    (viewVars ^. #palette)+  let a = second (\x -> nonEmpty $ mapElems $ x ^. #genres) maybeGenres+  respondWithViewOrErr'     a-    (exec @View . genreEditPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette))+    (exec @View . genreEditPage env vv . head)   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie++genreEditFormRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> MultipartData tag -> m a+genreEditFormRoute env cookie maybeReferer identifier multipartData = do+  editResult <- liftIO $ exec @Backend (editGenre env (vv ^. #authToken) r)++  respondWithHttp+    httpFound+      { cause = Just "Updated genre!",+        headers = [withLocation (fromMaybe "/genres" maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      GenreDeltaRequest+        { genreDeltas =+            [ GenreDelta+                { identifier = identifier,+                  displayName = maybeFromForm multipartData "displayName",+                  spotifyUrl = maybeFromForm multipartData "spotifyUrl",+                  youtubeUrl = maybeFromForm multipartData "youtubeUrl",+                  soundcloudUrl = maybeFromForm multipartData "soundcloudUrl",+                  wikipediaUrl = maybeFromForm multipartData "wikipediaUrl",+                  description = maybeFromForm multipartData "description"+                }+            ]+        }++searchGenreRoute :: (MonadIO m, MonadError ServerError m) => Env -> MultipartData tag -> m a+searchGenreRoute _ multipartData =+  respondWithHttp+    httpFound+      { cause = Just "Go to search genres!",+        headers = [withLocation newRoute]+      }+  where+    searchData = fromForm multipartData "" "searchInput"+    newRoute = "/genres?searchInput=" <> searchData++createGenreArtworkRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> MultipartData tag -> m a+createGenreArtworkRoute env cookie maybeReferer identifier multipartData = do+  _ <- liftIO $ exec @Backend (createGenreArtwork env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Created genre artwork!",+        headers = [withLocation (maybe "/genres" (<> "#edit-artwork") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      InsertGenreArtworksRequest+        { genreArtworks =+            [ InsertGenreArtworksRequestItem+                { genreIdentifier = identifier,+                  orderValue = fromMaybe 0 $ readMaybe (unpackText . fromMaybe "0" $ maybeFromForm multipartData "orderValue"),+                  contentUrl = fromMaybe "" $ maybeFromForm multipartData "contentUrl",+                  contentCaption = maybeFromForm multipartData "contentCaption"+                }+            ]+        }++genreDeleteRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> UUID -> m a+genreDeleteRoute env cookie identifier = do+  _ <- liftIO $ exec @Backend (deleteGenre env (vv ^. #authToken) identifier)+  respondWithHttp+    httpFound+      { cause = Just "Deleted genre!",+        headers = [withLocation "/genres"]+      }+  where+    vv = vvFromCookies cookie++genreArtworkDeleteRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> m a+genreArtworkDeleteRoute env cookie maybeReferer identifier = do+  _ <- liftIO $ exec @Backend (deleteGenreArtwork env (vv ^. #authToken) identifier)+  respondWithHttp+    httpFound+      { cause = Just "Deleted genre artwork!",+        headers = [withLocation (maybe "/genres" (<> "#edit-artwork") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie++updateGenreArtworkOrderRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> MultipartData tag -> m a+updateGenreArtworkOrderRoute env cookie maybeReferer identifier multipartData = do+  _ <- liftIO $ exec @Backend (updateGenreArtworkOrder env (vv ^. #authToken) r)+  respondWithHttp+    serverResponse+      { code = 302,+        cause = Just "Deleted genre artwork!",+        headers = [withLocation (maybe "/genres" (<> "#edit-artwork") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      GenreArtworkOrderUpdateRequest+        { genreArtworkOrders =+            [ GenreArtworkOrderUpdate+                { identifier = identifier,+                  orderValue = fromMaybe 0 $ readMaybe (unpackText . fromMaybe "0" $ maybeFromForm multipartData "orderValue")+                }+            ]+        }

@@ -1,23 +1,15 @@ {-# LANGUAGE OverloadedLabels #-} -module WikiMusic.SSR.Servant.LoginRoutes (submitLoginRoute, loginFormRoute) where+module WikiMusic.SSR.Servant.LoginRoutes where -import Control.Monad.Error.Class-import Data.ByteString.Lazy qualified as BL-import Data.Map qualified as Map-import Data.Text qualified as T-import Free.AlaCarte-import Optics-import Relude+import Principium import Servant import Servant.Multipart-import Text.Blaze.Html as Html+import WikiMusic.Interaction.Model.User import WikiMusic.Model.Auth import WikiMusic.SSR.Backend.Rest () import WikiMusic.SSR.Free.Backend import WikiMusic.SSR.Free.View-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env import WikiMusic.SSR.Servant.Utilities import WikiMusic.SSR.View.Html () @@ -26,14 +18,93 @@   maybeAuthToken <- liftIO $ exec @Backend (login env (LoginRequest {wikimusicEmail = email, wikimusicPassword = password}))   case maybeAuthToken of     Left e -> do-      _ <- liftIO $ BL.putStr . fromString . T.unpack $ e-      setCookieRoute (env ^. #cfg % #cookie) "/login" Map.empty-    Right authToken -> setCookieRoute (env ^. #cfg % #cookie) "/songs" (Map.fromList [(authCookieName, encodeToken authToken)])+      setCookieRoute (env ^. #cfg % #cookie) "/login" emptyMap+    Right authToken -> setCookieRoute (env ^. #cfg % #cookie) "/songs" (mapFromList [(authCookieName, encodeToken authToken)])   where-    email = T.unpack $ fromForm multipartData "" "email"-    password = T.unpack $ fromForm multipartData "" "password"+    email = unpackText $ fromForm multipartData "" "email"+    password = unpackText $ fromForm multipartData "" "password"  loginFormRoute :: (MonadIO m) => Env -> Maybe Text -> m Html-loginFormRoute env cookie = liftIO $ exec @View (loginPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette))+loginFormRoute env cookie = liftIO $ exec @View (loginPage env vv)   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie++doPasswordResetFormRoute :: (MonadIO m) => Env -> Maybe Text -> Maybe Text -> m Html+doPasswordResetFormRoute env cookie maybeToken = liftIO $ exec @View (doPasswordResetPage env vv maybeToken)+  where+    vv = vvFromCookies cookie++requestPasswordResetRoute :: (MonadIO m) => Env -> Maybe Text -> m Html+requestPasswordResetRoute env cookie = liftIO $ exec @View (requestPasswordResetPage env vv)+  where+    vv = vvFromCookies cookie++doRequestPasswordResetRoute :: (MonadIO m, MonadError ServerError m) => Env -> MultipartData tag -> m a+doRequestPasswordResetRoute env multipartData = do+  _ <-+    liftIO+      $ exec @Backend+        ( resetPassword+            env+            email+        )+  respondWithHttp+    httpFound+      { cause = Just "Requested password reset!",+        headers = [withLocation ("/login?email=" <> email)]+      }+  where+    email = fromForm multipartData "" "email"++doPasswordResetRoute :: (MonadIO m, MonadError ServerError m) => Env -> MultipartData tag -> m a+doPasswordResetRoute env multipartData = do+  _ <-+    liftIO+      $ exec @Backend+        ( resetPasswordDo+            env+            ( DoPasswordResetRequest+                { email = email,+                  token = token,+                  password = password,+                  passwordConfirm = passwordConfirm+                }+            )+        )+  respondWithHttp+    httpFound+      { cause = Just "Reset password!",+        headers = [withLocation ("/login?email=" <> email)]+      }+  where+    email = fromForm multipartData "" "email"+    password = fromForm multipartData "" "password"+    passwordConfirm = fromForm multipartData "" "passwordConfirm"+    token = fromForm multipartData "" "token"++inviteUsersRoute :: (MonadIO m) => Env -> Maybe Text -> m Html+inviteUsersRoute env cookie = liftIO $ exec @View (inviteUsersPage env vv)+  where+    vv = vvFromCookies cookie++inviteUsersFormRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a+inviteUsersFormRoute env cookie multipartData = do+  _ <-+    liftIO+      $ exec @Backend+        ( userInvite+            env+            (vv ^. #authToken)+            InviteUsersRequest {..}+        )+  respondWithHttp+    httpFound+      { cause = Just "Requested password reset!",+        headers = [withLocation ("/login?email=" <> email)]+      }+  where+    vv = vvFromCookies cookie+    email = fromForm multipartData "" "email"+    displayName = fromForm multipartData "" "displayName"+    description = maybeFromForm multipartData "description"+    role = (read . unpackText $ fromForm multipartData "" "role") :: UserRole

@@ -11,56 +11,51 @@   ) where -import Control.Monad.Error.Class-import Data.Map qualified as Map-import Optics-import Relude+import Principium import Servant import Servant.Multipart import WikiMusic.SSR.Backend.Rest ()-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env import WikiMusic.SSR.Servant.Utilities import WikiMusic.SSR.View.Html ()  setLanguageRoute :: (MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a setLanguageRoute env maybeReferer multipartData =-  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/songs" maybeReferer) (Map.fromList [(localeCookieName, wantedLanguage)])+  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/songs" maybeReferer) (mapFromList [(localeCookieName, wantedLanguage)])   where     wantedLanguage = fromForm multipartData "en" "locale"  setArtistSortingRoute :: (MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a setArtistSortingRoute env maybeReferer multipartData =-  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/artists" maybeReferer) (Map.fromList [(artistSortingCookieName, artistSorting)])+  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/artists" maybeReferer) (mapFromList [(artistSortingCookieName, artistSorting)])   where     artistSorting = fromForm multipartData "created-at-desc" "artist-sorting"  setGenreSortingRoute :: (MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a setGenreSortingRoute env maybeReferer multipartData =-  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/genres" maybeReferer) (Map.fromList [(genreSortingCookieName, genreSorting)])+  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/genres" maybeReferer) (mapFromList [(genreSortingCookieName, genreSorting)])   where     genreSorting = fromForm multipartData "created-at-desc" "genre-sorting"  setSongSortingRoute :: (MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a setSongSortingRoute env maybeReferer multipartData =-  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/songs" maybeReferer) (Map.fromList [(songSortingCookieName, songSorting)])+  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/songs" maybeReferer) (mapFromList [(songSortingCookieName, songSorting)])   where     songSorting = fromForm multipartData "created-at-desc" "song-sorting"  setDarkModeRoute :: (MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a setDarkModeRoute env maybeReferer multipartData =-  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/songs" maybeReferer) (Map.fromList [(uiModeCookieName, mode)])+  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/songs" maybeReferer) (mapFromList [(uiModeCookieName, mode)])   where     mode = fromForm multipartData "dark" "dark-mode"  setSongAsciiSizeRoute :: (MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a setSongAsciiSizeRoute env maybeReferer multipartData =-  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/songs" maybeReferer) (Map.fromList [(songAsciiSizeCookieName, songAsciiSize)])+  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/songs" maybeReferer) (mapFromList [(songAsciiSizeCookieName, songAsciiSize)])   where     songAsciiSize = fromForm multipartData "medium" "song-ascii-size"  setPaletteRoute :: (MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a setPaletteRoute env maybeReferer multipartData =-  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/songs" maybeReferer) (Map.fromList [(paletteCookieName, palette')])+  setCookieRoute (env ^. #cfg % #cookie) (fromMaybe "/songs" maybeReferer) (mapFromList [(paletteCookieName, palette')])   where-    palette' = fromForm multipartData "mauve" "palette"+    palette' = fromForm multipartData "purple" "palette"

@@ -1,103 +1,87 @@ {-# LANGUAGE OverloadedLabels #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -module WikiMusic.SSR.Servant.SongRoutes-  ( songsRoute,-    songRoute,-    songCreateRoute,-    songCreateFormRoute,-    songLikeRoute,-    songDislikeRoute,-    songEditRoute,-  )-where+module WikiMusic.SSR.Servant.SongRoutes where -import Control.Monad.Error.Class-import Data.ByteString.Lazy qualified as BL-import Data.Text qualified as T-import Data.UUID (UUID)-import Free.AlaCarte-import Optics-import Relude+import Principium import Servant import Servant.Multipart-import Text.Blaze.Html as Html import WikiMusic.Interaction.Model.Song import WikiMusic.Model.Other+import WikiMusic.Model.Song import WikiMusic.SSR.Backend.Rest () import WikiMusic.SSR.Free.Backend import WikiMusic.SSR.Free.View-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env import WikiMusic.SSR.Servant.Utilities import WikiMusic.SSR.View.Html ()-import Data.Map qualified as Map-import Data.Maybe qualified  -songsRoute :: (MonadIO m) => Env -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Int -> m Html-songsRoute env cookie givenSortOrder limit offset = do-  maybeSongs <--    liftIO-      $ exec @Backend-        ( getSongs-            env-            (viewVars ^. #authToken)-            (maybe (Limit 50) Limit limit)-            (maybe (Offset 0) Offset offset)-            sortOrder-            (Include {value = "artworks,comments,opinions"})-        )-  eitherView-    env-    (viewVars ^. #uiMode)-    (viewVars ^. #locale)-    (viewVars ^. #palette)+songsRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> m Html+songsRoute env cookie givenSortOrder limit offset searchInput = do+  maybeSongs <- case searchInput of+    Nothing ->+      liftIO+        $ exec @Backend+          ( getSongs+              env+              (vv ^. #authToken)+              limit'+              offset'+              sortOrder+              (Include {value = "artworks,comments,opinions,artists"})+          )+    Just search ->+      liftIO+        $ exec @Backend+          ( searchSongs+              env+              (vv ^. #authToken)+              search+              limit'+              offset'+              sortOrder+              (Include {value = "artworks,comments,opinions,artists"})+          )+  respondWithViewOrErr     maybeSongs-    (exec @View . songListPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette) sortOrder)+    (exec @View . songListPage limit' offset' env vv)   where-    viewVars = viewVarsFromCookies cookie-    sortOrder = maybe (viewVars ^. #songSorting) SortOrder givenSortOrder+    vv = vvFromCookies cookie+    sortOrder = maybe (vv ^. #songSorting) SortOrder givenSortOrder+    limit' = maybe (Limit 50) Limit limit+    offset' = maybe (Offset 0) Offset offset -songRoute :: (MonadIO m) => Env -> Maybe Text -> UUID -> m Html+songRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> UUID -> m Html songRoute env cookie identifier = do   maybeSongs <-     liftIO       $ exec @Backend         ( getSong             env-            (viewVars ^. #authToken)+            (vv ^. #authToken)             identifier-            (Include {value = "artworks,comments,opinions,contents"})         )-  eitherView-    env-    (viewVars ^. #uiMode)-    (viewVars ^. #locale)-    (viewVars ^. #palette)+  respondWithViewOrErr     maybeSongs-    (exec @View . songDetailPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette) (viewVars ^. #songAsciiSize))+    (exec @View . songDetailPage env vv)   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie  songCreateRoute :: (MonadIO m) => Env -> Maybe Text -> m Html songCreateRoute env cookie = do-  liftIO $ exec @View (songCreatePage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette))+  liftIO $ exec @View (songCreatePage env vv)   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie  songCreateFormRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a songCreateFormRoute env cookie multipartData = do-  createResult <- liftIO $ exec @Backend (createSong env (viewVars ^. #authToken) r)-  _ <- liftIO $ BL.putStr (fromString . show $ createResult)-  throwError-    $ ServerError-      { errHTTPCode = 302,-        errReasonPhrase = "Found",-        errBody = "",-        errHeaders =-          [("Location", "/songs")]+  createResult <- liftIO $ exec @Backend (createSong env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Created song!",+        headers = [withLocation "/songs"]       }   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie     r =       InsertSongsRequest         { songs =@@ -119,18 +103,14 @@  songLikeRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> m a songLikeRoute env cookie maybeReferer identifier = do-  res <- liftIO $ exec @Backend (upsertSongOpinion env (viewVars ^. #authToken) r)-  _ <- liftIO $ BL.putStr (fromString . show $ res)-  throwError-    $ ServerError-      { errHTTPCode = 302,-        errReasonPhrase = "Found",-        errBody = "",-        errHeaders =-          [("Location", fromString . T.unpack $ fromMaybe "/songs" maybeReferer)]+  res <- liftIO $ exec @Backend (upsertSongOpinion env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Liked song!",+        headers = [withLocation (fromMaybe "/songs" maybeReferer)]       }   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie     r =       UpsertSongOpinionsRequest         { songOpinions =@@ -143,18 +123,14 @@  songDislikeRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> m a songDislikeRoute env cookie maybeReferer identifier = do-  res <- liftIO $ exec @Backend (upsertSongOpinion env (viewVars ^. #authToken) r)-  _ <- liftIO $ BL.putStr (fromString . show $ res)-  throwError-    $ ServerError-      { errHTTPCode = 302,-        errReasonPhrase = "Found",-        errBody = "",-        errHeaders =-          [("Location", fromString . T.unpack $ fromMaybe "/songs" maybeReferer)]+  _ <- liftIO $ exec @Backend (upsertSongOpinion env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Disliked song!",+        headers = [withLocation (fromMaybe "/songs" maybeReferer)]       }   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie     r =       UpsertSongOpinionsRequest         { songOpinions =@@ -165,24 +141,202 @@             ]         } -songEditRoute :: (MonadIO m) => Env -> Maybe Text -> UUID -> m Html+songEditRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> UUID -> m Html songEditRoute env cookie identifier = do   maybeSongs <-     liftIO       $ exec @Backend         ( getSong             env-            (viewVars ^. #authToken)+            (vv ^. #authToken)             identifier-            (Include {value = "artworks,comments,opinions"})         )-  let a = second (\x -> (head . Data.Maybe.fromJust . nonEmpty) $ Map.elems $ x ^. #songs) maybeSongs-  eitherView-    env-    (viewVars ^. #uiMode)-    (viewVars ^. #locale)-    (viewVars ^. #palette)+  let a = second (\x -> nonEmpty $ mapElems $ x ^. #songs) maybeSongs+  respondWithViewOrErr'     a-    (exec @View . songEditPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette))+    (exec @View . songEditPage env vv . head)   where-    viewVars = viewVarsFromCookies cookie+    vv = vvFromCookies cookie++songEditFormRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> MultipartData tag -> m a+songEditFormRoute env cookie maybeReferer identifier multipartData = do+  _ <- liftIO $ exec @Backend (editSong env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Edited song!",+        headers = [withLocation (maybe "/songs" (replaceText "/edit" "") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      SongDeltaRequest+        { songDeltas =+            [ SongDelta+                { identifier = identifier,+                  displayName = maybeFromForm multipartData "displayName",+                  spotifyUrl = maybeFromForm multipartData "spotifyUrl",+                  youtubeUrl = maybeFromForm multipartData "youtubeUrl",+                  soundcloudUrl = maybeFromForm multipartData "soundcloudUrl",+                  wikipediaUrl = maybeFromForm multipartData "wikipediaUrl",+                  description = maybeFromForm multipartData "description",+                  musicKey = maybeFromForm multipartData "musicKey",+                  musicTuning = maybeFromForm multipartData "musicTuning",+                  musicCreationDate = maybeFromForm multipartData "musicCreationDate",+                  albumName = maybeFromForm multipartData "albumName",+                  albumInfoLink = maybeFromForm multipartData "albumInfoLink"+                }+            ]+        }++searchSongRoute :: (MonadIO m, MonadError ServerError m) => Env -> MultipartData tag -> m a+searchSongRoute _ multipartData = do+  respondWithHttp+    httpFound+      { cause = Just "Go to search songs page",+        headers = [withLocation newRoute]+      }+  where+    searchQuery = fromForm multipartData "" "searchInput"+    newRoute = "/songs?searchInput=" <> searchQuery++createSongArtworkRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> MultipartData tag -> m a+createSongArtworkRoute env cookie maybeReferer identifier multipartData = do+  _ <- liftIO $ exec @Backend (createSongArtwork env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Created song artwork!",+        headers = [withLocation (maybe "/songs" (<> "#edit-artwork") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      InsertSongArtworksRequest+        { songArtworks =+            [ InsertSongArtworksRequestItem+                { songIdentifier = identifier,+                  orderValue = fromMaybe 0 $ readMaybe (unpackText . fromMaybe "0" $ maybeFromForm multipartData "orderValue"),+                  contentUrl = fromMaybe "" $ maybeFromForm multipartData "contentUrl",+                  contentCaption = maybeFromForm multipartData "contentCaption"+                }+            ]+        }++songDeleteRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> UUID -> m a+songDeleteRoute env cookie identifier = do+  _ <- liftIO $ exec @Backend (deleteSong env (vv ^. #authToken) identifier)+  respondWithHttp+    httpFound+      { cause = Just "Deleted song!",+        headers = [("Location", "/songs")]+      }+  where+    vv = vvFromCookies cookie++songArtworkDeleteRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> m a+songArtworkDeleteRoute env cookie maybeReferer identifier = do+  _ <- liftIO $ exec @Backend (deleteSongArtwork env (vv ^. #authToken) identifier)+  respondWithHttp+    httpFound+      { cause = Just "Deleted song artwork!",+        headers = [withLocation (maybe "/songs" (<> "#edit-artwork") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie++updateSongArtworkOrderRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> UUID -> MultipartData tag -> m a+updateSongArtworkOrderRoute env cookie maybeReferer identifier multipartData = do+  _ <- liftIO $ exec @Backend (updateSongArtworkOrder env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Updated song artwork!",+        headers = [withLocation (maybe "/songs" (<> "#edit-artwork") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      SongArtworkOrderUpdateRequest+        { songArtworkOrders =+            [ SongArtworkOrderUpdate+                { identifier = identifier,+                  orderValue =+                    fromMaybe 0+                      $ readMaybe (unpackText . fromMaybe "0" $ maybeFromForm multipartData "orderValue")+                }+            ]+        }++songContentCreateFormRoute ::+  (MonadIO m, MonadError ServerError m) =>+  Env ->+  Maybe Text ->+  Maybe Text ->+  UUID ->+  MultipartData tag ->+  m b+songContentCreateFormRoute env cookie maybeReferer identifier multipartData = do+  _ <- liftIO $ exec @Backend (createSongContents env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Edited song!",+        headers = [withLocation (maybe "/songs" (replaceText "/edit" "" . (<> "#edit-contents")) maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      InsertSongContentsRequest+        { songContents =+            [ InsertSongContentsRequestItem+                { songIdentifier = identifier,+                  versionName = fromMaybe "" $ maybeFromForm multipartData "versionName",+                  instrumentType = fromMaybe "" $ maybeFromForm multipartData "instrumentType",+                  asciiLegend = maybeFromForm multipartData "asciiLegend",+                  asciiContents = maybeFromForm multipartData "asciiContents",+                  pdfContents = maybeFromForm multipartData "pdfContents",+                  guitarProContents = maybeFromForm multipartData "guitarProContents"+                }+            ]+        }++songContentEditFormRoute ::+  (MonadIO m, MonadError ServerError m) =>+  Env ->+  Maybe Text ->+  Maybe Text ->+  p ->+  UUID ->+  MultipartData tag ->+  m b+songContentEditFormRoute env cookie maybeReferer _ songContentIdentifier multipartData = do+  _ <- liftIO $ exec @Backend (editSongContents env (vv ^. #authToken) r)+  respondWithHttp+    httpFound+      { cause = Just "Edited song!",+        headers = [withLocation (maybe "/songs" (replaceText "/edit" "") maybeReferer)]+      }+  where+    vv = vvFromCookies cookie+    r =+      SongContentDeltaRequest+        { songContentDeltas =+            [ SongContentDelta+                { identifier = songContentIdentifier,+                  versionName = fromMaybe "" $ maybeFromForm multipartData "versionName",+                  instrumentType = maybeFromForm multipartData "instrumentType",+                  asciiLegend = maybeFromForm multipartData "asciiLegend",+                  asciiContents = maybeFromForm multipartData "asciiContents",+                  pdfContents = maybeFromForm multipartData "pdfContents",+                  guitarProContents = maybeFromForm multipartData "guitarProContents"+                }+            ]+        }++songContentDeleteRoute :: (MonadIO m, MonadError ServerError m) => Env -> UUID -> Maybe Text -> Maybe Text -> m a+songContentDeleteRoute env identifier cookie maybeReferer = do+  _ <- liftIO $ exec @Backend (deleteSongContents env (vv ^. #authToken) identifier)+  respondWithHttp+    httpFound+      { cause = Just "Deleted song contents!",+        headers = [withLocation (fromMaybe "/songs" maybeReferer)]+      }+  where+    vv = vvFromCookies cookie

@@ -1,35 +1,20 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-} -module WikiMusic.SSR.Servant.Utilities-  ( fromForm,-    setCookieRoute,-    encodeToken,-    mkCookieData,-    mkCookieMap,-    decodeToken,-    eitherView,-    viewVarsFromCookies,-    maybeFromForm,-  )-where+module WikiMusic.SSR.Servant.Utilities where -import Control.Monad.Error.Class import Data.ByteString.Base16.Lazy qualified as B16 import Data.Map qualified as Map import Data.Text qualified as T-import Free.AlaCarte import NeatInterpolation-import Optics-import Relude+import Principium import Servant import Servant.Multipart-import Text.Blaze.Html+import Text.Blaze.Html.Renderer.Utf8 import WikiMusic.SSR.Backend.Rest () import WikiMusic.SSR.Free.View-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Config-import WikiMusic.SSR.Model.Env import WikiMusic.SSR.View.Html ()  fromForm :: MultipartData tag -> Text -> Text -> Text@@ -74,7 +59,10 @@     cookieHeaders = map mkCookieHeaders (Map.assocs cookieMap)  mkCookieData :: CookieConfig -> Text -> Text-mkCookieData cookieConfig dyn = [trimming|$dyn; HttpOnly; $sameSite; Domain=$domain; Path=/; Max-Age=$maxAge $secureSuffix |]+mkCookieData cookieConfig dyn =+  [trimming|+    $dyn; HttpOnly; $sameSite; Domain=$domain; Path=/; Max-Age=$maxAge $secureSuffix+  |]   where     maxAge = show $ cookieConfig ^. #maxAge     domain = cookieConfig ^. #domain@@ -89,35 +77,113 @@       cookieMap = Map.fromList $ mapMaybe (cookieParser . T.splitOn "=") diffCookies   cookieMap -eitherView :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> Either Text t -> (t -> IO Html) -> m Html-eitherView env mode language palette x eff = case x of-  Left e -> liftIO $ exec @View (errorPage env mode language palette e)-  Right r -> liftIO $ eff r- decodeToken :: Text -> Text decodeToken = decodeUtf8 . B16.decodeLenient . encodeUtf8  encodeToken :: Text -> Text encodeToken = decodeUtf8 . B16.encode . encodeUtf8 -viewVarsFromCookies :: Maybe Text -> ViewVars-viewVarsFromCookies cookie = ViewVars {..}+vvFromCookies :: Maybe Text -> ViewVars+vvFromCookies cookie = ViewVars {..}   where     cookieMap = mkCookieMap cookie-    locale = Language {value = fromMaybe "en" (cookieMap Map.!? localeCookieName)}-    uiMode = UiMode {value = fromMaybe "light" (cookieMap Map.!? uiModeCookieName)}-    authToken = AuthToken {value = decodeToken $ fromMaybe "" (cookieMap Map.!? authCookieName)}-    songAsciiSize = SongAsciiSize {value = fromMaybe "medium" (cookieMap Map.!? songAsciiSizeCookieName)}+    language = Language {value = fromMaybe "en" (cookieMap !? localeCookieName)}+    uiMode = UiMode {value = fromMaybe "light" (cookieMap !? uiModeCookieName)}+    authToken = AuthToken {value = decodeToken $ fromMaybe "" (cookieMap !? authCookieName)}+    songAsciiSize = SongAsciiSize {value = fromMaybe "sm" (cookieMap !? songAsciiSizeCookieName)}     artistSorting =       SortOrder-        { value = fromMaybe "created-at-desc" (cookieMap Map.!? artistSortingCookieName)+        { value = fromMaybe "created-at-desc" (cookieMap !? artistSortingCookieName)         }     songSorting =       SortOrder-        { value = fromMaybe "created-at-desc" (cookieMap Map.!? songSortingCookieName)+        { value = fromMaybe "created-at-desc" (cookieMap !? songSortingCookieName)         }     genreSorting =       SortOrder-        { value = fromMaybe "created-at-desc" (cookieMap Map.!? genreSortingCookieName)+        { value = fromMaybe "created-at-desc" (cookieMap !? genreSortingCookieName)         }-    palette = Palette {value = fromMaybe "mauve" (cookieMap Map.!? paletteCookieName)}+    palette = Palette {value = fromMaybe "purple" (cookieMap !? paletteCookieName)}++errorRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Text -> m Html+errorRoute env cookie _ maybeCode maybeMessage = do+  h <- liftIO $ exec @View (errorPage env vv maybeCode maybeMessage)+  throwError+    $ ServerError+      { errHTTPCode = fromMaybe 500 maybeCode,+        errReasonPhrase = "Error!",+        errBody = renderHtml h,+        errHeaders = []+      }+  where+    vv = vvFromCookies cookie++data ServerResponse = ServerResponse+  { code :: Int,+    cause :: Maybe Text,+    body :: Maybe Text,+    headers :: [(Text, Text)]+  }+  deriving (Eq, Show)++makeFieldLabelsNoPrefix ''ServerResponse++serverResponse :: ServerResponse+serverResponse =+  ServerResponse+    { code = 200,+      cause = Just "OK",+      body = Nothing,+      headers = []+    }++withLocation :: (IsString a, IsString b) => Text -> (a, b)+withLocation location = ("Location", fromString . T.unpack $ location)++respondWithHttp :: (MonadIO m, MonadError ServerError m) => ServerResponse -> m a+respondWithHttp sr =+  throwError+    $ ServerError+      { errHTTPCode = sr ^. #code,+        errReasonPhrase = T.unpack $ fromMaybe "" $ sr ^. #cause,+        errBody = encodeUtf8 $ fromMaybe "" $ sr ^. #body,+        errHeaders =+          map+            ( bimap+                (fromString . unpackText)+                (fromString . unpackText)+            )+            (sr ^. #headers)+      }++httpFound :: ServerResponse+httpFound = serverResponse {code = 302}++callErrorPage :: (MonadIO m, MonadError ServerError m) => Text -> m a+callErrorPage e = respondWithHttp httpFound {cause = Just "Error occured!", headers = [withLocation newLocation]}+  where+    newLocation =+      "/error?code="+        <> ( T.pack+               . show+               $ 500+           )+        <> "&message="+        <> ( decodeUtf8+               . B16.encode+               . fromString+               . T.unpack+               $ e+           )++respondWithViewOrErr :: (MonadIO m, MonadError ServerError m) => Either Text t -> (t -> IO a) -> m a+respondWithViewOrErr x eff = case x of+  Left e -> callErrorPage e+  Right r -> liftIO $ eff r++respondWithViewOrErr' :: (MonadIO m, MonadError ServerError m) => Either Text (Maybe t) -> (t -> IO a) -> m a+respondWithViewOrErr' x eff = case x of+  Left e -> callErrorPage e+  Right r -> case r of+    Nothing -> callErrorPage "Error!"+    Just item -> liftIO $ eff item

@@ -6,84 +6,72 @@   ( artistListPage',     artistDetailPage',     artistCreatePage',-    artistEditPage'+    artistEditPage',   ) where  import Data.Map qualified as Map-import Optics-import Relude-import Text.Blaze.Html-import Text.Blaze.Html5 as H+import Data.Text qualified as T+import Principium+import Text.Blaze.Html5 as H hiding (map) import Text.Blaze.Html5.Attributes as A import WikiMusic.Interaction.Model.Artist-import WikiMusic.SSR.Language-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env import WikiMusic.SSR.View.Components.Forms-import WikiMusic.SSR.View.Components.Meta import WikiMusic.SSR.View.Components.Other-import WikiMusic.SSR.View.Components.PageTop+import WikiMusic.SSR.View.HtmlUtil -artistListPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> SortOrder -> GetArtistsQueryResponse -> m Html-artistListPage' env mode language palette sortOrder xs = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #artistsPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop (Just $ (^. #titles % #artistsPage) |##| language) mode language palette-      section ! class_ "flex direction-row justify-content-center gap-small align-items-baseline" $ do+artistListPage' :: (MonadIO m) => Limit -> Offset -> Env -> ViewVars -> GetArtistsQueryResponse -> m Html+artistListPage' limit offset env vv xs =+  simplePage env vv (SimplePageTitle $ (^. #titles % #artistsPage) |##| (vv ^. #language)) $ do+    section ! css' ["flex", "flex-row", "flex-wrap", "gap-4", "justify-center", "align-center", "items-center"] $ do+      searchForm "/artists/search" $ do+        searchInput "searchInput"+        submitButtonNoText++      section $ do         H.a ! href "/artists/create" $ button $ H.small "+ new artist"-        mkSortingForm language sortOrder "/user-preferences/artist-sorting" "artist-sorting"-      section ! class_ "entity-card-section" $ mapM_ (simpleEntityCard language "artists") sortedXs+        mkSortingForm vv (vv ^. #artistSorting) "/user-preferences/artist-sorting" "artist-sorting"+    section ! css cssCenteredCardGrid $ mapM_ (simpleEntityCard vv "artists") sortedXs+    section ! css' ["flex", "flex-row", "flex-wrap", "gap-4", "justify-center", "align-center", "items-center", "my-6"] $ do+      maybePrevPaginationButton vv limit offset (length (xs ^. #artists))+      maybeNextPaginationButton vv limit offset (length (xs ^. #artists))   where     sortedXs =       mapMaybe-        (\identifier -> (xs ^. #artists) Map.!? identifier)+        (\identifier -> (xs ^. #artists) Principium.!? identifier)         (xs ^. #sortOrder) -artistDetailPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> Artist -> m Html-artistDetailPage' env mode language palette x = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #artistsPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop Nothing mode language palette-      entityDetails language "artists" x+artistDetailPage' :: (MonadIO m) => Env -> ViewVars -> Artist -> m Html+artistDetailPage' env vv x = do+  simplePage env vv (SimplePageTitle $ (^. #titles % #artistsPage) |##| (vv ^. #language)) $ do+    entityDetails vv "artists" x -artistCreatePage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> m Html-artistCreatePage' env mode language palette = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #artistsPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop Nothing mode language palette-      section $ do-        H.h2 "Create artist"-        postForm "/artists/create" $ do-          requiredTextInput "displayName" "artist name"-          optionalTextArea "description" "description"-          optionalTextInput "spotifyUrl" "spotify URL"-          optionalTextInput "youtubeUrl" "youtube URL"-          optionalTextInput "wikipediaUrl" "wikipedia URL"-          optionalTextInput "soundcloudUrl" "soundcloud URL"-          submitButton language+artistCreatePage' :: (MonadIO m) => Env -> ViewVars -> m Html+artistCreatePage' env vv = do+  simplePage env vv (SimplePageTitle "Create artist") $ do+    section ! css' ["container", "mx-auto"] $ do+      postForm "/artists/create" $ do+        requiredTextInput "displayName" "artist name"+        optionalTextArea "description" "description"+        optionalTextInput "spotifyUrl" "spotify URL"+        optionalTextInput "youtubeUrl" "youtube URL"+        optionalTextInput "wikipediaUrl" "wikipedia URL"+        optionalTextInput "soundcloudUrl" "soundcloud URL"+        submitButton vv -artistEditPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> Artist -> m Html-artistEditPage' env mode language palette artist = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #artistsPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop Nothing mode language palette-      section $ do-        H.h2 "Edit artist"-        postForm "/artists/edit" $ do-          requiredTextInput' "displayName" "artist name" (Just $ artist ^. #displayName)-          optionalTextArea' "description" "description" (artist ^. #description)-          optionalTextInput' "spotifyUrl" "spotify URL" (artist ^. #spotifyUrl)-          optionalTextInput' "youtubeUrl" "youtube URL" (artist ^. #youtubeUrl)-          optionalTextInput' "wikipediaUrl" "wikipedia URL" (artist ^. #wikipediaUrl)-          optionalTextInput' "soundcloudUrl" "soundcloud URL" (artist ^. #soundcloudUrl)-          -          submitButton language+artistEditPage' :: (MonadIO m) => Env -> ViewVars -> Artist -> m Html+artistEditPage' env vv artist = do+  simplePage env vv (SimplePageTitle "Edit artist") $ do+    section ! css' ["container", "mx-auto"] $ do+      postForm ("/artists/edit/" <> (T.pack . show $ artist ^. #identifier)) $ do+        requiredTextInput' "displayName" "artist name" (Just $ artist ^. #displayName)+        optionalTextArea' "description" "description" (artist ^. #description)+        optionalTextInput' "spotifyUrl" "spotify URL" (artist ^. #spotifyUrl)+        optionalTextInput' "youtubeUrl" "youtube URL" (artist ^. #youtubeUrl)+        optionalTextInput' "wikipediaUrl" "wikipedia URL" (artist ^. #wikipediaUrl)+        optionalTextInput' "soundcloudUrl" "soundcloud URL" (artist ^. #soundcloudUrl)+        submitButton vv++      entityArtworkForm vv "artists" (map (^. #artwork) . Map.elems $ artist ^. #artworks)+      hr+      entityNewArtworkForm vv "artists" (artist ^. #identifier)

@@ -1,22 +1,29 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedLabels #-} -module WikiMusic.SSR.View.Components.DetailList-  ( detailList,-    detailListEntry,-  )-where+module WikiMusic.SSR.View.Components.DetailList where -import Relude-import Text.Blaze.Html+import Principium import Text.Blaze.Html5 as H-import Text.Blaze.Html5.Attributes as A -detailListEntry :: Text -> Html -> Html-detailListEntry key val =-  H.div ! class_ "flex direction-row gap-small align-items-baseline" $ do-    dt . small . text $ key-    dd . small $ val+detailListEntry' :: ViewVars -> Bool -> Text -> Html -> Html+detailListEntry' vv isMono key val =+  H.div+    ! css'+      [ "flex",+        "flex-row",+        "gap-4",+        "w-fit",+        "font-mono"+      ]+    $ do+      (dt ! css' ["text-sm", "font-bold", if vv ^. #uiMode % #value == "dark" then "text-stone-300" else "text-stone-700"]) . text $ key+      dd ! css' ["text-sm", "break-all", if vv ^. #uiMode % #value == "dark" then "text-gray-300" else "text-gray-700", if isMono then "font-mono" else "font-mono"] $ val +detailListEntry :: ViewVars -> Text -> Html -> Html+detailListEntry vv = detailListEntry' vv False++monoDetailListEntry :: ViewVars -> Text -> Html -> Html+monoDetailListEntry vv = detailListEntry' vv True+ detailList :: Html -> Html-detailList = dl ! class_ "margin-top-medium flex direction-column gap-small align-items-baseline"+detailList = dl ! css' ["flex", "flex-col", "gap-2", "justify-start"]

@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedLabels #-}++module WikiMusic.SSR.View.Components.Footer+  ( simpleFooter,+    bodyWithFooter,+  )+where++import Principium+import Text.Blaze.Html5 as H+import Text.Blaze.Html5.Attributes as A++simpleFooter :: ViewVars -> Html+simpleFooter vv = H.footer ! css' ["flex", "flex-col", "justify-center", "gap-4", "align-center", "text-center", "py-6", "font-mono"] $ do+  (small ! css' ["italic", if vv ^. #uiMode % #value == "dark" then "text-gray-400" else "text-gray-700"]) . text $ ((^. #more % #copyright0) |##| (vv ^. #language))+  a+    ! css (cssLink vv)+    ! href "https://github.com/jjba23/wikimusic-ssr"+    $ small+    . text+    $ ((^. #more % #copyright1) |##| (vv ^. #language))+  (small ! css' [if vv ^. #uiMode % #value == "dark" then "text-gray-400" else "text-gray-700"]) . text $ ((^. #more % #copyright2) |##| (vv ^. #language))++bodyWithFooter :: ViewVars -> Html -> Html+bodyWithFooter vv x = do+  body ! css' ["bg-gradient-to-br", "from-" <> vv ^. #palette % #value <> "-200", "to-" <> vv ^. #palette % #value <> "-300"] $ do+    H.div ! css' [if vv ^. #uiMode % #value == "dark" then "bg-black/90" else "bg-white/80", "h-auto"] $ do+      _ <- x+      hr+      simpleFooter vv

@@ -1,127 +1,224 @@ {-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} -module WikiMusic.SSR.View.Components.Forms-  ( mkSortingForm,-    requiredTextInput,-    formInput,-    optionalTextInput,-    requiredEmailInput,-    requiredPasswordInput,-    submitButton,-    postForm,-    postForm',-    formArea,-    optionalTextArea,-    requiredTextArea,-    requiredTextInput',-    optionalTextInput',-    requiredTextArea',-    optionalTextArea',-  )-where+module WikiMusic.SSR.View.Components.Forms where -import Data.Text qualified as T-import Optics-import Relude-import Text.Blaze.Html-import Text.Blaze.Html5 as H+import Principium+import Text.Blaze.Html5 as H hiding (map) import Text.Blaze.Html5.Attributes as A-import WikiMusic.SSR.Language-import WikiMusic.SSR.Model.Api+import WikiMusic.Model.Artwork+import WikiMusic.SSR.View.Components.Icons -mkSortingForm :: Language -> SortOrder -> Text -> Text -> Html-mkSortingForm language sortOrder action' fieldName = section+mkSortingForm :: ViewVars -> SortOrder -> Text -> Text -> Html+mkSortingForm vv sortOrder action' fieldName = section   $ H.form-  ! action (fromString . T.unpack $ action')+  ! action (textToAttrValue action')   ! method "POST"   ! enctype "multipart/form-data"   $ do-    select ! onchange "this.form.submit()" ! name (fromString . T.unpack $ fieldName) $ mapM_ mkOption entries+    select ! css (cssSelect vv) ! onchange "this.form.submit()" ! name (textToAttrValue fieldName) $ mapM_ mkOption entries     noscript $ button ! type_ "submit" $ "submit"   where     mkOption :: (Text, Text) -> Html     mkOption o =       option-        !? (fst o == sortOrder ^. #value, selected "true")-        ! value (fromString . T.unpack $ fst o)+        H.!? (fst o == sortOrder ^. #value, selected "true")+        ! value (textToAttrValue $ fst o)         $ text ("↕  " <> snd o)     entries =-      [ ("display-name-asc", (^. #sortings % #alphabeticalAsc) |##| language),-        ("display-name-desc", (^. #sortings % #alphabeticalDesc) |##| language),-        ("created-at-asc", (^. #sortings % #createdAtAsc) |##| language),-        ("created-at-desc", (^. #sortings % #createdAtDesc) |##| language)+      [ ("display-name-asc", (^. #sortings % #alphabeticalAsc) |##| (vv ^. #language)),+        ("display-name-desc", (^. #sortings % #alphabeticalDesc) |##| (vv ^. #language)),+        ("created-at-asc", (^. #sortings % #createdAtAsc) |##| (vv ^. #language)),+        ("created-at-desc", (^. #sortings % #createdAtDesc) |##| (vv ^. #language)),+        ("last-edited-at-desc", (^. #sortings % #lastEditedAtDesc) |##| (vv ^. #language)),+        ("last-edited-at-asc", (^. #sortings % #lastEditedAtAsc) |##| (vv ^. #language))       ]  requiredTextInput :: Text -> Text -> Html-requiredTextInput name' displayLabel = formInput name' displayLabel True "text" Nothing+requiredTextInput name' displayLabel = formInput name' (Just displayLabel) True "text" Nothing +searchInput :: Text -> Html+searchInput name' = formInput name' Nothing True "text" Nothing+ requiredTextInput' :: Text -> Text -> Maybe Text -> Html-requiredTextInput' name' displayLabel = formInput name' displayLabel True "text"+requiredTextInput' name' displayLabel = formInput name' (Just displayLabel) True "text"  requiredTextArea :: Text -> Text -> Html-requiredTextArea name' displayLabel = formArea name' displayLabel True "text" Nothing+requiredTextArea name' displayLabel = formArea name' (Just displayLabel) True False "text" Nothing  requiredTextArea' :: Text -> Text -> Maybe Text -> Html-requiredTextArea' name' displayLabel = formArea name' displayLabel True "text"+requiredTextArea' name' displayLabel = formArea name' (Just displayLabel) True False "text" +requiredMonoArea :: Text -> Text -> Html+requiredMonoArea name' displayLabel = formArea name' (Just displayLabel) True True "text" Nothing++requiredMonoArea' :: Text -> Text -> Maybe Text -> Html+requiredMonoArea' name' displayLabel = formArea name' (Just displayLabel) True True "text"+ optionalTextInput :: Text -> Text -> Html-optionalTextInput name' displayLabel = formInput name' displayLabel False "text" Nothing+optionalTextInput name' displayLabel = formInput name' (Just displayLabel) False "text" Nothing  optionalTextInput' :: Text -> Text -> Maybe Text -> Html-optionalTextInput' name' displayLabel = formInput name' displayLabel False "text"+optionalTextInput' name' displayLabel = formInput name' (Just displayLabel) False "text"  optionalTextArea :: Text -> Text -> Html-optionalTextArea name' displayLabel = formArea name' displayLabel False "text" Nothing+optionalTextArea name' displayLabel = formArea name' (Just displayLabel) False False "text" Nothing  optionalTextArea' :: Text -> Text -> Maybe Text -> Html-optionalTextArea' name' displayLabel = formArea name' displayLabel False "text"+optionalTextArea' name' displayLabel = formArea name' (Just displayLabel) False False "text" +optionalMonoArea :: Text -> Text -> Html+optionalMonoArea name' displayLabel = formArea name' (Just displayLabel) False True "text" Nothing++optionalMonoArea' :: Text -> Text -> Maybe Text -> Html+optionalMonoArea' name' displayLabel = formArea name' (Just displayLabel) False True "text"+ requiredEmailInput :: Text -> Text -> Html-requiredEmailInput name' displayLabel = formInput name' displayLabel True "email" Nothing+requiredEmailInput name' displayLabel = formInput name' (Just displayLabel) True "email" Nothing  requiredPasswordInput :: Text -> Text -> Html-requiredPasswordInput name' displayLabel = formInput name' displayLabel True "password" Nothing+requiredPasswordInput name' displayLabel = formInput name' (Just displayLabel) True "password" Nothing -formInput :: Text -> Text -> Bool -> AttributeValue -> Maybe Text -> Html-formInput name' displayLabel isRequired type' content' = do-  H.div ! class_ "flex direction-column gap-medium margin-top-small" $ do-    H.div $ do-      H.label ! A.for name'' $ fromString . T.unpack $ displayLabel-      mapM_ (H.span ! class_ "color-error") (if isRequired then Just "*" else Nothing)-    H.input ! class_ "" !? (isRequired, required "") ! A.name name'' ! A.id name'' ! type_ type' ! A.value (fromString . T.unpack $ fromMaybe "" content')+optionalFileInput :: Text -> Text -> Html+optionalFileInput name' displayLabel =+  H.div $ do+    H.div $ H.label ! A.for name'' $ text displayLabel+    H.input+      ! class_ "rounded-2xl px-10 py-6 font-mono"+      ! A.name name''+      ! A.id name''+      ! type_ "file"   where-    name'' = fromString . T.unpack $ name'+    name'' = textToAttrValue name' -formArea :: Text -> Text -> Bool -> AttributeValue -> Maybe Text -> Html-formArea name' displayLabel isRequired type' content' = do-  H.div ! class_ "flex direction-column gap-medium margin-top-small" $ do+formInput :: Text -> Maybe Text -> Bool -> AttributeValue -> Maybe Text -> Html+formInput name' displayLabel isRequired type' content' = H.div $ do+  H.div $ do+    mapM_ ((H.label ! A.for name'') . text) displayLabel+    mapM_ (\_ -> mapM_ (H.span ! css' ["font-bold"]) (if isRequired then Just "*" else Nothing)) displayLabel+  H.input ! css cssInput H.!? (isRequired, required "") ! A.name name'' ! A.id name'' ! type_ type' ! A.value (textToAttrValue $ fromMaybe "" content')+  where+    name'' = textToAttrValue name'++formArea :: Text -> Maybe Text -> Bool -> Bool -> AttributeValue -> Maybe Text -> Html+formArea name' displayLabel isRequired isMono type' content' = do+  let optionalMonoCss = fromList [if isMono then "font-mono" else "font-mono"] :: Set Text++  H.div $ do     H.div $ do-      H.label ! A.for name'' $ fromString . T.unpack $ displayLabel+      mapM_ ((H.label ! A.for name'') . text) displayLabel       mapM_ (H.span ! class_ "color-error") (if isRequired then Just "*" else Nothing)-    H.textarea ! class_ "" !? (isRequired, required "") ! A.name name'' ! A.id name'' ! type_ type' $ (fromString . T.unpack $ fromMaybe "" content')+    H.textarea+      ! css (cssTextarea `setUnion` optionalMonoCss)+      H.!? (isRequired, required "")+      ! A.name name''+      ! A.id name''+      ! type_ type'+      $ text (fromMaybe "" content')   where-    name'' = fromString . T.unpack $ name'+    name'' = textToAttrValue name' -submitButton :: Language -> Html-submitButton language =-  button ! A.class_ "background-success border-success align-self-flex-end" ! type_ "submit" $ do+deleteButton :: ViewVars -> Html+deleteButton vv =+  button ! css (cssButton vv) ! type_ "submit" $ text $ (^. #forms % #delete) |##| (vv ^. #language)++submitButton :: ViewVars -> Html+submitButton vv =+  button ! css cssSubmitButton ! type_ "submit" $ do     H.span "✓"-    text $ (^. #forms % #submit) |##| language+    text $ (^. #forms % #submit) |##| (vv ^. #language) +submitButton' :: ViewVars -> Html+submitButton' vv =+  button ! css cssSubmitButton ! type_ "submit" $ do+    H.span "✓"+    text $ (^. #forms % #submit) |##| (vv ^. #language)++submitButtonNoText :: Html+submitButtonNoText =+  button ! css' ["transparent", "text-3xl", "px-4"] ! type_ "submit" $ H.span "🔍"++dangerPostForm :: ViewVars -> Text -> Html -> Html+dangerPostForm vv action' =+  H.form+    ! method "POST"+    ! action (textToAttrValue action')+    ! enctype "multipart/form-data"+    ! onsubmit (textToAttrValue $ "alert('" <> ((^. #more % #irreversibleAction) |##| (vv ^. #language)) <> "')")+ postForm :: Text -> Html -> Html postForm action' =   H.form-    ! class_ "margin-top-large flex direction-column align-items-flex-start"     ! method "POST"-    ! action (fromString . T.unpack $ action')+    ! action (textToAttrValue action')     ! enctype "multipart/form-data" -postForm' :: Text -> Text -> Html -> Html+postForm' :: Text -> [Text] -> Html -> Html postForm' action' class' =   H.form-    ! class_ (fromString . T.unpack $ class')+    ! css' class'     ! method "POST"-    ! action (fromString . T.unpack $ action')+    ! action (textToAttrValue action')     ! enctype "multipart/form-data"++searchForm :: Text -> Html -> Html+searchForm action' =+  H.form+    ! class_ (textToAttrValue "margin-top-medium flex direction-row align-items-flex-end no-gap")+    ! method "POST"+    ! action (textToAttrValue action')+    ! enctype "multipart/form-data"++entityArtworkForm :: ViewVars -> Text -> [Artwork] -> Html+entityArtworkForm vv path xs = section $ do+  unless (null xs) (hr >> (H.h2 ! A.id "edit-artwork" $ "Edit artwork"))+  H.div $ do+    let arts = sortBy (\x y -> compare (x ^. #orderValue) (y ^. #orderValue)) xs+    mapM_ (mkArtworkManager vv path) arts++mkArtworkManager :: ViewVars -> Text -> Artwork -> Html+mkArtworkManager vv path artwork = H.div ! css' ["flex", "flex-col", "flex-wrap", "justify-center", "w-64"] $ do+  img+    ! css' ["object-cover", "w-64", "h-auto", "rounded-2xl"]+    ! customAttribute "loading" "lazy"+    ! src (textToAttrValue $ artwork ^. #contentUrl)+  mapM_ (H.span . text) (artwork ^. #contentCaption)+  H.div ! css' ["flex", "flex-row", "flex-wrap", "justify-center", "gap-4"] $ do+    postForm ("/" <> path <> "/artworks/order/" <> uuidToText (artwork ^. #identifier)) $ do+      input ! type_ "hidden" ! name "orderValue" ! A.value (textToAttrValue plusOne)+      button ! css (cssButton vv) ! type_ "submit" $ small . text $ plusOne+    postForm ("/" <> path <> "/artworks/order/" <> uuidToText (artwork ^. #identifier)) $ do+      input+        ! type_ "hidden"+        ! name "orderValue"+        ! A.value+          (textToAttrValue minusOne)+      button ! css (cssButton vv) ! type_ "submit" $ small . text $ minusOne+  H.div+    ! css' []+    $ dangerPostForm+      vv+      ( "/"+          <> path+          <> "/artworks/delete/"+          <> uuidToText (artwork ^. #identifier)+      )+    $ button+    ! css cssSubmitButton+    ! type_ "submit"+    $ small+    $ simpleIcon "❌" "delete"+  where+    plusOne = intToText $ artwork ^. #orderValue + 1+    minusOne =+      if artwork ^. #orderValue < 1+        then "0"+        else intToText $ artwork ^. #orderValue - 1++entityNewArtworkForm :: ViewVars -> Text -> UUID -> Html+entityNewArtworkForm vv path identifier = do+  H.h2 "New artwork"+  postForm ("/" <> path <> "/artworks/create/" <> uuidToText identifier) $ do+    requiredTextInput "contentUrl" "url"+    optionalTextInput "contentCaption" "caption"+    requiredTextInput' "orderValue" "position" (Just "0")+    submitButton vv

@@ -0,0 +1,15 @@+module WikiMusic.SSR.View.Components.Icons+  ( simpleIcon,+  )+where++import Relude+import Text.Blaze.Html+import Text.Blaze.Html5 as H+import Text.Blaze.Html5.Attributes as A++simpleIcon :: Text -> Text -> Html+simpleIcon x txt =+  H.span $ do+    H.span $ text x+    H.span $ text txt

@@ -1,37 +0,0 @@-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module WikiMusic.SSR.View.Components.Meta-  ( mkSharedHead,-  )-where--import Data.Text qualified as T-import Optics-import Relude-import Text.Blaze.Html-import Text.Blaze.Html5 as H-import Text.Blaze.Html5.Attributes as A-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env--mkSharedHead :: (MonadIO m) => Env -> UiMode -> Palette -> Text -> m Html-mkSharedHead env mode palette pageTitle = do-  let style' = fromString . T.unpack $ (env ^. #mainCss)-  let modeStyle =-        if (mode ^. #value) == "dark"-          then env ^. #darkCss-          else env ^. #lightCss-  let paletteStyle = case palette ^. #value of-        "green" -> env ^. #palettes % #green-        _ -> env ^. #palettes % #mauve--  pure $ H.head $ do-    H.meta ! charset "utf-8"-    H.meta ! lang "en"-    H.title . fromString . T.unpack $ pageTitle-    meta ! name "viewport" ! content "width=device-width, initial-scale=1"-    H.style $ fromString . T.unpack $ modeStyle-    H.style $ fromString . T.unpack $ paletteStyle-    H.style style'

@@ -8,239 +8,187 @@     simpleEntityCard,     imageCarousel,     warningBanner,-    simpleIcon,     entityDetails,   ) where -import Data.Map qualified as Map-import Data.Text qualified as T-import Data.UUID (UUID)-import Optics-import Relude-import Text.Blaze.Html-import Text.Blaze.Html5 as H+import Principium+import Text.Blaze.Html5 as H hiding (head, map) import Text.Blaze.Html5.Attributes as A import WikiMusic.Model.Artwork-import WikiMusic.SSR.Language-import WikiMusic.SSR.Model.Api import WikiMusic.SSR.View.Components.DetailList import WikiMusic.SSR.View.Components.Forms -likeCount ::-  ( Is k1 A_Getter,-    Is k2 A_Getter,-    JoinKinds k3 l k2,-    LabelOptic "isLike" l u v Bool Bool,-    LabelOptic "opinions" k1 s1 s1 (Map k4 s2) (Map k4 s2),-    LabelOptic "opinion" k3 s2 s2 u v-  ) =>-  s1 ->-  Text likeCount entity =-  T.pack+  packText     . show     . length-    $ Map.elems-    $ Map.filter (^. #opinion % #isLike) (entity ^. #opinions)+    $ mapElems+    $ mapFilter (^. #opinion % #isLike) (entity ^. #opinions) -dislikeCount ::-  ( Is k1 A_Getter,-    Is k2 A_Getter,-    JoinKinds k3 l k2,-    LabelOptic "opinions" k1 s1 s1 (Map k4 s2) (Map k4 s2),-    LabelOptic "opinion" k3 s2 s2 u v,-    LabelOptic "isDislike" l u v Bool Bool-  ) =>-  s1 ->-  Text dislikeCount entity =-  T.pack+  packText     . show     . length-    $ Map.elems-    $ Map.filter (^. #opinion % #isDislike) (entity ^. #opinions)+    $ mapElems+    $ mapFilter (^. #opinion % #isDislike) (entity ^. #opinions)  mkIdentifierHref :: Text -> UUID -> AttributeValue-mkIdentifierHref path identifier = fromString ("/" <> T.unpack path <> "/" <> show identifier)+mkIdentifierHref path identifier = fromString ("/" <> unpackText path <> "/" <> show identifier) -simpleEntityCard ::-  ( Is k1 A_Getter,-    Is k3 A_Getter,-    Is k4 A_Getter,-    Is k5 A_Getter,-    Is k6 A_Getter,-    Is k7 A_Getter,-    Is k8 A_Getter,-    Is k9 A_Getter,-    Show a,-    JoinKinds k10 l1 k4,-    JoinKinds k10 l2 k3,-    LabelOptic "displayName" k8 s1 s1 Text Text,-    LabelOptic "isLike" l1 u v Bool Bool,-    LabelOptic "artworks" k5 s1 s1 (Map k11 s2) (Map k11 s2),-    LabelOptic "identifier" k7 s1 s1 UUID UUID,-    LabelOptic "opinions" k9 s1 s1 (Map k12 s3) (Map k12 s3),-    LabelOptic "viewCount" k1 s1 s1 a a,-    LabelOptic "artwork" k6 s2 s2 Artwork Artwork,-    LabelOptic "opinion" k10 s3 s3 u v,-    LabelOptic "isDislike" l2 u v Bool Bool-  ) =>-  Language ->-  Text ->-  s1 ->-  Html-simpleEntityCard language path entity = article ! class_ "simple-entity-card" $ do-  maybeImg-  a-    ! href (mkIdentifierHref path (entity ^. #identifier))-    ! class_ "margin-top-large"-    $ h3-    . text-    $ entity-    ^. #displayName-  detailList $ do-    detailListEntry ((^. #more % #likes) |##| language) (text $ likeCount entity)-    detailListEntry ((^. #more % #dislikes) |##| language) (text $ dislikeCount entity)-    detailListEntry ((^. #more % #views) |##| language) (text $ T.pack . show $ entity ^. #viewCount)+-- use dark: in tailwind to use system dark / light mode, or use vv to read from cookie+simpleEntityCard vv path entity = article+  ! css'+    [ "bg-slate-100",+      "rounded-2xl",+      "flex",+      "flex-wrap",+      "gap-4",+      "flex-row",+      "md:flex-col",+      "max-w-56",+      "border",+      if vv ^. #uiMode % #value == "dark" then "dark:bg-black/70" else "bg-white/80",+      "border-" <> vv ^. #palette % #value <> "-300/50"+    ]+  $ do+    maybeImg+    H.div ! css' ["px-4", "py-4", "flex", "flex-col", "gap-4", "align-center"] $ do+      a+        ! href (mkIdentifierHref path (entity ^. #identifier))+        $ (h3 ! css' ["text-xl", "font-bold", "break-words", "text-center", if vv ^. #uiMode % #value == "dark" then "text-white" else "text-black"])+        . text+        $ entity+        ^. #displayName+      detailList $ do+        detailListEntry vv ((^. #more % #likes) |##| (vv ^. #language)) (text $ likeCount entity)+        detailListEntry vv ((^. #more % #dislikes) |##| (vv ^. #language)) (text $ dislikeCount entity)+        detailListEntry vv ((^. #more % #views) |##| (vv ^. #language)) (text . packText . show $ entity ^. #viewCount)   where-    artworks = Relude.map (\x -> x ^. #artwork) (Map.elems $ entity ^. #artworks) :: [Artwork]-    maybeImg = maybe (H.span "") (toImg . Relude.head) (nonEmpty artworks)+    artworks = map (\x -> x ^. #artwork) (mapElems $ entity ^. #artworks) :: [Artwork]+    sortedArts = sortBy (\x y -> compare (x ^. #orderValue) (y ^. #orderValue)) artworks+    maybeImg = maybe (H.span "") (toImg . head) (nonEmpty sortedArts)     toImg x =       a         ! href (mkIdentifierHref path (entity ^. #identifier))         $ img+        ! css' ["object-cover", "w-60", "h-60", "rounded-2xl"]         ! customAttribute "loading" "lazy"-        ! src (fromString . T.unpack $ x ^. #contentUrl)+        ! src (fromString . unpackText $ x ^. #contentUrl)  imageCarousel :: [Artwork] -> Html imageCarousel artworks =-  section ! class_ "slider" $ do+  section ! class_ "flex flex-wrap flex-col gap-6" $ do     mapM_       ( \x ->-          img-            ! customAttribute "loading" "lazy"-            ! src (fromString . T.unpack $ x ^. #contentUrl)+          H.div $ do+            img+              ! css' ["object-cover", "w-72", "h-72", "rounded-2xl"]+              ! customAttribute "loading" "lazy"+              ! src (fromString . unpackText $ x ^. #contentUrl)+            mapM_ (H.span . text) (x ^. #contentCaption)       )       artworks  entityDetailsSkeleton :: Html -> Html -> Html entityDetailsSkeleton slot0 slot1 =-  H.div ! class_ "flex direction-row justify-content-space-evenly" $ do-    H.div ! class_ "col" $ do+  H.div ! css' ["flex", "flex-row", "flex-wrap", "container", "mx-auto"] $ do+    H.div ! css' ["flex", "flex-col", "flex-wrap", "w-full", "md:w-1/2"] $ do       slot0-    H.div ! class_ "col" $ do+    H.div ! css' ["flex", "flex-col", "flex-wrap", "w-full", "md:w-1/2", "my-4"] $ do       slot1 -entityDetails ::-  ( Is k1 A_Getter,-    Is k2 A_Getter,-    Is k3 A_Getter,-    Is k4 A_Getter,-    Is k5 A_Getter,-    Is k6 A_Getter,-    Is k7 A_Getter,-    Is k8 A_Getter,-    Is k9 A_Getter,-    Is k10 A_Getter,-    Is k11 A_Getter,-    Is k12 A_Getter,-    Is k13 A_Getter,-    Foldable t1,-    Foldable t2,-    Foldable t3,-    Foldable t4,-    Foldable t5,-    Foldable t6,-    Show a1,-    Show a2,-    Show a3,-    Show a4,-    Show a5,-    Functor t4,-    LabelOptic "createdAt" k4 s s a2 a2,-    LabelOptic "createdBy" k3 s s a1 a1,-    LabelOptic "lastEditedAt" k11 s s (t4 a5) (t4 a5),-    LabelOptic "displayName" k5 s s Text Text,-    LabelOptic "artworks" k6 s s (Map k14 a6) (Map k14 a6),-    LabelOptic "identifier" k9 s s a3 a3,-    LabelOptic "viewCount" k10 s s a4 a4,-    LabelOptic "artwork" k7 a6 a6 Artwork Artwork,-    LabelOptic "description" k8 s s (t3 Text) (t3 Text),-    LabelOptic "soundcloudUrl" k1 s s (t1 Text) (t1 Text),-    LabelOptic "spotifyUrl" k12 s s (t5 Text) (t5 Text),-    LabelOptic "wikipediaUrl" k2 s s (t2 Text) (t2 Text),-    LabelOptic "youtubeUrl" k13 s s (t6 Text) (t6 Text)-  ) =>-  Language ->-  Text ->-  s ->-  Html-entityDetails language path x =-  entityDetailsSkeleton slot0 slot1+hiddenUriLink' vv txt uri = a ! target "_blank" ! css (cssLink vv) ! href (fromString . unpackText $ uri) $ text ("🔗 " <> txt)++entityLinks vv x = do+  mapM_+    (hiddenUriLink' vv "Spotify")+    (x ^. #spotifyUrl)+  mapM_+    (hiddenUriLink' vv "Wikipedia")+    (x ^. #wikipediaUrl)+  mapM_+    (hiddenUriLink' vv "YouTube")+    (x ^. #youtubeUrl)+  mapM_+    (hiddenUriLink' vv "SoundCloud")+    (x ^. #soundcloudUrl)++slot0 vv x = do+  H.div ! css' ["flex", "flex-col", "flex-wrap", "justify-center", "align-center", "gap-4"] $ do+    imageCarousel (map (^. #artwork) (mapElems $ x ^. #artworks))+    mapM_ ((p ! css' ["white-space-break-spaces", if vv ^. #uiMode % #value == "dark" then "text-white" else "text-black"]) . text) (x ^. #description)++slot1 vv path x = section+  ! css'+    [ "flex",+      "flex-col",+      "flex-wrap",+      "items-center",+      "gap-8"+    ]+  $ do+    ( h3+        ! css'+          [ "text-3xl",+            "text-black",+            "font-bold",+            if vv ^. #uiMode % #value == "dark" then "text-white" else "text-black"+          ]+      )+      . fromString+      . unpackText+      $ (x ^. #displayName)+    H.div ! css' ["flex", "flex-row", "flex-wrap", "justify-center", "gap-4"] $ do+      likesDislikes vv path' x+      entityButtons vv path' x++      section+        ! css' ["flex", "flex-row", "flex-wrap", "justify-center", "gap-4"]+        $ detailList+        $ do+          entityBaseDetails vv x+      hr+    H.div ! css' ["flex", "flex-row", "flex-wrap", "justify-center", "gap-6"] $ entityLinks vv x   where-    verboseLink' uri = a ! href (fromString . T.unpack $ uri) $ text uri-    path' = T.unpack path-    entityLinks = do-      mapM_-        (detailListEntry "Spotify" . verboseLink')-        (x ^. #spotifyUrl)-      mapM_-        (detailListEntry "Wikipedia" . verboseLink')-        (x ^. #wikipediaUrl)-      mapM_-        (detailListEntry "YouTube" . verboseLink')-        (x ^. #youtubeUrl)-      mapM_-        (detailListEntry "SoundCloud" . verboseLink')-        (x ^. #soundcloudUrl)-    slot0 = do-      imageCarousel (Relude.map (^. #artwork) (Map.elems $ x ^. #artworks))-      H.div ! class_ "flex direction-row" $ do-        a-          ! href (fromString ("/" <> path' <> "/edit/" <> show (x ^. #identifier)))-          $ button-          $ text ((^. #buttons % #edit) |##| language)-        a-          ! href (fromString ("/" <> path' <> "/delete/" <> show (x ^. #identifier)))-          $ button-          $ text ((^. #buttons % #delete) |##| language)-      mapM_ (p . text) (x ^. #description)+    path' = unpackText path -    slot1 = do-      (h3 ! class_ "text-align-center font-size-xxx-large font-weight-500") . fromString . T.unpack $ (x ^. #displayName)-      H.div ! class_ "flex direction-column" $ do-        section ! class_ "flex direction-row justify-content-center gap-small align-items-baseline" $ do-          postForm' (fromString ("/" <> path' <> "/like/" <> show (x ^. #identifier))) "" $ do-            button ! type_ "submit" $ do-              H.span "+"-              text ((^. #buttons % #like) |##| language)-          postForm' (fromString ("/" <> path' <> "/dislike/" <> show (x ^. #identifier))) "" $ do-            button ! type_ "submit" $ do-              H.span "-"-              text ((^. #buttons % #dislike) |##| language)+entityDetails vv path x = do+  entityDetailsSkeleton (slot0 vv x) (slot1 vv path x) -        section $ detailList $ do-          detailListEntry ((^. #more % #views) |##| language) (Relude.show $ x ^. #viewCount)-          detailListEntry ((^. #more % #createdAt) |##| language) (Relude.show $ x ^. #createdAt)-          mapM_-            (detailListEntry ((^. #more % #lastEditedAt) |##| language))-            (Relude.show <$> x ^. #lastEditedAt)-          detailListEntry ((^. #more % #createdBy) |##| language) (Relude.show $ x ^. #createdBy)+likesDislikes vv path' x = do+  postForm (fromString ("/" <> path' <> "/like/" <> show (x ^. #identifier))) $ do+    button ! css (cssButton vv) ! type_ "submit" $ do+      H.span "+"+      text ((^. #buttons % #like) |##| (vv ^. #language))+  postForm (fromString ("/" <> path' <> "/dislike/" <> show (x ^. #identifier))) $ do+    button ! css (cssButton vv) ! type_ "submit" $ do+      H.span "-"+      text ((^. #buttons % #dislike) |##| (vv ^. #language)) -          hr-          entityLinks+entityBaseDetails vv x = do+  detailListEntry vv ((^. #more % #likes) |##| (vv ^. #language)) (text $ likeCount x)+  detailListEntry vv ((^. #more % #dislikes) |##| (vv ^. #language)) (text $ dislikeCount x)+  detailListEntry vv ((^. #more % #views) |##| (vv ^. #language)) (show $ x ^. #viewCount)+  detailListEntry vv ((^. #more % #createdAt) |##| (vv ^. #language)) (show $ x ^. #createdAt)+  mapM_+    (detailListEntry vv ((^. #more % #lastEditedAt) |##| (vv ^. #language)))+    (show <$> x ^. #lastEditedAt)+  detailListEntry vv ((^. #more % #createdBy) |##| (vv ^. #language)) (show $ x ^. #createdBy) -warningBanner :: Language -> Html-warningBanner language =-  section ! class_ "warning-section text-align-center" $ do+entityButtons vv path' x = do+  a+    ! href (fromString ("/" <> path' <> "/edit/" <> show (x ^. #identifier)))+    $ button+    ! css (cssButton vv)+    $ text ((^. #buttons % #edit) |##| (vv ^. #language))+  dangerPostForm vv (fromString ("/" <> path' <> "/delete/" <> show (x ^. #identifier))) $ do+    deleteButton vv++warningBanner :: ViewVars -> Html+warningBanner vv =+  section $ do     small       ! class_ "warning-text"       $ text-        ((^. #more % #warningHeavyDevelopment) |##| language)--simpleIcon :: Text -> Text -> Html-simpleIcon x txt =-  H.span $ do-    H.span ! class_ "margin-medium" $ (fromString . T.unpack $ x)-    H.span (fromString . T.unpack $ txt)+        ((^. #more % #warningHeavyDevelopment) |##| (vv ^. #language))

@@ -1,67 +1,137 @@ {-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} -module WikiMusic.SSR.View.Components.PageTop-  ( sharedPageTop,-  )-where+module WikiMusic.SSR.View.Components.PageTop where -import Data.Text qualified as T-import Optics-import Relude-import Text.Blaze.Html+import Principium import Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes as A-import WikiMusic.SSR.Language-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.View.Components.Other+import WikiMusic.SSR.View.Components.Icons -sharedPageTop :: Maybe Text -> UiMode -> Language -> Palette -> Html-sharedPageTop title' mode language palette = do-  section ! class_ "flex direction-column flex items-center" $ do-    a-      ! href "/songs"-      $ h1-      ! class_ "italic font-size-xxx-large font-weight-300"-      $ text ((^. #titles % #wikimusicSSR) |##| language)-    em-      ! class_ "margin-top-large font-size-large font-weight-300"-      $ text ((^. #slogans % #pageTop) |##| language)+sharedPageTop :: Maybe Text -> ViewVars -> Html+sharedPageTop title' vv = do+  topTitle vv+  myNav vv -  section ! class_ "flex direction-row justify-content-center gap-small" $ do-    H.div-      $ H.form-      ! action "/user-preferences/locale"-      ! method "POST"-      ! enctype "multipart/form-data"-      $ do-        select ! onchange "this.form.submit()" ! name "locale" $ do-          option !? ((language ^. #value) == "en", selected "true") ! value "en" $ "🇬🇧 English"-          option !? ((language ^. #value) == "nl", selected "true") ! value "nl" $ "🇳🇱 Nederlands"+  H.div ! css' ["flex", "flex-wrap", "flex-row", "gap-6", "justify-center"] $ do+    userPrefs vv+    -- warningBanner language+    maybeTitle title' -        noscript $ button ! type_ "submit" $ "submit"-    H.div $ H.form ! action "/user-preferences/dark-mode" ! method "POST" ! enctype "multipart/form-data" $ do-      select ! onchange "this.form.submit()" ! type_ "checkbox" ! name "dark-mode" ! A.id "dark-mode" $ do-        option !? ((mode ^. #value) == "dark", selected "true") ! value "dark" $ simpleIcon "🌙" "dark mode"-        option !? ((mode ^. #value) == "light", selected "true") ! value "light" $ simpleIcon "☀️" "light mode"-      noscript $ button ! type_ "submit" $ "submit"-    H.div $ H.form ! action "/user-preferences/palette" ! method "POST" ! enctype "multipart/form-data" $ do-      select ! onchange "this.form.submit()" ! type_ "checkbox" ! name "palette" ! A.id "palette" $ do-        option !? ((palette ^. #value) == "mauve", selected "true") ! value "mauve" $ "mauve"-        option !? ((palette ^. #value) == "green", selected "true") ! value "green" $ "green"-      noscript $ button ! type_ "submit" $ "submit"+maybeTitle :: Maybe Text -> Html+maybeTitle =+  mapM_+    ( (h2 ! css' ["text-2xl", "text-grey-600", "font-mono"])+        . text+    ) -  warningBanner language-  myNav language-  mapM_ (\x -> H.div ! class_ "text-align-center" $ (h2 ! class_ "font-weight-300 font-size-xx-large") . fromString . T.unpack $ x) title'+languageMenu :: ViewVars -> Html+languageMenu vv = do+  H.form+  ! action "/user-preferences/locale"+  ! method "POST"+  ! enctype "multipart/form-data"+  $ do+    select ! css (cssSelect vv) ! onchange "this.form.submit()" ! name "locale" $ do+      mapM_ (mkLanguageOption vv) [("en", "🇬🇧 English"), ("nl", "🇳🇱 Nederlands")]+    noscript $ button ! type_ "submit" $ "submit" -myNav :: Language -> Html-myNav language = do+mkLanguageOption :: ViewVars -> (Text, Text) -> Html+mkLanguageOption vv (locale, viewLabel) =+  ( option+      H.!? ((vv ^. #language % #value) == (fromString . unpackText $ locale), selected (fromString . unpackText $ ""))+      ! value (fromString . unpackText $ locale)+  )+    . text+    $ viewLabel++myNav :: ViewVars -> Html+myNav vv = do   hr-  nav $ ol $ do-    li $ a ! class_ "nav-link scale-on-hover" ! href "/songs" $ text ((^. #more % #songsNav) |##| language)-    li $ a ! class_ "nav-link scale-on-hover" ! href "/artists" $ text ((^. #more % #artistsNav) |##| language)-    li $ a ! class_ "nav-link scale-on-hover" ! href "/genres" $ text ((^. #more % #genresNav) |##| language)-    li $ a ! class_ "nav-link scale-on-hover" ! href "/login" $ text ((^. #more % #loginNav) |##| language)+  nav ! css' ["flex", "flex-row", "flex-wrap", "gap-8", "py-4", "justify-center"] $ do+    H.div ! css' ["flex", "flex-wrap", "flex-row", "justify-center", "gap-8", "items-center", "font-mono"] $ do+      a ! css' navLinkClass ! href "/songs" $ text ((^. #more % #songsNav) |##| (vv ^. #language))+      a ! css' navLinkClass ! href "/artists" $ text ((^. #more % #artistsNav) |##| (vv ^. #language))+      a ! css' navLinkClass ! href "/genres" $ text ((^. #more % #genresNav) |##| (vv ^. #language))+      a ! css' navLinkClass ! href "/login" $ text ((^. #more % #loginNav) |##| (vv ^. #language))+    H.div ! css' ["flex", "flex-wrap", "flex-row", "justify-center", "gap-8", "items-center"] $ do+      languageMenu vv   hr+  where+    navLinkClass = ["text-lg", "font-bold", if vv ^. #uiMode % #value == "dark" then "text-stone-200" else "text-stone-700"]++userPrefs :: ViewVars -> Html+userPrefs vv = do+  H.div ! css' ["mt-6", "flex", "flex-wrap", "flex-row", "gap-6", "justify-center", "align-center"] $ do+    H.form ! action "/user-preferences/dark-mode" ! method "POST" ! enctype "multipart/form-data" $ do+      select ! css (cssSelect vv) ! onchange "this.form.submit()" ! type_ "checkbox" ! name "dark-mode" ! A.id "dark-mode" $ do+        option H.!? ((vv ^. #uiMode % #value) == "dark", selected "true") ! value "dark" $ simpleIcon "🌙" "dark mode"+        option H.!? ((vv ^. #uiMode % #value) == "light", selected "true") ! value "light" $ simpleIcon "☀️" "light mode"+      noscript $ button ! type_ "submit" $ "submit"++    H.form ! action "/user-preferences/palette" ! method "POST" ! enctype "multipart/form-data" $ do+      select ! css (cssSelect vv) ! onchange "this.form.submit()" ! type_ "checkbox" ! name "palette" ! A.id "palette" $ do+        mapM_+          (mkPaletteOption vv)+          ( sort+              [ "purple",+                "green",+                "amber",+                "stone",+                "white",+                "red",+                "pink",+                "orange",+                "slate",+                "gray",+                "yellow",+                "lime",+                "emerald",+                "teal",+                "cyan",+                "sky",+                "blue",+                "indigo",+                "violet",+                "rose"+              ]+          )+      noscript $ button ! type_ "submit" $ "submit"++mkPaletteOption :: ViewVars -> Text -> Html+mkPaletteOption vv choice = do+  (option H.!? ((vv ^. #palette % #value) == choice, selected "true") ! value (fromString . unpackText $ choice)) . text $ choice++topTitle :: ViewVars -> Html+topTitle vv = do+  section+    ! css'+      [ "flex",+        "flex-wrap",+        "flex-row",+        "justify-center",+        "align-center",+        "gap-8",+        "px-3",+        "py-3"+      ]+    $ do+      a+        ! href "/songs"+        $ h1+        ! css'+          [ "text-xl",+            "font-bold",+            "font-mono",+            "italic",+            if vv ^. #uiMode % #value == "dark" then "text-stone-200" else "text-stone-800"+          ]+        $ text ((^. #titles % #wikimusicSSR) |##| (vv ^. #language))+      em+        ! css'+          [ "text-xl",+            "font-light",+            "font-mono",+            "italic",+            if vv ^. #uiMode % #value == "dark" then "text-stone-200" else "text-stone-800"+          ]+        $ text ((^. #slogans % #pageTop) |##| (vv ^. #language))

@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoFieldSelectors #-}++module WikiMusic.SSR.View.Css where++import Data.Text qualified as T+import Optics+import Relude+import Text.Blaze.Html qualified as BlazeHtml+import Text.Blaze.Html5.Attributes qualified as A+import WikiMusic.SSR.Model.Api++newtype Css = Css {className :: Text} deriving (Generic, Eq, Show)++makeFieldLabelsNoPrefix ''Css++cssToAttrValue :: [Text] -> BlazeHtml.AttributeValue+cssToAttrValue = fromString . T.unpack . joinClasses . fromList+  where+    joinClasses :: Set Text -> Text+    joinClasses = T.intercalate " " . sort . toList++css' :: [Text] -> BlazeHtml.Attribute+css' xs = css (fromList xs :: Set Text)++css :: Set Text -> BlazeHtml.Attribute+css xs = A.class_ (cssToAttrValue $ toList xs)++cssSubmitButton :: Set Text+cssSubmitButton =+  fromList+    [ "text-white",+      "bg-green-700/75",+      "hover:bg-green-800",+      "focus:outline-none",+      "focus:ring-4",+      "focus:ring-green-300",+      "font-medium",+      "rounded-2xl",+      "text-sm",+      "px-5",+      "py-2.5",+      "text-center",+      "font-mono",+      "w-fit"+    ]++cssButton :: ViewVars -> Set Text+cssButton vv =+  fromList+    [ if vv ^. #uiMode % #value == "dark" then "text-white" else "text-black",+      "hover:bg-" <> vv ^. #palette % #value <> "-500/40",+      "focus:outline-none",+      "focus:ring-4",+      "focus:ring-gray-300",+      "font-medium",+      "rounded-2xl",+      "text-md",+      "px-5",+      "py-2.5",+      "font-mono",+      "w-fit",+      "border",+      "border-" <> vv ^. #palette % #value <> "-500/40",+      "bg-" <> vv ^. #palette % #value <> "-400/40"+    ]++cssSelect :: ViewVars -> Set Text+cssSelect vv =+  fromList+    [ if vv ^. #uiMode % #value == "dark" then "text-white" else "text-black",+      "bg-" <> vv ^. #palette % #value <> "-400/40",+      "hover:bg-" <> vv ^. #palette % #value <> "-500/40",+      "focus:outline-none",+      "focus:ring-4",+      "focus:ring-gray-300",+      "font-medium",+      "rounded-2xl",+      "text-sm",+      "px-8",+      "cursor-pointer",+      "py-2",+      "font-mono",+      "w-fit",+      "h-fit",+      "border-" <> vv ^. #palette % #value <> "-400/40"+    ]++cssCenteredCardGrid :: Set Text+cssCenteredCardGrid = fromList ["flex", "flex-row", "flex-wrap", "gap-4", "justify-center", "align-center"]++cssInput :: Set Text+cssInput = fromList ["rounded-2xl", "px-5", "py-2.5", "font-mono", "w-full", "bg-white/40"]++cssTextarea :: Set Text+cssTextarea = fromList ["rounded-2xl", "px-5", "py-2.5", "w-full", "h-fit", "min-h-72", "bg-white/40"]++cssDetails :: ViewVars -> Set Text+cssDetails vv =+  fromList+    [ "border-2",+      "border",+      "border-gray-200",+      "p-4",+      "[&_svg]:open:-rotate-180]",+      "my-4",+      "rounded-2xl",+      if vv ^. #uiMode % #value == "dark" then "bg-black/70" else "bg-white/80",+      if vv ^. #uiMode % #value == "dark" then "text-white" else "text-black"+    ]++cssSummary :: Set Text+cssSummary = fromList ["text-xl", "font-bold", "cursor-pointer"]++cssLink :: ViewVars -> Set Text+cssLink vv = fromList ["text-" <> vv ^. #palette % #value <> "-500", "font-bold", "font-mono", "cursor-pointer"]

@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module WikiMusic.SSR.View.ErrorHtml where++import Data.ByteString.Base16.Lazy qualified as B16+import Data.Text qualified as T+import Principium+import Text.Blaze.Html5 as H+import Text.Blaze.Html5.Attributes as A+import WikiMusic.SSR.View.HtmlUtil++errorPage' :: (MonadIO m) => Env -> ViewVars -> Text -> m Html+errorPage' env vv message' =+  simplePage env vv (SimplePageTitle $ (^. #titles % #songsPage) |##| (vv ^. #language)) $ section $ do+    h3 . text $ messageCauses+    H.pre $ text message+  where+    messageCauses :: Text+    messageCauses = T.intercalate " - " causeStrings+    message = decodeUtf8 . B16.decodeLenient . encodeUtf8 $ message'+    causeStrings = catMaybes [Just "Error", if T.isInfixOf "504" message then Just "Gateway Timeout" else Nothing]

@@ -6,84 +6,70 @@   ( genreListPage',     genreDetailPage',     genreCreatePage',-    genreEditPage'+    genreEditPage',   ) where -import Data.Map qualified as Map-import Optics-import Relude-import Text.Blaze.Html-import Text.Blaze.Html5 as H+import Principium+import Text.Blaze.Html5 as H hiding (map) import Text.Blaze.Html5.Attributes as A import WikiMusic.Interaction.Model.Genre-import WikiMusic.SSR.Language-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env import WikiMusic.SSR.View.Components.Forms-import WikiMusic.SSR.View.Components.Meta import WikiMusic.SSR.View.Components.Other-import WikiMusic.SSR.View.Components.PageTop+import WikiMusic.SSR.View.HtmlUtil -genreListPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> SortOrder -> GetGenresQueryResponse -> m Html-genreListPage' env mode language palette sortOrder xs = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #genresPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop (Just $ (^. #titles % #genresPage) |##| language) mode language palette-      section ! class_ "flex direction-row justify-content-center gap-small align-items-baseline" $ do+genreListPage' :: (MonadIO m) => Limit -> Offset -> Env -> ViewVars -> GetGenresQueryResponse -> m Html+genreListPage' limit offset env vv xs =+  simplePage env vv (SimplePageTitle $ (^. #titles % #genresPage) |##| (vv ^. #language)) $ do+    section ! css' ["flex", "flex-row", "flex-wrap", "gap-4", "justify-center", "align-center", "items-center"] $ do+      searchForm "/genres/search" $ do+        searchInput "searchInput"+        submitButtonNoText+      section $ do         H.a ! href "/genres/create" $ button $ H.small "+ new genre"-        mkSortingForm language sortOrder "/user-preferences/genre-sorting" "genre-sorting"-      section ! class_ "entity-card-section" $ mapM_ (simpleEntityCard language "genres") sortedXs+        mkSortingForm vv (vv ^. #genreSorting) "/user-preferences/genre-sorting" "genre-sorting"+    --+    section ! css cssCenteredCardGrid $ mapM_ (simpleEntityCard vv "genres") sortedXs+    section ! css' ["flex", "flex-row", "flex-wrap", "gap-4", "justify-center", "align-center", "items-center", "my-6"] $ do+      maybePrevPaginationButton vv limit offset (length (xs ^. #genres))+      maybeNextPaginationButton vv limit offset (length (xs ^. #genres))   where     sortedXs =       mapMaybe-        (\identifier -> (xs ^. #genres) Map.!? identifier)+        (\identifier -> (xs ^. #genres) Principium.!? identifier)         (xs ^. #sortOrder) -genreDetailPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> Genre -> m Html-genreDetailPage' env mode language palette x = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #genresPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop Nothing mode language palette-      entityDetails language "genres" x+genreDetailPage' :: (MonadIO m) => Env -> ViewVars -> Genre -> m Html+genreDetailPage' env vv x = do+  simplePage env vv (SimplePageTitle $ (^. #titles % #genresPage) |##| (vv ^. #language)) $ do+    entityDetails vv "genres" x -genreCreatePage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> m Html-genreCreatePage' env mode language palette = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #genresPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop Nothing mode language palette-      section $ do-        H.h2 "Create genre"-        postForm "/genres/create" $ do-          requiredTextInput "displayName" "genre name"-          optionalTextArea "description" "description"-          optionalTextInput "spotifyUrl" "spotify URL"-          optionalTextInput "youtubeUrl" "youtube URL"-          optionalTextInput "wikipediaUrl" "wikipedia URL"-          optionalTextInput "soundcloudUrl" "soundcloud URL"-          submitButton language+genreCreatePage' :: (MonadIO m) => Env -> ViewVars -> m Html+genreCreatePage' env vv =+  simplePage env vv (SimplePageTitle "Create genre") $ do+    section ! css' ["container", "mx-auto"] $ do+      postForm "/genres/create" $ do+        requiredTextInput "displayName" "genre name"+        optionalTextArea "description" "description"+        optionalTextInput "spotifyUrl" "spotify URL"+        optionalTextInput "youtubeUrl" "youtube URL"+        optionalTextInput "wikipediaUrl" "wikipedia URL"+        optionalTextInput "soundcloudUrl" "soundcloud URL"+        submitButton vv -genreEditPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> Genre -> m Html-genreEditPage' env mode language palette genre = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #genresPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop Nothing mode language palette-      section $ do-        H.h2 "Edit genre"-        postForm "/genres/edit" $ do-          requiredTextInput' "displayName" "genre name" (Just $ genre ^. #displayName)-          optionalTextArea' "description" "description" (genre ^. #description)-          optionalTextInput' "spotifyUrl" "spotify URL" (genre ^. #spotifyUrl)-          optionalTextInput' "youtubeUrl" "youtube URL" (genre ^. #youtubeUrl)-          optionalTextInput' "wikipediaUrl" "wikipedia URL" (genre ^. #wikipediaUrl)-          optionalTextInput' "soundcloudUrl" "soundcloud URL" (genre ^. #soundcloudUrl)-          -          submitButton language+genreEditPage' :: (MonadIO m) => Env -> ViewVars -> Genre -> m Html+genreEditPage' env vv genre =+  simplePage env vv (SimplePageTitle "Edit genre") $ do+    section ! css' ["container", "mx-auto"] $ do+      postForm ("/genres/edit/" <> (packText . show $ genre ^. #identifier)) $ do+        requiredTextInput' "displayName" "genre name" (Just $ genre ^. #displayName)+        optionalTextArea' "description" "description" (genre ^. #description)+        optionalTextInput' "spotifyUrl" "spotify URL" (genre ^. #spotifyUrl)+        optionalTextInput' "youtubeUrl" "youtube URL" (genre ^. #youtubeUrl)+        optionalTextInput' "wikipediaUrl" "wikipedia URL" (genre ^. #wikipediaUrl)+        optionalTextInput' "soundcloudUrl" "soundcloud URL" (genre ^. #soundcloudUrl)++        submitButton vv+      entityArtworkForm vv "genres" (map (^. #artwork) . mapElems $ genre ^. #artworks)+      hr+      entityNewArtworkForm vv "genres" (genre ^. #identifier)

@@ -1,84 +1,54 @@ {-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module WikiMusic.SSR.View.Html () where  import Data.Map qualified as Map-import Data.Text qualified as T-import Free.AlaCarte-import Optics-import Relude-import Text.Blaze.Html-import Text.Blaze.Html5 as H-import Text.Blaze.Html5.Attributes as A+import Principium import WikiMusic.SSR.Free.View-import WikiMusic.SSR.Language-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env import WikiMusic.SSR.View.ArtistHtml-import WikiMusic.SSR.View.Components.Forms-import WikiMusic.SSR.View.Components.Meta-import WikiMusic.SSR.View.Components.PageTop import WikiMusic.SSR.View.GenreHtml+import WikiMusic.SSR.View.OtherHtml import WikiMusic.SSR.View.SongHtml-import Prelude qualified  instance Exec View where   -- artists-  execAlgebra (ArtistListPage env mode sortOrder l palette r next) =-    next =<< artistListPage' env mode sortOrder l palette r-  execAlgebra (ArtistDetailPage env mode language palette r next) =-    next =<< artistDetailPage' env mode language palette (Prelude.head . Map.elems $ r ^. #artists)-  execAlgebra (ArtistCreatePage env mode language palette next) =-    next =<< artistCreatePage' env mode language palette-  execAlgebra (ArtistEditPage env mode language palette artist next) =-    next =<< artistEditPage' env mode language palette artist+  execAlgebra (ArtistListPage limit offset env vv r next) =+    next =<< artistListPage' limit offset env vv r+  execAlgebra (ArtistDetailPage env vv r next) = do+    let maybeArtist = fmap head . nonEmpty . Map.elems $ r ^. #artists+    next =<< maybe (errorPage' env vv Nothing Nothing) (artistDetailPage' env vv) maybeArtist+  execAlgebra (ArtistCreatePage env vv next) =+    next =<< artistCreatePage' env vv+  execAlgebra (ArtistEditPage env vv artist next) =+    next =<< artistEditPage' env vv artist   -- genres-  execAlgebra (GenreListPage env mode sortOrder l palette r next) =-    next =<< genreListPage' env mode sortOrder l palette r-  execAlgebra (GenreDetailPage env mode language palette r next) =-    next =<< genreDetailPage' env mode language palette (Prelude.head . Map.elems $ r ^. #genres)-  execAlgebra (GenreCreatePage env mode language palette next) =-    next =<< genreCreatePage' env mode language palette-  execAlgebra (GenreEditPage env mode language palette genre next) =-    next =<< genreEditPage' env mode language palette genre+  execAlgebra (GenreListPage limit offset env vv r next) =+    next =<< genreListPage' limit offset env vv r+  execAlgebra (GenreDetailPage env vv r next) = do+    let maybeGenre = fmap head . nonEmpty . Map.elems $ r ^. #genres+    next =<< maybe (errorPage' env vv Nothing Nothing) (genreDetailPage' env vv) maybeGenre+  execAlgebra (GenreCreatePage env vv next) =+    next =<< genreCreatePage' env vv+  execAlgebra (GenreEditPage env vv genre next) =+    next =<< genreEditPage' env vv genre   -- songs-  execAlgebra (SongListPage env mode sortOrder language palette r next) =-    next =<< songListPage' env mode sortOrder language palette r-  execAlgebra (SongDetailPage env mode language palette songAsciiSize r next) =-    next =<< songDetailPage' env mode language palette songAsciiSize (Prelude.head . Map.elems $ r ^. #songs)-  execAlgebra (SongCreatePage env mode language palette next) =-    next =<< songCreatePage' env mode language palette-  execAlgebra (SongEditPage env mode language palette song next) =-    next =<< songEditPage' env mode language palette song-  execAlgebra (ErrorPage env mode language palette message next) =-    next =<< errorPage' env mode language palette message-  execAlgebra (LoginPage env mode language palette next) =-    next =<< loginPage' env mode language palette--errorPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> Text -> m Html-errorPage' env mode language palette message = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #errorOccurred) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop (Just $ (^. #titles % #errorOccurred) |##| language) mode language palette-      h3 . text $ messageCauses-      H.pre ! class_ "font-size-small" $ text message-  where-    messageCauses :: Text-    messageCauses = T.intercalate " - " causeStrings-    causeStrings = catMaybes [Just "Error", if T.isInfixOf "504" message then Just "Gateway Timeout" else Nothing]--loginPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> m Html-loginPage' env mode language palette = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #login) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop (Just $ (^. #titles % #login) |##| language) mode language palette-      section $ postForm "/login" $ do-        requiredEmailInput "email" ((^. #forms % #email) |##| language)-        requiredPasswordInput "password" ((^. #forms % #password) |##| language)-        submitButton language+  execAlgebra (SongListPage limit offset env vv r next) =+    next =<< songListPage' limit offset env vv r+  execAlgebra (SongDetailPage env vv r next) = do+    let maybeSong = fmap head . nonEmpty . Map.elems $ r ^. #songs+    next =<< maybe (errorPage' env vv Nothing Nothing) (songDetailPage' env vv) maybeSong+  execAlgebra (SongCreatePage env vv next) =+    next =<< songCreatePage' env vv+  execAlgebra (SongEditPage env vv song next) =+    next =<< songEditPage' env vv song+  execAlgebra (ErrorPage env vv maybeCode maybeMessage next) =+    next =<< errorPage' env vv maybeCode maybeMessage+  execAlgebra (LoginPage env vv next) =+    next =<< loginPage' env vv+  execAlgebra (RequestPasswordResetPage env vv next) =+    next =<< requestPasswordResetPage' env vv+  execAlgebra (DoPasswordResetPage env vv t next) =+    next =<< doPasswordResetPage' env vv t+  execAlgebra (InviteUsersPage env vv next) =+    next =<< inviteUserPage' env vv

@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module WikiMusic.SSR.View.HtmlUtil where++import Principium+import Text.Blaze.Html5 as H hiding (map)+import Text.Blaze.Html5.Attributes as A+import WikiMusic.SSR.View.Components.Footer+import WikiMusic.SSR.View.Components.PageTop++newtype SimplePageTitle = SimplePageTitle {value :: Text} deriving (Eq, Show)++makeFieldLabelsNoPrefix ''SimplePageTitle++mkSharedHead :: (MonadIO m) => Env -> ViewVars -> SimplePageTitle -> m Html+mkSharedHead _ _ pageTitle = do+  pure $ H.head $ do+    H.meta ! charset "utf-8"+    H.meta ! lang "en"+    H.title . text $ (pageTitle ^. #value)+    meta ! name "viewport" ! content "width=device-width, initial-scale=1"+    H.style+      . text+      $ [trimming|+        @import url('https://fonts.cdnfonts.com/css/liberation-sans');+        @import url('https://fonts.cdnfonts.com/css/liberation-serif');++@font-face {+  font-family: 'Intel One Mono';+  font-style: normal;+  font-weight: 400;+  src: url('/static/ttf/IntelOneMono-Regular.ttf') format('truetype');+}++@font-face {+  font-family: 'Intel One Mono';+  font-style: italic;+  font-weight: 400;+  src: url('/static/ttf/IntelOneMono-Italic.ttf') format('truetype');+}++@font-face {+  font-family: 'Intel One Mono';+  font-style: normal;+  font-weight: 500;+  src: url('/static/ttf/IntelOneMono-Medium.ttf') format('truetype');+}++@font-face {+  font-family: 'Intel One Mono';+  font-style: italic;+  font-weight: 500;+  src: url('/static/ttf/IntelOneMono-MediumItalic.ttf') format('truetype');+}++@font-face {+  font-family: 'Intel One Mono';+  font-style: normal;+  font-weight: 700;+  src: url('/static/ttf/IntelOneMono-Bold.ttf') format('truetype');+}++@font-face {+  font-family: 'Intel One Mono';+  font-style: italic;+  font-weight: 700;+  src: url('/static/ttf/IntelOneMono-BoldItalic.ttf') format('truetype');+}++@font-face {+  font-family: 'Intel One Mono';+  font-style: normal;+  font-weight: 300;+  src: url('/static/ttf/IntelOneMono-Light.ttf') format('truetype');+}++@font-face {+  font-family: 'Intel One Mono';+  font-style: italic;+  font-weight: 300;+  src: url('/static/ttf/IntelOneMono-LightItalic.ttf') format('truetype');+}+        |]+    H.script ! src "https://cdn.tailwindcss.com?plugins=forms,typography,aspect-ratio,container-queries" $ ""+    H.script+      . text+      $ [trimming|+      tailwind.config = {+        theme: {+          container: { center: true },+          fontFamily: {+            sans: ['Liberation Sans', 'sans-serif'],+            serif: ['Liberation Serif', 'serif'],+            mono: ['Intel One Mono', 'monospace']+          },+        }+      }                              +    |]++simplePage :: (MonadIO m) => Env -> ViewVars -> SimplePageTitle -> Html -> m Html+simplePage env vv title' body' = do+  sharedHead <- mkSharedHead env vv title'+  pure $ H.html $ do+    sharedHead+    bodyWithFooter vv $ do+      sharedPageTop Nothing vv+      (H.div ! css' ["text-center", "my-4"]) $ do+        (H.h2 ! css' ["text-xl", "text-slate-600", "font-mono", "font-bold"]) . text $ title' ^. #value+      body'++paginationOffsetJS :: Text -> Text -> Text+paginationOffsetJS offset' newOffset =+  [trimming|(function(){+                 if(/offset/.test(window.location.toString())){+                     window.location = window.location.toString()+                       .replace("offset=$offset'", "offset=$newOffset");+                   }else{+                     window.location = window.location + "?offset=$newOffset";+                   }+                 })+                 ()|]++maybeNextPaginationButton :: ViewVars -> Limit -> Offset -> Int -> Html+maybeNextPaginationButton _ _ _ 0 = pure ()+maybeNextPaginationButton _ (Limit 0) _ _ = pure ()+maybeNextPaginationButton vv (Limit limit) (Offset offset) itemSize =+  when (itemSize == limit)+    $ H.button+    ! css (cssButton vv)+    ! onclick (textToAttrValue . minify $ paginationOffsetJS offset' newOffset)+    $ "("+    <> pageNum+    <> ") next page >"+  where+    offset' = show offset+    newOffset = show $ offset + limit+    pageNum = show $ (offset `Principium.div` limit) + 1+    minify =+      replaceText+        "\n"+        ""++maybePrevPaginationButton :: ViewVars -> Limit -> Offset -> Int -> Html+maybePrevPaginationButton _ (Limit 0) _ _ = pure ()+maybePrevPaginationButton vv (Limit limit) (Offset offset) _ =+  when (offset > 0)+    $ H.button+    ! css (cssButton vv)+    ! onclick (textToAttrValue . minify $ paginationOffsetJS offset' newOffset)+    $ "< previous page ("+    <> pageNum+    <> ")"+  where+    offset' = show offset+    newOffset = show $ offset - limit+    pageNum = show $ (offset `Principium.div` limit) - 1+    minify = replaceText "\n" ""

@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module WikiMusic.SSR.View.OtherHtml where++import Data.Text qualified as T+import Principium+import Text.Blaze.Html5 as H+import Text.Blaze.Html5.Attributes as A+import WikiMusic.SSR.View.Components.Forms+import WikiMusic.SSR.View.HtmlUtil++errorPage' :: (MonadIO m) => Env -> ViewVars -> Maybe Int -> Maybe Text -> m Html+errorPage' env vv _ maybeMessage = do+  simplePage env vv (SimplePageTitle $ (^. #titles % #songsPage) |##| (vv ^. #language)) $ section $ do+    h3 . text $ messageCauses+    let maybeDecoded = fmap maybeDecodeBase16 maybeMessage+    H.pre+      $ do+        case maybeDecoded of+          Nothing -> text "Unexpected Error!"+          Just maybeDecodedError -> either (pure $ text "Unexpected Error!") (text . T.pack . decodeUtf8) maybeDecodedError+  where+    messageCauses = T.intercalate " - " causeStrings+    causeStrings = catMaybes [Just "Error", if T.isInfixOf "504" (fromMaybe "Error ocurred!" maybeMessage) then Just "Gateway Timeout" else Nothing]++loginPage' :: (MonadIO m) => Env -> ViewVars -> m Html+loginPage' env vv = do+  simplePage env vv (SimplePageTitle $ (^. #more % #loginNav) |##| (vv ^. #language)) $ do+    section ! css' ["flex", "justify-center"] $ postForm' "/login" ["flex", "flex-col", "gap-4"] $ do+      H.div ! css' ["flex", "flex-row", "flex-wrap", "gap-8"] $ do+        requiredEmailInput "email" ((^. #forms % #email) |##| (vv ^. #language))+        requiredPasswordInput "password" ((^. #forms % #password) |##| (vv ^. #language))+      submitButton vv+    a ! css (cssLink vv) ! href "/passwords/request-reset" $ "forgot password ?"++doPasswordResetPage' :: (MonadIO m) => Env -> ViewVars -> Maybe Text -> m Html+doPasswordResetPage' env vv t = do+  simplePage env vv (SimplePageTitle "Reset password") $ do+    section $ postForm "/passwords/do-reset" $ do+      requiredEmailInput "email" "email"+      requiredPasswordInput "password" "password"+      requiredPasswordInput "passwordConfirm" "password again"+      requiredTextInput' "token" "token" t+      submitButton vv++requestPasswordResetPage' :: (MonadIO m) => Env -> ViewVars -> m Html+requestPasswordResetPage' env vv = do+  simplePage env vv (SimplePageTitle "Request password reset ?") $ do+    section $ postForm "/passwords/request-reset" $ do+      requiredEmailInput "email" "email"+      submitButton vv++inviteUserPage' :: (MonadIO m) => Env -> ViewVars -> m Html+inviteUserPage' env vv = do+  simplePage env vv (SimplePageTitle "Invite user") $ do+    section $ postForm "/users/invite" $ do+      requiredEmailInput "email" "email"+      requiredTextInput "displayName" "name"+      H.label ! for "role" $ "role"+      select ! css (cssSelect vv) ! required "" ! name "role" ! A.id "role" $ do+        option ! value "wm::demo" $ "demo user"+        option ! value "wm::lowrank" $ "average user"+        option ! value "wm::maintainer" $ "wiki maintainer"+        option ! value "wm::superuser" $ "super user"+      optionalTextArea "description" "description"+      submitButton vv

@@ -6,155 +6,214 @@   ( songListPage',     songDetailPage',     songCreatePage',-    songEditPage'+    songEditPage',   ) where -import Data.Map qualified as Map-import Data.Text qualified as T-import Optics-import Relude-import Text.Blaze.Html-import Text.Blaze.Html5 as H+import Principium+import Text.Blaze.Html5 as H hiding (map) import Text.Blaze.Html5.Attributes as A import WikiMusic.Interaction.Model.Song-import WikiMusic.Model.Song-import WikiMusic.SSR.Language-import WikiMusic.SSR.Model.Api-import WikiMusic.SSR.Model.Env+import WikiMusic.Model.Song hiding (show) import WikiMusic.SSR.View.Components.DetailList import WikiMusic.SSR.View.Components.Forms-import WikiMusic.SSR.View.Components.Meta import WikiMusic.SSR.View.Components.Other-import WikiMusic.SSR.View.Components.PageTop+import WikiMusic.SSR.View.HtmlUtil -songListPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> SortOrder -> GetSongsQueryResponse -> m Html-songListPage' env mode language palette sortOrder xs = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #songsPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop (Just $ (^. #titles % #songsPage) |##| language) mode language palette-      section ! class_ "flex direction-row justify-content-center gap-small align-items-baseline" $ do+songListPage' :: (MonadIO m) => Limit -> Offset -> Env -> ViewVars -> GetSongsQueryResponse -> m Html+songListPage' limit offset env vv xs =+  simplePage env vv (SimplePageTitle $ (^. #titles % #songsPage) |##| (vv ^. #language)) $ do+    section ! css' ["flex", "flex-row", "flex-wrap", "gap-4", "justify-center", "align-center", "items-center"] $ do+      searchForm "/songs/search" $ do+        searchInput "searchInput"+        submitButtonNoText+      section $ do         H.a ! href "/songs/create" $ button $ H.small "+ new song"-        mkSortingForm language sortOrder "/user-preferences/song-sorting" "song-sorting"-      section ! class_ "entity-card-section" $ mapM_ (simpleEntityCard language "songs") sortedXs+        mkSortingForm vv (vv ^. #songSorting) "/user-preferences/song-sorting" "song-sorting"+    --+    section ! css cssCenteredCardGrid $ mapM_ (simpleEntityCard vv "songs") sortedXs+    section ! css' ["flex", "flex-row", "flex-wrap", "gap-4", "justify-center", "align-center", "items-center", "my-6"] $ do+      maybePrevPaginationButton vv limit offset (length (xs ^. #songs))+      maybeNextPaginationButton vv limit offset (length (xs ^. #songs))   where     sortedXs =       mapMaybe-        (\identifier -> (xs ^. #songs) Map.!? identifier)+        (\identifier -> (xs ^. #songs) Principium.!? identifier)         (xs ^. #sortOrder) -songDetailPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> SongAsciiSize -> Song -> m Html-songDetailPage' env mode language palette songAsciiSize x = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #songsPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop Nothing mode language palette-      entityDetails language "songs" x-      songDetails language x-      H.div $ H.form ! action "/user-preferences/song-ascii-size" ! method "POST" ! enctype "multipart/form-data" $ do-        select ! onchange "this.form.submit()" ! type_ "checkbox" ! name "song-ascii-size" ! A.id "song-ascii-size" $ do-          mapM_-            ( \size' ->-                let mkOption = option !? ((songAsciiSize ^. #value) == size', selected "true") ! value (fromString . T.unpack $ size')-                 in mkOption . text $ size'-            )-            fontSizes-        noscript $ button ! type_ "submit" $ "submit"-      section $ do-        mapM_ (mkVersion language songAsciiSize) (x ^. #contents)+songDetailPage' :: (MonadIO m) => Env -> ViewVars -> Song -> m Html+songDetailPage' env vv x = do+  simplePage env vv (SimplePageTitle $ (^. #titles % #songsPage) |##| (vv ^. #language)) $ do+    entityDetails vv "songs" x+    songDetails vv x+    H.form ! css' ["flex", "flex-row", "flex-wrap", "justify-center", "gap-4", "items-center"] ! action "/user-preferences/song-ascii-size" ! method "POST" ! enctype "multipart/form-data" $ do+      H.label ! for "song-ascii-size" $ "ascii size:"+      select ! css (cssSelect vv) ! onchange "this.form.submit()" ! type_ "checkbox" ! name "song-ascii-size" ! A.id "song-ascii-size" $ do+        mapM_+          ( \(size', sizeName) ->+              let mkOption = option H.!? ((vv ^. #songAsciiSize % #value) == size', selected "true") ! value (textToAttrValue size')+               in mkOption . text $ sizeName+          )+          fontSizes+      noscript $ button ! type_ "submit" $ "submit"+    section ! css' ["container", "mx-auto"] $ do+      mapM_ (mkVersion vv) (x ^. #contents)   where-    fontSizes :: [Text]-    fontSizes = ["xx-small", "x-small", "small", "medium", "large", "larger", "x-large", "xx-large"]+    fontSizes :: [(Text, Text)]+    fontSizes = [("xs", "extra small"), ("sm", "small"), ("md", "medium"), ("lg", "large"), ("xl", "extra large")] -songDetails :: Language -> Song -> Html-songDetails language x = do+songDetails :: ViewVars -> Song -> Html+songDetails vv x = do   section $ detailList $ do     mapM_-      (detailListEntry ((^. #more % #musicTuning) |##| language) . text)+      (monoDetailListEntry vv ((^. #more % #musicTuning) |##| (vv ^. #language)) . text)       (x ^. #musicTuning)     mapM_-      (detailListEntry ((^. #more % #musicKey) |##| language) . text)+      (detailListEntry vv ((^. #more % #musicKey) |##| (vv ^. #language)) . text)       (x ^. #musicKey)     mapM_-      (detailListEntry ((^. #more % #musicCreationDate) |##| language) . text)+      (detailListEntry vv ((^. #more % #musicCreationDate) |##| (vv ^. #language)) . text)       (x ^. #musicCreationDate)     mapM_-      (detailListEntry ((^. #more % #albumName) |##| language) . text)+      (detailListEntry vv ((^. #more % #albumName) |##| (vv ^. #language)) . text)       (x ^. #albumName)     mapM_-      (detailListEntry ((^. #more % #albumInfoLink) |##| language) . text)+      (detailListEntry vv ((^. #more % #albumInfoLink) |##| (vv ^. #language)) . text)       (x ^. #albumInfoLink) -mkVersion :: Language -> SongAsciiSize -> SongContent -> Html-mkVersion language songAsciiSize v = H.article $ do-  hr ! class_ "margin-top-medium"-  h3 . text $ (v ^. #versionName) <> " " <> (v ^. #instrumentType)+mkVersion :: ViewVars -> SongContent -> Html+mkVersion vv v = do+  hr+  H.article ! css' ["my-6"] $ do+    (h3 ! css' ["text-xl", "font-bold"]) . text $ (v ^. #versionName) <> " " <> (v ^. #instrumentType) -  detailList $ do+    detailList $ do+      mapM_+        (detailListEntry vv ((^. #more % #lastEditedAt) |##| (vv ^. #language)))+        (show <$> v ^. #lastEditedAt)+      detailListEntry vv ((^. #more % #createdAt) |##| (vv ^. #language)) (show $ v ^. #createdAt)+      monoDetailListEntry vv ((^. #more % #createdBy) |##| (vv ^. #language)) (show $ v ^. #createdBy)+     mapM_-      (detailListEntry ((^. #more % #lastEditedAt) |##| language))-      (Relude.show <$> v ^. #lastEditedAt)-    detailListEntry ((^. #more % #createdAt) |##| language) (Relude.show $ v ^. #createdAt)-    detailListEntry ((^. #more % #createdBy) |##| language) (Relude.show $ v ^. #createdBy)+      ( \asciiLegend -> details ! css (cssDetails vv) ! open "" $ do+          H.summary ! css cssSummary $ "ASCII Legend"+          (H.pre ! class_ (textToAttrValue $ "text-" <> (vv ^. #songAsciiSize % #value))) . text $ asciiLegend+      )+      (v ^. #asciiLegend)+    mapM_+      ( \asciiContents -> details ! css (cssDetails vv) ! open "" $ do+          H.summary ! css cssSummary $ "ASCII Content"+          (H.pre ! class_ (textToAttrValue $ "text-" <> (vv ^. #songAsciiSize % #value))) . text $ asciiContents+      )+      (v ^. #asciiContents)+    mapM_+      ( \pdfContents ->+          when (pdfContents /= "data:application/octet-stream;base64,") $ do+            details ! css (cssDetails vv) ! open "" $ do+              H.summary ! css cssSummary $ "PDF Content"+              H.iframe+                ! css' ["w-full", "h-full", "block"]+                ! customAttribute "loading" "lazy"+                ! customAttribute "allowed" ""+                ! customAttribute "allowfullscreen" ""+                ! customAttribute "referrerpolicy" "noreferrer"+                ! A.src (textToAttrValue pdfContents)+                $ ""+      )+      (v ^. #pdfContents) -  mapM_-    ( \asciiLegend -> details ! open "" $ do-        H.summary "ASCII Legend"-        (H.pre ! class_ (fromString . T.unpack $ "font-size-" <> (songAsciiSize ^. #value))) . text $ asciiLegend-    )-    (v ^. #asciiLegend)-  mapM_-    ( \asciiContents -> details ! open "" $ do-        H.summary "ASCII Content"-        (H.pre ! class_ (fromString . T.unpack $ "font-size-" <> (songAsciiSize ^. #value))) . text $ asciiContents-    )-    (v ^. #asciiContents)+songCreatePage' :: (MonadIO m) => Env -> ViewVars -> m Html+songCreatePage' env vv = do+  simplePage env vv (SimplePageTitle "Create song") $ do+    section ! css' ["container", "mx-auto"] $ do+      postForm "/songs/create" $ do+        requiredTextInput "displayName" "song name"+        optionalTextArea "description" "description"+        optionalTextInput "spotifyUrl" "spotify URL"+        optionalTextInput "youtubeUrl" "youtube URL"+        optionalTextInput "wikipediaUrl" "wikipedia URL"+        optionalTextInput "soundcloudUrl" "soundcloud URL"+        optionalTextInput "musicKey" "music key"+        optionalTextInput "musicTuning" "tuning"+        optionalTextInput "musicCreationDate" "date composed"+        optionalTextInput "albumName" "album name"+        optionalTextInput "albumInfoLink" "about the album"+        submitButton vv -songCreatePage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> m Html-songCreatePage' env mode language palette = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #songsPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop Nothing mode language palette-      section $ do-        H.h2 "Create song"-        postForm "/songs/create" $ do-          requiredTextInput "displayName" "song name"-          optionalTextArea "description" "description"-          optionalTextInput "spotifyUrl" "spotify URL"-          optionalTextInput "youtubeUrl" "youtube URL"-          optionalTextInput "wikipediaUrl" "wikipedia URL"-          optionalTextInput "soundcloudUrl" "soundcloud URL"-          optionalTextInput "musicKey" "music key"-          optionalTextInput "musicTuning" "tuning"-          optionalTextInput "musicCreationDate" "date composed"-          optionalTextInput "albumName" "album name"-          optionalTextInput "albumInfoLink" "about the album"-          submitButton language+songEditPage' :: (MonadIO m) => Env -> ViewVars -> Song -> m Html+songEditPage' env vv song = do+  simplePage env vv (SimplePageTitle "Edit song") $ do+    section ! css' ["container", "mx-auto"] $ do+      postForm ("/songs/edit/" <> uuidToText (song ^. #identifier)) $ do+        requiredTextInput' "displayName" "song name" (Just $ song ^. #displayName)+        optionalTextArea' "description" "description" (song ^. #description)+        optionalTextInput' "spotifyUrl" "spotify URL" (song ^. #spotifyUrl)+        optionalTextInput' "youtubeUrl" "youtube URL" (song ^. #youtubeUrl)+        optionalTextInput' "wikipediaUrl" "wikipedia URL" (song ^. #wikipediaUrl)+        optionalTextInput' "soundcloudUrl" "soundcloud URL" (song ^. #soundcloudUrl)+        optionalTextInput' "musicKey" "music key" (song ^. #musicKey)+        optionalTextInput' "musicTuning" "tuning" (song ^. #musicTuning)+        optionalTextInput' "musicCreationDate" "date composed" (song ^. #musicCreationDate)+        optionalTextInput' "albumName" "album name" (song ^. #albumName)+        optionalTextInput' "albumInfoLink" "about the album" (song ^. #albumInfoLink)+        submitButton vv -songEditPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> Song -> m Html-songEditPage' env mode language palette song = do-  sharedHead <- mkSharedHead env mode palette ((^. #titles % #songsPage) |##| language)-  pure $ H.html $ do-    sharedHead-    body $ section $ do-      sharedPageTop Nothing mode language palette-      section $ do-        H.h2 "Edit song"-        postForm "/songs/edit" $ do-          requiredTextInput' "displayName" "song name" (Just $ song ^. #displayName)-          optionalTextArea' "description" "description" (song ^. #description)-          optionalTextInput' "spotifyUrl" "spotify URL" (song ^. #spotifyUrl)-          optionalTextInput' "youtubeUrl" "youtube URL" (song ^. #youtubeUrl)-          optionalTextInput' "wikipediaUrl" "wikipedia URL" (song ^. #wikipediaUrl)-          optionalTextInput' "soundcloudUrl" "soundcloud URL" (song ^. #soundcloudUrl)-          optionalTextInput' "musicKey" "music key" (song ^. #musicKey)-          optionalTextInput' "musicTuning" "tuning" (song ^. #musicTuning)-          optionalTextInput' "musicCreationDate" "date composed" (song ^. #musicCreationDate)-          optionalTextInput' "albumName" "album name" (song ^. #albumName)-          optionalTextInput' "albumInfoLink" "about the album" (song ^. #albumInfoLink)-          submitButton language+      entityArtworkForm vv "songs" (map (^. #artwork) . mapElems $ song ^. #artworks)+      hr+      entityNewArtworkForm vv "songs" (song ^. #identifier)+      mapM_ (\c -> hr >> songContentsEditForm env vv (song ^. #identifier) c) (mapElems $ song ^. #contents)+      hr+      H.h2 "Create contents"+      songContentsCreateForm vv (song ^. #identifier)+      hr+      H.h2 "Artist <> Song"++      mapM_+        ( \art -> do+            H.h4 . text $ art+            -- dangerPostForm vv ("/songs/" <> (T.pack . Relude.show $ song ^. #identifier) <> "/artists/" <> (T.pack . Relude.show $ artistIdentifier) <> "/delete") $ do+            --   deleteButton vv+        )+        (mapElems $ song ^. #artists)+      songArtistForm vv (song ^. #identifier)++songArtistForm :: ViewVars -> UUID -> Html+songArtistForm vv songIdentifier = do+  postForm ("/songs/" <> uuidToText songIdentifier <> "/artists") $ do+    requiredTextInput "identifier" "artist identifier (UUID)"+    submitButton vv++songContentsCreateForm :: ViewVars -> UUID -> Html+songContentsCreateForm vv songIdentifier = do+  postForm ("/songs/" <> (packText . show $ songIdentifier) <> "/contents") $ do+    requiredTextInput "versionName" "version name"+    requiredTextInput "instrumentType" "instrument type"+    optionalMonoArea "asciiLegend" "ascii legend"+    optionalMonoArea "asciiContents" "ascii contents"+    optionalFileInput "pdfContents" "pdf file"+    optionalFileInput "guitarProContents" "guitar pro file"+    submitButton vv++songContentsEditForm :: Env -> ViewVars -> UUID -> SongContent -> Html+songContentsEditForm _ vv songIdentifier content' = do+  H.h3 "Edit contents"+  dangerPostForm+    vv+    ( "/songs/contents/"+        <> (packText . show $ content' ^. #identifier)+        <> "/delete"+    )+    $ do+      deleteButton vv+  postForm+    ( "/songs/"+        <> (packText . show $ songIdentifier)+        <> "/contents/"+        <> (packText . show $ content' ^. #identifier)+    )+    $ do+      requiredTextInput' "versionName" "version name" (Just $ content' ^. #versionName)+      requiredTextInput' "instrumentType" "instrument type" (Just $ content' ^. #instrumentType)+      optionalMonoArea' "asciiLegend" "ascii legend" (content' ^. #asciiLegend)+      optionalMonoArea' "asciiContents" "ascii contents" (content' ^. #asciiContents)+      submitButton vv

@@ -1,10 +1,10 @@ cabal-version: 1.12  name:           wikimusic-ssr-version:        0.6.0.1-description:    Please see the README at <https://gitlab.com/jjba-projects/wikimusic-ssr>-homepage:       https://gitlab.com/jjba-projects/wikimusic-ssr-bug-reports:    https://gitlab.com/jjba-projects/wikimusic-ssr/-/issues+version:        1.0.1.6+description:    Please see the README at <https://codeberg.org/jjba23/wikimusic-ssr>+homepage:       https://codeberg.org/jjba23/wikimusic-ssr+bug-reports:    https://codeberg.org/jjba23/wikimusic-ssr/-/issues author:         Josep Bigorra maintainer:     Josep Bigorra <jjbigorra@gmail.com> copyright:      2023 Josep Bigorra@@ -14,19 +14,18 @@                  extra-source-files:     README.org-    CHANGELOG.org-+     source-repository head   type: git-  location: https://gitlab.com/jjba-projects/wikimusic-ssr-  subdir: wikimusic-ssr+  location: https://codeberg.org/jjba23/wikimusic-ssr  library   exposed-modules:+      -- λ principium (beginning / prelude)+      Principium       -- λ main       WikiMusic.SSR.Config       WikiMusic.SSR.Boot-      WikiMusic.SSR.Prelude       WikiMusic.SSR.Clock.LiveClock       WikiMusic.SSR.Console.Logger       WikiMusic.SSR.Model.Config@@ -38,13 +37,19 @@       WikiMusic.SSR.Free.View       WikiMusic.SSR.Free.Backend       WikiMusic.SSR.View.Html+      WikiMusic.SSR.View.HtmlUtil       WikiMusic.SSR.View.ArtistHtml       WikiMusic.SSR.View.GenreHtml       WikiMusic.SSR.View.SongHtml+      WikiMusic.SSR.View.ErrorHtml+      WikiMusic.SSR.View.OtherHtml+             WikiMusic.SSR.View.Components.Forms       WikiMusic.SSR.View.Components.Other-      WikiMusic.SSR.View.Components.Meta+      WikiMusic.SSR.View.Components.Icons+      WikiMusic.SSR.View.Components.Footer       WikiMusic.SSR.View.Components.DetailList+      WikiMusic.SSR.View.Css       WikiMusic.SSR.Backend.Rest       WikiMusic.SSR.Language       WikiMusic.SSR.Servant.ApiSetup@@ -101,12 +106,16 @@     , servant-auth-server     , servant-multipart     , servant-client+    , prometheus-client+    , prometheus-metrics-ghc+    , wai-middleware-prometheus     , text     , containers     , filepath     , directory     , uuid     , wai+    , wai-logger     , wai-cors     , wai-extra     , warp@@ -116,6 +125,7 @@     , free-alacarte     , tomland     , blaze-html+    , blaze-markup     , wikimusic-model-hs     , wikimusic-api-spec     , http-client@@ -129,7 +139,7 @@       Paths_wikimusic_ssr   hs-source-dirs:       app-  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-T -N"   default-extensions:       DataKinds       DefaultSignatures