Merge branch 'rss' (closes #7)

itsa.cabal

@@ -50,8 +50,10 @@ Executable itsa
     text                      >= 0.11,
     time                      >= 1.1,
     transformers              >= 0.3,
+    xml-conduit               >= 1.0,
+    xml-hamlet,
     xmlhtml                   >= 0.1,
-    yaml                      >= 0.8,
+    yaml                      >= 0.8
 
   if flag(development)
     build-depends:

src/Config.hs

@@ -5,14 +5,17 @@ module Config where
 
 import Control.Applicative ((<$>), (<*>))
 import Control.Lens
-import Data.Text (Text)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text, stripSuffix)
 import Data.Time (TimeZone)
 import Data.Yaml as Yaml
 
 data Config = Config {
     __postsPerPage :: Int, -- ^ Number of posts to display on a page.
     __blogTitle :: Text, -- ^ Title of the blog.
-    __timeZone :: TimeZone -- ^ Time zone to display times in.
+    __timeZone :: TimeZone, -- ^ Time zone to display times in.
+    __appRoot :: Text -- ^ The base for all URLs used throughout,
+                      -- without the trailing slash.
 }
 
 makeLenses ''Config
@@ -21,4 +24,7 @@ instance FromJSON Config where
     parseJSON (Object o) = Config <$> o .: "posts-per-page"
                            <*> o .: "blog-title"
                            <*> fmap read (o .: "time-zone")
+                           <*> fmap stripSlash (o .: "app-root")
+      where
+        stripSlash url = fromMaybe url (stripSuffix "/" url)
     parseJSON _ = fail "Expected an object"

src/Handler.hs

@@ -3,29 +3,30 @@
 -- | Individual handlers. We use the renderers defined in Renderer and
 -- our own logic for picking which posts to render.
 
-module Handler (draftsPage, mainPage, postPage, queuePage, tagPage, staticPage)
+module Handler (draftsPage, mainPage, postPage, queuePage, tagPage, rss,
+                staticPage)
        where
 
-import Control.Applicative      ((<$>))
-import Control.Lens
-import Control.Monad.Reader
-import Data.ByteString          (ByteString)
-import Data.Maybe               (fromMaybe)
-import Data.Monoid              ((<>))
-import Data.Table
-import Data.Text                (Text, unpack)
-import Data.Text.Encoding       (decodeUtf8With)
-import Data.Text.Encoding.Error (lenientDecode)
-import Data.Time                (TimeZone, getCurrentTime)
-import Prelude                  hiding (FilePath)
-import Snap.Core
-import Text.Blaze.Renderer.Utf8 (renderMarkup)
-import Text.Hamlet              (HtmlUrl, hamlet)
-
-import Application
-import Config
-import Post.Types
-import Renderer
+import           Control.Applicative      ((<$>))
+import           Control.Lens
+import           Control.Monad.Reader
+import           Data.ByteString          (ByteString)
+import           Data.Maybe               (fromMaybe)
+import           Data.Table
+import           Data.Text                (Text, unpack)
+import           Data.Text.Encoding       (decodeUtf8With)
+import           Data.Text.Encoding.Error (lenientDecode)
+import           Data.Time                (TimeZone, getCurrentTime)
+import           Prelude                  hiding (FilePath)
+import           Snap.Core
+import           Text.Blaze.Renderer.Utf8 (renderMarkup)
+import           Text.Hamlet              (HtmlUrl, hamlet)
+import qualified Text.XML                 as XML
+
+import           Application
+import           Config
+import           Post.Types
+import           Renderer
 
 -- | This handler renders the main page; i.e., the most recent posts.
 mainPage :: AppHandler ()
@@ -84,6 +85,15 @@ staticPage = do
                    return $ renderStaticPage page
                Nothing -> return render404
 
+rss :: AppHandler ()
+rss = do
+    postTable <- getPostTable
+    now <- liftIO getCurrentTime
+    let posts = postTable^..withG _isDraft (==) False .withG _posted (<=) now
+                .group (^._posted).rows'
+                & take 10 . reverse
+    writeLBS =<< XML.renderLBS XML.def <$> renderRss posts
+
 
 -- | Similar to 'showAllPaginatedPosts', but excludes drafts and queued posts.
 showPaginatedPosts :: Lens' (Table Post) (Table Post) -> AppHandler ()
@@ -117,16 +127,10 @@ localhostOnly action = do
 -- | Serve a template using Snap by supplying the route renderer to
 -- it, rendering it, and writing as a lazy
 -- 'Data.ByteString.Lazy.ByteString'.
-serveTemplate :: (MonadSnap m) => HtmlUrl ItsaR -> m ()
-serveTemplate tpl = writeLBS . renderMarkup $ tpl renderRoute
- where
-    -- The route renderer. Make sure this synchronizes with the route
-    -- parser in Site.hs!
-    renderRoute :: ItsaR -> [(Text, Text)] -> Text
-    renderRoute RootR _ = "/"
-    renderRoute (TagR tag) _ = "/tagged/" <> tag
-    renderRoute (PostR slug) _ = "/post/" <> slug
-    renderRoute (StaticPageR slug) _ = "/page/" <> slug
+serveTemplate :: HtmlUrl ItsaR -> AppHandler ()
+serveTemplate tpl = do
+    appRoot <- view $ _config._appRoot
+    writeLBS . renderMarkup $ tpl $ Renderer.renderRoute appRoot
 
 getParamAsText :: (MonadSnap m) => ByteString -> m (Maybe Text)
 getParamAsText param = fmap (decodeUtf8With lenientDecode) <$> getParam param

src/RelativeHamlet.hs

@@ -7,19 +7,19 @@
 -- separate module from anything that uses hamletRelativeFile due to
 -- how TH staging works.
 
-module RelativeHamlet (hamletRelativeFile, Html) where
+module RelativeHamlet (hamletRelativeFile, xmlRelativeFile, Html) where
 
 import           Control.Applicative        ((<$>))
 import           Data.Maybe                 (mapMaybe)
 import           Filesystem
 import           Filesystem.Path.CurrentOS  hiding (FilePath, null)
 import qualified Filesystem.Path.CurrentOS  as FS
 import           Language.Haskell.TH.Syntax (Exp, Q, qAddDependentFile, qRunIO)
+import           Text.Hamlet                (Html, hamletFile)
+import           Text.Hamlet.XML            (xmlFile)
 
-import           Text.Hamlet                (Html, defaultHamletSettings,
-                                             hamletFileWithSettings,
-                                             hamletRules)
-
+-- | Find the cabal directory,s tarting from the path. If none found,
+-- error.
 findCabalDirFrom :: FS.FilePath -> IO FS.FilePath
 findCabalDirFrom path = do
     files <- filter ((/= ".cabal") . filename) <$> listDirectory path
@@ -33,10 +33,18 @@ findCabalDirFrom path = do
                then error "reached root (not below a .cabal file?)"
                 else findCabalDirFrom canonicalParent
 
--- Load a Hamlet file with a path relative to the .cabal directory.
+-- | Load a Hamlet file with a path relative to the .cabal directory.
 hamletRelativeFile :: String -> Q Exp
-hamletRelativeFile path = do
-    dir <- qRunIO $ getWorkingDirectory >>= findCabalDirFrom
+hamletRelativeFile path = hamletFile =<< getRealPath path
+
+-- | Load an XML Hamlet file with a path relative to the .cabal
+-- directory.
+xmlRelativeFile :: String -> Q Exp
+xmlRelativeFile path = xmlFile =<< getRealPath path
+
+getRealPath :: String -> Q String
+getRealPath path = do
+    dir <- qRunIO $ findCabalDirFrom =<< getWorkingDirectory
     let realPath = encodeString (dir </> decodeString path)
     qAddDependentFile realPath
-    hamletFileWithSettings hamletRules defaultHamletSettings realPath
+    return realPath

src/Renderer.hs

@@ -4,35 +4,59 @@
 -- rendered templates and give another template in return. Note that
 -- these templates don't have the routing renderer applied to them for
 -- composability reasons/separation of concerns.
-module Renderer (ItsaR(..),
+module Renderer (ItsaR(..), renderRoute,
                  renderTwoColumn,
                  renderDefault,
                  renderPosts,
                  renderPost,
                  renderStaticPage,
                  renderTagList,
+                 renderRss,
                  render404) where
 
-import Control.Lens
-import Data.List      (sortBy)
-import Data.Monoid
-import Data.Ord       (comparing)
-import Data.Table     (count, group, rows)
-import Data.Text      (Text)
-import Data.Time      (TimeZone, formatTime, utcToZonedTime)
-import System.Locale  (defaultTimeLocale)
-import Text.Hamlet    (HtmlUrl, hamlet)
-
-import Application
-import Config
-import Post.Types
-import RelativeHamlet
+import           Control.Lens
+import           Data.List                (sortBy)
+import qualified Data.Map                 as Map
+import           Data.Monoid
+import           Data.Ord                 (comparing)
+import           Data.Table               (count, group, rows)
+import           Data.Text                (Text)
+import           Data.Text.Lazy           (toStrict)
+import           Data.Time                (TimeZone, formatTime, utcToZonedTime)
+import           System.Locale            (defaultTimeLocale)
+import qualified Text.Blaze.Renderer.Text as Blaze
+import           Text.Hamlet              (HtmlUrl, hamlet)
+import qualified Text.XML                 as XML
+
+import           Application
+import           Config
+import           Post.Types
+import           RelativeHamlet
 
 -- | The datatype representing a route.
 data ItsaR = RootR -- ^ The docroot.
            | TagR Text -- ^ Posts related to a tag.
            | PostR Text -- ^ An individual post.
            | StaticPageR Text -- ^ An individual page.
+           | RssR -- ^ The RSS feed.
+
+-- | The route renderer. Make sure this synchronizes with the route
+-- parser in Site.hs!
+renderRoute :: Text -- ^ The approot.
+               -> ItsaR -- ^ The route to render.
+               -> [(Text, Text)] -- ^ A list of query strings
+                                 -- parameters(?). TODO: Figure out
+                                 -- what these are and use them.
+                                 -- Actually use these.
+               -> Text
+renderRoute appRoot route query = appRoot <> renderRoute' route query
+  where
+    renderRoute' RootR _ = "/"
+    renderRoute' (TagR tag) _ = "/tagged/" <> tag
+    renderRoute' (PostR slug) _ = "/post/" <> slug
+    renderRoute' (StaticPageR slug) _ = "/page/" <> slug
+    renderRoute' RssR _ = "/feed/rss"
+
 
 -- | 'Top-level' renderer that puts its arguments in the default layout.
 renderTwoColumn :: HtmlUrl ItsaR -- ^ The HTML to show in the left column.
@@ -73,14 +97,33 @@ renderTagList :: [(Text, Int)] -> HtmlUrl ItsaR
 renderTagList unsorted = $(hamletRelativeFile "templates/tag-list.hamlet")
   where tagList = reverse $ sortBy (comparing snd) unsorted
 
+-- | Render an RSS feed for a list of posts. Note that unlike the
+-- others, this is an 'XML.Document', not an 'HtmlUrl' 'ItsaR' (or
+-- monadic wrapper around one, or function returning one, etc.).
+renderRss :: [Post] -> AppHandler XML.Document
+renderRss posts = do
+    blogTitle <- view $ _config._blogTitle
+    appRoot <- view $ _config._appRoot
+    let render route = renderRoute appRoot route []
+    let xmlElement = XML.Element "rss" rootAttributes
+                     $(xmlRelativeFile "templates/rss.xhamlet")
+    return $ XML.Document prologue xmlElement []
+    where prologue = XML.Prologue [] Nothing []
+          rootAttributes =
+              Map.fromList [ ("version", "2.0"),
+                             ("xmlns:atom", "http://www.w3.org/2005/Atom")
+                           ]
+
 -- | Render a 404 page.
 render404 :: HtmlUrl ItsaR
 render404 = $(hamletRelativeFile "templates/404.hamlet")
 
+
+
 -- | Get the route referring to a post.
-postRouter :: Post -> ItsaR
-postRouter post = PostR $ view _slug post
+routePost :: Post -> ItsaR
+routePost post = PostR $ view _slug post
 
 -- | Get the route referring to a page.
-pageRouter :: StaticPage -> ItsaR
-pageRouter page = StaticPageR $ view _slug page
+routePage :: StaticPage -> ItsaR
+routePage page = StaticPageR $ view _slug page

src/Site.hs

@@ -38,6 +38,7 @@ routes = [ ("/static", serveDirectory "static"),
            ("/drafts/:page", Handler.draftsPage),
            ("/queue", Handler.queuePage),
            ("/queue/:page", Handler.queuePage),
+           ("/feed/rss", Handler.rss),
            ("/:pageName", ifTop Handler.staticPage),
            ("/", Handler.mainPage)
          ]

templates/default-layout.hamlet

@@ -5,7 +5,7 @@
         <meta name="viewport" content="width=device-width,initial-scale=1">
 
         <title>#{pageTitle}</title>
-        <link rel=alternate type=application/rss+xml href=rss>
+        <link rel=alternate type=application/rss+xml href="/feed/rss">
         <link rel=icon type=image/png href="/static/favicon.ico">
         <link rel=stylesheet type=text/css href="/static/css/highlight_default.css">
         <link rel=stylesheet type=text/css href="/static/css/1140.css">
@@ -26,6 +26,9 @@
                 <li>
                   <a href=@{StaticPageR $ view _slug staticPage}>
                     #{view _shortTitle staticPage}
+            <div #rss>
+                <a href=@{RssR}>
+                   <img src="/static/img/rss.png">
 
       ^{body}
 

templates/page.hamlet

@@ -1,5 +1,5 @@
 <article>
   <div .title>
-    <a .title href=@{pageRouter page}>#{view _title page}
+    <a .title href=@{routePage page}>#{view _title page}
   <div>
     <div .content>#{view _body page}

templates/post.hamlet

@@ -1,6 +1,6 @@
 <article>
   <div .title>
-    <a .title href=@{postRouter post}>#{view _title post}
+    <a .title href=@{routePost post}>#{view _title post}
   <div>
     <div .content>#{view _body post}
     <div .metadata>

templates/rss.xhamlet

@@ -0,0 +1,11 @@
+<channel>
+  <atom:link href=#{render RssR} rel=self type="application/rss+xml">
+  <title>#{blogTitle}
+  <link>#{render RootR}
+  <description>#{blogTitle}
+  $forall post <- posts
+    <item>
+      <title>#{view _title post}
+      <guid>#{render $ routePost post}
+      <link>#{render $ routePost post}
+      <description>#{toStrict $ Blaze.renderMarkup $ view _body post}