Move model functions out of C monad

src/Data/Conduit/List/TakeDrop.hs

@@ -0,0 +1,27 @@
+-- | Take/drop tools.
+
+module Data.Conduit.List.TakeDrop where
+
+import Data.Conduit
+import Prelude hiding (takeWhile,dropWhile)
+
+-- | Take elements and yield them into upstream while the given
+-- predicate holds, afterwards stop consuming.
+takeWhile :: Monad m => (a -> Bool) -> Conduit a m a
+takeWhile p =
+  do m <- await
+     case m of
+       Nothing -> return ()
+       Just x | p x -> do yield x
+                          takeWhile p
+              | otherwise -> return ()
+
+-- | Consume elements and discard them until a given predicate holds,
+-- then yield everything following from upstream to downstream.
+dropWhile :: Monad m => (a -> Bool) -> Conduit a m a
+dropWhile p =
+  do m <- await
+     case m of
+       Nothing -> return ()
+       Just x | p x -> dropWhile p
+              | otherwise -> awaitForever yield

src/Data/Conduit/TakeDrop.hs

@@ -0,0 +1,21 @@
+-- | Take/drop tools.
+
+module Data.Conduit.List.TakeDrop where
+
+takeWhile :: Monad m => (a -> Bool) -> Conduit a m a
+takeWhile p =
+  do m <- await
+     case m of
+       Nothing -> return ()
+       Just x | p x -> do yield x
+                          takeWhile p
+              | otherwise -> return ()
+
+
+dropWhile :: Monad m => (a -> Bool) -> Conduit a m a
+dropWhile p =
+  do m <- await
+     case m of
+       Nothing -> return ()
+       Just x | p x -> dropWhile p
+              | otherwise -> awaitForever yield

src/HL/C/Documentation.hs

@@ -4,10 +4,10 @@
 
 module HL.C.Documentation where
 
-import HL.C.Markdown
 import HL.C
+import HL.V.Documentation
 
 -- | Documentation controller.
 getDocumentationR :: C Html
 getDocumentationR =
-  markdownPage [DocumentationR] "Documentation" "documentation.md"
+  blaze documentationV

src/HL/C/Markdown.hs

@@ -11,5 +11,5 @@ import           HL.V.Markdown
 -- | Render a simple markdown page.
 markdownPage :: [Route App] -> Text -> FilePath -> C Html
 markdownPage crumbs t name =
-  do content <- getMarkdown name
+  do content <- io (getMarkdown name)
      blaze (markdownV crumbs t content)

src/HL/C/News.hs

@@ -11,5 +11,5 @@ import HL.V.News
 -- | News controller.
 getNewsR :: C Html
 getNewsR =
-  do html <- getHaskellNews
+  do html <- io getHaskellNews
      blaze (newsV html)

src/HL/C/Report.hs

@@ -4,7 +4,15 @@ module HL.C.Report where
 
 import HL.C
 import HL.V.Report
+import HL.M.Report
 
 -- | Report controller.
-getReportR :: Int -> C Html
-getReportR _ = blaze reportV
+getReportR :: Int -> FilePath -> C Html
+getReportR year page =
+  do content <- io (getReportPage year page)
+     blaze (reportV year page content)
+
+-- | Default page to go to for the given year.
+getReportHomeR :: Int -> C Html
+getReportHomeR year =
+  redirect (ReportR year "haskell.html")

src/HL/C/Wiki.hs

@@ -21,5 +21,5 @@ getWikiHomeR =
 getWikiR :: Text -> C Html
 getWikiR name =
   do url <- getUrlRender
-     result <- getWikiPage name
+     result <- io (getWikiPage name)
      blaze (wikiV url result)

src/HL/M/Markdown.hs

@@ -14,11 +14,11 @@ import           System.FilePath
 import           Text.Markdown
 
 -- | Get the HTML for the given markdown static file.
-getMarkdown :: FilePath -> C Html
+getMarkdown :: FilePath -> IO Html
 getMarkdown name =
-  do exists <- io (doesFileExist fp)
+  do exists <- doesFileExist fp
      if exists
-        then do text <- io (LT.readFile fp)
+        then do text <- LT.readFile fp
                 let !html = markdown def text
                 return html
         else throw (MarkdownFileUnavailable name)

src/HL/M/News.hs

@@ -12,7 +12,7 @@ import Data.Text.Lazy (toStrict)
 import Network.HTTP.Conduit
 import Prelude hiding (readFile,catch)
 
-getHaskellNews :: C Html
+getHaskellNews :: IO Html
 getHaskellNews =
   do bytes <- simpleHttp "http://haskellnews.org/grouped?embeddable"
      return (preEscapedToMarkup (toStrict (decodeUtf8 bytes)))

src/HL/M/Report.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Read the Haskell report from file, do necessary transformations
+-- to get a reasonable page out of it.
+
+module HL.M.Report where
+
+import           HL.C
+import           HL.Types
+
+import           Control.Exception
+import qualified Data.ByteString as S
+import           Data.Char
+import           Data.Conduit
+import qualified Data.Conduit.List as CL
+import qualified Data.Conduit.List.TakeDrop as CL
+import           Data.Monoid
+import           Data.Text.ICU.Convert
+import           Data.XML.Types
+import           System.Directory
+import           System.FilePath
+import           Text.HTML.DOM
+import           Text.XML.Stream.Render
+
+-- | Get a report's page. The Haskell report is ISO-8859-1 encoded
+-- rather than UTF-8 so we use ICU to decode it from that instead,
+-- strip out surrounding HTML tags, and then return it as normal Html.
+getReportPage :: Int -> FilePath -> IO Html
+getReportPage year path =
+  do exists <- doesFileExist fp
+     converter <- open "iso-8859-1" (Just True)
+     if exists
+        then do !text <- fmap id (S.readFile fp)
+                stripWrapper text
+        else throw (ReportPageNotFound fp)
+  where normalize = filter (\c -> isDigit c || isLetter c || c == '.')
+        fp = "static" </> "report" </> ("haskell" ++ show year) </> normalize path
+
+-- | Rather than parsing the HTML, which is slower, we simply strip
+-- out any text until we see <body> and keep until we see </body>.
+stripWrapper :: S.ByteString -> IO Html
+stripWrapper x =
+  fmap (preEscapedToMarkup . mconcat) (conduit $$ CL.consume)
+  where conduit =
+          CL.sourceList [x] $=
+          eventConduit $=
+          CL.dropWhile (not . matchBegin "body") $=
+          CL.takeWhile (not . matchEnd "body") $=
+          renderText def
+
+-- | Match a beginning element.
+matchBegin :: Name -> Event -> Bool
+matchBegin n e =
+  case e of { EventBeginElement n' _ -> n == n'; _ -> False }
+
+-- | Match an ending element.
+matchEnd :: Name -> Event -> Bool
+matchEnd n e =
+  case e of { EventEndElement n' -> n == n'; _ -> False }

src/HL/M/Wiki.hs

@@ -26,7 +26,7 @@ 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 :: Text -> IO (Either Text (Text,Pandoc))
 getWikiPage article =
   do request <- parseUrl ("http://www.haskell.org/haskellwiki/Special:Export/" <> unpack article)
      withManager $ \manager -> do

src/HL/Types.hs

@@ -10,14 +10,15 @@ import Data.Typeable
 import Yesod.Static
 
 -- | A haskell-lang exception.
-data HaskellLangException =
-  MarkdownFileUnavailable FilePath
+data HaskellLangException
+  = MarkdownFileUnavailable !FilePath
+  | ReportPageNotFound !FilePath
   deriving (Show,Typeable,Eq)
 
 instance Exception HaskellLangException
 
 -- | Application state.
 data App = App
-  { appStatic :: Static
-  , appReload :: Chan ()
+  { appStatic :: !Static
+  , appReload :: !(Chan ())
   }

src/HL/V/Documentation.hs

@@ -13,7 +13,7 @@ import HL.V.Template
 documentationV :: Blaze App
 documentationV =
   template
-    [(DocumentationR,"Documentation")]
+    [DocumentationR]
     "Documentation"
     (\url ->
        container
@@ -35,7 +35,7 @@ report url =
   do h2 [] "Language Report"
      p []
        (do "The Haskell 2010 language report is available online "
-           a [href (url (ReportR 2010))]
+           a [href (url (ReportHomeR 2010))]
              "here"
            ".")
      p []

src/HL/V/Report.hs

@@ -9,13 +9,14 @@ import HL.V
 import HL.V.Template
 
 -- | Report view.
-reportV :: Blaze App
-reportV =
+reportV :: Int -> FilePath -> Html -> Blaze App
+reportV year page inner =
   template
-    [ReportR 2010]
+    [DocumentationR
+    ,ReportR year page]
     "Report"
     (\_ ->
        container
          (row
             (span12
-               (do p [] "Insert report here."))))
+               inner)))

src/HL/V/Template.hs

@@ -11,6 +11,7 @@ import           HL.V hiding (item)
 import qualified Blaze.Elements as E
 import           Data.Maybe
 import           Data.Monoid
+import           Data.Text (pack)
 
 -- | Render a template.
 template
@@ -110,5 +111,6 @@ fromRoute r =
     StaticR{}      -> "Static"
     DownloadsR     -> "Downloads"
     WikiR t        -> "Wiki: " <> t
-    ReportR{}      -> "Report"
+    ReportR i _    -> "Report " <> pack (show i)
+    ReportHomeR{}  -> "Report"
     WikiHomeR{}    -> "Wiki"