Added theme configuration.

diff --git a/package.yaml b/package.yaml
index 5c170d9..235ffa6 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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