From 37441e1927d23915b886f176af740107f4a91257 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Fri, 14 Mar 2014 19:04:25 +0100 Subject: [PATCH] Re-organize and simplify some bits --- .gitignore | 1 + hl.cabal | 9 ++- src/Blaze/Prelude.hs | 1 + src/DevelMain.hs | 9 ++- src/HL.hs | 3 - src/HL/C.hs | 19 +++++ src/HL/C/Community.hs | 13 ++++ src/HL/C/Documentation.hs | 13 ++++ src/HL/C/Downloads.hs | 13 ++++ src/HL/C/Home.hs | 13 ++++ src/HL/C/Markdown.hs | 15 ++++ src/HL/C/News.hs | 10 +++ src/HL/{Controller => C}/Reload.hs | 6 +- src/HL/C/Report.hs | 10 +++ src/HL/C/Theme.hs | 21 ++++++ src/HL/C/Wiki.hs | 25 +++++++ src/HL/Controller.hs | 11 +++ src/HL/Controller/Community.hs | 10 --- src/HL/Controller/Documentation.hs | 10 --- src/HL/Controller/Downloads.hs | 10 --- src/HL/Controller/Home.hs | 10 --- src/HL/Controller/News.hs | 10 --- src/HL/Controller/Report.hs | 10 --- src/HL/Controller/Theme.hs | 19 ----- src/HL/Controller/Wiki.hs | 111 ---------------------------- src/HL/Dispatch.hs | 20 ++--- src/HL/Foundation.hs | 11 +-- src/HL/M.hs | 12 +++ src/HL/M/Markdown.hs | 25 +++++++ src/HL/M/Wiki.hs | 64 ++++++++++++++++ src/HL/Static.hs | 1 + src/HL/Types.hs | 23 ++++++ src/HL/V.hs | 14 ++++ src/HL/{View => V}/Documentation.hs | 16 ++-- src/HL/V/Markdown.hs | 16 ++++ src/HL/{View => V}/News.hs | 9 +-- src/HL/{View => V}/Report.hs | 11 +-- src/HL/{View => V}/Template.hs | 55 +++++++------- src/HL/{View => V}/Theme.hs | 10 +-- src/HL/V/Wiki.hs | 71 ++++++++++++++++++ src/HL/View/Community.hs | 33 --------- src/HL/View/Downloads.hs | 32 -------- src/HL/View/Home.hs | 39 ---------- src/HL/View/Wiki.hs | 34 --------- src/Main.hs | 2 +- static/markdown/community.md | 9 +++ static/markdown/documentation.md | 17 +++++ static/markdown/downloads.md | 10 +++ static/markdown/home.md | 1 + 49 files changed, 502 insertions(+), 415 deletions(-) delete mode 100644 src/HL.hs create mode 100644 src/HL/C.hs create mode 100644 src/HL/C/Community.hs create mode 100644 src/HL/C/Documentation.hs create mode 100644 src/HL/C/Downloads.hs create mode 100644 src/HL/C/Home.hs create mode 100644 src/HL/C/Markdown.hs create mode 100644 src/HL/C/News.hs rename src/HL/{Controller => C}/Reload.hs (68%) create mode 100644 src/HL/C/Report.hs create mode 100644 src/HL/C/Theme.hs create mode 100644 src/HL/C/Wiki.hs create mode 100644 src/HL/Controller.hs delete mode 100644 src/HL/Controller/Community.hs delete mode 100644 src/HL/Controller/Documentation.hs delete mode 100644 src/HL/Controller/Downloads.hs delete mode 100644 src/HL/Controller/Home.hs delete mode 100644 src/HL/Controller/News.hs delete mode 100644 src/HL/Controller/Report.hs delete mode 100644 src/HL/Controller/Theme.hs delete mode 100644 src/HL/Controller/Wiki.hs create mode 100644 src/HL/M.hs create mode 100644 src/HL/M/Markdown.hs create mode 100644 src/HL/M/Wiki.hs create mode 100644 src/HL/Types.hs create mode 100644 src/HL/V.hs rename src/HL/{View => V}/Documentation.hs (84%) create mode 100644 src/HL/V/Markdown.hs rename src/HL/{View => V}/News.hs (74%) rename src/HL/{View => V}/Report.hs (69%) rename src/HL/{View => V}/Template.hs (62%) rename src/HL/{View => V}/Theme.hs (96%) create mode 100644 src/HL/V/Wiki.hs delete mode 100644 src/HL/View/Community.hs delete mode 100644 src/HL/View/Downloads.hs delete mode 100644 src/HL/View/Home.hs delete mode 100644 src/HL/View/Wiki.hs create mode 100644 static/markdown/community.md create mode 100644 static/markdown/documentation.md create mode 100644 static/markdown/downloads.md create mode 100644 static/markdown/home.md diff --git a/.gitignore b/.gitignore index 212b0d3..ee61276 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ cabal-dev/ TAGS tags *.tag +client_session_key.aes diff --git a/hl.cabal b/hl.cabal index d76254c..592026a 100644 --- a/hl.cabal +++ b/hl.cabal @@ -15,9 +15,12 @@ executable hl hs-source-dirs: src/ ghc-options: -Wall -O2 main-is: Main.hs - build-depends: xml-conduit >= 1.1.0.9, - conduit >= 1.0.15, - warp >= 2.0.3.2, + build-depends: monad-extras == 0.5.4, + filepath == 1.3.0.0, + markdown == 0.1.7, + xml-conduit == 1.1.0.9, + conduit == 1.0.15, + warp == 2.0.3.2, wai-logger == 2.1.1, fast-logger == 2.1.5, yesod-core == 1.2.6.4, diff --git a/src/Blaze/Prelude.hs b/src/Blaze/Prelude.hs index c7058ae..a314632 100644 --- a/src/Blaze/Prelude.hs +++ b/src/Blaze/Prelude.hs @@ -4,6 +4,7 @@ module Blaze.Prelude (module Blaze.Attributes ,module Blaze.Senza ,module Prelude + ,AttributeValue ,docTypeHtml) where diff --git a/src/DevelMain.hs b/src/DevelMain.hs index 70291f0..b635241 100644 --- a/src/DevelMain.hs +++ b/src/DevelMain.hs @@ -2,13 +2,14 @@ module DevelMain where -import HL.Foundation import HL.Dispatch () +import HL.Foundation import Control.Concurrent import Data.IORef import Foreign.Store import Network.Wai.Handler.Warp +import Yesod import Yesod.Static -- | Start the web server. @@ -25,9 +26,9 @@ main = do handler <- readIORef ref handler req)) _ <- newStore tid - ref <- newStore ref - newStore c - return ref + ref' <- newStore ref + _ <- newStore c + return ref' -- | Update the server, start it if not running. update :: IO (Store (IORef Application)) diff --git a/src/HL.hs b/src/HL.hs deleted file mode 100644 index fa98a5e..0000000 --- a/src/HL.hs +++ /dev/null @@ -1,3 +0,0 @@ --- | Haskell web site. - -module HL where diff --git a/src/HL/C.hs b/src/HL/C.hs new file mode 100644 index 0000000..93f59f4 --- /dev/null +++ b/src/HL/C.hs @@ -0,0 +1,19 @@ +-- | Controller library. + +module HL.C + (module C + ,App(..) + ,C + ,io) + where + +import HL.Foundation (Handler) +import HL.Foundation as C (Route(..),App(..)) + +import Control.Monad.Extra +import Data.Text as C (Text) +import Yesod as C +import Yesod.Blaze as C + +-- | Controller type. +type C = Handler diff --git a/src/HL/C/Community.hs b/src/HL/C/Community.hs new file mode 100644 index 0000000..e128ebb --- /dev/null +++ b/src/HL/C/Community.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Community page controller. + +module HL.C.Community where + +import HL.C.Markdown +import HL.C + +-- | Community controller. +getCommunityR :: C Html +getCommunityR = + markdownPage CommunityR "Community" "community.md" diff --git a/src/HL/C/Documentation.hs b/src/HL/C/Documentation.hs new file mode 100644 index 0000000..8fb9f08 --- /dev/null +++ b/src/HL/C/Documentation.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Documentation page controller. + +module HL.C.Documentation where + +import HL.C.Markdown +import HL.C + +-- | Documentation controller. +getDocumentationR :: C Html +getDocumentationR = + markdownPage DocumentationR "Documentation" "documentation.md" diff --git a/src/HL/C/Downloads.hs b/src/HL/C/Downloads.hs new file mode 100644 index 0000000..03f7532 --- /dev/null +++ b/src/HL/C/Downloads.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Downloads page controller. + +module HL.C.Downloads where + +import HL.C.Markdown +import HL.C + +-- | Downloads controller. +getDownloadsR :: C Html +getDownloadsR = + markdownPage DownloadsR "Downloads" "downloads.md" diff --git a/src/HL/C/Home.hs b/src/HL/C/Home.hs new file mode 100644 index 0000000..aa7892a --- /dev/null +++ b/src/HL/C/Home.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Home page controller. + +module HL.C.Home where + +import HL.C.Markdown +import HL.C + +-- | Home controller. +getHomeR :: C Html +getHomeR = + markdownPage HomeR "Home" "home.md" diff --git a/src/HL/C/Markdown.hs b/src/HL/C/Markdown.hs new file mode 100644 index 0000000..d22fe2c --- /dev/null +++ b/src/HL/C/Markdown.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Get markdown templates. + +module HL.C.Markdown where + +import HL.C +import HL.M.Markdown +import HL.V.Markdown + +-- | Render a simple markdown page. +markdownPage :: Route App -> Text -> FilePath -> C Html +markdownPage route t name = + do content <- getMarkdown name + blaze (markdownV route t content) diff --git a/src/HL/C/News.hs b/src/HL/C/News.hs new file mode 100644 index 0000000..8163855 --- /dev/null +++ b/src/HL/C/News.hs @@ -0,0 +1,10 @@ +-- | News page controller. + +module HL.C.News where + +import HL.C +import HL.V.News + +-- | News controller. +getNewsR :: C Html +getNewsR = blaze newsV diff --git a/src/HL/Controller/Reload.hs b/src/HL/C/Reload.hs similarity index 68% rename from src/HL/Controller/Reload.hs rename to src/HL/C/Reload.hs index ad2032b..2bef3c7 100644 --- a/src/HL/Controller/Reload.hs +++ b/src/HL/C/Reload.hs @@ -1,13 +1,13 @@ -- | Reload poller. -module HL.Controller.Reload where +module HL.C.Reload where -import HL.Foundation +import HL.C import Control.Concurrent.Chan.Lifted -- | Reload controller. -getReloadR :: Handler () +getReloadR :: C () getReloadR = do reload <- fmap appReload getYesod dupChan reload >>= readChan diff --git a/src/HL/C/Report.hs b/src/HL/C/Report.hs new file mode 100644 index 0000000..db1b2ac --- /dev/null +++ b/src/HL/C/Report.hs @@ -0,0 +1,10 @@ +-- | Report page controller. + +module HL.C.Report where + +import HL.C +import HL.V.Report + +-- | Report controller. +getReportR :: Int -> C Html +getReportR _ = blaze reportV diff --git a/src/HL/C/Theme.hs b/src/HL/C/Theme.hs new file mode 100644 index 0000000..4745923 --- /dev/null +++ b/src/HL/C/Theme.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | CSS theme. + +module HL.C.Theme where + +import HL.C hiding (Text) +import HL.V.Theme + +import Data.Text.Lazy (Text) +import Language.CSS + +-- | Generate CSS from theme. +getThemeR :: C TypedContent +getThemeR = + respondSource "text/css" (sendChunk themeCss) + +-- | The theme's CSS. +themeCss :: Text +themeCss = + renderCSS (runCSS theme) diff --git a/src/HL/C/Wiki.hs b/src/HL/C/Wiki.hs new file mode 100644 index 0000000..1f144c8 --- /dev/null +++ b/src/HL/C/Wiki.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Wiki page controller. + +module HL.C.Wiki where + +import HL.C +import HL.M.Wiki +import HL.V.Wiki + +import Prelude hiding (readFile,catch) + +-- | Wiki home (no page specified). +getWikiHomeR :: C Html +getWikiHomeR = + redirect (WikiR "HaskellWiki:Community") + +-- | Wiki controller. +getWikiR :: Text -> C Html +getWikiR name = + do url <- getUrlRender + result <- getWikiPage name + blaze (wikiV url result) diff --git a/src/HL/Controller.hs b/src/HL/Controller.hs new file mode 100644 index 0000000..c5d54e3 --- /dev/null +++ b/src/HL/Controller.hs @@ -0,0 +1,11 @@ +-- | Controller library. + +module HL.Controller + (module C) + where + +import HL.Foundation + +import Yesod as C + +type Controller = Handler diff --git a/src/HL/Controller/Community.hs b/src/HL/Controller/Community.hs deleted file mode 100644 index 908fb0c..0000000 --- a/src/HL/Controller/Community.hs +++ /dev/null @@ -1,10 +0,0 @@ --- | Community page controller. - -module HL.Controller.Community where - -import HL.Foundation -import HL.View.Community - --- | Community controller. -getCommunityR :: Handler Html -getCommunityR = blaze communityV diff --git a/src/HL/Controller/Documentation.hs b/src/HL/Controller/Documentation.hs deleted file mode 100644 index ccc2f6b..0000000 --- a/src/HL/Controller/Documentation.hs +++ /dev/null @@ -1,10 +0,0 @@ --- | Documentation page controller. - -module HL.Controller.Documentation where - -import HL.Foundation -import HL.View.Documentation - --- | Documentation controller. -getDocumentationR :: Handler Html -getDocumentationR = blaze documentationV diff --git a/src/HL/Controller/Downloads.hs b/src/HL/Controller/Downloads.hs deleted file mode 100644 index fe708ab..0000000 --- a/src/HL/Controller/Downloads.hs +++ /dev/null @@ -1,10 +0,0 @@ --- | Downloads page controller. - -module HL.Controller.Downloads where - -import HL.Foundation -import HL.View.Downloads - --- | Downloads controller. -getDownloadsR :: Handler Html -getDownloadsR = blaze downloadsV diff --git a/src/HL/Controller/Home.hs b/src/HL/Controller/Home.hs deleted file mode 100644 index ba1da68..0000000 --- a/src/HL/Controller/Home.hs +++ /dev/null @@ -1,10 +0,0 @@ --- | Home page controller. - -module HL.Controller.Home where - -import HL.Foundation -import HL.View.Home - --- | Home controller. -getHomeR :: Handler Html -getHomeR = blaze homeV diff --git a/src/HL/Controller/News.hs b/src/HL/Controller/News.hs deleted file mode 100644 index 9616465..0000000 --- a/src/HL/Controller/News.hs +++ /dev/null @@ -1,10 +0,0 @@ --- | News page controller. - -module HL.Controller.News where - -import HL.Foundation -import HL.View.News - --- | News controller. -getNewsR :: Handler Html -getNewsR = blaze newsV diff --git a/src/HL/Controller/Report.hs b/src/HL/Controller/Report.hs deleted file mode 100644 index 2fc341f..0000000 --- a/src/HL/Controller/Report.hs +++ /dev/null @@ -1,10 +0,0 @@ --- | Report page controller. - -module HL.Controller.Report where - -import HL.Foundation -import HL.View.Report - --- | Report controller. -getReportR :: Int -> Handler Html -getReportR year = blaze reportV diff --git a/src/HL/Controller/Theme.hs b/src/HL/Controller/Theme.hs deleted file mode 100644 index eefb64d..0000000 --- a/src/HL/Controller/Theme.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | CSS theme. - -module HL.Controller.Theme where - -import HL.Foundation -import HL.View.Theme - -import Data.Text.Lazy (Text) -import Language.CSS - --- | Generate CSS from Clay theme. -getThemeR :: Handler TypedContent -getThemeR = - respondSource "text/css" (sendChunk themeCss) - -themeCss :: Text -themeCss = renderCSS (runCSS theme) diff --git a/src/HL/Controller/Wiki.hs b/src/HL/Controller/Wiki.hs deleted file mode 100644 index b06b892..0000000 --- a/src/HL/Controller/Wiki.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Wiki page controller. - -module HL.Controller.Wiki where - -import HL.Foundation -import HL.View.Wiki - -import Text.Pandoc.Options -import Blaze (renderHtml) -import Language.Haskell.HsColour.CSS (hscolour) -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,pack) -import Network.HTTP.Conduit -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 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 url article = - do request <- parseUrl ("http://www.haskell.org/haskellwiki/Special:Export/" <> unpack article) - withManager $ \manager -> do - response <- http request manager - 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 writeOptions text)) - where - writeOptions = def { writerTableOfContents = True } - parse doc = - do let cursor = fromDocument doc - title <- listToMaybe (getTitle cursor) - text <- listToMaybe (getText cursor) - return (title,(highlightBlock . highlightInline . relativize url) - (readMediaWiki def (unpack text))) - name n = - Name {nameLocalName = n - ,nameNamespace = Just "http://www.mediawiki.org/xml/export-0.6/" - ,namePrefix = Nothing} - getText cursor = - element (name "mediawiki") cursor >>= - descendant >>= - element (name "page") >>= - descendant >>= - element (name "text") >>= - descendant >>= - content - getTitle cursor = - element (name "mediawiki") cursor >>= - descendant >>= - element (name "page") >>= - descendant >>= - element (name "title") >>= - descendant >>= - content - --- | Make all wiki links use the wiki route. -relativize :: (Route App -> Text) -> Pandoc -> Pandoc -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 - --- | Highlight code blocks and inline code samples with a decent --- Haskell syntax highlighter. -highlightBlock :: Pandoc -> Pandoc -highlightBlock = walk codes - where codes (CodeBlock attrs@("",["haskell"],[]) text) = - RawBlock "html" (hscolour False text) - codes x = x - --- | Highlight code blocks and inline code samples with a decent --- Haskell syntax highlighter. -highlightInline :: Pandoc -> Pandoc -highlightInline = walk codes - where codes (Code attrs@("",["haskell"],[]) text) = - RawInline "html" (codeEl (stripCPre (stripPre (hscolour False text)))) - codes x = x - stripPre ('<':'p':'r':'e':'>':xs) = xs - stripPre xs = xs - stripCPre (reverse -> ('<':'/':'p':'r':'e':'>':xs)) = reverse xs - stripCPre xs = xs - codeEl xs = "" ++ xs ++ "" diff --git a/src/HL/Dispatch.hs b/src/HL/Dispatch.hs index 8aca49a..a116648 100644 --- a/src/HL/Dispatch.hs +++ b/src/HL/Dispatch.hs @@ -5,15 +5,17 @@ module HL.Dispatch () where -import HL.Controller.Community -import HL.Controller.Documentation -import HL.Controller.Downloads -import HL.Controller.Home -import HL.Controller.News -import HL.Controller.Reload -import HL.Controller.Report -import HL.Controller.Theme -import HL.Controller.Wiki +import HL.C.Community +import HL.C.Documentation +import HL.C.Downloads +import HL.C.Home +import HL.C.News +import HL.C.Reload +import HL.C.Report +import HL.C.Theme +import HL.C.Wiki import HL.Foundation +import Yesod + mkYesodDispatch "App" resourcesApp diff --git a/src/HL/Foundation.hs b/src/HL/Foundation.hs index 061645a..5fdef6c 100644 --- a/src/HL/Foundation.hs +++ b/src/HL/Foundation.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-orphans #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,7 +8,6 @@ module HL.Foundation (module HL.Static - ,module Yesod.Blaze ,App(..) ,Route(..) ,Handler @@ -16,22 +16,15 @@ module HL.Foundation where import HL.Static +import HL.Types -import Control.Concurrent.Chan import Data.Text (Text) import Network.Wai.Logger import System.Log.FastLogger import Yesod -import Yesod.Blaze import Yesod.Core.Types import Yesod.Static --- | Application state. -data App = App - { appStatic :: Static - , appReload :: Chan () - } - -- | Generate boilerplate. mkYesodData "App" $(parseRoutesFile "config/routes") diff --git a/src/HL/M.hs b/src/HL/M.hs new file mode 100644 index 0000000..70438bf --- /dev/null +++ b/src/HL/M.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Model library. + +module HL.M where + +import Control.Applicative + +-- | The model monad. +newtype Model a = Model (IO a) + deriving (Monad,Functor,Applicative) diff --git a/src/HL/M/Markdown.hs b/src/HL/M/Markdown.hs new file mode 100644 index 0000000..a1cc65d --- /dev/null +++ b/src/HL/M/Markdown.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Markdown files. + +module HL.M.Markdown where + +import HL.C +import HL.Types + +import Control.Exception +import qualified Data.Text.Lazy.IO as LT +import System.Directory +import System.FilePath +import Text.Markdown + +-- | Get the HTML for the given markdown static file. +getMarkdown :: FilePath -> C Html +getMarkdown name = + do exists <- io (doesFileExist fp) + if exists + then do text <- io (LT.readFile fp) + let !html = markdown def text + return html + else throw (MarkdownFileUnavailable name) + where fp = "static" "markdown" name diff --git a/src/HL/M/Wiki.hs b/src/HL/M/Wiki.hs new file mode 100644 index 0000000..b1030d6 --- /dev/null +++ b/src/HL/M/Wiki.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Model for wiki. + +module HL.M.Wiki where + +import HL.C + +import Control.Exception.Lifted (catch) +import Data.Conduit + +import Data.Maybe +import Data.Monoid +import Data.Text (unpack) + +import Network.HTTP.Conduit +import Prelude hiding (readFile,catch) +import Text.Pandoc.Definition +import Text.Pandoc.Options +import Text.Pandoc.Readers.MediaWiki + +import Text.XML +import Text.XML.Cursor + +-- | Get the MediaWiki markup of a wiki page and then convert it to +-- HTML. +getWikiPage :: Text -> C (Either Text (Text,Pandoc)) +getWikiPage article = + do request <- parseUrl ("http://www.haskell.org/haskellwiki/Special:Export/" <> unpack article) + withManager $ \manager -> do + response <- http request manager + doc <- catch (fmap Just (responseBody response $$+- sinkDoc def)) + (\(_::UnresolvedEntityException) -> return Nothing) + case doc >>= parse of + Nothing -> return (Left "Unable to parse XML from haskell.org.") + Just (title,pan) -> return (Right (title,pan)) + where + parse doc = + do let cursor = fromDocument doc + title <- listToMaybe (getTitle cursor) + text <- listToMaybe (getText cursor) + return (title,readMediaWiki def (unpack text)) + name n = + Name {nameLocalName = n + ,nameNamespace = Just "http://www.mediawiki.org/xml/export-0.6/" + ,namePrefix = Nothing} + getText cursor = + element (name "mediawiki") cursor >>= + descendant >>= + element (name "page") >>= + descendant >>= + element (name "text") >>= + descendant >>= + content + getTitle cursor = + element (name "mediawiki") cursor >>= + descendant >>= + element (name "page") >>= + descendant >>= + element (name "title") >>= + descendant >>= + content diff --git a/src/HL/Static.hs b/src/HL/Static.hs index 935fd6e..041c219 100644 --- a/src/HL/Static.hs +++ b/src/HL/Static.hs @@ -4,4 +4,5 @@ module HL.Static where import Yesod.Static + staticFiles "static/" diff --git a/src/HL/Types.hs b/src/HL/Types.hs new file mode 100644 index 0000000..8177bd9 --- /dev/null +++ b/src/HL/Types.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Side-wide datatypes. + +module HL.Types where + +import Control.Concurrent.Chan +import Control.Exception +import Data.Typeable +import Yesod.Static + +-- | A haskell-lang exception. +data HaskellLangException = + MarkdownFileUnavailable FilePath + deriving (Show,Typeable,Eq) + +instance Exception HaskellLangException + +-- | Application state. +data App = App + { appStatic :: Static + , appReload :: Chan () + } diff --git a/src/HL/V.hs b/src/HL/V.hs new file mode 100644 index 0000000..0d5d309 --- /dev/null +++ b/src/HL/V.hs @@ -0,0 +1,14 @@ +-- | View library. + +module HL.V + (module V) + where + +import HL.Foundation as V (Route(..),App) +import HL.Static as V + +import Blaze.Bootstrap as V +import Blaze.Prelude as V +import Data.Text as V (Text) +import Yesod.Blaze as V +import Control.Monad as V diff --git a/src/HL/View/Documentation.hs b/src/HL/V/Documentation.hs similarity index 84% rename from src/HL/View/Documentation.hs rename to src/HL/V/Documentation.hs index 307571d..aec16bc 100644 --- a/src/HL/View/Documentation.hs +++ b/src/HL/V/Documentation.hs @@ -1,15 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS -fno-warn-unused-do-bind #-} -- | Documentation page view. -module HL.View.Documentation where +module HL.V.Documentation where -import HL.Foundation -import HL.View.Template - -import Blaze.Prelude -import Blaze.Bootstrap +import HL.V +import HL.V.Template -- | Documentation view. documentationV :: Blaze App @@ -22,15 +20,17 @@ documentationV = (row (span12 (do h1 [] "Documentation" - online url + online report url)))) -online url = +online :: Html +online = do h2 [] "Online Resources" p [] "There are various online resources for learning Haskell; books, \ \articles, videos, etc. below are some of the highlights:" +report :: (Route App -> AttributeValue) -> Html report url = do h2 [] "Language Report" p [] diff --git a/src/HL/V/Markdown.hs b/src/HL/V/Markdown.hs new file mode 100644 index 0000000..57ed915 --- /dev/null +++ b/src/HL/V/Markdown.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Simple markdown page view. + +module HL.V.Markdown where + +import HL.V +import HL.V.Template + +-- | Render a simple page. +markdownV :: Route App -> Text -> Html -> Blaze App +markdownV route t inner = + template + [(route,t)] + t + (const (container (row (span12 inner)))) diff --git a/src/HL/View/News.hs b/src/HL/V/News.hs similarity index 74% rename from src/HL/View/News.hs rename to src/HL/V/News.hs index 3d3ec8e..75b82ad 100644 --- a/src/HL/View/News.hs +++ b/src/HL/V/News.hs @@ -3,13 +3,10 @@ -- | News page view. -module HL.View.News where +module HL.V.News where -import HL.Foundation -import HL.View.Template - -import Blaze.Prelude -import Blaze.Bootstrap +import HL.V +import HL.V.Template -- | News view. newsV :: Blaze App diff --git a/src/HL/View/Report.hs b/src/HL/V/Report.hs similarity index 69% rename from src/HL/View/Report.hs rename to src/HL/V/Report.hs index e423088..6e236e3 100644 --- a/src/HL/View/Report.hs +++ b/src/HL/V/Report.hs @@ -3,13 +3,10 @@ -- | Report page view. -module HL.View.Report where +module HL.V.Report where -import HL.Foundation -import HL.View.Template - -import Blaze.Prelude -import Blaze.Bootstrap +import HL.V +import HL.V.Template -- | Report view. reportV :: Blaze App @@ -17,7 +14,7 @@ reportV = template [(ReportR 2010,"Report")] "Report" - (\url -> + (\_ -> container (row (span12 diff --git a/src/HL/View/Template.hs b/src/HL/V/Template.hs similarity index 62% rename from src/HL/View/Template.hs rename to src/HL/V/Template.hs index 85a37d4..62b7a09 100644 --- a/src/HL/View/Template.hs +++ b/src/HL/V/Template.hs @@ -3,16 +3,11 @@ -- | Templates. -module HL.View.Template where +module HL.V.Template where -import HL.Foundation +import HL.V hiding (item) -import Blaze (AttributeValue) -import Blaze.Bootstrap import qualified Blaze.Elements as E -import Blaze.Prelude -import Control.Monad -import Data.Text (Text) -- | Render a template. template @@ -64,31 +59,33 @@ navigation cur url = (div [class_ "container"] (do brand items)) - where items = - div [class_ "collapse navbar-collapse"] - (ul [class_ "nav navbar-nav"] - (mapM_ (uncurry item) - [(DownloadsR,"Downloads") - ,(CommunityR,"Community") - ,(DocumentationR,"Documentation") - ,(NewsR,"News") - ,(WikiHomeR,"Wiki")])) - where item route title = li theclass (a [href (url route)] title) - where theclass - | Just route == cur = [class_ "active"] - | otherwise = [] - brand = - div [class_ "navbar-header"] - (do a [class_ "navbar-brand" - ,href (url HomeR)] - (do span [class_ "logo"] - "\xe000" - "Haskell")) + where + items = + div [class_ "collapse navbar-collapse"] + (ul [class_ "nav navbar-nav"] + (mapM_ (uncurry item) + [(DownloadsR,"Downloads") + ,(CommunityR,"Community") + ,(DocumentationR,"Documentation") + ,(NewsR,"News") + ,(WikiHomeR,"Wiki")])) + where item route t = li theclass (a [href (url route)] t) + where theclass + | Just route == cur = [class_ "active"] + | otherwise = [] + brand = + div [class_ "navbar-header"] + (do a [class_ "navbar-brand" + ,href (url HomeR)] + (do span [class_ "logo"] + "\xe000" + "Haskell")) -- | Breadcrumb. bread :: (t -> E.AttributeValue) -> [(t,Text)] -> Html bread url crumbs = ol [class_ "breadcrumb"] (forM_ crumbs - (\(route,title) -> li [] (a [href (url route)] - (toHtml title)))) + (\(route,t) -> + li [] (a [href (url route)] + (toHtml t)))) diff --git a/src/HL/View/Theme.hs b/src/HL/V/Theme.hs similarity index 96% rename from src/HL/View/Theme.hs rename to src/HL/V/Theme.hs index 110b4b8..c4cd68d 100644 --- a/src/HL/View/Theme.hs +++ b/src/HL/V/Theme.hs @@ -4,7 +4,7 @@ -- | CSS theme. -module HL.View.Theme +module HL.V.Theme (theme) where @@ -64,15 +64,15 @@ navbar = rule ".navbar-header .navbar-brand:hover" (color "#fff") rule ".navbar-default .navbar-nav > .active > a" - (do theme + (do theme' backgroundColor "#312b3f" borderBottom "0.3em solid #465787") rule ".navbar-default .navbar-nav > .active > a:hover" - (do theme + (do theme' backgroundColor "#312b3f") rule ".navbar-default .navbar-nav > li > a" - theme - where theme = + theme' + where theme' = do color "#d1cddc !important" backgroundColor "inherit" diff --git a/src/HL/V/Wiki.hs b/src/HL/V/Wiki.hs new file mode 100644 index 0000000..353982b --- /dev/null +++ b/src/HL/V/Wiki.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Wiki page view. + +module HL.V.Wiki where + +import HL.V +import HL.V.Template + +import Data.List (isPrefixOf) +import Data.Text (unpack,pack) +import Language.Haskell.HsColour.CSS (hscolour) +import Prelude hiding (readFile,catch) +import Text.Pandoc.Definition +import Text.Pandoc.Options +import Text.Pandoc.Walk +import Text.Pandoc.Writers.HTML + +-- | Wiki view. +wikiV :: (Route App -> Text) -> Either Text (Text,Pandoc) -> Blaze App +wikiV urlr result = + template + ([(WikiHomeR,"Wiki")] ++ + [(WikiR n,n) | Right (n,_) <- [result]]) + (case result of + Left{} -> "Wiki error!" + Right (t,_) -> t) + (\_ -> + container + (row + (span12 + (case result of + Left err -> + do h1 [] "Wiki page retrieval problem!" + p [] (toHtml err) + Right (t,pan) -> + do h1 [] (toHtml t) + writeHtml writeOptions (cleanup urlr pan))))) + where cleanup url = highlightBlock . highlightInline . relativize url + writeOptions = def { writerTableOfContents = True } + +-- | Make all wiki links use the wiki route. +relativize :: (Route App -> Text) -> Pandoc -> Pandoc +relativize url = walk links + where links asis@(Link is (ref,t)) + | isPrefixOf "http://" ref || isPrefixOf "https://" ref = asis + | otherwise = Link is (unpack (url (WikiR (pack ref))),t) + links x = x + +-- | Highlight code blocks and inline code samples with a decent +-- Haskell syntax highlighter. +highlightBlock :: Pandoc -> Pandoc +highlightBlock = walk codes + where codes (CodeBlock ("",["haskell"],[]) text) = + RawBlock "html" (hscolour False text) + codes x = x + +-- | Highlight code blocks and inline code samples with a decent +-- Haskell syntax highlighter. +highlightInline :: Pandoc -> Pandoc +highlightInline = walk codes + where codes (Code ("",["haskell"],[]) text) = + RawInline "html" (codeEl (stripCPre (stripPre (hscolour False text)))) + codes x = x + stripPre ('<':'p':'r':'e':'>':xs) = xs + stripPre xs = xs + stripCPre (reverse -> ('<':'/':'p':'r':'e':'>':xs)) = reverse xs + stripCPre xs = xs + codeEl xs = "" ++ xs ++ "" diff --git a/src/HL/View/Community.hs b/src/HL/View/Community.hs deleted file mode 100644 index cdc74e1..0000000 --- a/src/HL/View/Community.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Community page view. - -module HL.View.Community where - -import HL.Foundation -import HL.View.Template - -import Blaze.Prelude -import Blaze.Bootstrap - --- | Community view. -communityV :: Blaze App -communityV = - template - [(CommunityR,"Community")] - "Community" - (\_ -> - container - (row - (span12 - (do h1 [] "Community" - p [] - "The Haskell community is spread out online across several mediums \ - \and around the world!" - ul [] - (do li [] "The Haskell-Cafe mailing list" - li [] "StackOverflow" - li [] "G+" - li [] "Reddit" - li [] "The Wiki"))))) diff --git a/src/HL/View/Downloads.hs b/src/HL/View/Downloads.hs deleted file mode 100644 index ffa9d8b..0000000 --- a/src/HL/View/Downloads.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Downloads page view. - -module HL.View.Downloads where - -import HL.Foundation -import HL.View.Template - -import Blaze.Prelude -import Blaze.Bootstrap - --- | Downloads view. -downloadsV :: Blaze App -downloadsV = - template - [(DownloadsR,"Downloads")] - "Downloads" - (\_ -> - container - (row - (span12 - (do h1 [] "Downloads" - p [] - "The Haskell Platform was a comprehensive, robust development \ - \environment for programming in Haskell. For new users the \ - \platform makes it trivial to get up and running with a full \ - \Haskell development environment. For experienced developers, \ - \the platform provides a comprehensive, standard base for \ - \commercial and open source Haskell development that maximises \ - \interoperability and stability of your code.")))) diff --git a/src/HL/View/Home.hs b/src/HL/View/Home.hs deleted file mode 100644 index 65c11e8..0000000 --- a/src/HL/View/Home.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Home page view. - -module HL.View.Home where - -import HL.Foundation -import HL.View.Template - -import Blaze.Prelude -import Blaze.Bootstrap - --- | Home view. -homeV :: Blaze App -homeV = - template - [(HomeR,"Home")] - "Home" - (\_ -> - container - (row - (span12 - (do h1 [] "Haskell" - p [] - "The Haskell Platform was a comprehensive, robust development \ - \environment for programming in Haskell. For new users the \ - \platform makes it trivial to get up and running with a full \ - \Haskell development environment. For experienced developers, \ - \the platform provides a comprehensive, standard base for \ - \commercial and open source Haskell development that maximises \ - \interoperability and stability of your code." - p [] - "Lorem ipsum dolor sit amet, consectetur adipiscing elit. \ - \Suspendisse vitae aliquet lorem. Praesent sed egestas risus. \ - \Cras a neque eget dui pharetra feugiat sed vel erat. Vivamus \ - \magna sapien, congue quis tellus eu, imperdiet sagittis dolor. \ - \Praesent dolor magna, suscipit in posuere nec, faucibus eu \ - \velit.")))) diff --git a/src/HL/View/Wiki.hs b/src/HL/View/Wiki.hs deleted file mode 100644 index 0d720f9..0000000 --- a/src/HL/View/Wiki.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Wiki page view. - -module HL.View.Wiki where - -import HL.Foundation -import HL.View.Template - -import Blaze.Bootstrap -import Blaze.Prelude -import Data.Text (Text) - --- | Wiki view. -wikiV :: Either Text (Text,Html) -> Blaze App -wikiV result = - template - ([(WikiHomeR,"Wiki")] ++ - [(WikiR name,name) | Right (name,_) <- [result]]) - (case result of - Left{} -> "Wiki error!" - Right (title,_) -> title) - (\_ -> - container - (row - (span12 - (case result of - Left err -> - do h1 [] "Wiki page retrieval problem!" - p [] (toHtml err) - Right (title,html) -> - do h1 [] (toHtml title) - html)))) diff --git a/src/Main.hs b/src/Main.hs index a31f612..78cd66e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,7 +4,7 @@ module Main where import HL.Foundation import HL.Dispatch () -import HL.Controller.Theme +import HL.C.Theme import Control.Concurrent.Chan import qualified Data.Text.Lazy.IO as L diff --git a/static/markdown/community.md b/static/markdown/community.md new file mode 100644 index 0000000..046be98 --- /dev/null +++ b/static/markdown/community.md @@ -0,0 +1,9 @@ +# Community + +The Haskell community is spread out online across several mediums and around the world! + +* The Haskell-Cafe mailing list +* StackOverflow +* G+ +* Reddit +* The Wiki diff --git a/static/markdown/documentation.md b/static/markdown/documentation.md new file mode 100644 index 0000000..8c11811 --- /dev/null +++ b/static/markdown/documentation.md @@ -0,0 +1,17 @@ +# Documentation + +## Online Resources + +There are various online resources for learning Haskell; books, +articles, videos, etc. below are some of the highlights: + +## Language Report + +The Haskell 2010 language report is available +[online here](http://localhost:1990/report/2010). + +A PDF version is [available here](http://haskell.org/definition/haskell2010.pdf). + +It can also be downloaded as a darcs repository: + + $ darcs get http://darcs.haskell.org/haskell2010-report diff --git a/static/markdown/downloads.md b/static/markdown/downloads.md new file mode 100644 index 0000000..fbf1ac2 --- /dev/null +++ b/static/markdown/downloads.md @@ -0,0 +1,10 @@ +# Downloads + +The Haskell Platform was a comprehensive, robust development +environment for programming in Haskell. For new users the platform +makes it trivial to get up and running with a full Haskell development +environment. + +For experienced developers, the platform provides a comprehensive, +standard base for commercial and open source Haskell development that +maximises interoperability and stability of your code. diff --git a/static/markdown/home.md b/static/markdown/home.md new file mode 100644 index 0000000..10ddd6d --- /dev/null +++ b/static/markdown/home.md @@ -0,0 +1 @@ +Hello!