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