From e02a0fa4db280f964675804c0abe40529bc8eb38 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Mon, 27 May 2019 18:30:48 +0000
Subject: [PATCH] Make pandoc highlight style configurable in settings and in
 query parameter

---
 config/settings-default.yaml     |  9 +++++++++
 src/Vervis/Handler/Repo.hs       | 13 +++++++++++--
 src/Vervis/Handler/Repo/Darcs.hs |  6 ++++--
 src/Vervis/Handler/Repo/Git.hs   |  6 ++++--
 src/Vervis/Settings.hs           | 11 +++++++++++
 5 files changed, 39 insertions(+), 6 deletions(-)

diff --git a/config/settings-default.yaml b/config/settings-default.yaml
index 491d7a5..ceb41e2 100644
--- a/config/settings-default.yaml
+++ b/config/settings-default.yaml
@@ -168,3 +168,12 @@ retry-delivery-every:
 
 # List of (hosts of) other known federating instances.
 #instances:              []
+
+###############################################################################
+# User interface
+###############################################################################
+
+# Default color scheme for syntax highlighing of code blocks inside rendered
+# documents. The available styles are listed in the "Text.Pandoc.Highlighting"
+# module documentation.
+highlight-style:        zenburn
diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs
index 49ab1cb..48e72ec 100644
--- a/src/Vervis/Handler/Repo.hs
+++ b/src/Vervis/Handler/Repo.hs
@@ -66,7 +66,7 @@ import System.Hourglass (dateCurrent)
 import Text.Blaze.Html (Html)
 import Text.Pandoc.Highlighting
 import Yesod.Auth (requireAuthId)
-import Yesod.Core (defaultLayout, setMessage)
+import Yesod.Core
 import Yesod.Core.Content
 import Yesod.Core.Handler (lookupPostParam, redirect, notFound)
 import Yesod.Form.Functions (runFormPost)
@@ -364,4 +364,13 @@ postRepoDevR shr rp dev = do
         _             -> notFound
 
 getHighlightStyleR :: Handler TypedContent
-getHighlightStyleR = pure $ TypedContent typeCss $ toContent $ styleToCss tango
+getHighlightStyleR = do
+    styleName <- do
+        ms <- lookupGetParam "style"
+        case ms of
+            Nothing -> getsYesod $ appHighlightStyle . appSettings
+            Just s -> return $ unpack s
+    case lookup 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 adc19c9..87e25ce 100644
--- a/src/Vervis/Handler/Repo/Darcs.hs
+++ b/src/Vervis/Handler/Repo/Darcs.hs
@@ -26,7 +26,7 @@ import Prelude
 
 import Control.Monad.IO.Class (liftIO)
 import Data.List (inits)
-import Data.Maybe (fromMaybe)
+import Data.Maybe
 import Data.Text (Text, unpack)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
@@ -84,7 +84,9 @@ getDarcsRepoSource repository user repo dir = do
             let parent = if null dir then [] else init dir
                 dirs = zip parent (tail $ inits parent)
             defaultLayout $ do
-                addStylesheet HighlightStyleR
+                ms <- lookupGetParam "style"
+                let mparam = ("style",) <$> ms
+                addStylesheetAttrs HighlightStyleR $ maybeToList mparam
                 $(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 44abeac..0121c28 100644
--- a/src/Vervis/Handler/Repo/Git.hs
+++ b/src/Vervis/Handler/Repo/Git.hs
@@ -35,7 +35,7 @@ import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
 import Data.Graph.Inductive.Graph (noNodes)
 import Data.Graph.Inductive.Query.Topsort
 import Data.List (inits)
-import Data.Maybe (fromMaybe)
+import Data.Maybe
 import Data.Text (Text, unpack)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
@@ -94,7 +94,9 @@ getGitRepoSource repository user repo ref dir = do
             let parent = if null dir then [] else init dir
                 dirs = zip parent (tail $ inits parent)
             defaultLayout $ do
-                addStylesheet HighlightStyleR
+                ms <- lookupGetParam "style"
+                let mparam = ("style",) <$> ms
+                addStylesheetAttrs HighlightStyleR $ maybeToList mparam
                 $(widgetFile "repo/source-git")
 
 getGitRepoHeadChanges :: Repo -> ShrIdent -> RpIdent -> Handler TypedContent
diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs
index 9b573e9..96a77a9 100644
--- a/src/Vervis/Settings.hs
+++ b/src/Vervis/Settings.hs
@@ -39,6 +39,7 @@ import Data.Yaml                   (decodeEither')
 import Database.Persist.Postgresql (PostgresConf)
 import Language.Haskell.TH.Syntax  (Exp, Name, Q)
 import Network.Wai.Handler.Warp    (HostPreference)
+import Text.Pandoc.Highlighting
 import Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
 import Yesod.Default.Util          (WidgetFileSettings, widgetFileNoReload,
                                     widgetFileReload)
@@ -154,6 +155,10 @@ data AppSettings = AppSettings
     , appInboxDebugReportLength   :: Maybe Int
       -- | List of (hosts of) other known federating instances.
     , appInstances                :: [Text]
+
+      -- | Default color scheme for syntax highlighting of code blocks inside
+      -- documentes rendered with pandoc.
+    , appHighlightStyle           :: String
     }
 
 instance FromJSON AppSettings where
@@ -205,6 +210,12 @@ instance FromJSON AppSettings where
         appInboxDebugReportLength   <- o .:? "activity-debug-reports"
         appInstances                <- o .:? "instances" .!= []
 
+        appHighlightStyle           <- do
+            s <- o .:? "highlight-style" .!= "zenburn"
+            case lookup s highlightingStyles of
+                Nothing -> fail $ "Highlighting style " ++ s ++ " not found"
+                Just _ -> return s
+
         return AppSettings {..}
         where
         toSeconds :: TimeInterval -> Second