From 60af396f9c769114de59226963b151a35ab34ee2 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 2 May 2016 14:18:27 +0300
Subject: [PATCH] Add Haddock style.css and script.js

---
 Handler/Haddock.hs       | 45 ++++++++++++++++++++++++++++++++++++++--
 config/routes            |  1 +
 stackage-server.cabal    |  1 +
 static/haddock/script.js |  1 +
 static/haddock/style.css |  1 +
 5 files changed, 47 insertions(+), 2 deletions(-)
 create mode 100644 static/haddock/script.js
 create mode 100644 static/haddock/style.css

diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs
index fc30276..13f02ec 100644
--- a/Handler/Haddock.hs
+++ b/Handler/Haddock.hs
@@ -1,12 +1,53 @@
 module Handler.Haddock
     ( getHaddockR
+    , getHaddockBackupR
     ) where
 
 import Import
 import Stackage.Database
+import Text.HTML.TagStream.Types (Token' (..))
+import Text.HTML.TagStream.ByteString (tokenStream, showToken)
 
-getHaddockR :: SnapName -> [Text] -> Handler ()
-getHaddockR slug rest = redirect $ concat
+makeURL :: SnapName -> [Text] -> Text
+makeURL slug rest = concat
     $ "http://haddock.stackage.org/"
     : toPathPiece slug
     : map (cons '/') rest
+
+getHaddockR :: SnapName -> [Text] -> Handler TypedContent
+getHaddockR slug rest
+  | final:_ <- reverse rest, ".html" `isSuffixOf` final = do
+      render <- getUrlRender
+
+      let stylesheet = encodeUtf8 $ render $ StaticR haddock_style_css
+          script = encodeUtf8 $ render $ StaticR haddock_script_js
+
+          addExtra t@(TagClose "head") =
+            [ TagOpen "link"
+                [ ("rel", "stylesheet")
+                , ("href", stylesheet)
+                ]
+                False
+            , TagOpen "script"
+                [ ("src", script)
+                ]
+                False
+            , TagClose "script"
+            , t
+            ]
+          addExtra t = [t]
+
+      req <- parseUrl $ unpack $ makeURL slug rest
+      (_, res) <- acquireResponse req >>= allocateAcquire
+
+      respondSource typeHtml
+         $ responseBody res
+        $= tokenStream
+        $= concatMapC addExtra
+        $= mapC (Chunk . showToken id)
+  | otherwise = redirect $ makeURL slug rest
+
+getHaddockBackupR :: [Text] -> Handler ()
+getHaddockBackupR rest = redirect $ concat
+    $ "http://haddock.stackage.org"
+    : map (cons '/') rest
diff --git a/config/routes b/config/routes
index 1607bbc..576e308 100644
--- a/config/routes
+++ b/config/routes
@@ -28,6 +28,7 @@
 
 /system SystemR GET
 /haddock/#SnapName/*Texts HaddockR GET
+!/haddock/*Texts HaddockBackupR GET
 /package/#PackageName PackageR GET
 /package/#PackageName/snapshots PackageSnapshotsR GET
 /package/#PackageName/badge/#SnapshotBranch PackageBadgeR GET
diff --git a/stackage-server.cabal b/stackage-server.cabal
index adf667d..2a8b85c 100644
--- a/stackage-server.cabal
+++ b/stackage-server.cabal
@@ -125,6 +125,7 @@ library
                   , shakespeare                   >= 2.0         &&   < 2.1
                   , system-fileio                 >= 0.3         &&   < 0.4
                   , system-filepath               >= 0.4         &&   < 0.5
+                  , tagstream-conduit
                   , tar                           >= 0.5         &&   < 0.6
                   , template-haskell              >= 2.10        &&   < 2.11
                   , temporary-rc                  >= 1.2         &&   < 1.3
diff --git a/static/haddock/script.js b/static/haddock/script.js
new file mode 100644
index 0000000..6b01adf
--- /dev/null
+++ b/static/haddock/script.js
@@ -0,0 +1 @@
+// FIXME add something here later
diff --git a/static/haddock/style.css b/static/haddock/style.css
new file mode 100644
index 0000000..0cebd7a
--- /dev/null
+++ b/static/haddock/style.css
@@ -0,0 +1 @@
+/* FIXME add something here later */
\ No newline at end of file