Improve dark mode; also change source code highlighting

HighlightCSS.hs

@@ -0,0 +1,106 @@
+module HighlightCSS (
+    processHighlightCSS,
+) where
+
+import Control.Monad (void)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS8
+import Data.Char (isSpace)
+import Data.List (intercalate)
+import Text.Parsec
+
+
+processHighlightCSS :: IO ByteString
+processHighlightCSS = do
+    cssl <- parseCSS "highlight-light.pack.css" <$> readFile "highlight-light.pack.css"
+    cssd <- parseCSS "highlight-dark.pack.css" <$> readFile "highlight-dark.pack.css"
+    let css = namespaceSels (Selector ".clrl") cssl <> namespaceSels (Selector ".clrd") cssd
+        result = BS8.pack (writeCSS css)
+    result `seq` return result
+
+
+namespaceSels :: Selector -> CSS -> CSS
+namespaceSels sel (CSS items) =
+    CSS [(mc, [Block (map (sel <>) sels) rules
+              | Block sels rules <- blocks])
+        | (mc, blocks) <- items]
+
+
+newtype CSS = CSS [(Maybe Comment, [Block])]
+  deriving (Show)
+
+data Block = Block [Selector] [Rule]
+  deriving (Show)
+
+newtype Selector = Selector String
+  deriving (Show)
+
+data Rule = Rule String String
+  deriving (Show)
+
+newtype Comment = Comment String
+  deriving (Show)
+
+instance Semigroup CSS where
+    CSS l <> CSS l' = CSS (l ++ l')
+
+instance Semigroup Selector where
+    Selector s <> Selector s' = Selector (s ++ ' ' : s')
+
+parseCSS :: FilePath -> String -> CSS
+parseCSS fname s =
+    case parse (pCSS <* eof) fname s of
+      Left err -> error (show err)
+      Right res -> res
+
+writeCSS :: CSS -> String
+writeCSS (CSS items) =
+    intercalate "\n"
+        [maybe "" (\(Comment c) -> "/*" ++ c ++ "*/\n") mcomment ++
+            concat [intercalate "," [s | Selector s <- sels] ++
+                    "{" ++
+                    intercalate ";" [k ++ ":" ++ v | Rule k v <- rules] ++
+                    "}"
+                   | Block sels rules <- blocks]
+        | (mcomment, blocks) <- items]
+
+type Parser = Parsec String ()
+
+pCSS :: Parser CSS
+pCSS = CSS <$> many ((,) <$> optionMaybe pHeaderComment <*> many1 pBlock)
+
+pHeaderComment :: Parser Comment
+pHeaderComment = do
+    string' "/*"
+    s <- manyTill anyChar (string' "*/")
+    void endOfLine
+    return (Comment s)
+
+pBlock :: Parser Block
+pBlock = do
+    sels <- pSelector `sepBy1` (try (whitespace >> char ',') >> whitespace)
+    whitespace
+    void $ char '{'
+    rules <- pRule `sepBy` (try (whitespace >> char ';') >> whitespace)
+    whitespace
+    void $ char '}'
+    whitespace
+    return (Block sels rules)
+
+pSelector :: Parser Selector
+pSelector = Selector <$> many (noneOf ",{}")
+
+pRule :: Parser Rule
+pRule = do
+    key <- try (whitespace >> many1 (satisfy (\c -> c `notElem` ":;}" && not (isSpace c))))
+    whitespace
+    void $ char ':'
+    whitespace
+    value <- many (noneOf ";}")
+    return (Rule key value)
+
+string' :: String -> Parser ()
+string' s = void (try (string s))
+
+whitespace :: Parser ()
+whitespace = void (many (satisfy isSpace))

Main.hs

@@ -27,6 +27,7 @@ import Text.Read (readMaybe)
 import Archive
 import qualified DB
 import DB (Database, ClientAddr, KeyType, Contents(..))
+import HighlightCSS
 import qualified Options as Opt
 import SpamDetect hiding (Action(..))
 import qualified SpamDetect as Spam (Action(..))
@@ -56,7 +57,8 @@ defaultOptions = Options False "."
 
 data Context = Context
     { cDB :: Database
-    , cSpam :: SpamDetect ByteString }
+    , cSpam :: SpamDetect ByteString
+    , cHighlightCSS :: ByteString }
 
 data State = State
     { sRandGen :: StdGen
@@ -112,11 +114,14 @@ httpError code msg = do
     putResponse $ setResponseCode code emptyResponse
     writeBS (Char8.pack msg)
 
+applyStaticFileHeaders :: String -> Response -> Response
+applyStaticFileHeaders mime =
+    setContentType (Char8.pack mime)
+    . setHeader (fromString "Cache-Control") "public max-age=3600"
+
 staticFile :: String -> FilePath -> Snap ()
 staticFile mime path = do
-    modifyResponse $
-        setContentType (Char8.pack mime)
-        . setHeader (fromString "Cache-Control") "public max-age=3600"
+    modifyResponse (applyStaticFileHeaders mime)
     sendFile path
 
 collectContentsFromPost :: POSIXTime -> Map ByteString [ByteString] -> Contents
@@ -153,7 +158,7 @@ staticFiles =
     [(Char8.pack path, (path, mime))
     | (path, mime) <-
         [("highlight.pack.js", "text/javascript")
-        ,("highlight.pack.css", "text/css")
+        -- ,("highlight.pack.css", "text/css")  -- this one is generated, not a static file
         ,("robots.txt", "text/plain")]]
 
 data WhatRequest
@@ -163,6 +168,7 @@ data WhatRequest
     | ReadPasteOld ByteString
     | EditPaste ByteString
     | StaticFile String FilePath
+    | HighlightCSS
     | StorePaste
     | DownloadPaste ByteString
 
@@ -180,6 +186,7 @@ parseRequest method path =
            (GET, [x, "raw", y]) | canBeKey x, Just idx <- readMaybe (Char8.unpack y) -> Just (ReadPasteRaw x idx)
            (GET, [x, "download"]) | canBeKey x -> Just (DownloadPaste x)
            (GET, ["paste", x]) | canBeKey x -> Just (ReadPasteOld x)
+           (GET, ["highlight.pack.css"]) -> Just HighlightCSS
            (GET, [x]) | Just (path', mime) <- List.lookup x staticFiles -> Just (StaticFile mime path')
            (POST, ["paste"]) -> Just StorePaste
            _ -> Nothing
@@ -220,6 +227,9 @@ handleRequest context stvar = \case
             then httpError 429 "Please slow down a bit, you're rate limited"
             else handleNonSpamSubmit (collectContentsFromPost now (rqPostParams req))
     StaticFile mime path -> staticFile mime path
+    HighlightCSS -> do
+        modifyResponse (applyStaticFileHeaders "text/css")
+        writeBS (cHighlightCSS context)
     DownloadPaste key -> do
         liftIO (getPaste context key) >>= \case
             Just (_, Contents files _ _) -> do
@@ -297,7 +307,8 @@ main = do
 
     DB.withDatabase (oDBDir options) $ \db -> do
         spam <- initSpamDetect
-        let context = Context db spam
+        css <- processHighlightCSS
+        let context = Context db spam css
 
         -- Create state
         randgen <- newStdGen

index.mustache

@@ -14,22 +14,37 @@ body {
 	padding-bottom: 90px;
 }
 
+header, footer {
+	background-color: #3e3a3f;
+	color: #e8e8e8;
+}
+
 @media (prefers-color-scheme: dark) {
 	body {
-		color: white;
+		color: #ddd;
 		background-color: #121212;
 	}
-}
 
-header, footer {
-	background-color: #3e3a3f;
-	color: white;
+	header, footer {
+		color: #ddd;
+	}
+
+	/* Headings are bold and large; make less flashy-white to compensate. */
+	h1, h2, h3 {
+		color: #ccc;
+	}
 }
 
 header a, footer a {
 	color: #bbf;
 }
 
+@media (prefers-color-scheme: dark) {
+	a {
+		color: #bbf;
+	}
+}
+
 header {
 	padding: 20px 40px 20px 25px;
 	font-size: 14pt;
@@ -51,6 +66,10 @@ footer > div {
 	margin: 0 auto 30px auto;
 }
 
+.invisible {
+	display: none;
+}
+
 /* --- */
 
 .bodytext {

pastebin-haskell.cabal

@@ -8,19 +8,20 @@ author:              Tom Smeding
 maintainer:          [email protected]
 build-type:          Simple
 homepage:            https://github.com/tomsmeding/pastebin-haskell
-extra-source-files:  index.mustache read.mustache highlight.pack.css highlight.pack.js
+extra-source-files:  index.mustache read.mustache highlight-light.pack.css highlight-dark.pack.css highlight.pack.js
 extra-source-files:  migrate_db_1_2.sh migrate_db_2_3.sh migrate_db_3_4.sh migrate_db_4_5.sh
 extra-source-files:  robots.txt ChangeLog.md
 
 executable pastebin-haskell
   main-is:             Main.hs
-  other-modules:       Archive, DB, Options, Pages, SpamDetect
+  other-modules:       Archive, DB, HighlightCSS, Options, Pages, SpamDetect
   build-depends:       base >= 4.13 && < 4.15,
                        array >= 0.5.4 && < 0.6,
                        bytestring >= 0.10.12 && < 0.11,
                        containers >= 0.6.3.1 && < 0.7,
                        clock >= 0.8 && < 0.9,
                        mustache >= 2.3.1 && < 2.4,
+                       parsec >= 3.1.14.0 && < 3.2,
                        stm >= 2.5 && < 2.6,
                        random >= 1.2.0 && < 1.3,
                        snap-server >= 1.1.1.2 && < 1.2,

read.mustache

@@ -2,6 +2,7 @@
 <html>
 <head>
 <meta charset="utf-8">
+<meta name="viewport" content="width=device-width, initial-scale=1">
 <title>Paste: {{key}}</title>
 <style>
 html {
@@ -15,13 +16,35 @@ body {
 
 header, footer {
 	background-color: #3e3a3f;
-	color: white;
+	color: #e8e8e8;
+}
+
+@media (prefers-color-scheme: dark) {
+	body {
+		color: #ddd;
+		background-color: #121212;
+	}
+
+	header, footer {
+		color: #ddd;
+	}
+
+	/* Headings are bold and large; make less flashy-white to compensate. */
+	h1, h2, h3 {
+		color: #ccc;
+	}
 }
 
 header a, footer a {
 	color: #bbf;
 }
 
+@media (prefers-color-scheme: dark) {
+	a {
+		color: #bbf;
+	}
+}
+
 header {
 	padding: 20px 40px 20px 25px;
 	font-size: 14pt;
@@ -69,6 +92,12 @@ pre.plain {
 	padding: 0.5em;
 }
 
+@media (prefers-color-scheme: dark) {
+	pre.plain {
+		background-color: #272822;
+	}
+}
+
 .lnumtable {
 	border-collapse: collapse;
 }
@@ -153,10 +182,26 @@ function applyLineNumbers(yes) {
 	}
 }
 
+function applyDarkScheme(yes) {
+	if (yes) {
+		document.body.classList.remove("clrl");
+		document.body.classList.add("clrd");
+	} else {
+		document.body.classList.remove("clrd");
+		document.body.classList.add("clrl");
+	}
+}
+
 document.addEventListener("DOMContentLoaded", () => {
 	loaded = true;
 	if (wantHighlighting) applyHighlighting(true);
 	if (!wantLineNumbers) applyLineNumbers(false);
+
+	if ("matchMedia" in window) {
+		var media = window.matchMedia("(prefers-color-scheme: dark)");
+		applyDarkScheme(media.matches);
+		media.addEventListener("change", function(ev) { applyDarkScheme(ev.matches); });
+	}
 });
 </script>
 </head>