Add Haddock style.css and script.js
This commit is contained in:
parent
a9534e5390
commit
60af396f9c
5 changed files with 47 additions and 2 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
1
static/haddock/script.js
Normal file
1
static/haddock/script.js
Normal file
|
@ -0,0 +1 @@
|
|||
// FIXME add something here later
|
1
static/haddock/style.css
Normal file
1
static/haddock/style.css
Normal file
|
@ -0,0 +1 @@
|
|||
/* FIXME add something here later */
|
Loading…
Reference in a new issue