diff --git a/CHANGELOG.org b/CHANGELOG.org deleted file mode 100644 --- a/CHANGELOG.org +++ /dev/null diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -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] diff --git a/src/Principium.hs b/src/Principium.hs new file mode 100644 --- /dev/null +++ b/src/Principium.hs @@ -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 diff --git a/src/WikiMusic/SSR/Backend/Rest.hs b/src/WikiMusic/SSR/Backend/Rest.hs --- a/src/WikiMusic/SSR/Backend/Rest.hs +++ b/src/WikiMusic/SSR/Backend/Rest.hs @@ -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 diff --git a/src/WikiMusic/SSR/Boot.hs b/src/WikiMusic/SSR/Boot.hs --- a/src/WikiMusic/SSR/Boot.hs +++ b/src/WikiMusic/SSR/Boot.hs @@ -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 diff --git a/src/WikiMusic/SSR/Free/Backend.hs b/src/WikiMusic/SSR/Free/Backend.hs --- a/src/WikiMusic/SSR/Free/Backend.hs +++ b/src/WikiMusic/SSR/Free/Backend.hs @@ -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) diff --git a/src/WikiMusic/SSR/Free/View.hs b/src/WikiMusic/SSR/Free/View.hs --- a/src/WikiMusic/SSR/Free/View.hs +++ b/src/WikiMusic/SSR/Free/View.hs @@ -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) diff --git a/src/WikiMusic/SSR/Language.hs b/src/WikiMusic/SSR/Language.hs --- a/src/WikiMusic/SSR/Language.hs +++ b/src/WikiMusic/SSR/Language.hs @@ -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" + } } } diff --git a/src/WikiMusic/SSR/Model/Api.hs b/src/WikiMusic/SSR/Model/Api.hs --- a/src/WikiMusic/SSR/Model/Api.hs +++ b/src/WikiMusic/SSR/Model/Api.hs @@ -77,7 +77,7 @@ paletteCookieName = "wikimusic-palette" data ViewVars = ViewVars - { locale :: Language, + { language :: Language, uiMode :: UiMode, authToken :: AuthToken, songSorting :: SortOrder, diff --git a/src/WikiMusic/SSR/Model/Config.hs b/src/WikiMusic/SSR/Model/Config.hs --- a/src/WikiMusic/SSR/Model/Config.hs +++ b/src/WikiMusic/SSR/Model/Config.hs @@ -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 diff --git a/src/WikiMusic/SSR/Model/Env.hs b/src/WikiMusic/SSR/Model/Env.hs --- a/src/WikiMusic/SSR/Model/Env.hs +++ b/src/WikiMusic/SSR/Model/Env.hs @@ -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 diff --git a/src/WikiMusic/SSR/Prelude.hs b/src/WikiMusic/SSR/Prelude.hs deleted file mode 100644 --- a/src/WikiMusic/SSR/Prelude.hs +++ /dev/null @@ -1,1 +0,0 @@ -module WikiMusic.SSR.Prelude where diff --git a/src/WikiMusic/SSR/Servant/ApiSetup.hs b/src/WikiMusic/SSR/Servant/ApiSetup.hs --- a/src/WikiMusic/SSR/Servant/ApiSetup.hs +++ b/src/WikiMusic/SSR/Servant/ApiSetup.hs @@ -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 } - diff --git a/src/WikiMusic/SSR/Servant/ApiSpec.hs b/src/WikiMusic/SSR/Servant/ApiSpec.hs --- a/src/WikiMusic/SSR/Servant/ApiSpec.hs +++ b/src/WikiMusic/SSR/Servant/ApiSpec.hs @@ -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 diff --git a/src/WikiMusic/SSR/Servant/ArtistRoutes.hs b/src/WikiMusic/SSR/Servant/ArtistRoutes.hs --- a/src/WikiMusic/SSR/Servant/ArtistRoutes.hs +++ b/src/WikiMusic/SSR/Servant/ArtistRoutes.hs @@ -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") + } + ] + } diff --git a/src/WikiMusic/SSR/Servant/GenreRoutes.hs b/src/WikiMusic/SSR/Servant/GenreRoutes.hs --- a/src/WikiMusic/SSR/Servant/GenreRoutes.hs +++ b/src/WikiMusic/SSR/Servant/GenreRoutes.hs @@ -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") + } + ] + } diff --git a/src/WikiMusic/SSR/Servant/LoginRoutes.hs b/src/WikiMusic/SSR/Servant/LoginRoutes.hs --- a/src/WikiMusic/SSR/Servant/LoginRoutes.hs +++ b/src/WikiMusic/SSR/Servant/LoginRoutes.hs @@ -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 diff --git a/src/WikiMusic/SSR/Servant/PreferenceRoutes.hs b/src/WikiMusic/SSR/Servant/PreferenceRoutes.hs --- a/src/WikiMusic/SSR/Servant/PreferenceRoutes.hs +++ b/src/WikiMusic/SSR/Servant/PreferenceRoutes.hs @@ -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" diff --git a/src/WikiMusic/SSR/Servant/SongRoutes.hs b/src/WikiMusic/SSR/Servant/SongRoutes.hs --- a/src/WikiMusic/SSR/Servant/SongRoutes.hs +++ b/src/WikiMusic/SSR/Servant/SongRoutes.hs @@ -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 diff --git a/src/WikiMusic/SSR/Servant/Utilities.hs b/src/WikiMusic/SSR/Servant/Utilities.hs --- a/src/WikiMusic/SSR/Servant/Utilities.hs +++ b/src/WikiMusic/SSR/Servant/Utilities.hs @@ -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 diff --git a/src/WikiMusic/SSR/View/ArtistHtml.hs b/src/WikiMusic/SSR/View/ArtistHtml.hs --- a/src/WikiMusic/SSR/View/ArtistHtml.hs +++ b/src/WikiMusic/SSR/View/ArtistHtml.hs @@ -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) diff --git a/src/WikiMusic/SSR/View/Components/DetailList.hs b/src/WikiMusic/SSR/View/Components/DetailList.hs --- a/src/WikiMusic/SSR/View/Components/DetailList.hs +++ b/src/WikiMusic/SSR/View/Components/DetailList.hs @@ -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"] diff --git a/src/WikiMusic/SSR/View/Components/Footer.hs b/src/WikiMusic/SSR/View/Components/Footer.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/Components/Footer.hs @@ -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 diff --git a/src/WikiMusic/SSR/View/Components/Forms.hs b/src/WikiMusic/SSR/View/Components/Forms.hs --- a/src/WikiMusic/SSR/View/Components/Forms.hs +++ b/src/WikiMusic/SSR/View/Components/Forms.hs @@ -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 diff --git a/src/WikiMusic/SSR/View/Components/Icons.hs b/src/WikiMusic/SSR/View/Components/Icons.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/Components/Icons.hs @@ -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 diff --git a/src/WikiMusic/SSR/View/Components/Meta.hs b/src/WikiMusic/SSR/View/Components/Meta.hs deleted file mode 100644 --- a/src/WikiMusic/SSR/View/Components/Meta.hs +++ /dev/null @@ -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' diff --git a/src/WikiMusic/SSR/View/Components/Other.hs b/src/WikiMusic/SSR/View/Components/Other.hs --- a/src/WikiMusic/SSR/View/Components/Other.hs +++ b/src/WikiMusic/SSR/View/Components/Other.hs @@ -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)) diff --git a/src/WikiMusic/SSR/View/Components/PageTop.hs b/src/WikiMusic/SSR/View/Components/PageTop.hs --- a/src/WikiMusic/SSR/View/Components/PageTop.hs +++ b/src/WikiMusic/SSR/View/Components/PageTop.hs @@ -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)) diff --git a/src/WikiMusic/SSR/View/Css.hs b/src/WikiMusic/SSR/View/Css.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/Css.hs @@ -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"] diff --git a/src/WikiMusic/SSR/View/ErrorHtml.hs b/src/WikiMusic/SSR/View/ErrorHtml.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/ErrorHtml.hs @@ -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] diff --git a/src/WikiMusic/SSR/View/GenreHtml.hs b/src/WikiMusic/SSR/View/GenreHtml.hs --- a/src/WikiMusic/SSR/View/GenreHtml.hs +++ b/src/WikiMusic/SSR/View/GenreHtml.hs @@ -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) diff --git a/src/WikiMusic/SSR/View/Html.hs b/src/WikiMusic/SSR/View/Html.hs --- a/src/WikiMusic/SSR/View/Html.hs +++ b/src/WikiMusic/SSR/View/Html.hs @@ -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 diff --git a/src/WikiMusic/SSR/View/HtmlUtil.hs b/src/WikiMusic/SSR/View/HtmlUtil.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/HtmlUtil.hs @@ -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" "" diff --git a/src/WikiMusic/SSR/View/OtherHtml.hs b/src/WikiMusic/SSR/View/OtherHtml.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/OtherHtml.hs @@ -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 diff --git a/src/WikiMusic/SSR/View/SongHtml.hs b/src/WikiMusic/SSR/View/SongHtml.hs --- a/src/WikiMusic/SSR/View/SongHtml.hs +++ b/src/WikiMusic/SSR/View/SongHtml.hs @@ -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 diff --git a/wikimusic-ssr.cabal b/wikimusic-ssr.cabal --- a/wikimusic-ssr.cabal +++ b/wikimusic-ssr.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 name: wikimusic-ssr -version: 0.6.0.1 -description: Please see the README at -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 +homepage: https://codeberg.org/jjba23/wikimusic-ssr +bug-reports: https://codeberg.org/jjba23/wikimusic-ssr/-/issues author: Josep Bigorra maintainer: Josep Bigorra 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