Initial Import.Content, no Markdown support yet

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "content"]
+	path = content
+	url = https://github.com/yesodweb/yesodweb.com-content.git

Handler/Root.hs

@@ -3,4 +3,4 @@ module Handler.Root where
 import Import
 
 getRootR :: Handler RepHtml
-getRootR = defaultLayout $(widgetFile "homepage")
+getRootR = returnContent [unsafeHtmlFormat] ["homepage"]

Import.hs

@@ -5,14 +5,16 @@ module Import
     , Text
     , module Data.Monoid
     , module Control.Applicative
+    , module Import.Content
     ) where
 
 import Prelude hiding (writeFile, readFile)
 import Foundation
 import Data.Monoid (Monoid (mappend, mempty, mconcat))
 import Control.Applicative ((<$>), (<*>), pure)
 import Data.Text (Text)
+import Import.Content
 
 infixr 5 <>
 (<>) :: Monoid m => m -> m -> m
-(<>) = mappend
+(<>) = mappend

Import/Content.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Load page contents from the content folder.
+module Import.Content
+    ( ContentFormat (..)
+    , htmlFormat
+    , unsafeHtmlFormat
+    , loadContent
+    , returnContent
+    ) where
+
+import Prelude ((.), ($), IO, Maybe (..), return, (==), maybe)
+import Data.Text (Text)
+import qualified Data.Conduit as C
+import qualified Data.Conduit.List as CL
+import qualified Data.Conduit.Text as CT
+import qualified Data.Conduit.Filesystem as CB
+import Text.Blaze (Html, preEscapedText, preEscapedLazyText, toHtml)
+import qualified Data.ByteString as S
+import Control.Applicative ((<$>))
+import Text.HTML.SanitizeXSS (sanitizeBalance)
+import Filesystem.Path.CurrentOS ((</>), fromText, (<.>))
+import Filesystem (isFile)
+import Data.List (foldl')
+import qualified Data.Text.Lazy as TL
+import Control.Arrow (second)
+import Yesod
+    ( liftIO, GHandler, Yesod, RepHtml, notFound, defaultLayout
+    , setTitle, toWidget
+    )
+
+data ContentFormat = ContentFormat
+    { cfExtension :: Text
+    , cfLoad :: C.Sink S.ByteString IO (Maybe Html, Html)
+    }
+
+-- | Turn a stream of 'S.ByteString's into an optional title line and the rest
+-- of the text. Assumes UTF8 encoding.
+sinkText :: C.Sink S.ByteString IO (Maybe Html, TL.Text)
+sinkText =
+    go . TL.fromChunks <$> (CT.decode CT.utf8 C.=$ CL.consume)
+  where
+    go t =
+        case TL.stripPrefix "title: " x of
+            Just title -> (Just $ toHtml title, TL.drop 1 y)
+            Nothing -> (Nothing, t)
+      where
+        (x, y) = TL.break (== '\n') t
+
+-- | HTML content with XSS protection.
+htmlFormat :: ContentFormat
+htmlFormat = ContentFormat "html" $
+    second (preEscapedText . sanitizeBalance . TL.toStrict) <$> sinkText
+
+-- | HTML content without XSS protection.
+unsafeHtmlFormat :: ContentFormat
+unsafeHtmlFormat = ContentFormat "html" $
+    second preEscapedLazyText <$> sinkText
+
+-- | Try to load 'Html' from the given path.
+loadContent :: [ContentFormat]
+            -> [Text]
+            -> IO (Maybe (Maybe Html, Html))
+loadContent [] _ = return Nothing
+loadContent (cf:cfs) pieces = do
+    e <- isFile path
+    if e
+        -- FIXME caching
+        then Just <$> (C.runResourceT $ CB.sourceFile path C.$$ cfLoad cf)
+        else loadContent cfs pieces
+  where
+    path = foldl' go "content" pieces <.> cfExtension cf
+    go x y = x </> fromText y
+
+-- | Return some content as a 'Handler'.
+returnContent :: Yesod master
+              => [ContentFormat]
+              -> [Text]
+              -> GHandler sub master RepHtml
+returnContent cfs pieces = do
+    mc <- liftIO $ loadContent cfs pieces
+    case mc of
+        Nothing -> notFound
+        Just (mtitle, body) -> defaultLayout $ do
+            maybe (return ()) setTitle mtitle
+            toWidget body

yesodweb.cabal

@@ -29,6 +29,7 @@ library
     exposed-modules: Application
     other-modules:   Foundation
                      Import
+                     Import.Content
                      Model
                      Settings
                      Settings.StaticFiles
@@ -85,7 +86,7 @@ executable         yesodweb
                  , bytestring                    >= 0.9        && < 0.10
                  , text                          >= 0.11       && < 0.12
                  , persistent                    >= 0.7        && < 0.8
-                 , persistent-postgresql     >= 0.7        && < 0.8
+                 , persistent-postgresql         >= 0.7        && < 0.8
                  , template-haskell
                  , hamlet                        >= 0.10       && < 0.11
                  , shakespeare-css               >= 0.10       && < 0.11
@@ -95,3 +96,9 @@ executable         yesodweb
                  , monad-control                 >= 0.3        && < 0.4
                  , wai-extra                     >= 1.0        && < 1.1
                  , yaml                          >= 0.5        && < 0.6
+                 , blaze-html                    >= 0.4        && < 0.5
+                 , conduit                       >= 0.0        && < 0.1
+                 , xss-sanitize                  >= 0.3.1      && < 0.4
+                 , system-filepath               >= 0.4.4      && < 0.5
+                 , system-fileio                 >= 0.3        && < 0.4
+                 , filesystem-conduit            >= 0.0        && < 0.1