Switched to using typesafe links.

diff --git a/package.yaml b/package.yaml
index 24f4621..6a46990 100644 (file)
--- a/package.yaml
+++ b/package.yaml
@@ -45,6 +45,7 @@ default-extensions:
 - MultiParamTypeClasses
 - OverloadedStrings
 - StandaloneDeriving
+- TypeApplications
 - TypeOperators
 
 library:

diff --git a/src/ApiTypes.hs b/src/ApiTypes.hs
index 5eb93b7..7a8c0a0 100644 (file)
--- a/src/ApiTypes.hs
+++ b/src/ApiTypes.hs
@@ -7,13 +7,11 @@ import Servant.HTML.Lucid (HTML(..))
 import qualified Clay as C
 import qualified Data.Text as T
 
-type Api = Page :<|> Themes
+type Api = Styling :<|> Page
 type Page = MainPage :<|> BlogPost
 type MainPage = ThemeParam :> Get '[HTML] (Html ())
 type BlogPost = ThemeParam :> Capture "id" BlogId :> Get '[HTML] (Html ())
-type Themes = DarkTheme :<|> LightTheme
-type DarkTheme = "style" :> "dark" :> QueryParam "red" Integer :> QueryParam "green" Integer :> QueryParam "blue" Integer :> Get '[CSS] C.Css
-type LightTheme = "style" :> "light" :> QueryParam "red" Integer :> QueryParam "green" Integer :> QueryParam "blue" Integer :> Get '[CSS] C.Css
+type Styling = "style" :> ThemeParam :> Get '[CSS] C.Css
 type ThemeParam = QueryParam "theme" Theme
 
 type BlogId = FilePath
@@ -52,11 +50,8 @@ instance ToHttpApiData Theme where
 apiProxy :: Proxy Api
 apiProxy = Proxy
 
-safeBlogLink :: MkLink BlogPost Link
-safeBlogLink = safeLink apiProxy (Proxy :: Proxy BlogPost)
+safeBlogLink :: Maybe Theme -> BlogId -> T.Text
+safeBlogLink theme blogId = toUrlPiece $ safeLink apiProxy (Proxy @BlogPost) theme blogId
 
-safeDarkThemeLink :: MkLink DarkTheme Link
-safeDarkThemeLink = safeLink apiProxy (Proxy :: Proxy DarkTheme)
-
-safeLightThemeLink :: MkLink LightTheme Link
-safeLightThemeLink = safeLink apiProxy (Proxy :: Proxy LightTheme)
+safeStylingLink :: Maybe Theme -> T.Text
+safeStylingLink theme = toUrlPiece $ safeLink apiProxy (Proxy @Styling) theme

diff --git a/src/Html.hs b/src/Html.hs
index 4322820..e7b8bfa 100644 (file)
--- a/src/Html.hs
+++ b/src/Html.hs
@@ -33,11 +33,7 @@ blogListItem :: Maybe Theme -> T.Text -> Html ()
 blogListItem theme path = do
   case blogLink path of
     Nothing -> pure $ mempty
-    Just file -> li_ [class_ "blog-link"] $ a_ [href_ $ makeLink theme file] $ toHtml file
-
-makeLink :: Maybe Theme -> T.Text -> T.Text
-makeLink Nothing link = link
-makeLink (Just theme) link = link <> "?theme=" <> toQueryParam theme
+    Just file -> li_ [class_ "blog-link"] $ a_ [href_ $ safeBlogLink theme $ T.unpack file] $ toHtml file
 
 blogLink :: T.Text -> Maybe T.Text
 blogLink = T.stripSuffix markdownExtension
@@ -52,7 +48,4 @@ markdownExtension :: T.Text
 markdownExtension = ".md"
 
 getTheme :: Maybe Theme -> T.Text
-getTheme Nothing = "/style/dark"
-getTheme (Just theme)
-  | themeType theme == Dark = "/style/dark?red=" <> toQueryParam (themeRed theme) <> "&green=" <> toQueryParam (themeGreen theme) <> "&blue=" <> toQueryParam (themeBlue theme)
-  | themeType theme == Light = "/style/light?red=" <> toQueryParam (themeRed theme) <> "&green=" <> toQueryParam (themeGreen theme) <> "&blue=" <> toQueryParam (themeBlue theme)
+getTheme theme = safeStylingLink theme

diff --git a/src/Server.hs b/src/Server.hs
index 60081ba..e21744a 100644 (file)
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -17,7 +17,7 @@ app :: Application
 app = serve apiProxy api
 
 api :: Server Api
-api = page :<|> themes
+api = styling :<|> page
 
 page :: Server Page
 page = mainPage :<|> blogPost
@@ -31,25 +31,20 @@ blogPost theme = htmlContainer theme . renderBlog <=< findBlogPost
 findBlogPost :: BlogId -> Handler T.Text
 findBlogPost = liftIO . T.readFile . (<>) staticPath . flip (<>) (T.unpack markdownExtension)
 
-themes :: Server Themes
-themes = darkTheme :<|> lightTheme
+styling :: Maybe Theme -> Handler C.Css
+styling Nothing = pure $ darkStyle $ getColorFromInput 0 0 0
+styling (Just theme) = pure $ getStyleFromTheme (themeType theme) $ getColorFromInput (themeRed theme) (themeGreen theme) (themeBlue theme)
 
-darkTheme :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Handler C.Css
-darkTheme red green blue = pure $ darkStyle $ getColorFromInput Dark red green blue
+getStyleFromTheme :: LightDark -> C.Color -> C.Css
+getStyleFromTheme Dark = darkStyle
+getStyleFromTheme Light = lightStyle
 
-lightTheme :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Handler C.Css
-lightTheme red green blue = pure $ lightStyle $ getColorFromInput Light red green blue
-
-getColorFromInput :: LightDark -> Maybe Integer -> Maybe Integer -> Maybe Integer -> C.Color
-getColorFromInput lightDark redColor greenColor blueColor = do
-  let red = getIndividualColor lightDark redColor
-  let green = getIndividualColor lightDark greenColor
-  let blue = getIndividualColor lightDark blueColor
+getColorFromInput :: Integer -> Integer -> Integer -> C.Color
+getColorFromInput redColor greenColor blueColor = do
+  let red = getIndividualColor redColor
+  let green = getIndividualColor greenColor
+  let blue = getIndividualColor blueColor
   C.rgba red green blue 1
 
-getIndividualColor :: LightDark -> Maybe Integer -> Integer
-getIndividualColor color = flip mod 0x100 . fromMaybe (defaultColor color)
-
-defaultColor :: LightDark -> Integer
-defaultColor Dark = 0x00
-defaultColor Light = 0xFF
+getIndividualColor :: Integer -> Integer
+getIndividualColor = flip mod 0x100