From 9df2ede39ec521f80964a1ff644e14d2143af34b Mon Sep 17 00:00:00 2001 From: sabadev Date: Sun, 11 Apr 2021 12:25:28 -0400 Subject: [PATCH] Added theme configuration. --- package.yaml | 2 ++ src/ApiTypes.hs | 22 ++++++++++++++++++++-- src/Html.hs | 36 +++++++++++++++++++++++++++++++++--- src/Server.hs | 13 ++++++++----- src/StyleSheet.hs | 24 +++++++++++++++++------- 5 files changed, 80 insertions(+), 17 deletions(-) diff --git a/package.yaml b/package.yaml index 5c170d9..235ffa6 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,7 @@ dependencies: - cmark == 0.6 - containers == 0.6.2.1 - directory == 1.3.6.0 +- http-api-data == 0.4.1.1 - http-media == 0.8.0.0 - lucid == 2.9.12.1 - mtl == 2.2.2 @@ -40,6 +41,7 @@ dependencies: default-extensions: - DataKinds +- DeriveGeneric - FlexibleContexts - FlexibleInstances - GADTs diff --git a/src/ApiTypes.hs b/src/ApiTypes.hs index 3348aa6..0204167 100644 --- a/src/ApiTypes.hs +++ b/src/ApiTypes.hs @@ -2,17 +2,20 @@ module ApiTypes where import Control.Monad ((<=<)) import CssContentType +import GHC.Generics (Generic(..)) import Lucid import Servant import Servant.HTML.Lucid (HTML(..)) +import Web.FormUrlEncoded (FromForm(..)) import qualified Clay as C import qualified Data.Text as T type Api = Styling :<|> Page -type Page = MainPage :<|> BlogPost +type Page = ChangeTheme :<|> MainPage :<|> BlogPost type MainPage = ThemeParam :> Get '[HTML] (Html ()) type BlogPost = ThemeParam :> Capture "id" BlogId :> Get '[HTML] (Html ()) type Styling = "style" :> ThemeParam :> Get '[CSS] C.Css +type ChangeTheme = ReqBody '[FormUrlEncoded] Theme :> Capture "id" BlogId :> Post '[HTML] (Html ()) type ThemeParam = QueryParam "theme" Theme type BlogId = FilePath @@ -32,7 +35,9 @@ data Theme = Theme { themeType :: !LightDark , themeRed :: !Integer , themeGreen :: !Integer , themeBlue :: !Integer - } + } deriving (Generic) + +instance FromForm Theme instance FromHttpApiData Theme where parseQueryParam (T.splitOn "," -> [lightText, redText, greenText, blueText]) = do @@ -47,9 +52,22 @@ instance FromHttpApiData Theme where instance ToHttpApiData Theme where toQueryParam theme = toQueryParam (themeType theme) <> "," <> toQueryParam (themeRed theme) <> "," <> toQueryParam (themeGreen theme) <> "," <> toQueryParam (themeBlue theme) +defaultTheme :: Theme +defaultTheme = Theme { themeType = Dark + , themeRed = 0 + , themeGreen = 0 + , themeBlue = 0 + } + +defaultBlogId :: BlogId +defaultBlogId = "index" + apiProxy :: Proxy Api apiProxy = Proxy +safeChangeThemeLink :: BlogId -> T.Text +safeChangeThemeLink blogId = toUrlPiece $ safeLink apiProxy (Proxy @ChangeTheme) blogId + safeBlogLink :: Maybe Theme -> BlogId -> T.Text safeBlogLink theme blogId = toUrlPiece $ safeLink apiProxy (Proxy @BlogPost) theme blogId diff --git a/src/Html.hs b/src/Html.hs index 3ed063a..2e0d759 100644 --- a/src/Html.hs +++ b/src/Html.hs @@ -13,9 +13,10 @@ import System.Directory (getDirectoryContents) import qualified Data.Text as T import qualified Data.Text.IO as T -htmlContainer :: (MonadIO m) => Maybe Theme -> Html a -> m (Html ()) -htmlContainer theme contents = do +htmlContainer :: (MonadIO m) => Maybe Theme -> Maybe BlogId -> Html a -> m (Html ()) +htmlContainer theme maybeBlogId contents = do nav <- navigation theme + themeConfig <- themeConfiguration theme maybeBlogId pure $ sanitizeHtml $ void $ with doctypehtml_ [lang_ "en"] $ do head_ $ do title_ $ toHtml siteTitle @@ -25,6 +26,35 @@ htmlContainer theme contents = do body_ $ do div_ [role_ "main"] contents nav + themeConfig + +themeConfiguration :: (MonadIO m) => Maybe Theme -> Maybe BlogId -> m (Html ()) +themeConfiguration (fromMaybe defaultTheme -> theme) (fromMaybe defaultBlogId -> blogId) = pure $ do + div_ [role_ "banner"] $ do + h2_ "Theme:" + form_ [action_ $ safeChangeThemeLink blogId, method_ "POST"] $ do + lightDarkInput (themeType theme) + colorInput (themeRed theme) "Red" + colorInput (themeGreen theme) "Green" + colorInput (themeBlue theme) "Blue" + div_ [class_ "input"] $ input_ [type_ "submit"] + +lightDarkInput :: LightDark -> Html () +lightDarkInput lightDark = do + let fieldId = "themeType" + let useDark = lightDark == Dark + div_ [class_ "input"] $ do + label_ [for_ fieldId] $ toHtml @T.Text "Style" + select_ [id_ fieldId, name_ fieldId] $ do + option_ (attributes "dark" useDark) $ toHtml @T.Text "Dark" + option_ (attributes "light" $ not useDark) $ toHtml @T.Text "Light" + where + attributes value isSelected = if isSelected then [value_ value, selected_ mempty] else [value_ value] + +colorInput :: Integer -> T.Text -> Html () +colorInput value label = let fieldId = "theme" <> label in div_ [class_ "input"] $ do + label_ [for_ fieldId] $ toHtml label + input_ [id_ fieldId, name_ fieldId, value_ $ T.pack $ show value, type_ "number", min_ "0", max_ "255", step_ "1"] navigation :: (MonadIO m) => Maybe Theme -> m (Html ()) navigation theme = do @@ -44,7 +74,7 @@ blogLink :: T.Text -> Maybe T.Text blogLink = T.stripSuffix markdownExtension blogNotFound :: (MonadIO m) => Maybe Theme -> BlogId -> SomeException -> m (Html ()) -blogNotFound theme blogId _ = htmlContainer theme $ do +blogNotFound theme blogId _ = htmlContainer theme Nothing $ do div_ [class_ "not-found"] $ do h1_ $ toHtml @T.Text "Blog not found" p_ $ toHtml $ "Blog post " <> T.pack blogId <> " could not found." diff --git a/src/Server.hs b/src/Server.hs index 7bf770d..b1c7900 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -4,6 +4,7 @@ import ApiTypes import Control.Exception.Safe (handleAny) import Control.Monad ((<=<)) import Control.Monad.IO.Class (liftIO) +import Data.Maybe (fromMaybe) import Html import Lucid import RenderBlog (renderBlog) @@ -20,20 +21,22 @@ api :: Server Api api = styling :<|> page page :: Server Page -page = mainPage :<|> blogPost +page = changeTheme :<|> mainPage :<|> blogPost mainPage :: Maybe Theme -> Handler (Html ()) -mainPage = flip blogPost "index" +mainPage = flip blogPost defaultBlogId blogPost :: Maybe Theme -> BlogId -> Handler (Html ()) -blogPost theme blogId = handleAny (blogNotFound theme blogId) $ findBlogPost blogId >>= htmlContainer theme . renderBlog +blogPost theme blogId = handleAny (blogNotFound theme blogId) $ findBlogPost blogId >>= htmlContainer theme (Just blogId) . renderBlog findBlogPost :: BlogId -> Handler T.Text findBlogPost = liftIO . T.readFile . (<>) staticPath . flip (<>) (T.unpack markdownExtension) +changeTheme :: Theme -> BlogId -> Handler (Html ()) +changeTheme theme = blogPost (Just theme) + styling :: Maybe Theme -> Handler C.Css -styling Nothing = pure $ darkStyle C.black -styling (Just theme) = pure $ getStyleFromTheme (themeType theme) $ C.rgba (themeRed theme) (themeGreen theme) (themeBlue theme) 1 +styling (fromMaybe defaultTheme -> theme) = pure $ getStyleFromTheme (themeType theme) $ C.rgba (themeRed theme) (themeGreen theme) (themeBlue theme) 1 getStyleFromTheme :: LightDark -> C.Color -> C.Css getStyleFromTheme Dark = darkStyle diff --git a/src/StyleSheet.hs b/src/StyleSheet.hs index 377b68a..f576252 100644 --- a/src/StyleSheet.hs +++ b/src/StyleSheet.hs @@ -21,6 +21,7 @@ makeStyle colorAction themeColor = do headerStyle linkStyle colorAction themeColor navigationStyle + bannerStyle bodyStyle :: ColorAction -> Color -> Css bodyStyle action themeColor = body ? do @@ -75,10 +76,19 @@ codeStyle = do overflowX scroll navigationStyle :: Css -navigationStyle = do - div # ("role" @= "navigation") |> h2 ? smallHeaderStyle - where - smallHeaderStyle = do - fontSize $ rem 1.414 - paddingBottom $ rem 0 - textAlign inherit +navigationStyle = div # ("role" @= "navigation") |> h2 ? smallHeaderStyle + +bannerStyle :: Css +bannerStyle = do + let bannerDiv = div # ("role" @= "banner") + let inputDiv = bannerDiv |> form |> div # ("class" @= "input") + bannerDiv |> h2 ? smallHeaderStyle + inputDiv ? marginTop (em 0.5) + inputDiv |> (select <> input # ("type" @= "number")) ? marginLeft (em 1) + inputDiv |> label ? fontWeight bold + +smallHeaderStyle :: Css +smallHeaderStyle = do + fontSize $ rem 1.414 + paddingBottom $ rem 0 + textAlign inherit -- 2.20.1