diff --git a/CHANGELOG.org b/CHANGELOG.org new file mode 100644 --- /dev/null +++ b/CHANGELOG.org diff --git a/README.org b/README.org new file mode 100644 --- /dev/null +++ b/README.org @@ -0,0 +1,26 @@ +#+title: WikiMusic SSR +#+options: toc:nil + +Server side rendered (SSR) frontend for WikiMusic + +/WikiMusic/ + +#+begin_html +
+Haskell +GNU Emacs +NixOS +
+#+end_html + + +WikiMusic as a software means an ingenious combination of a server-side-rendered frontend, a powerful backend REST API, a database, and a user-interface to create a Content Management System (CMS) and a Gallery for music of all kinds, with educational intents. + +This is 100% free software, licensed under the GNU General Public License v3 or later. +[[https://www.gnu.org/licenses/gpl-3.0.en.html][Refer to the full license, on GNU's website]] + +The WikiMusic project is an invite-only community, with the goal of knowledge sharing, and not profit driven. + +[[https://www.buymeacoffee.com/jjbigorra][Please donate by clicking here]]. This helps us keep the underlying cloud infrastructure and Joe's work hours going strong. + +In this Git repository you will find the source code behind WikiMusic's frontend. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Relude +import WikiMusic.SSR.Boot qualified + +main :: (MonadIO m) => m () +main = liftIO WikiMusic.SSR.Boot.boot diff --git a/src/WikiMusic/SSR/Backend/Rest.hs b/src/WikiMusic/SSR/Backend/Rest.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Backend/Rest.hs @@ -0,0 +1,528 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.SSR.Backend.Rest () where + +import Data.Text (pack) +import Data.UUID (UUID) +import Free.AlaCarte +import Optics +import Relude +import Servant +import Servant.Client +import WikiMusic.Interaction.Model.Artist +import WikiMusic.Interaction.Model.Auth +import WikiMusic.Interaction.Model.Genre +import WikiMusic.Interaction.Model.Song +import WikiMusic.Interaction.Model.User +import WikiMusic.Model.Auth +import WikiMusic.Model.Other +import WikiMusic.SSR.Free.Backend +import WikiMusic.SSR.Model.Api +import WikiMusic.SSR.Model.Env +import WikiMusic.Servant.ApiSpec + +instance Exec Backend where + -- artists + execAlgebra (GetArtists env authToken limit offset sortOrder include next) = + 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 (CreateArtist env authToken r next) = + next =<< createArtist' env authToken r + execAlgebra (CreateArtistComment env authToken r next) = + next =<< createArtistComment' env authToken r + execAlgebra (UpsertArtistOpinion env authToken r next) = + next =<< upsertArtistOpinion' env authToken r + execAlgebra (CreateArtistArtwork env authToken r next) = + next =<< createArtistArtwork' env authToken r + execAlgebra (DeleteArtist env authToken identifier next) = + next =<< deleteArtist' env authToken identifier + execAlgebra (DeleteArtistComment env authToken identifier next) = + next =<< deleteArtistComment' env authToken identifier + execAlgebra (DeleteArtistOpinion env authToken identifier next) = + next =<< deleteArtistOpinion' env authToken identifier + execAlgebra (DeleteArtistArtwork env authToken identifier next) = + next =<< deleteArtistArtwork' env authToken identifier + execAlgebra (UpdateArtistArtworkOrder env authToken r next) = + next =<< updateArtistArtworkOrder' env authToken r + execAlgebra (EditArtist env authToken r next) = + next =<< editArtist' env authToken r + -- genres + execAlgebra (GetGenres env authToken limit offset sortOrder include next) = + 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 (CreateGenre env authToken r next) = + next =<< createGenre' env authToken r + execAlgebra (CreateGenreComment env authToken r next) = + next =<< createGenreComment' env authToken r + execAlgebra (UpsertGenreOpinion env authToken r next) = + next =<< upsertGenreOpinion' env authToken r + execAlgebra (CreateGenreArtwork env authToken r next) = + next =<< createGenreArtwork' env authToken r + execAlgebra (DeleteGenre env authToken identifier next) = + next =<< deleteGenre' env authToken identifier + execAlgebra (DeleteGenreComment env authToken identifier next) = + next =<< deleteGenreComment' env authToken identifier + execAlgebra (DeleteGenreOpinion env authToken identifier next) = + next =<< deleteGenreOpinion' env authToken identifier + execAlgebra (DeleteGenreArtwork env authToken identifier next) = + next =<< deleteGenreArtwork' env authToken identifier + execAlgebra (UpdateGenreArtworkOrder env authToken r next) = + next =<< updateGenreArtworkOrder' env authToken r + execAlgebra (EditGenre env authToken r next) = + next =<< editGenre' env authToken r + -- songs + execAlgebra (GetSongs env authToken limit offset sortOrder include next) = + 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 (CreateSong env authToken r next) = + next =<< createSong' env authToken r + execAlgebra (CreateSongComment env authToken r next) = + next =<< createSongComment' env authToken r + execAlgebra (UpsertSongOpinion env authToken r next) = + next =<< upsertSongOpinion' env authToken r + execAlgebra (CreateSongArtwork env authToken r next) = + next =<< createSongArtwork' env authToken r + execAlgebra (CreateArtistOfSong env authToken r next) = + next =<< createArtistOfSong' env authToken r + execAlgebra (DeleteArtistOfSong env authToken r next) = + next =<< deleteArtistOfSong' env authToken r + execAlgebra (DeleteSong env authToken identifier next) = + next =<< deleteSong' env authToken identifier + execAlgebra (DeleteSongComment env authToken identifier next) = + next =<< deleteSongComment' env authToken identifier + execAlgebra (DeleteSongOpinion env authToken identifier next) = + next =<< deleteSongOpinion' env authToken identifier + execAlgebra (DeleteSongArtwork env authToken identifier next) = + next =<< deleteSongArtwork' env authToken identifier + execAlgebra (UpdateSongArtworkOrder env authToken r next) = + next =<< updateSongArtworkOrder' env authToken r + execAlgebra (EditSong env authToken r next) = + next =<< editSong' env authToken r + execAlgebra (CreateSongContents env authToken r next) = + next =<< createSongContents' env authToken r + execAlgebra (DeleteSongContents env authToken identifier next) = + next =<< deleteSongContents' env authToken identifier + execAlgebra (EditSongContents env authToken r next) = + next =<< editSongContents' env authToken r + -- auth + execAlgebra (Me env authToken next) = + next =<< me' env authToken + execAlgebra (UserInvite env authToken r next) = + next =<< userInvite' env authToken r + execAlgebra (UserDelete env authToken r next) = + next =<< userDelete' env authToken r + -- more + execAlgebra (Login env loginRequest next) = + next =<< login' env loginRequest + execAlgebra (ResetPassword env r next) = + next =<< resetPassword' env r + execAlgebra (ResetPasswordDo env r next) = + next =<< resetPasswordDo' env r + execAlgebra (SystemInformation env next) = + next =<< systemInformation' env + +-- artists + +getArtists' :: (MonadIO m) => Env -> AuthToken -> Limit -> Offset -> SortOrder -> Include -> m (Either Text GetArtistsQueryResponse) +getArtists' env authToken (Limit limit) (Offset offset) sortOrder include = do + doRest env + $ getArtistsHTTP (Just $ authToken ^. #value) (Just limit) (Just offset) (Just $ sortOrder ^. #value) (Just $ include ^. #value) + +searchArtists' :: (MonadIO m) => Env -> AuthToken -> Text -> Limit -> Offset -> SortOrder -> Include -> m (Either Text GetArtistsQueryResponse) +searchArtists' env authToken search (Limit limit) (Offset offset) sortOrder include = do + 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 + doRest env + $ getArtistHTTP (Just $ authToken ^. #value) identifier Nothing (Just $ include ^. #value) + +createArtist' :: (MonadIO m) => Env -> AuthToken -> InsertArtistsRequest -> m (Either Text InsertArtistsCommandResponse) +createArtist' env authToken r = do + doRest env + $ createArtistHTTP (Just $ authToken ^. #value) r + +createArtistComment' :: (MonadIO m) => Env -> AuthToken -> InsertArtistCommentsRequest -> m (Either Text InsertArtistCommentsCommandResponse) +createArtistComment' env authToken r = do + doRest env + $ createArtistCommentHTTP (Just $ authToken ^. #value) r + +upsertArtistOpinion' :: (MonadIO m) => Env -> AuthToken -> UpsertArtistOpinionsRequest -> m (Either Text UpsertArtistOpinionsCommandResponse) +upsertArtistOpinion' env authToken r = do + doRest env + $ upsertArtistOpinionHTTP (Just $ authToken ^. #value) r + +createArtistArtwork' :: (MonadIO m) => Env -> AuthToken -> InsertArtistArtworksRequest -> m (Either Text InsertArtistArtworksCommandResponse) +createArtistArtwork' env authToken r = do + doRest env + $ createArtistArtworkHTTP (Just $ authToken ^. #value) r + +deleteArtist' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteArtist' env authToken identifier = do + doRest env + $ deleteArtistHTTP (Just $ authToken ^. #value) identifier + +deleteArtistComment' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteArtistComment' env authToken identifier = do + doRest env + $ deleteArtistCommentHTTP (Just $ authToken ^. #value) identifier + +deleteArtistOpinion' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteArtistOpinion' env authToken identifier = do + doRest env + $ deleteArtistOpinionHTTP (Just $ authToken ^. #value) identifier + +deleteArtistArtwork' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteArtistArtwork' env authToken identifier = do + doRest env + $ deleteArtistArtworkHTTP (Just $ authToken ^. #value) identifier + +updateArtistArtworkOrder' :: (MonadIO m) => Env -> AuthToken -> ArtistArtworkOrderUpdateRequest -> m (Either Text ()) +updateArtistArtworkOrder' env authToken r = do + doRest env + $ updateArtistArtworkOrderHTTP (Just $ authToken ^. #value) r + +editArtist' :: (MonadIO m) => Env -> AuthToken -> ArtistDeltaRequest -> m (Either Text ()) +editArtist' env authToken r = do + doRest env + $ editArtistHTTP (Just $ authToken ^. #value) r + +-- genres + +getGenres' :: (MonadIO m) => Env -> AuthToken -> Limit -> Offset -> SortOrder -> Include -> m (Either Text GetGenresQueryResponse) +getGenres' env authToken (Limit limit) (Offset offset) sortOrder include = do + doRest env + $ getGenresHTTP (Just $ authToken ^. #value) (Just limit) (Just offset) (Just $ sortOrder ^. #value) (Just $ include ^. #value) + +searchGenres' :: (MonadIO m) => Env -> AuthToken -> Text -> Limit -> Offset -> SortOrder -> Include -> m (Either Text GetGenresQueryResponse) +searchGenres' env authToken search (Limit limit) (Offset offset) sortOrder include = do + 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 + doRest env + $ getGenreHTTP (Just $ authToken ^. #value) identifier Nothing (Just $ include ^. #value) + +createGenre' :: (MonadIO m) => Env -> AuthToken -> InsertGenresRequest -> m (Either Text InsertGenresCommandResponse) +createGenre' env authToken r = do + doRest env + $ createGenreHTTP (Just $ authToken ^. #value) r + +createGenreComment' :: (MonadIO m) => Env -> AuthToken -> InsertGenreCommentsRequest -> m (Either Text InsertGenreCommentsCommandResponse) +createGenreComment' env authToken r = do + doRest env + $ createGenreCommentHTTP (Just $ authToken ^. #value) r + +upsertGenreOpinion' :: (MonadIO m) => Env -> AuthToken -> UpsertGenreOpinionsRequest -> m (Either Text UpsertGenreOpinionsCommandResponse) +upsertGenreOpinion' env authToken r = do + doRest env + $ upsertGenreOpinionHTTP (Just $ authToken ^. #value) r + +createGenreArtwork' :: (MonadIO m) => Env -> AuthToken -> InsertGenreArtworksRequest -> m (Either Text InsertGenreArtworksCommandResponse) +createGenreArtwork' env authToken r = do + doRest env + $ createGenreArtworkHTTP (Just $ authToken ^. #value) r + +deleteGenre' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteGenre' env authToken identifier = do + doRest env + $ deleteGenreHTTP (Just $ authToken ^. #value) identifier + +deleteGenreComment' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteGenreComment' env authToken identifier = do + doRest env + $ deleteGenreCommentHTTP (Just $ authToken ^. #value) identifier + +deleteGenreOpinion' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteGenreOpinion' env authToken identifier = do + doRest env + $ deleteGenreOpinionHTTP (Just $ authToken ^. #value) identifier + +deleteGenreArtwork' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteGenreArtwork' env authToken identifier = do + doRest env + $ deleteGenreArtworkHTTP (Just $ authToken ^. #value) identifier + +updateGenreArtworkOrder' :: (MonadIO m) => Env -> AuthToken -> GenreArtworkOrderUpdateRequest -> m (Either Text ()) +updateGenreArtworkOrder' env authToken r = do + doRest env + $ updateGenreArtworkOrderHTTP (Just $ authToken ^. #value) r + +editGenre' :: (MonadIO m) => Env -> AuthToken -> GenreDeltaRequest -> m (Either Text ()) +editGenre' env authToken r = do + doRest env + $ editGenreHTTP (Just $ authToken ^. #value) r + +-- songs + +getSongs' :: (MonadIO m) => Env -> AuthToken -> Limit -> Offset -> SortOrder -> Include -> m (Either Text GetSongsQueryResponse) +getSongs' env authToken (Limit limit) (Offset offset) sortOrder include = do + doRest env + $ getSongsHTTP (Just $ authToken ^. #value) (Just limit) (Just offset) (Just $ sortOrder ^. #value) (Just $ include ^. #value) + +searchSongs' :: (MonadIO m) => Env -> AuthToken -> Text -> Limit -> Offset -> SortOrder -> Include -> m (Either Text GetSongsQueryResponse) +searchSongs' env authToken search (Limit limit) (Offset offset) sortOrder include = do + 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 + doRest env + $ getSongHTTP (Just $ authToken ^. #value) identifier Nothing (Just $ include ^. #value) + +createSong' :: (MonadIO m) => Env -> AuthToken -> InsertSongsRequest -> m (Either Text InsertSongsCommandResponse) +createSong' env authToken r = do + doRest env + $ createSongHTTP (Just $ authToken ^. #value) r + +createSongComment' :: (MonadIO m) => Env -> AuthToken -> InsertSongCommentsRequest -> m (Either Text InsertSongCommentsCommandResponse) +createSongComment' env authToken r = do + doRest env + $ createSongCommentHTTP (Just $ authToken ^. #value) r + +upsertSongOpinion' :: (MonadIO m) => Env -> AuthToken -> UpsertSongOpinionsRequest -> m (Either Text UpsertSongOpinionsCommandResponse) +upsertSongOpinion' env authToken r = do + doRest env + $ upsertSongOpinionHTTP (Just $ authToken ^. #value) r + +createSongArtwork' :: (MonadIO m) => Env -> AuthToken -> InsertSongArtworksRequest -> m (Either Text InsertSongArtworksCommandResponse) +createSongArtwork' env authToken r = do + doRest env + $ createSongArtworkHTTP (Just $ authToken ^. #value) r + +deleteSong' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteSong' env authToken identifier = do + doRest env + $ deleteSongHTTP (Just $ authToken ^. #value) identifier + +deleteSongComment' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteSongComment' env authToken identifier = do + doRest env + $ deleteSongCommentHTTP (Just $ authToken ^. #value) identifier + +deleteSongOpinion' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteSongOpinion' env authToken identifier = do + doRest env + $ deleteSongOpinionHTTP (Just $ authToken ^. #value) identifier + +deleteSongArtwork' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteSongArtwork' env authToken identifier = do + doRest env + $ deleteSongArtworkHTTP (Just $ authToken ^. #value) identifier + +updateSongArtworkOrder' :: (MonadIO m) => Env -> AuthToken -> SongArtworkOrderUpdateRequest -> m (Either Text ()) +updateSongArtworkOrder' env authToken r = do + doRest env + $ updateSongArtworkOrderHTTP (Just $ authToken ^. #value) r + +editSong' :: (MonadIO m) => Env -> AuthToken -> SongDeltaRequest -> m (Either Text ()) +editSong' env authToken r = do + doRest env + $ editSongHTTP (Just $ authToken ^. #value) r + +createArtistOfSong' :: (MonadIO m) => Env -> AuthToken -> InsertArtistsOfSongsRequest -> m (Either Text InsertArtistsOfSongCommandResponse) +createArtistOfSong' env authToken r = do + doRest env + $ createArtistOfSongHTTP (Just $ authToken ^. #value) r + +deleteArtistOfSong' :: (MonadIO m) => Env -> AuthToken -> InsertArtistsOfSongsRequest -> m (Either Text ()) +deleteArtistOfSong' env authToken r = do + doRest env + $ deleteArtistOfSongHTTP (Just $ authToken ^. #value) r + +createSongContents' :: (MonadIO m) => Env -> AuthToken -> InsertSongContentsRequest -> m (Either Text InsertSongContentsCommandResponse) +createSongContents' env authToken r = do + doRest env + $ createSongContentsHTTP (Just $ authToken ^. #value) r + +deleteSongContents' :: (MonadIO m) => Env -> AuthToken -> UUID -> m (Either Text ()) +deleteSongContents' env authToken identifier = do + doRest env + $ deleteSongContentsHTTP (Just $ authToken ^. #value) identifier + +editSongContents' :: (MonadIO m) => Env -> AuthToken -> SongContentDeltaRequest -> m (Either Text ()) +editSongContents' env authToken r = do + doRest env + $ editSongContentsHTTP (Just $ authToken ^. #value) r + +-- auth +me' :: (MonadIO m) => Env -> AuthToken -> m (Either Text GetMeQueryResponse) +me' env authToken = doRest env $ meHTTP (Just $ authToken ^. #value) + +userInvite' :: (MonadIO m) => Env -> AuthToken -> InviteUsersRequest -> m (Either Text MakeResetPasswordLinkResponse) +userInvite' env authToken r = doRest env $ userInviteHTTP (Just $ authToken ^. #value) r + +userDelete' :: (MonadIO m) => Env -> AuthToken -> DeleteUsersRequest -> m (Either Text ()) +userDelete' env authToken r = doRest env $ userDeleteHTTP (Just $ authToken ^. #value) r + +-- more + +login' :: (MonadIO m) => Env -> LoginRequest -> m (Either Text Text) +login' env loginRequest = do + eitherResponse <- doRest env $ loginHTTP loginRequest + let maybeParsedHeaders = second (nonEmpty . map snd . filter (\(name, _) -> name == "x-wikimusic-auth") . getHeaders) eitherResponse + case maybeParsedHeaders of + Left e -> pure . Left $ e + Right Nothing -> pure . Left $ "No x-wikimusic-auth header was found!" + Right (Just h) -> pure . Right . decodeUtf8 . head $ h + +resetPassword' :: (MonadIO m) => Env -> Text -> m (Either Text MakeResetPasswordLinkResponse) +resetPassword' env r = doRest env $ resetPasswordHTTP r + +resetPasswordDo' :: (MonadIO m) => Env -> DoPasswordResetRequest -> m (Either Text ()) +resetPasswordDo' env r = doRest env $ resetPasswordDoHTTP r + +systemInformation' :: (MonadIO m) => Env -> m (Either Text SystemInformationResponse) +systemInformation' env = doRest env systemInformationHTTP + +-- +-- +-- + +doRest :: (MonadIO m) => Env -> ClientM r -> m (Either Text r) +doRest env restCall = do + eff <- liftIO $ runClientM restCall (env ^. #clientEnv) + pure $ first (pack . Relude.show) eff + +backendAPI :: Proxy BackendAPI +backendAPI = Proxy + +type BackendAPI = + WikiMusicPrivateArtistsAPI + :<|> WikiMusicPrivateGenresAPI + :<|> WikiMusicPrivateSongsAPI + :<|> WikiMusicPrivateAuthAPI + :<|> WikiMusicPublicAPI + +-- +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 +createArtistHTTP :: Maybe Text -> InsertArtistsRequest -> ClientM InsertArtistsCommandResponse +createArtistCommentHTTP :: Maybe Text -> InsertArtistCommentsRequest -> ClientM InsertArtistCommentsCommandResponse +upsertArtistOpinionHTTP :: Maybe Text -> UpsertArtistOpinionsRequest -> ClientM UpsertArtistOpinionsCommandResponse +createArtistArtworkHTTP :: Maybe Text -> InsertArtistArtworksRequest -> ClientM InsertArtistArtworksCommandResponse +deleteArtistHTTP :: Maybe Text -> UUID -> ClientM () +deleteArtistCommentHTTP :: Maybe Text -> UUID -> ClientM () +deleteArtistOpinionHTTP :: Maybe Text -> UUID -> ClientM () +deleteArtistArtworkHTTP :: Maybe Text -> UUID -> ClientM () +updateArtistArtworkOrderHTTP :: Maybe Text -> ArtistArtworkOrderUpdateRequest -> ClientM () +editArtistHTTP :: Maybe Text -> ArtistDeltaRequest -> ClientM () +-- +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 +createGenreHTTP :: Maybe Text -> InsertGenresRequest -> ClientM InsertGenresCommandResponse +createGenreCommentHTTP :: Maybe Text -> InsertGenreCommentsRequest -> ClientM InsertGenreCommentsCommandResponse +upsertGenreOpinionHTTP :: Maybe Text -> UpsertGenreOpinionsRequest -> ClientM UpsertGenreOpinionsCommandResponse +createGenreArtworkHTTP :: Maybe Text -> InsertGenreArtworksRequest -> ClientM InsertGenreArtworksCommandResponse +deleteGenreHTTP :: Maybe Text -> UUID -> ClientM () +deleteGenreCommentHTTP :: Maybe Text -> UUID -> ClientM () +deleteGenreOpinionHTTP :: Maybe Text -> UUID -> ClientM () +deleteGenreArtworkHTTP :: Maybe Text -> UUID -> ClientM () +updateGenreArtworkOrderHTTP :: Maybe Text -> GenreArtworkOrderUpdateRequest -> ClientM () +editGenreHTTP :: Maybe Text -> GenreDeltaRequest -> ClientM () +-- +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 +createSongHTTP :: Maybe Text -> InsertSongsRequest -> ClientM InsertSongsCommandResponse +createSongCommentHTTP :: Maybe Text -> InsertSongCommentsRequest -> ClientM InsertSongCommentsCommandResponse +upsertSongOpinionHTTP :: Maybe Text -> UpsertSongOpinionsRequest -> ClientM UpsertSongOpinionsCommandResponse +createSongArtworkHTTP :: Maybe Text -> InsertSongArtworksRequest -> ClientM InsertSongArtworksCommandResponse +createArtistOfSongHTTP :: Maybe Text -> InsertArtistsOfSongsRequest -> ClientM InsertArtistsOfSongCommandResponse +deleteArtistOfSongHTTP :: Maybe Text -> InsertArtistsOfSongsRequest -> ClientM () +deleteSongHTTP :: Maybe Text -> UUID -> ClientM () +deleteSongCommentHTTP :: Maybe Text -> UUID -> ClientM () +deleteSongOpinionHTTP :: Maybe Text -> UUID -> ClientM () +deleteSongArtworkHTTP :: Maybe Text -> UUID -> ClientM () +updateSongArtworkOrderHTTP :: Maybe Text -> SongArtworkOrderUpdateRequest -> ClientM () +editSongHTTP :: Maybe Text -> SongDeltaRequest -> ClientM () +createSongContentsHTTP :: Maybe Text -> InsertSongContentsRequest -> ClientM InsertSongContentsCommandResponse +deleteSongContentsHTTP :: Maybe Text -> UUID -> ClientM () +editSongContentsHTTP :: Maybe Text -> SongContentDeltaRequest -> ClientM () +-- +meHTTP :: Maybe Text -> ClientM GetMeQueryResponse +userInviteHTTP :: Maybe Text -> InviteUsersRequest -> ClientM MakeResetPasswordLinkResponse +userDeleteHTTP :: Maybe Text -> DeleteUsersRequest -> ClientM () +-- +loginHTTP :: + LoginRequest -> + ClientM + ( Headers + '[Header "x-wikimusic-auth" Text] + NoContent + ) +resetPasswordHTTP :: Text -> ClientM MakeResetPasswordLinkResponse +resetPasswordDoHTTP :: DoPasswordResetRequest -> ClientM () +systemInformationHTTP :: ClientM SystemInformationResponse +-- artists +( getArtistsHTTP + :<|> searchArtistsHTTP + :<|> getArtistHTTP + :<|> createArtistHTTP + :<|> createArtistCommentHTTP + :<|> upsertArtistOpinionHTTP + :<|> createArtistArtworkHTTP + :<|> deleteArtistHTTP + :<|> deleteArtistCommentHTTP + :<|> deleteArtistOpinionHTTP + :<|> deleteArtistArtworkHTTP + :<|> updateArtistArtworkOrderHTTP + :<|> editArtistHTTP + ) + -- genres + :<|> ( getGenresHTTP + :<|> searchGenresHTTP + :<|> getGenreHTTP + :<|> createGenreHTTP + :<|> createGenreCommentHTTP + :<|> upsertGenreOpinionHTTP + :<|> createGenreArtworkHTTP + :<|> deleteGenreHTTP + :<|> deleteGenreCommentHTTP + :<|> deleteGenreOpinionHTTP + :<|> deleteGenreArtworkHTTP + :<|> updateGenreArtworkOrderHTTP + :<|> editGenreHTTP + ) + -- songs + :<|> ( getSongsHTTP + :<|> searchSongsHTTP + :<|> getSongHTTP + :<|> createSongHTTP + :<|> createSongCommentHTTP + :<|> upsertSongOpinionHTTP + :<|> createSongArtworkHTTP + :<|> createArtistOfSongHTTP + :<|> deleteArtistOfSongHTTP + :<|> deleteSongHTTP + :<|> deleteSongCommentHTTP + :<|> deleteSongOpinionHTTP + :<|> deleteSongArtworkHTTP + :<|> updateSongArtworkOrderHTTP + :<|> editSongHTTP + :<|> createSongContentsHTTP + :<|> deleteSongContentsHTTP + :<|> editSongContentsHTTP + ) + -- auth + :<|> (meHTTP :<|> userInviteHTTP :<|> userDeleteHTTP) + -- public + :<|> (loginHTTP :<|> resetPasswordHTTP :<|> resetPasswordDoHTTP :<|> systemInformationHTTP) = + client backendAPI diff --git a/src/WikiMusic/SSR/Boot.hs b/src/WikiMusic/SSR/Boot.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Boot.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +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 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 + where + crashWithBadConfig e = error ("Bad config could not be parsed! " <> show e) + cfg args = case nonEmpty args of + Just (x :| []) -> pack 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 + where + apiSettings = setPort (cfg ^. #servant % #port) defaultSettings diff --git a/src/WikiMusic/SSR/Clock/LiveClock.hs b/src/WikiMusic/SSR/Clock/LiveClock.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Clock/LiveClock.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.SSR.Clock.LiveClock () where + +import Data.Text qualified as T +import Data.Time +import Free.AlaCarte +import Relude +import WikiMusic.SSR.Free.Clock + +instance Exec Clock where + execAlgebra (TimeElapsedUntilNow fromTime f) = do + diffWithNow fromTime >>= f + execAlgebra (Now f) = do + getCurrentTime >>= f + +diffWithNow :: (MonadIO m) => UTCTime -> m Text +diffWithNow fromTime = do + now' <- liftIO getCurrentTime + pure $ T.pack . show $ diffUTCTime now' fromTime diff --git a/src/WikiMusic/SSR/Config.hs b/src/WikiMusic/SSR/Config.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Config.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.SSR.Config (readConfig) where + +import Data.Text (unpack) +import Relude +import Toml +import WikiMusic.SSR.Model.Config + +readConfig :: (MonadIO m) => Text -> m (Either Text AppConfig) +readConfig filePath = do + parseResult <- liftIO $ decodeFileEither appConfigCodec (unpack filePath) + case parseResult of + Left e -> pure . Left $ prettyTomlDecodeErrors e + Right r -> pure . Right $ r diff --git a/src/WikiMusic/SSR/Console/Logger.hs b/src/WikiMusic/SSR/Console/Logger.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Console/Logger.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.SSR.Console.Logger () where + +import Data.ByteString.Lazy qualified as BL +import Data.Text qualified as T +import Data.Time +import Free.AlaCarte +import Relude +import WikiMusic.SSR.Free.Logger + +instance Exec Logger where + execAlgebra (LogInfo msg next) = do + now <- iso8601 + _ <- textToStdout (logExpr now "INFO" msg) + next + execAlgebra (LogError msg next) = do + now <- iso8601 + _ <- textToStderr (logExpr now "ERROR" msg) + next + execAlgebra (LogDebug msg next) = do + now <- iso8601 + _ <- textToStdout (logExpr now "DEBUG" msg) + next + +textToStdout :: (MonadIO m) => Text -> m () +textToStdout = liftIO . BL.hPutStr stdout . BL.fromStrict . encodeUtf8 . liner + +textToStderr :: (MonadIO m) => Text -> m () +textToStderr = liftIO . BL.hPutStr stderr . BL.fromStrict . encodeUtf8 . liner + +liner :: Text -> Text +liner = (<> "\n") + +-- Construct format string according to . +iso8601 :: (MonadIO m) => m Text +iso8601 = do + n <- liftIO getCurrentTime + let n' = T.pack $ formatTime defaultTimeLocale (T.unpack "%Y-%m-%dT%H:%M:%SZ") n + pure n' + +logExpr :: (Semigroup a, IsString a) => a -> a -> a -> a +logExpr now lev msg = "[" <> now <> "][" <> lev <> "] " <> msg diff --git a/src/WikiMusic/SSR/Free/Backend.hs b/src/WikiMusic/SSR/Free/Backend.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Free/Backend.hs @@ -0,0 +1,288 @@ +module WikiMusic.SSR.Free.Backend + ( getArtists, + getArtist, + Backend (..), + login, + getGenres, + getGenre, + getSongs, + getSong, + searchArtists, + searchGenres, + searchSongs, + createArtist, + createGenre, + createSong, + createSongComment, + upsertSongOpinion, + createSongArtwork, + deleteSong, + deleteSongComment, + deleteSongOpinion, + deleteSongArtwork, + updateSongArtworkOrder, + editSong, + editGenre, + updateGenreArtworkOrder, + deleteGenreArtwork, + deleteGenreOpinion, + deleteGenreComment, + deleteGenre, + createGenreArtwork, + upsertGenreOpinion, + createGenreComment, + createArtistComment, + upsertArtistOpinion, + createArtistArtwork, + deleteArtist, + deleteArtistComment, + deleteArtistOpinion, + editArtist, + updateArtistArtworkOrder, + deleteArtistArtwork, + createArtistOfSong, + deleteArtistOfSong, + createSongContents, + editSongContents, + deleteSongContents, + systemInformation, + resetPassword, + resetPasswordDo, + userInvite, + userDelete, + me, + ) +where + +import Data.UUID (UUID) +import Free.AlaCarte +import Relude +import WikiMusic.Interaction.Model.Artist +import WikiMusic.Interaction.Model.Auth +import WikiMusic.Interaction.Model.Genre +import WikiMusic.Interaction.Model.Song +import WikiMusic.Interaction.Model.User +import WikiMusic.Model.Auth +import WikiMusic.Model.Other +import WikiMusic.SSR.Model.Api +import WikiMusic.SSR.Model.Env + +type Backend :: Type -> Type +data Backend a + = -- 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) + | CreateArtist Env AuthToken InsertArtistsRequest (Either Text InsertArtistsCommandResponse -> a) + | CreateArtistComment Env AuthToken InsertArtistCommentsRequest (Either Text InsertArtistCommentsCommandResponse -> a) + | UpsertArtistOpinion Env AuthToken UpsertArtistOpinionsRequest (Either Text UpsertArtistOpinionsCommandResponse -> a) + | CreateArtistArtwork Env AuthToken InsertArtistArtworksRequest (Either Text InsertArtistArtworksCommandResponse -> a) + | DeleteArtist Env AuthToken UUID (Either Text () -> a) + | DeleteArtistComment Env AuthToken UUID (Either Text () -> a) + | DeleteArtistOpinion Env AuthToken UUID (Either Text () -> a) + | DeleteArtistArtwork Env AuthToken UUID (Either Text () -> a) + | UpdateArtistArtworkOrder Env AuthToken ArtistArtworkOrderUpdateRequest (Either Text () -> a) + | EditArtist Env AuthToken ArtistDeltaRequest (Either Text () -> a) + | -- 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) + | CreateGenre Env AuthToken InsertGenresRequest (Either Text InsertGenresCommandResponse -> a) + | CreateGenreComment Env AuthToken InsertGenreCommentsRequest (Either Text InsertGenreCommentsCommandResponse -> a) + | UpsertGenreOpinion Env AuthToken UpsertGenreOpinionsRequest (Either Text UpsertGenreOpinionsCommandResponse -> a) + | CreateGenreArtwork Env AuthToken InsertGenreArtworksRequest (Either Text InsertGenreArtworksCommandResponse -> a) + | DeleteGenre Env AuthToken UUID (Either Text () -> a) + | DeleteGenreComment Env AuthToken UUID (Either Text () -> a) + | DeleteGenreOpinion Env AuthToken UUID (Either Text () -> a) + | DeleteGenreArtwork Env AuthToken UUID (Either Text () -> a) + | UpdateGenreArtworkOrder Env AuthToken GenreArtworkOrderUpdateRequest (Either Text () -> a) + | EditGenre Env AuthToken GenreDeltaRequest (Either Text () -> a) + | -- 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) + | CreateSong Env AuthToken InsertSongsRequest (Either Text InsertSongsCommandResponse -> a) + | CreateSongComment Env AuthToken InsertSongCommentsRequest (Either Text InsertSongCommentsCommandResponse -> a) + | UpsertSongOpinion Env AuthToken UpsertSongOpinionsRequest (Either Text UpsertSongOpinionsCommandResponse -> a) + | CreateSongArtwork Env AuthToken InsertSongArtworksRequest (Either Text InsertSongArtworksCommandResponse -> a) + | CreateArtistOfSong Env AuthToken InsertArtistsOfSongsRequest (Either Text InsertArtistsOfSongCommandResponse -> a) + | DeleteArtistOfSong Env AuthToken InsertArtistsOfSongsRequest (Either Text () -> a) + | DeleteSong Env AuthToken UUID (Either Text () -> a) + | DeleteSongComment Env AuthToken UUID (Either Text () -> a) + | DeleteSongOpinion Env AuthToken UUID (Either Text () -> a) + | DeleteSongArtwork Env AuthToken UUID (Either Text () -> a) + | UpdateSongArtworkOrder Env AuthToken SongArtworkOrderUpdateRequest (Either Text () -> a) + | EditSong Env AuthToken SongDeltaRequest (Either Text () -> a) + | CreateSongContents Env AuthToken InsertSongContentsRequest (Either Text InsertSongContentsCommandResponse -> a) + | DeleteSongContents Env AuthToken UUID (Either Text () -> a) + | EditSongContents Env AuthToken SongContentDeltaRequest (Either Text () -> a) + | -- auth + Me Env AuthToken (Either Text GetMeQueryResponse -> a) + | UserInvite Env AuthToken InviteUsersRequest (Either Text MakeResetPasswordLinkResponse -> a) + | UserDelete Env AuthToken DeleteUsersRequest (Either Text () -> a) + | -- more + Login Env LoginRequest (Either Text Text -> a) + | ResetPassword Env Text (Either Text MakeResetPasswordLinkResponse -> a) + | ResetPasswordDo Env DoPasswordResetRequest (Either Text () -> a) + | SystemInformation Env (Either Text SystemInformationResponse -> a) + deriving (Functor) + +-- artists + +getArtists :: (Backend :<: f) => Env -> AuthToken -> Limit -> Offset -> SortOrder -> Include -> Free f (Either Text GetArtistsQueryResponse) +getArtists env authToken limit offset sortOrder include = injectFree (GetArtists env authToken limit offset sortOrder include Pure) + +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) + +createArtist :: (Backend :<: f) => Env -> AuthToken -> InsertArtistsRequest -> Free f (Either Text InsertArtistsCommandResponse) +createArtist env authToken r = injectFree (CreateArtist env authToken r Pure) + +createArtistComment :: (Backend :<: f) => Env -> AuthToken -> InsertArtistCommentsRequest -> Free f (Either Text InsertArtistCommentsCommandResponse) +createArtistComment env authToken r = injectFree (CreateArtistComment env authToken r Pure) + +upsertArtistOpinion :: (Backend :<: f) => Env -> AuthToken -> UpsertArtistOpinionsRequest -> Free f (Either Text UpsertArtistOpinionsCommandResponse) +upsertArtistOpinion env authToken r = injectFree (UpsertArtistOpinion env authToken r Pure) + +createArtistArtwork :: (Backend :<: f) => Env -> AuthToken -> InsertArtistArtworksRequest -> Free f (Either Text InsertArtistArtworksCommandResponse) +createArtistArtwork env authToken r = injectFree (CreateArtistArtwork env authToken r Pure) + +deleteArtist :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteArtist env authToken identifier = injectFree (DeleteArtist env authToken identifier Pure) + +deleteArtistComment :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteArtistComment env authToken identifier = injectFree (DeleteArtistComment env authToken identifier Pure) + +deleteArtistOpinion :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteArtistOpinion env authToken identifier = injectFree (DeleteArtistOpinion env authToken identifier Pure) + +deleteArtistArtwork :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteArtistArtwork env authToken identifier = injectFree (DeleteArtistArtwork env authToken identifier Pure) + +updateArtistArtworkOrder :: (Backend :<: f) => Env -> AuthToken -> ArtistArtworkOrderUpdateRequest -> Free f (Either Text ()) +updateArtistArtworkOrder env authToken r = injectFree (UpdateArtistArtworkOrder env authToken r Pure) + +editArtist :: (Backend :<: f) => Env -> AuthToken -> ArtistDeltaRequest -> Free f (Either Text ()) +editArtist env authToken r = injectFree (EditArtist env authToken r Pure) + +-- genres + +getGenres :: (Backend :<: f) => Env -> AuthToken -> Limit -> Offset -> SortOrder -> Include -> Free f (Either Text GetGenresQueryResponse) +getGenres env authToken limit offset sortOrder include = injectFree (GetGenres env authToken limit offset sortOrder include Pure) + +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) + +createGenre :: (Backend :<: f) => Env -> AuthToken -> InsertGenresRequest -> Free f (Either Text InsertGenresCommandResponse) +createGenre env authToken r = injectFree (CreateGenre env authToken r Pure) + +createGenreComment :: (Backend :<: f) => Env -> AuthToken -> InsertGenreCommentsRequest -> Free f (Either Text InsertGenreCommentsCommandResponse) +createGenreComment env authToken r = injectFree (CreateGenreComment env authToken r Pure) + +upsertGenreOpinion :: (Backend :<: f) => Env -> AuthToken -> UpsertGenreOpinionsRequest -> Free f (Either Text UpsertGenreOpinionsCommandResponse) +upsertGenreOpinion env authToken r = injectFree (UpsertGenreOpinion env authToken r Pure) + +createGenreArtwork :: (Backend :<: f) => Env -> AuthToken -> InsertGenreArtworksRequest -> Free f (Either Text InsertGenreArtworksCommandResponse) +createGenreArtwork env authToken r = injectFree (CreateGenreArtwork env authToken r Pure) + +deleteGenre :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteGenre env authToken identifier = injectFree (DeleteGenre env authToken identifier Pure) + +deleteGenreComment :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteGenreComment env authToken identifier = injectFree (DeleteGenreComment env authToken identifier Pure) + +deleteGenreOpinion :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteGenreOpinion env authToken identifier = injectFree (DeleteGenreOpinion env authToken identifier Pure) + +deleteGenreArtwork :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteGenreArtwork env authToken identifier = injectFree (DeleteGenreArtwork env authToken identifier Pure) + +updateGenreArtworkOrder :: (Backend :<: f) => Env -> AuthToken -> GenreArtworkOrderUpdateRequest -> Free f (Either Text ()) +updateGenreArtworkOrder env authToken r = injectFree (UpdateGenreArtworkOrder env authToken r Pure) + +editGenre :: (Backend :<: f) => Env -> AuthToken -> GenreDeltaRequest -> Free f (Either Text ()) +editGenre env authToken r = injectFree (EditGenre env authToken r Pure) + +-- songs + +getSongs :: (Backend :<: f) => Env -> AuthToken -> Limit -> Offset -> SortOrder -> Include -> Free f (Either Text GetSongsQueryResponse) +getSongs env authToken limit offset sortOrder include = injectFree (GetSongs env authToken limit offset sortOrder include Pure) + +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) + +createSong :: (Backend :<: f) => Env -> AuthToken -> InsertSongsRequest -> Free f (Either Text InsertSongsCommandResponse) +createSong env authToken r = injectFree (CreateSong env authToken r Pure) + +createSongComment :: (Backend :<: f) => Env -> AuthToken -> InsertSongCommentsRequest -> Free f (Either Text InsertSongCommentsCommandResponse) +createSongComment env authToken r = injectFree (CreateSongComment env authToken r Pure) + +upsertSongOpinion :: (Backend :<: f) => Env -> AuthToken -> UpsertSongOpinionsRequest -> Free f (Either Text UpsertSongOpinionsCommandResponse) +upsertSongOpinion env authToken r = injectFree (UpsertSongOpinion env authToken r Pure) + +createSongArtwork :: (Backend :<: f) => Env -> AuthToken -> InsertSongArtworksRequest -> Free f (Either Text InsertSongArtworksCommandResponse) +createSongArtwork env authToken r = injectFree (CreateSongArtwork env authToken r Pure) + +createArtistOfSong :: (Backend :<: f) => Env -> AuthToken -> InsertArtistsOfSongsRequest -> Free f (Either Text InsertArtistsOfSongCommandResponse) +createArtistOfSong env authToken r = injectFree (CreateArtistOfSong env authToken r Pure) + +deleteArtistOfSong :: (Backend :<: f) => Env -> AuthToken -> InsertArtistsOfSongsRequest -> Free f (Either Text ()) +deleteArtistOfSong env authToken r = injectFree (DeleteArtistOfSong env authToken r Pure) + +deleteSong :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteSong env authToken identifier = injectFree (DeleteSong env authToken identifier Pure) + +deleteSongComment :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteSongComment env authToken identifier = injectFree (DeleteSongComment env authToken identifier Pure) + +deleteSongOpinion :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteSongOpinion env authToken identifier = injectFree (DeleteSongOpinion env authToken identifier Pure) + +deleteSongArtwork :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteSongArtwork env authToken identifier = injectFree (DeleteSongArtwork env authToken identifier Pure) + +updateSongArtworkOrder :: (Backend :<: f) => Env -> AuthToken -> SongArtworkOrderUpdateRequest -> Free f (Either Text ()) +updateSongArtworkOrder env authToken r = injectFree (UpdateSongArtworkOrder env authToken r Pure) + +editSong :: (Backend :<: f) => Env -> AuthToken -> SongDeltaRequest -> Free f (Either Text ()) +editSong env authToken r = injectFree (EditSong env authToken r Pure) + +createSongContents :: (Backend :<: f) => Env -> AuthToken -> InsertSongContentsRequest -> Free f (Either Text InsertSongContentsCommandResponse) +createSongContents env authToken r = injectFree (CreateSongContents env authToken r Pure) + +deleteSongContents :: (Backend :<: f) => Env -> AuthToken -> UUID -> Free f (Either Text ()) +deleteSongContents env authToken identifier = injectFree (DeleteSongContents env authToken identifier Pure) + +editSongContents :: (Backend :<: f) => Env -> AuthToken -> SongContentDeltaRequest -> Free f (Either Text ()) +editSongContents env authToken r = injectFree (EditSongContents env authToken r Pure) + +me :: (Backend :<: f) => Env -> AuthToken -> Free f (Either Text GetMeQueryResponse) +me env authToken = injectFree (Me env authToken Pure) + +userInvite :: (Backend :<: f) => Env -> AuthToken -> InviteUsersRequest -> Free f (Either Text MakeResetPasswordLinkResponse) +userInvite env authToken r = injectFree (UserInvite env authToken r Pure) + +userDelete :: (Backend :<: f) => Env -> AuthToken -> DeleteUsersRequest -> Free f (Either Text ()) +userDelete env authToken r = injectFree (UserDelete env authToken r Pure) + +-- more +login :: (Backend :<: f) => Env -> LoginRequest -> Free f (Either Text Text) +login env loginRequest = injectFree (Login env loginRequest Pure) + +resetPassword :: (Backend :<: f) => Env -> Text -> Free f (Either Text MakeResetPasswordLinkResponse) +resetPassword env r = injectFree (ResetPassword env r Pure) + +resetPasswordDo :: (Backend :<: f) => Env -> DoPasswordResetRequest -> Free f (Either Text ()) +resetPasswordDo env r = injectFree (ResetPasswordDo env r Pure) + +systemInformation :: (Backend :<: f) => Env -> Free f (Either Text SystemInformationResponse) +systemInformation env = injectFree (SystemInformation env Pure) diff --git a/src/WikiMusic/SSR/Free/Clock.hs b/src/WikiMusic/SSR/Free/Clock.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Free/Clock.hs @@ -0,0 +1,22 @@ +module WikiMusic.SSR.Free.Clock + ( timeElapsedUntilNow, + now, + Clock (..), + ) +where + +import Data.Time +import Free.AlaCarte +import Relude + +type Clock :: Type -> Type +data Clock a + = TimeElapsedUntilNow UTCTime (Text -> a) + | Now (UTCTime -> a) + deriving (Functor) + +timeElapsedUntilNow :: (Clock :<: f) => UTCTime -> Free f Text +timeElapsedUntilNow fromTime = injectFree (TimeElapsedUntilNow fromTime Pure) + +now :: (Clock :<: f) => Free f UTCTime +now = injectFree (Now Pure) diff --git a/src/WikiMusic/SSR/Free/Logger.hs b/src/WikiMusic/SSR/Free/Logger.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Free/Logger.hs @@ -0,0 +1,26 @@ +module WikiMusic.SSR.Free.Logger + ( logInfo, + logError, + logDebug, + Logger (..), + ) +where + +import Free.AlaCarte +import Relude + +type Logger :: Type -> Type +data Logger a + = LogInfo Text a + | LogError Text a + | LogDebug Text a + deriving (Functor) + +logInfo :: (Logger :<: f) => Text -> Free f () +logInfo message = injectFree (LogInfo message (Pure ())) + +logError :: (Logger :<: f) => Text -> Free f () +logError message = injectFree (LogError message (Pure ())) + +logDebug :: (Logger :<: f) => Text -> Free f () +logDebug message = injectFree (LogDebug message (Pure ())) diff --git a/src/WikiMusic/SSR/Free/View.hs b/src/WikiMusic/SSR/Free/View.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Free/View.hs @@ -0,0 +1,72 @@ +module WikiMusic.SSR.Free.View + ( artistListPage, + View (..), + errorPage, + loginPage, + genreListPage, + artistDetailPage, + genreDetailPage, + songListPage, + songDetailPage, + artistCreatePage, + genreCreatePage, + songCreatePage, + ) +where + +import Free.AlaCarte +import Relude +import Text.Blaze.Html +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) + | GenreListPage Env UiMode Language Palette SortOrder GetGenresQueryResponse (Html -> a) + | GenreDetailPage Env UiMode Language Palette GetGenresQueryResponse (Html -> a) + | GenreCreatePage Env UiMode Language Palette (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) + | ErrorPage Env UiMode Language Palette Text (Html -> a) + | LoginPage Env UiMode Language Palette (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) + +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) + +artistCreatePage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Free f Html +artistCreatePage env mode language palette = injectFree (ArtistCreatePage env mode language palette 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) + +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) + +genreCreatePage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Free f Html +genreCreatePage env mode language palette = injectFree (GenreCreatePage env mode language palette 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) + +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) + +songCreatePage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Free f Html +songCreatePage env mode language palette = injectFree (SongCreatePage env mode language palette 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) + +loginPage :: (View :<: f) => Env -> UiMode -> Language -> Palette -> Free f Html +loginPage env mode language palette = injectFree (LoginPage env mode language palette Pure) diff --git a/src/WikiMusic/SSR/Language.hs b/src/WikiMusic/SSR/Language.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Language.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.SSR.Language + ( DictTerm (..), + Titles (..), + Errors (..), + Slogans (..), + LanguageDict (..), + More (..), + Forms (..), + Sortings (..), + towerOfBabel, + dictionary, + (|##|), + ) +where + +import Data.Text (unpack) +import Optics +import Relude +import WikiMusic.SSR.Model.Api + +data DictTerm = DictTerm + { en :: Text, + nl :: Text + } + deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''DictTerm + +data Titles = Titles + { wikimusicSSR :: DictTerm, + errorOccurred :: DictTerm, + artistsPage :: DictTerm, + genresPage :: DictTerm, + songsPage :: DictTerm, + login :: DictTerm + } + deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''Titles + +data Errors = Errors + { clientError :: DictTerm + } + deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''Errors + +data More = More + { likes :: DictTerm, + dislikes :: DictTerm, + artistsNav :: DictTerm, + genresNav :: DictTerm, + songsNav :: DictTerm, + loginNav :: DictTerm, + views :: DictTerm, + warningHeavyDevelopment :: DictTerm, + createdBy :: DictTerm, + createdAt :: DictTerm, + lastEditedAt :: DictTerm, + musicTuning :: DictTerm, + musicKey :: DictTerm, + musicCreationDate :: DictTerm, + albumName :: DictTerm, + albumInfoLink :: DictTerm + } + deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''More + +data Slogans = Slogans + { pageTop :: DictTerm + } + deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''Slogans + +data Forms = Forms + { email :: DictTerm, + password :: DictTerm, + submit :: DictTerm + } + deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''Forms + +data Sortings = Sortings + { alphabeticalAsc :: DictTerm, + alphabeticalDesc :: DictTerm, + createdAtAsc :: DictTerm, + createdAtDesc :: DictTerm + } + deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''Sortings + +data Buttons = Buttons + { edit :: DictTerm, + delete :: DictTerm, + like :: DictTerm, + dislike :: DictTerm + } + deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''Buttons + +data LanguageDict = LanguageDict + { titles :: Titles, + errors :: Errors, + slogans :: Slogans, + more :: More, + forms :: Forms, + sortings :: Sortings, + buttons :: Buttons + } + deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''LanguageDict + +dictionary :: LanguageDict +dictionary = + LanguageDict + { titles = + Titles + { wikimusicSSR = DictTerm {en = "WikiMusic", nl = "WikiMusic"}, + errorOccurred = DictTerm {en = "Error occurred!", nl = "Fout opgetreden"}, + artistsPage = DictTerm {en = "Artists", nl = "Artiesten"}, + genresPage = DictTerm {en = "Genres", nl = "Genres"}, + songsPage = DictTerm {en = "Songs", nl = "Nummers"}, + login = DictTerm {en = "Login", nl = "Inloggen"} + }, + forms = + Forms + { email = DictTerm {en = "email address:", nl = "emailadres:"}, + password = DictTerm {en = "password:", nl = "wachtwoord:"}, + submit = DictTerm {en = "submit", nl = "indienen"} + }, + errors = + Errors + { clientError = DictTerm {en = "Client error!", nl = "Client error!"} + }, + buttons = + Buttons + { edit = DictTerm {en = "edit", nl = "bewerken"}, + delete = DictTerm {en = "delete", nl = "verwijderen"}, + like = DictTerm {en = "like", nl = "leuk"}, + dislike = DictTerm {en = "dislike", nl = "niet leuk"} + }, + slogans = + Slogans + { pageTop = + DictTerm + { en = "Welcome to the music knowledge sharing community 🎼", + nl = "Welkom bij de gemeenschap waar je muziek kennis kan delen 🎼" + } + }, + sortings = + Sortings + { 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"} + }, + more = + More + { likes = + DictTerm + { en = "likes", + nl = "leuks" + }, + dislikes = + DictTerm + { en = "dislikes", + nl = "niet leuks" + }, + artistsNav = + DictTerm + { en = "Artists", + nl = "Artiesten" + }, + genresNav = + DictTerm + { en = "Genres", + nl = "Genres" + }, + songsNav = + DictTerm + { en = "Songs", + nl = "Nummers" + }, + loginNav = + DictTerm + { en = "Login", + nl = "Inloggen" + }, + views = + DictTerm + { en = "views", + nl = "weergaven" + }, + createdBy = + DictTerm + { en = "added by:", + nl = "toegevoeg door:" + }, + createdAt = + DictTerm + { en = "date created:", + nl = "datum gemaakt:" + }, + lastEditedAt = + DictTerm + { en = "last edited at:", + nl = "laatst bijgewerkt:" + }, + warningHeavyDevelopment = DictTerm {en = "Warning! WikiMusic is ongoing an experimental stage! Certain features will not work and are being fixed.", nl = "Let op! WikiMusic is momenteel in een experimentele periode. Hou rekening met de feit dat sommige functies niet zullen werken, er wordt aan gewerkt. "}, + musicTuning = DictTerm {en = "tuning:", nl = "stemming:"}, + 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:"} + } + } + +translateTerm :: Text -> DictTerm -> Text +translateTerm "nl" x = x ^. #nl +translateTerm _ x = x ^. #en + +towerOfBabel :: Language -> DictTerm -> Text +towerOfBabel language x = fromString . unpack $ translateTerm (language ^. #value) x + +-- towerOfBabel alias +infixl 8 |##| + +(|##|) :: DictTerm -> Language -> Text +(|##|) x language = towerOfBabel language x diff --git a/src/WikiMusic/SSR/Model/Api.hs b/src/WikiMusic/SSR/Model/Api.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Model/Api.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.SSR.Model.Api + ( AuthToken (..), + SortOrder (..), + Include (..), + UiMode (..), + Language (..), + Palette (..), + authCookieName, + localeCookieName, + uiModeCookieName, + ViewVars (..), + artistSortingCookieName, + songSortingCookieName, + genreSortingCookieName, + songAsciiSizeCookieName, + paletteCookieName, + SongAsciiSize (..), + ) +where + +import Optics +import Relude + +newtype AuthToken = AuthToken {value :: Text} deriving (Eq, Generic, Show) + +newtype SortOrder = SortOrder {value :: Text} deriving (Eq, Generic, Show) + +newtype Include = Include {value :: Text} deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''AuthToken +makeFieldLabelsNoPrefix ''SortOrder +makeFieldLabelsNoPrefix ''Include + +newtype Language = Language {value :: Text} deriving (Eq, Generic, Show) + +newtype UiMode = UiMode {value :: Text} deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''Language +makeFieldLabelsNoPrefix ''UiMode + +newtype SongAsciiSize = SongAsciiSize {value :: Text} deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''SongAsciiSize + +newtype Palette = Palette {value :: Text} deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''Palette + +localeCookieName :: Text +localeCookieName = "wikimusic-locale" + +uiModeCookieName :: Text +uiModeCookieName = "wikimusic-ui-mode" + +songAsciiSizeCookieName :: Text +songAsciiSizeCookieName = "wikimusic-song-ascii-size" + +authCookieName :: Text +authCookieName = "wikimusic-auth" + +artistSortingCookieName :: Text +artistSortingCookieName = "wikimusic-artist-sorting" + +songSortingCookieName :: Text +songSortingCookieName = "wikimusic-song-sorting" + +genreSortingCookieName :: Text +genreSortingCookieName = "wikimusic-genre-sorting" + +paletteCookieName :: Text +paletteCookieName = "wikimusic-palette" + +data ViewVars = ViewVars + { locale :: Language, + uiMode :: UiMode, + authToken :: AuthToken, + songSorting :: SortOrder, + artistSorting :: SortOrder, + genreSorting :: SortOrder, + songAsciiSize :: SongAsciiSize, + palette :: Palette + } + deriving (Eq, Generic, Show) + +makeFieldLabelsNoPrefix ''ViewVars diff --git a/src/WikiMusic/SSR/Model/Config.hs b/src/WikiMusic/SSR/Model/Config.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Model/Config.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.SSR.Model.Config + ( AppConfig (..), + ServantConfig (..), + CorsConfig (..), + CookieConfig (..), + WebFrontendConfig (..), + appConfigCodec, + ) +where + +import Optics +import Relude +import Toml + +data ServantConfig = ServantConfig + { port :: Int, + host :: Text + } + deriving (Generic, Eq, Show) + +servantConfigCodec :: TomlCodec ServantConfig +servantConfigCodec = + ServantConfig + <$> Toml.int "port" + .= (^. #port) + <*> Toml.text "host" + .= (^. #host) + +data CorsConfig = CorsConfig + { origins :: [Text], + methods :: [Text], + requestHeaders :: [Text] + } + deriving (Generic, Eq, Show) + +corsConfigCodec :: TomlCodec CorsConfig +corsConfigCodec = + CorsConfig + <$> Toml.arrayOf Toml._Text "origins" + .= (^. #origins) + <*> Toml.arrayOf Toml._Text "methods" + .= (^. #methods) + <*> Toml.arrayOf Toml._Text "request-headers" + .= (^. #requestHeaders) + +data CookieConfig = CookieConfig + { maxAge :: Int, + path :: Text, + domain :: Text, + secure :: Bool, + sameSite :: Text + } + deriving (Generic, Eq, Show) + +cookieConfigCodec :: TomlCodec CookieConfig +cookieConfigCodec = + CookieConfig + <$> Toml.int "max-age" + .= (^. #maxAge) + <*> Toml.text "path" + .= (^. #path) + <*> Toml.text "domain" + .= (^. #domain) + <*> Toml.bool "secure" + .= (^. #secure) + <*> Toml.text "same-site" + .= (^. #sameSite) + +newtype DevConfig = DevConfig + { reportedVersion :: Text + } + deriving (Generic, Eq, Show) + +devCodec :: TomlCodec DevConfig +devCodec = DevConfig <$> Toml.text "reported-version" .= (^. #reportedVersion) + +newtype WebFrontendConfig = WebFrontendConfig + { baseUrl :: Text + } + deriving (Generic, Eq, Show) + +webFrontendConfigCodec :: TomlCodec WebFrontendConfig +webFrontendConfigCodec = + WebFrontendConfig + <$> Toml.text "base-url" + .= (^. #baseUrl) + +data AppConfig = AppConfig + { servant :: ServantConfig, + cors :: CorsConfig, + cookie :: CookieConfig, + webFrontend :: WebFrontendConfig, + dev :: DevConfig + } + deriving (Generic, Eq, Show) + +appConfigCodec :: TomlCodec AppConfig +appConfigCodec = + AppConfig + <$> Toml.table servantConfigCodec "servant" + .= (^. #servant) + <*> Toml.table corsConfigCodec "cors" + .= (^. #cors) + <*> Toml.table cookieConfigCodec "cookie" + .= (^. #cookie) + <*> Toml.table webFrontendConfigCodec "web-frontend" + .= (^. #webFrontend) + <*> Toml.table devCodec "dev" + .= (^. #dev) + +makeFieldLabelsNoPrefix ''AppConfig +makeFieldLabelsNoPrefix ''ServantConfig +makeFieldLabelsNoPrefix ''CorsConfig +makeFieldLabelsNoPrefix ''CookieConfig +makeFieldLabelsNoPrefix ''WebFrontendConfig +makeFieldLabelsNoPrefix ''DevConfig diff --git a/src/WikiMusic/SSR/Model/Env.hs b/src/WikiMusic/SSR/Model/Env.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Model/Env.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module WikiMusic.SSR.Model.Env + ( Env (..), + PalettesCss (..), + ) +where + +import Data.Text +import Data.Time +import Optics +import Servant.Client +import WikiMusic.SSR.Model.Config + +data PalettesCss = PalettesCss + { green :: Text, + mauve :: Text + } + +makeFieldLabelsNoPrefix ''PalettesCss + +data Env = Env + { cfg :: AppConfig, + processStartedAt :: ZonedTime, + reportedVersion :: Text, + mainCss :: Text, + darkCss :: Text, + lightCss :: Text, + clientEnv :: ClientEnv, + palettes :: PalettesCss + } + +makeFieldLabelsNoPrefix ''Env diff --git a/src/WikiMusic/SSR/Prelude.hs b/src/WikiMusic/SSR/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Prelude.hs @@ -0,0 +1,1 @@ +module WikiMusic.SSR.Prelude where diff --git a/src/WikiMusic/SSR/Servant/ApiSetup.hs b/src/WikiMusic/SSR/Servant/ApiSetup.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Servant/ApiSetup.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedLabels #-} + +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.Middleware.Cors +import Optics +import Relude +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.View.Html () + +newClientEnv :: (MonadIO m) => m ClientEnv +newClientEnv = do + manager <- liftIO $ newManager tlsManagerSettings + pure $ clientEnv manager Nothing + where + baseUrl' = + BaseUrl + { baseUrlScheme = Https, + baseUrlHost = "api.wikimusic.jointhefreeworld.org", + baseUrlPort = 443, + baseUrlPath = "" + } + clientEnv manager cookieJar = + ClientEnv + { manager = manager, + baseUrl = baseUrl', + cookieJar = cookieJar, + makeClientRequest = defaultMakeClientRequest + } + +mkApp :: AppConfig -> IO Application +mkApp 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 + let env = + Env + { 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 + } + } + pure + . myCors (cfg ^. #cors) + $ serveWithContext wikimusicSSRServant apiCfg (server env) + where + prepareCSS = T.filter (\x -> x /= '\n' && x /= '\t') . decodeUtf8 + +server :: Env -> Server WikiMusicSSRServant +server env = + fallbackRoute + :<|> artistsRoute env + :<|> artistRoute env + :<|> artistCreateRoute env + :<|> artistCreateFormRoute env + :<|> artistLikeRoute env + :<|> artistDislikeRoute env + :<|> genresRoute env + :<|> genreRoute env + :<|> genreCreateRoute env + :<|> songsRoute env + :<|> songRoute env + :<|> songCreateRoute env + :<|> setLanguageRoute env + :<|> setArtistSortingRoute env + :<|> setGenreSortingRoute env + :<|> setSongSortingRoute env + :<|> setDarkModeRoute env + :<|> setSongAsciiSizeRoute env + :<|> setPaletteRoute env + :<|> loginFormRoute env + :<|> submitLoginRoute env + +fallbackRoute :: Handler a +fallbackRoute = + do + throwError + $ ServerError + { errHTTPCode = 302, + errReasonPhrase = "Found", + errBody = "", + errHeaders = [("Location", "/songs")] + } + +wikimusicSSRServant :: Proxy WikiMusicSSRServant +wikimusicSSRServant = Proxy + +myCors :: CorsConfig -> Middleware +myCors cfg = cors (const $ Just policy) + 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), + corsExposedHeaders = + Just + [ "content-type", + "date", + "content-length", + "access-control-allow-origin", + "access-control-allow-methods", + "access-control-allow-headers", + "access-control-request-method", + "access-control-request-headers" + ], + corsMaxAge = Nothing, + corsVaryOrigin = False, + corsRequireOrigin = False, + corsIgnoreFailures = False + } diff --git a/src/WikiMusic/SSR/Servant/ApiSpec.hs b/src/WikiMusic/SSR/Servant/ApiSpec.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Servant/ApiSpec.hs @@ -0,0 +1,65 @@ +module WikiMusic.SSR.Servant.ApiSpec (WikiMusicSSRServant) where + +import Data.UUID (UUID) +import Relude +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 () + +type WikiMusicSSRServant = + Get '[ServantBlaze.HTML] NoContent + :<|> "artists" + :> WithCookie + :> QueryParam "sort-order" Text + :> QueryParam "limit" Int + :> QueryParam "offset" Int + :> GetHtml + :<|> "artists" :> WithCookie :> Capture "identifier" UUID :> GetHtml + :<|> "artists" :> "create" :> WithCookie :> GetHtml + :<|> "artists" :> "create" :> WithCookie :> PostDataForm + :<|> "artists" :> "like" :> WithCookie :> WithReferer :> Capture "identifier" UUID :> PostNoFields + :<|> "artists" :> "dislike" :> WithCookie :> WithReferer :> Capture "identifier" UUID :> PostNoFields + :<|> "genres" + :> WithCookie + :> QueryParam "sort-order" Text + :> QueryParam "limit" Int + :> QueryParam "offset" Int + :> GetHtml + :<|> "genres" :> WithCookie :> Capture "identifier" UUID :> GetHtml + :<|> "genres" :> "create" :> WithCookie :> GetHtml + :<|> "songs" + :> WithCookie + :> QueryParam "sort-order" Text + :> QueryParam "limit" Int + :> QueryParam "offset" Int + :> GetHtml + :<|> "songs" :> WithCookie :> Capture "identifier" UUID :> GetHtml + :<|> "songs" :> "create" :> WithCookie :> GetHtml + :<|> "user-preferences" :> "locale" :> WithReferer :> CookieForm + :<|> "user-preferences" :> "artist-sorting" :> WithReferer :> CookieForm + :<|> "user-preferences" :> "genre-sorting" :> WithReferer :> CookieForm + :<|> "user-preferences" :> "song-sorting" :> WithReferer :> CookieForm + :<|> "user-preferences" :> "dark-mode" :> WithReferer :> CookieForm + :<|> "user-preferences" :> "song-ascii-size" :> WithReferer :> CookieForm + :<|> "user-preferences" :> "palette" :> WithReferer :> CookieForm + :<|> "login" :> WithCookie :> GetHtml + :<|> "login" :> CookieForm + +type PostDataForm = + MultipartForm Mem (MultipartData Mem) + :> Post '[ServantBlaze.HTML] (Headers '[Header "Location" Text] NoContent) + +type PostNoFields = Post '[ServantBlaze.HTML] (Headers '[Header "Location" Text] NoContent) + +type CookieForm = + MultipartForm Mem (MultipartData Mem) + :> Post '[ServantBlaze.HTML] (Headers '[Header "Set-Cookie" Text, Header "Location" Text] NoContent) + +type GetHtml = Get '[ServantBlaze.HTML] Html + +type WithCookie = Header "cookie" Text + +type WithReferer = Header "referer" Text diff --git a/src/WikiMusic/SSR/Servant/ArtistRoutes.hs b/src/WikiMusic/SSR/Servant/ArtistRoutes.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Servant/ArtistRoutes.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedLabels #-} + +module WikiMusic.SSR.Servant.ArtistRoutes + ( artistsRoute, + artistRoute, + artistCreateRoute, + artistCreateFormRoute, + artistLikeRoute, + artistDislikeRoute, + ) +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 Servant +import Servant.Multipart +import Text.Blaze.Html as Html +import WikiMusic.Interaction.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) + maybeArtists + (exec @View . artistListPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette) sortOrder) + where + viewVars = viewVarsFromCookies cookie + sortOrder = maybe (viewVars ^. #artistSorting) SortOrder givenSortOrder + +artistRoute :: (MonadIO m) => Env -> Maybe Text -> UUID -> m Html +artistRoute env cookie identifier = do + maybeArtists <- + liftIO + $ exec @Backend + ( getArtist + env + (viewVars ^. #authToken) + identifier + (Include {value = "artworks,comments,opinions"}) + ) + eitherView + env + (viewVars ^. #uiMode) + (viewVars ^. #locale) + (viewVars ^. #palette) + maybeArtists + (exec @View . artistDetailPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette)) + where + viewVars = viewVarsFromCookies cookie + +artistCreateRoute :: (MonadIO m) => Env -> Maybe Text -> m Html +artistCreateRoute env cookie = do + liftIO $ exec @View (artistCreatePage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette)) + where + viewVars = viewVarsFromCookies 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")] + } + where + viewVars = viewVarsFromCookies cookie + r = + InsertArtistsRequest + { artists = + [ InsertArtistsRequestItem + { displayName = fromForm multipartData "" "displayName", + spotifyUrl = maybeFromForm multipartData "spotifyUrl", + youtubeUrl = maybeFromForm multipartData "youtubeUrl", + soundcloudUrl = maybeFromForm multipartData "soundcloudUrl", + wikipediaUrl = maybeFromForm multipartData "wikipediaUrl", + description = maybeFromForm multipartData "description" + } + ] + } + +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)] + } + where + viewVars = viewVarsFromCookies cookie + r = + UpsertArtistOpinionsRequest + { artistOpinions = + [ UpsertArtistOpinionsRequestItem + { artistIdentifier = identifier, + isLike = True + } + ] + } + +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)] + } + where + viewVars = viewVarsFromCookies cookie + r = + UpsertArtistOpinionsRequest + { artistOpinions = + [ UpsertArtistOpinionsRequestItem + { artistIdentifier = identifier, + isLike = False + } + ] + } diff --git a/src/WikiMusic/SSR/Servant/GenreRoutes.hs b/src/WikiMusic/SSR/Servant/GenreRoutes.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Servant/GenreRoutes.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedLabels #-} + +module WikiMusic.SSR.Servant.GenreRoutes + ( genresRoute, + genreRoute, + genreCreateRoute, + ) +where + +import Data.UUID (UUID) +import Free.AlaCarte +import Optics +import Relude +import Text.Blaze.Html as Html +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) + maybeGenres + (exec @View . genreListPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette) sortOrder) + where + viewVars = viewVarsFromCookies cookie + sortOrder = maybe (viewVars ^. #genreSorting) SortOrder givenSortOrder + +genreRoute :: (MonadIO m) => Env -> Maybe Text -> UUID -> m Html +genreRoute env cookie identifier = do + maybeGenres <- + liftIO + $ exec @Backend + ( getGenre + env + (viewVars ^. #authToken) + identifier + (Include {value = "artworks,comments,opinions"}) + ) + eitherView + env + (viewVars ^. #uiMode) + (viewVars ^. #locale) + (viewVars ^. #palette) + maybeGenres + (exec @View . genreDetailPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette)) + where + viewVars = viewVarsFromCookies cookie + +genreCreateRoute :: (MonadIO m) => Env -> Maybe Text -> m Html +genreCreateRoute env cookie = do + liftIO $ exec @View (genreCreatePage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette)) + where + viewVars = viewVarsFromCookies cookie diff --git a/src/WikiMusic/SSR/Servant/LoginRoutes.hs b/src/WikiMusic/SSR/Servant/LoginRoutes.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Servant/LoginRoutes.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedLabels #-} + +module WikiMusic.SSR.Servant.LoginRoutes (submitLoginRoute, loginFormRoute) 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 Servant +import Servant.Multipart +import Text.Blaze.Html as Html +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 () + +submitLoginRoute :: (MonadIO m, MonadError ServerError m) => Env -> MultipartData tag -> m a +submitLoginRoute env multipartData = do + 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)]) + where + email = T.unpack $ fromForm multipartData "" "email" + password = T.unpack $ 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)) + where + viewVars = viewVarsFromCookies cookie diff --git a/src/WikiMusic/SSR/Servant/PreferenceRoutes.hs b/src/WikiMusic/SSR/Servant/PreferenceRoutes.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Servant/PreferenceRoutes.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedLabels #-} + +module WikiMusic.SSR.Servant.PreferenceRoutes + ( setLanguageRoute, + setArtistSortingRoute, + setGenreSortingRoute, + setSongSortingRoute, + setDarkModeRoute, + setSongAsciiSizeRoute, + setPaletteRoute, + ) +where + +import Control.Monad.Error.Class +import Data.Map qualified as Map +import Optics +import Relude +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)]) + 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)]) + 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)]) + 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)]) + 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)]) + 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)]) + 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')]) + where + palette' = fromForm multipartData "mauve" "palette" diff --git a/src/WikiMusic/SSR/Servant/SongRoutes.hs b/src/WikiMusic/SSR/Servant/SongRoutes.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Servant/SongRoutes.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedLabels #-} + +module WikiMusic.SSR.Servant.SongRoutes + ( songsRoute, + songRoute, + songCreateRoute, + ) +where + +import Data.UUID (UUID) +import Free.AlaCarte +import Optics +import Relude +import Text.Blaze.Html as Html +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 () + +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) + maybeSongs + (exec @View . songListPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette) sortOrder) + where + viewVars = viewVarsFromCookies cookie + sortOrder = maybe (viewVars ^. #songSorting) SortOrder givenSortOrder + +songRoute :: (MonadIO m) => Env -> Maybe Text -> UUID -> m Html +songRoute env cookie identifier = do + maybeSongs <- + liftIO + $ exec @Backend + ( getSong + env + (viewVars ^. #authToken) + identifier + (Include {value = "artworks,comments,opinions,contents"}) + ) + eitherView + env + (viewVars ^. #uiMode) + (viewVars ^. #locale) + (viewVars ^. #palette) + maybeSongs + (exec @View . songDetailPage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette) (viewVars ^. #songAsciiSize)) + where + viewVars = viewVarsFromCookies cookie + +songCreateRoute :: (MonadIO m) => Env -> Maybe Text -> m Html +songCreateRoute env cookie = do + liftIO $ exec @View (songCreatePage env (viewVars ^. #uiMode) (viewVars ^. #locale) (viewVars ^. #palette)) + where + viewVars = viewVarsFromCookies cookie diff --git a/src/WikiMusic/SSR/Servant/Utilities.hs b/src/WikiMusic/SSR/Servant/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/Servant/Utilities.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuasiQuotes #-} + +module WikiMusic.SSR.Servant.Utilities + ( fromForm, + setCookieRoute, + encodeToken, + mkCookieData, + mkCookieMap, + decodeToken, + eitherView, + viewVarsFromCookies, + maybeFromForm, + ) +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 Servant +import Servant.Multipart +import Text.Blaze.Html +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 +fromForm multipart fallback name = + maybe fallback head + . nonEmpty + . map iValue + . filter (\i -> iName i == name) + $ inputs multipart + +maybeFromForm :: MultipartData tag -> Text -> Maybe Text +maybeFromForm multipart name = case rawVal of + (Just "") -> Nothing + (Just x) -> Just x + Nothing -> Nothing + where + rawVal = + fmap head + . nonEmpty + . map iValue + . filter (\i -> iName i == name) + $ inputs multipart + +setCookieRoute :: (MonadError ServerError m) => CookieConfig -> Text -> Map Text Text -> m a +setCookieRoute cookieConfig newLocation cookieMap = + throwError + $ ServerError + { errHTTPCode = 302, + errReasonPhrase = "Found", + errBody = "", + errHeaders = + ("Location", encodeUtf8 newLocation) : cookieHeaders + } + where + mkCookieHeaders (cookieName, cookieValue) = + ( "Set-Cookie", + fromString + . T.unpack + . mkCookieData cookieConfig + $ [trimming|$cookieName=$cookieValue|] + ) + cookieHeaders = map mkCookieHeaders (Map.assocs cookieMap) + +mkCookieData :: CookieConfig -> Text -> Text +mkCookieData cookieConfig dyn = [trimming|$dyn; HttpOnly; $sameSite; Domain=$domain; Path=/; Max-Age=$maxAge $secureSuffix |] + where + maxAge = show $ cookieConfig ^. #maxAge + domain = cookieConfig ^. #domain + sameSite = cookieConfig ^. #sameSite + secureSuffix = if cookieConfig ^. #secure then "; Secure" else "" + +mkCookieMap :: Maybe Text -> Map Text Text +mkCookieMap cookie = do + let diffCookies = maybe [] (T.splitOn "; ") cookie + cookieParser [a, b] = Just (a, b) + cookieParser _ = Nothing + 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 {..} + 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)} + artistSorting = + SortOrder + { value = fromMaybe "created-at-desc" (cookieMap Map.!? artistSortingCookieName) + } + songSorting = + SortOrder + { value = fromMaybe "created-at-desc" (cookieMap Map.!? songSortingCookieName) + } + genreSorting = + SortOrder + { value = fromMaybe "created-at-desc" (cookieMap Map.!? genreSortingCookieName) + } + palette = Palette {value = fromMaybe "mauve" (cookieMap Map.!? paletteCookieName)} diff --git a/src/WikiMusic/SSR/View/ArtistHtml.hs b/src/WikiMusic/SSR/View/ArtistHtml.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/ArtistHtml.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.SSR.View.ArtistHtml + ( artistListPage', + artistDetailPage', + artistCreatePage', + ) +where + +import Data.Map qualified as Map +import Optics +import Relude +import Text.Blaze.Html +import Text.Blaze.Html5 as H +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 + +artistListPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> SortOrder -> GetArtistsQueryResponse -> m Html +artistListPage' env mode language palette sortOrder xs = do + sharedHead <- mkSharedHead env mode palette (dictionary ^. #titles % #artistsPage |##| language) + pure $ H.html $ do + sharedHead + body $ section $ do + sharedPageTop (Just $ dictionary ^. #titles % #artistsPage |##| language) mode language palette + section ! class_ "flex direction-row justify-content-center gap-small align-items-baseline" $ 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 + where + sortedXs = + mapMaybe + (\identifier -> (xs ^. #artists) Map.!? 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 (dictionary ^. #titles % #artistsPage |##| language) + pure $ H.html $ do + sharedHead + body $ section $ do + sharedPageTop Nothing mode language palette + entityDetails language "artists" x + +artistCreatePage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> m Html +artistCreatePage' env mode language palette = do + sharedHead <- mkSharedHead env mode palette (dictionary ^. #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 diff --git a/src/WikiMusic/SSR/View/Components/DetailList.hs b/src/WikiMusic/SSR/View/Components/DetailList.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/Components/DetailList.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.SSR.View.Components.DetailList + ( detailList, + detailListEntry, + ) +where + +import Relude +import Text.Blaze.Html +import Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes as A + +detailListEntry :: Text -> Html -> Html +detailListEntry key val = do + H.div ! class_ "flex direction-row gap-small align-items-baseline" $ do + dt . small . text $ key + dd . small $ val + +detailList :: Html -> Html +detailList = dl ! class_ "margin-top-medium flex direction-column gap-small align-items-baseline" diff --git a/src/WikiMusic/SSR/View/Components/Forms.hs b/src/WikiMusic/SSR/View/Components/Forms.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/Components/Forms.hs @@ -0,0 +1,111 @@ +{-# 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, + ) +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.Language +import WikiMusic.SSR.Model.Api + +mkSortingForm :: Language -> SortOrder -> Text -> Text -> Html +mkSortingForm language sortOrder action' fieldName = section + $ H.form + ! action (fromString . T.unpack $ action') + ! method "POST" + ! enctype "multipart/form-data" + $ do + select ! onchange "this.form.submit()" ! name (fromString . T.unpack $ 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) + $ text ("↕ " <> snd o) + entries = + [ ("display-name-asc", dictionary ^. #sortings % #alphabeticalAsc |##| language), + ("display-name-desc", dictionary ^. #sortings % #alphabeticalDesc |##| language), + ("created-at-asc", dictionary ^. #sortings % #createdAtAsc |##| language), + ("created-at-desc", dictionary ^. #sortings % #createdAtDesc |##| language) + ] + +requiredTextInput :: Text -> Text -> Html +requiredTextInput name' displayLabel = formInput name' displayLabel True "text" + +requiredTextArea :: Text -> Text -> Html +requiredTextArea name' displayLabel = formArea name' displayLabel True "text" + +optionalTextInput :: Text -> Text -> Html +optionalTextInput name' displayLabel = formInput name' displayLabel False "text" + +optionalTextArea :: Text -> Text -> Html +optionalTextArea name' displayLabel = formArea name' displayLabel False "text" + +requiredEmailInput :: Text -> Text -> Html +requiredEmailInput name' displayLabel = formInput name' displayLabel True "email" + +requiredPasswordInput :: Text -> Text -> Html +requiredPasswordInput name' displayLabel = formInput name' displayLabel True "password" + +formInput :: Text -> Text -> Bool -> AttributeValue -> Html +formInput name' displayLabel isRequired type' = 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' + where + name'' = fromString . T.unpack $ name' + +formArea :: Text -> Text -> Bool -> AttributeValue -> Html +formArea name' displayLabel isRequired type' = 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.textarea ! class_ "" !? (isRequired, required "") ! A.name name'' ! A.id name'' ! type_ type' $ "" + where + name'' = fromString . T.unpack $ name' + +submitButton :: Language -> Html +submitButton language = + button ! A.class_ "background-success border-success align-self-flex-end" ! type_ "submit" $ do + H.span "✓" + text $ dictionary ^. #forms % #submit |##| 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') + ! enctype "multipart/form-data" + +postForm' :: Text -> Text -> Html -> Html +postForm' action' class' = + H.form + ! class_ (fromString . T.unpack $ class') + ! method "POST" + ! action (fromString . T.unpack $ action') + ! enctype "multipart/form-data" diff --git a/src/WikiMusic/SSR/View/Components/Meta.hs b/src/WikiMusic/SSR/View/Components/Meta.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/Components/Meta.hs @@ -0,0 +1,37 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/Components/Other.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.SSR.View.Components.Other + ( likeCount, + dislikeCount, + simpleEntityCard, + imageCarousel, + warningBanner, + 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 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 + . show + . length + $ Map.elems + $ Map.filter (^. #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 + . show + . length + $ Map.elems + $ Map.filter (^. #opinion % #isDislike) (entity ^. #opinions) + +mkIdentifierHref :: Text -> UUID -> AttributeValue +mkIdentifierHref path identifier = fromString ("/" <> T.unpack 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 (dictionary ^. #more % #likes |##| language) (text $ likeCount entity) + detailListEntry (dictionary ^. #more % #dislikes |##| language) (text $ dislikeCount entity) + detailListEntry (dictionary ^. #more % #views |##| language) (text $ T.pack . show $ entity ^. #viewCount) + where + artworks = Relude.map (\x -> x ^. #artwork) (Map.elems $ entity ^. #artworks) :: [Artwork] + maybeImg = maybe (H.span "") (toImg . Relude.head) (nonEmpty artworks) + toImg x = + a + ! href (mkIdentifierHref path (entity ^. #identifier)) + $ img + ! customAttribute "loading" "lazy" + ! src (fromString . T.unpack $ x ^. #contentUrl) + +imageCarousel :: [Artwork] -> Html +imageCarousel artworks = do + section ! class_ "slider" $ do + mapM_ + ( \x -> + img + ! customAttribute "loading" "lazy" + ! src (fromString . T.unpack $ x ^. #contentUrl) + ) + artworks + +entityDetailsSkeleton :: Html -> Html -> Html +entityDetailsSkeleton slot0 slot1 = do + H.div ! class_ "flex direction-row justify-content-space-evenly" $ do + H.div ! class_ "col" $ do + slot0 + H.div ! class_ "col" $ 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 = do + entityDetailsSkeleton slot0 slot1 + 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_ "" $ do + a + ! href (fromString ("/" <> path' <> "/edit/" <> show (x ^. #identifier))) + $ button + $ text (dictionary ^. #buttons % #edit |##| language) + a + ! href (fromString ("/" <> path' <> "/delete/" <> show (x ^. #identifier))) + $ button + $ text (dictionary ^. #buttons % #delete |##| language) + mapM_ (p . text) (x ^. #description) + + 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 (dictionary ^. #buttons % #like |##| language) + postForm' (fromString ("/" <> path' <> "/dislike/" <> show (x ^. #identifier))) "" $ do + button ! type_ "submit" $ do + H.span "-" + text (dictionary ^. #buttons % #dislike |##| language) + + section $ detailList $ do + detailListEntry (dictionary ^. #more % #views |##| language) (Relude.show $ x ^. #viewCount) + detailListEntry (dictionary ^. #more % #createdAt |##| language) (Relude.show $ x ^. #createdAt) + mapM_ + (detailListEntry (dictionary ^. #more % #lastEditedAt |##| language)) + (Relude.show <$> x ^. #lastEditedAt) + detailListEntry (dictionary ^. #more % #createdBy |##| language) (Relude.show $ x ^. #createdBy) + + hr + entityLinks + +warningBanner :: Language -> Html +warningBanner language = + section ! class_ "warning-section text-align-center" $ do + small + ! class_ "warning-text" + $ text + (dictionary ^. #more % #warningHeavyDevelopment |##| language) diff --git a/src/WikiMusic/SSR/View/Components/PageTop.hs b/src/WikiMusic/SSR/View/Components/PageTop.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/Components/PageTop.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.SSR.View.Components.PageTop + ( sharedPageTop, + ) +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.Language +import WikiMusic.SSR.Model.Api +import WikiMusic.SSR.View.Components.Other + +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 (dictionary ^. #titles % #wikimusicSSR |##| language) + em + ! class_ "margin-top-large font-size-large font-weight-300" + $ text (dictionary ^. #slogans % #pageTop |##| language) + + 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" + + 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" $ "☾ dark mode" + option !? ((mode ^. #value) == "light", selected "true") ! value "light" $ "☼ 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" + + 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' + +myNav :: Language -> Html +myNav language = do + hr + nav $ ol $ do + li $ a ! class_ "nav-link scale-on-hover" ! href "/songs" $ text (dictionary ^. #more % #songsNav |##| language) + li $ a ! class_ "nav-link scale-on-hover" ! href "/artists" $ text (dictionary ^. #more % #artistsNav |##| language) + li $ a ! class_ "nav-link scale-on-hover" ! href "/genres" $ text (dictionary ^. #more % #genresNav |##| language) + li $ a ! class_ "nav-link scale-on-hover" ! href "/login" $ text (dictionary ^. #more % #loginNav |##| language) + hr diff --git a/src/WikiMusic/SSR/View/GenreHtml.hs b/src/WikiMusic/SSR/View/GenreHtml.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/GenreHtml.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.SSR.View.GenreHtml + ( genreListPage', + genreDetailPage', + genreCreatePage', + ) +where + +import Data.Map qualified as Map +import Optics +import Relude +import Text.Blaze.Html +import Text.Blaze.Html5 as H +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 + +genreListPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> SortOrder -> GetGenresQueryResponse -> m Html +genreListPage' env mode language palette sortOrder xs = do + sharedHead <- mkSharedHead env mode palette (dictionary ^. #titles % #genresPage |##| language) + pure $ H.html $ do + sharedHead + body $ section $ do + sharedPageTop (Just $ dictionary ^. #titles % #genresPage |##| language) mode language palette + section ! class_ "flex direction-row justify-content-center gap-small align-items-baseline" $ 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 + where + sortedXs = + mapMaybe + (\identifier -> (xs ^. #genres) Map.!? 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 (dictionary ^. #titles % #genresPage |##| language) + pure $ H.html $ do + sharedHead + body $ section $ do + sharedPageTop Nothing mode language palette + entityDetails language "genres" x + +genreCreatePage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> m Html +genreCreatePage' env mode language palette = do + sharedHead <- mkSharedHead env mode palette (dictionary ^. #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 diff --git a/src/WikiMusic/SSR/View/Html.hs b/src/WikiMusic/SSR/View/Html.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/Html.hs @@ -0,0 +1,75 @@ +{-# 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 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.SongHtml +import Prelude qualified + +instance Exec View where + 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 (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 (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 (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 (dictionary ^. #titles % #errorOccurred |##| language) + pure $ H.html $ do + sharedHead + body $ section $ do + sharedPageTop (Just $ dictionary ^. #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 (dictionary ^. #titles % #login |##| language) + pure $ H.html $ do + sharedHead + body $ section $ do + sharedPageTop (Just $ dictionary ^. #titles % #login |##| language) mode language palette + section $ postForm "/login" $ do + requiredEmailInput "email" (dictionary ^. #forms % #email |##| language) + requiredPasswordInput "password" (dictionary ^. #forms % #password |##| language) + submitButton language diff --git a/src/WikiMusic/SSR/View/SongHtml.hs b/src/WikiMusic/SSR/View/SongHtml.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/SSR/View/SongHtml.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.SSR.View.SongHtml + ( songListPage', + songDetailPage', + songCreatePage', + ) +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 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.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 + +songListPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> SortOrder -> GetSongsQueryResponse -> m Html +songListPage' env mode language palette sortOrder xs = do + sharedHead <- mkSharedHead env mode palette (dictionary ^. #titles % #songsPage |##| language) + pure $ H.html $ do + sharedHead + body $ section $ do + sharedPageTop (Just $ dictionary ^. #titles % #songsPage |##| language) mode language palette + section ! class_ "flex direction-row justify-content-center gap-small align-items-baseline" $ 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 + where + sortedXs = + mapMaybe + (\identifier -> (xs ^. #songs) Map.!? 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 (dictionary ^. #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) + where + fontSizes :: [Text] + fontSizes = ["xx-small", "x-small", "small", "medium", "large", "larger", "x-large", "xx-large"] + +songDetails :: Language -> Song -> Html +songDetails language x = do + section $ detailList $ do + mapM_ + (detailListEntry (dictionary ^. #more % #musicTuning |##| language) . text) + (x ^. #musicTuning) + mapM_ + (detailListEntry (dictionary ^. #more % #musicKey |##| language) . text) + (x ^. #musicKey) + mapM_ + (detailListEntry (dictionary ^. #more % #musicCreationDate |##| language) . text) + (x ^. #musicCreationDate) + mapM_ + (detailListEntry (dictionary ^. #more % #albumName |##| language) . text) + (x ^. #albumName) + mapM_ + (detailListEntry (dictionary ^. #more % #albumInfoLink |##| 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) + + detailList $ do + mapM_ + (detailListEntry (dictionary ^. #more % #lastEditedAt |##| language)) + (Relude.show <$> v ^. #lastEditedAt) + detailListEntry (dictionary ^. #more % #createdAt |##| language) (Relude.show $ v ^. #createdAt) + detailListEntry (dictionary ^. #more % #createdBy |##| language) (Relude.show $ v ^. #createdBy) + + 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 -> UiMode -> Language -> Palette -> m Html +songCreatePage' env mode language palette = do + sharedHead <- mkSharedHead env mode palette (dictionary ^. #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 diff --git a/wikimusic-ssr.cabal b/wikimusic-ssr.cabal new file mode 100644 --- /dev/null +++ b/wikimusic-ssr.cabal @@ -0,0 +1,158 @@ +cabal-version: 1.12 + +name: wikimusic-ssr +version: 0.6.0.0 +description: Please see the README at +homepage: https://gitlab.com/jjba-projects/wikimusic-ssr +bug-reports: https://gitlab.com/jjba-projects/wikimusic-ssr/-/issues +author: Josep Bigorra +maintainer: Josep Bigorra +copyright: 2023 Josep Bigorra +license: GPL-3 +build-type: Simple + +extra-source-files: + README.org + CHANGELOG.org + +source-repository head + type: git + location: https://gitlab.com/jjba-projects/wikimusic-ssr + subdir: wikimusic-ssr + +library + exposed-modules: + -- λ main + WikiMusic.SSR.Config + WikiMusic.SSR.Boot + WikiMusic.SSR.Prelude + WikiMusic.SSR.Clock.LiveClock + WikiMusic.SSR.Console.Logger + WikiMusic.SSR.Model.Config + WikiMusic.SSR.Model.Env + WikiMusic.SSR.Model.Api + WikiMusic.SSR.View.Components.PageTop + WikiMusic.SSR.Free.Clock + WikiMusic.SSR.Free.Logger + WikiMusic.SSR.Free.View + WikiMusic.SSR.Free.Backend + WikiMusic.SSR.View.Html + WikiMusic.SSR.View.ArtistHtml + WikiMusic.SSR.View.GenreHtml + WikiMusic.SSR.View.SongHtml + WikiMusic.SSR.View.Components.Forms + WikiMusic.SSR.View.Components.Other + WikiMusic.SSR.View.Components.Meta + WikiMusic.SSR.View.Components.DetailList + WikiMusic.SSR.Backend.Rest + WikiMusic.SSR.Language + WikiMusic.SSR.Servant.ApiSetup + WikiMusic.SSR.Servant.ApiSpec + WikiMusic.SSR.Servant.Utilities + WikiMusic.SSR.Servant.PreferenceRoutes + WikiMusic.SSR.Servant.LoginRoutes + WikiMusic.SSR.Servant.ArtistRoutes + WikiMusic.SSR.Servant.GenreRoutes + WikiMusic.SSR.Servant.SongRoutes + + other-modules: + Paths_wikimusic_ssr + hs-source-dirs: + src + ghc-options: -Wall -threaded + default-extensions: + DataKinds + DefaultSignatures + DuplicateRecordFields + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + RecordWildCards + TypeFamilies + ViewPatterns + + build-depends: + aeson + , async + , base < 5 + , bytestring + , keuringsdienst + , keys + , mtl + , optics + , optparse-applicative + , relude + , time + , servant + , servant-blaze + , servant-server + , servant-auth-server + , servant-multipart + , servant-client + , text + , containers + , filepath + , directory + , uuid + , wai + , wai-cors + , wai-extra + , warp + , base64-bytestring + , neat-interpolation + , HTTP + , free-alacarte + , tomland + , blaze-html + , wikimusic-model-hs + , wikimusic-api-spec + , http-client + , http-client-tls + , base16-bytestring + default-language: GHC2021 + +executable wikimusic-ssr-exe + main-is: Main.hs + other-modules: + Paths_wikimusic_ssr + hs-source-dirs: + app + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-extensions: + DataKinds + DefaultSignatures + DuplicateRecordFields + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + RecordWildCards + TypeFamilies + ViewPatterns + + build-depends: + base + , relude + , wikimusic-ssr + default-language: GHC2021