Some error handling and link relativizing
This commit is contained in:
parent
251d058c01
commit
34ffb10c37
4 changed files with 33 additions and 10 deletions
|
@ -8,3 +8,4 @@
|
|||
/news NewsR GET
|
||||
/report/#Int ReportR GET
|
||||
/wiki/#Text WikiR GET
|
||||
/wiki/ WikiHomeR GET
|
||||
|
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Wiki page controller.
|
||||
|
@ -8,34 +9,44 @@ import HL.Foundation
|
|||
import HL.View.Wiki
|
||||
|
||||
import Blaze (renderHtml)
|
||||
import Control.Exception.Lifted (catch)
|
||||
import Data.Conduit
|
||||
import Data.Conduit.Binary
|
||||
import qualified Data.Conduit.List as CL
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import Data.Text (Text,unpack)
|
||||
import Data.Text (Text,unpack,pack)
|
||||
import Network.HTTP.Conduit
|
||||
import Prelude hiding (readFile)
|
||||
import Prelude hiding (readFile,catch)
|
||||
import Text.Pandoc.Definition
|
||||
import Text.Pandoc.Readers.MediaWiki
|
||||
import Text.Pandoc.Walk
|
||||
import Text.Pandoc.Writers.HTML
|
||||
import Text.XML
|
||||
import Text.XML.Cursor
|
||||
|
||||
-- | Wiki home (no page specified).
|
||||
getWikiHomeR :: Handler Html
|
||||
getWikiHomeR =
|
||||
redirect (WikiR "HaskellWiki:Community")
|
||||
|
||||
-- | Wiki controller.
|
||||
getWikiR :: Text -> Handler Html
|
||||
getWikiR name =
|
||||
do html <- liftIO (getWikiPageHtml name)
|
||||
do url <- getUrlRender
|
||||
html <- liftIO (getWikiPageHtml url name)
|
||||
blaze (wikiV html)
|
||||
|
||||
-- | Get the MediaWiki markup of a wiki page and then convert it to
|
||||
-- HTML.
|
||||
getWikiPageHtml :: Text -> IO (Either Text (Text,Html))
|
||||
getWikiPageHtml article =
|
||||
getWikiPageHtml url article =
|
||||
do request <- parseUrl ("http://www.haskell.org/haskellwiki/Special:Export/" <> unpack article)
|
||||
withManager $ \manager -> do
|
||||
response <- http request manager
|
||||
doc <- responseBody response $$+- sinkDoc def
|
||||
case parse doc of
|
||||
doc <- catch (fmap Just (responseBody response $$+- sinkDoc def))
|
||||
(\(e::UnresolvedEntityException) -> return Nothing)
|
||||
case doc >>= parse of
|
||||
Nothing -> return (Left "Unable to parse XML from haskell.org.")
|
||||
Just (title,text) -> return (Right (title,writeHtml def text))
|
||||
where
|
||||
|
@ -43,7 +54,10 @@ getWikiPageHtml article =
|
|||
do let cursor = fromDocument doc
|
||||
title <- listToMaybe (getTitle cursor)
|
||||
text <- listToMaybe (getText cursor)
|
||||
return (title,readMediaWiki def (unpack text))
|
||||
return (title,walk' (relativize url)
|
||||
(readMediaWiki def (unpack text)))
|
||||
where walk' :: (Inline -> Inline) -> Pandoc -> Pandoc
|
||||
walk' = walk
|
||||
name n =
|
||||
Name {nameLocalName = n
|
||||
,nameNamespace = Just "http://www.mediawiki.org/xml/export-0.6/"
|
||||
|
@ -64,3 +78,10 @@ getWikiPageHtml article =
|
|||
element (name "title") >>=
|
||||
descendant >>=
|
||||
content
|
||||
|
||||
|
||||
relativize url = walk links
|
||||
where links asis@(Link is (ref,title))
|
||||
| isPrefixOf "http://" ref || isPrefixOf "https://" ref = asis
|
||||
| otherwise = Link is (unpack (url (WikiR (pack ref))),title)
|
||||
links x = x
|
||||
|
|
|
@ -70,7 +70,7 @@ navigation cur url =
|
|||
,(CommunityR,"Community")
|
||||
,(DocumentationR,"Documentation")
|
||||
,(NewsR,"News")
|
||||
,(WikiR "","Wiki")]))
|
||||
,(WikiHomeR,"Wiki")]))
|
||||
where item route title = li theclass (a [href (url route)] title)
|
||||
where theclass
|
||||
| Just route == cur = [class_ "active"]
|
||||
|
|
|
@ -16,7 +16,8 @@ import Data.Text (Text)
|
|||
wikiV :: Either Text (Text,Html) -> Blaze App
|
||||
wikiV result =
|
||||
template
|
||||
[(WikiR "","Wiki")]
|
||||
([(WikiHomeR,"Wiki")] ++
|
||||
[(WikiR name,name) | Right (name,_) <- [result]])
|
||||
(\_ ->
|
||||
container
|
||||
(row
|
||||
|
|
Loading…
Reference in a new issue