Support ?style=plain on haddocks

2026-01-11 19:58:28 +01:00 · 2017-12-08 10:17:19 +02:00 · 2017-12-08 10:17:19 +02:00 · eac18f4b1b
commit eac18f4b1b
parent 950cb7ef6d
1 changed files with 11 additions and 6 deletions
--- a/Handler/Haddock.hs
+++ b/Handler/Haddock.hs
@ -50,12 +50,17 @@ getHaddockR slug rest
                addExtra t = [t]
            req <- parseRequest $ unpack $ makeURL slug rest
            (_, res) <- acquireResponse req >>= allocateAcquire
-            doc <- responseBody res
-                $$ eventConduit
-                =$ concatMapC addExtra
-                =$ mapC (Nothing, )
-                =$ fromEvents
-            sendResponse $ toHtml doc
+            mstyle <- lookupGetParam "style"
+            case mstyle of
+              Just "plain" -> respondSource "text/html; charset=utf-8"
+                            $ responseBody res .| mapC (Chunk . toBuilder)
+              _ -> do
+                doc <- responseBody res
+                    $$ eventConduit
+                    =$ concatMapC addExtra
+                    =$ mapC (Nothing, )
+                    =$ fromEvents
+                sendResponse $ toHtml doc
  | otherwise = redirect $ makeURL slug rest

 redirectWithVersion