From eb514b8c3f2a89fd9ddf166893a904760abfdd2f Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Mon, 27 May 2019 19:54:11 +0000
Subject: [PATCH] Use path segment in HighlightStyleR, addStylesheet doesn't
 support query params

---
 config/routes                    |  2 +-
 src/Vervis/Handler/Repo.hs       | 11 +++--------
 src/Vervis/Handler/Repo/Darcs.hs |  7 +++++--
 src/Vervis/Handler/Repo/Git.hs   |  7 +++++--
 src/Vervis/Settings.hs           |  7 +++++--
 5 files changed, 19 insertions(+), 15 deletions(-)

diff --git a/config/routes b/config/routes
index a029cd4..2c5dca1 100644
--- a/config/routes
+++ b/config/routes
@@ -20,7 +20,7 @@
 /favicon.ico                                 FaviconR          GET
 /robots.txt                                  RobotsR           GET
 
-/highlight.css                               HighlightStyleR   GET
+/highlight/#Text/style.css                   HighlightStyleR   GET
 
 -- ----------------------------------------------------------------------------
 -- Federation
diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs
index 48e72ec..29a5592 100644
--- a/src/Vervis/Handler/Repo.hs
+++ b/src/Vervis/Handler/Repo.hs
@@ -363,14 +363,9 @@ postRepoDevR shr rp dev = do
         Just "DELETE" -> deleteRepoDevR shr rp dev
         _             -> notFound
 
-getHighlightStyleR :: Handler TypedContent
-getHighlightStyleR = do
-    styleName <- do
-        ms <- lookupGetParam "style"
-        case ms of
-            Nothing -> getsYesod $ appHighlightStyle . appSettings
-            Just s -> return $ unpack s
-    case lookup styleName highlightingStyles of
+getHighlightStyleR :: Text -> Handler TypedContent
+getHighlightStyleR styleName =
+    case lookup (unpack styleName) highlightingStyles of
         Nothing -> notFound
         Just style ->
             return $ TypedContent typeCss $ toContent $ styleToCss style
diff --git a/src/Vervis/Handler/Repo/Darcs.hs b/src/Vervis/Handler/Repo/Darcs.hs
index 87e25ce..7d70226 100644
--- a/src/Vervis/Handler/Repo/Darcs.hs
+++ b/src/Vervis/Handler/Repo/Darcs.hs
@@ -85,8 +85,11 @@ getDarcsRepoSource repository user repo dir = do
                 dirs = zip parent (tail $ inits parent)
             defaultLayout $ do
                 ms <- lookupGetParam "style"
-                let mparam = ("style",) <$> ms
-                addStylesheetAttrs HighlightStyleR $ maybeToList mparam
+                style <-
+                    case ms of
+                        Nothing -> getsYesod $ appHighlightStyle . appSettings
+                        Just s -> return s
+                addStylesheet $ HighlightStyleR style
                 $(widgetFile "repo/source-darcs")
 
 getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler TypedContent
diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs
index 0121c28..8a764e0 100644
--- a/src/Vervis/Handler/Repo/Git.hs
+++ b/src/Vervis/Handler/Repo/Git.hs
@@ -95,8 +95,11 @@ getGitRepoSource repository user repo ref dir = do
                 dirs = zip parent (tail $ inits parent)
             defaultLayout $ do
                 ms <- lookupGetParam "style"
-                let mparam = ("style",) <$> ms
-                addStylesheetAttrs HighlightStyleR $ maybeToList mparam
+                style <-
+                    case ms of
+                        Nothing -> getsYesod $ appHighlightStyle . appSettings
+                        Just s -> return s
+                addStylesheet $ HighlightStyleR style
                 $(widgetFile "repo/source-git")
 
 getGitRepoHeadChanges :: Repo -> ShrIdent -> RpIdent -> Handler TypedContent
diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs
index 96a77a9..55740e5 100644
--- a/src/Vervis/Settings.hs
+++ b/src/Vervis/Settings.hs
@@ -43,6 +43,9 @@ import Text.Pandoc.Highlighting
 import Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
 import Yesod.Default.Util          (WidgetFileSettings, widgetFileNoReload,
                                     widgetFileReload)
+
+import qualified Data.Text as T
+
 import Yesod.Mail.Send (MailSettings)
 
 -- | Runtime settings to configure this application. These settings can be
@@ -158,7 +161,7 @@ data AppSettings = AppSettings
 
       -- | Default color scheme for syntax highlighting of code blocks inside
       -- documentes rendered with pandoc.
-    , appHighlightStyle           :: String
+    , appHighlightStyle           :: Text
     }
 
 instance FromJSON AppSettings where
@@ -214,7 +217,7 @@ instance FromJSON AppSettings where
             s <- o .:? "highlight-style" .!= "zenburn"
             case lookup s highlightingStyles of
                 Nothing -> fail $ "Highlighting style " ++ s ++ " not found"
-                Just _ -> return s
+                Just _ -> return $ T.pack s
 
         return AppSettings {..}
         where