Add 404 page support

blaaargh.cabal

@@ -1,5 +1,5 @@
 Name:                Blaaargh
-Version:             0.1
+Version:             0.2
 Synopsis:            A simple content-management system for Happstack,
                      suitable for small-to-medium-sized websites 
 License:             BSD3

src/Blaaargh/Handlers.hs

@@ -11,6 +11,7 @@ import           Data.List
 import           Data.Map (Map)
 import qualified Data.Map as Map
 import           Data.Maybe
+import           Data.Monoid
 import           Happstack.Server
 import           Happstack.Server.HTTP.FileServe
 import           Happstack.Server.Parts
@@ -44,7 +45,7 @@ serveBlaaargh = do
     cm    <- lift get >>= return . blaaarghPostMap
     paths <- askRq >>= return . map B.pack . rqPaths
 
-    serve [] paths cm
+    serve [] paths cm `mappend` fourohfour
 
   where
     --------------------------------------------------------------------------
@@ -103,6 +104,21 @@ serveBlaaargh = do
               mbD
 
 
+
+------------------------------------------------------------------------------
+fourohfour :: BlaaarghHandler
+fourohfour = do
+    state  <- lift get
+    mbTmpl <- findFourOhFourTemplate
+    tmpl   <- maybe mzero return mbTmpl
+
+    let title = getTextContent . Atom.feedTitle . blaaarghFeedInfo $ state
+
+    let tmpl'  = setAttribute "pageTitle" title tmpl
+
+    return $ toResponse $ HtmlResponse $ render tmpl'
+
+
 ------------------------------------------------------------------------------
 serveStatic :: FilePath -> BlaaarghHandler
 serveStatic = localRq (\r -> r { rqPaths=[]}) . fileServeStrict []

src/Blaaargh/Templates.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Blaaargh.Templates
-  ( findTemplateForPost
+  ( findFourOhFourTemplate
+  , findTemplateForPost
   , findTemplateForDirectory )
 where
 
@@ -14,13 +15,23 @@ import           Data.ByteString.Char8 (ByteString)
 import           Data.List
 import           Data.Maybe
 import           Data.Monoid
+import           Happstack.Server
 import           Prelude hiding (catch)
 import           Text.StringTemplate
 ------------------------------------------------------------------------------
 import           Blaaargh.Types
 import           Blaaargh.Util.Templates
 
 
+------------------------------------------------------------------------------
+findFourOhFourTemplate :: ServerPartT BlaaarghMonad (Maybe Template)
+findFourOhFourTemplate = do
+    templates <- lift $ liftM blaaarghTemplates get
+    pathList  <- askRq >>= return . map B.pack . rqPaths
+
+    lift $ cascadingTemplateFind pathList "404"
+
+
 ------------------------------------------------------------------------------
 findTemplateForPost :: [ByteString]   -- ^ path to the post, relative
                                       -- to the "content/" directory;
@@ -31,25 +42,21 @@ findTemplateForPost :: [ByteString]   -- ^ path to the post, relative
                     -> BlaaarghMonad (Maybe (Template))
 findTemplateForPost pathList = do
     xformTmpl <- liftM blaaarghExtraTmpl get
+    templates <- liftM blaaarghTemplates get
     assert (not $ null pathList) (return ())
 
-    mbT <- findFirstMatchingTemplate templatesToSearch
+    let ft  = First $ lookupTmpl templates firstTmpl
+    st     <- cascadingTemplateFind pathList "post" >>= return . First
+    let mbT = getFirst (ft `mappend` st)
+
     return $ xformTmpl `fmap` mbT
 
   where
     postName = last pathList
 
-    -- if post is at "foo/bar/baz.md", then containingDirs contains
-    -- [["foo","bar"], ["foo"], []]
-    containingDirs    = tail . reverse . inits $ pathList
-
     -- search for a template specific to this post first, then walk up
     -- the directory structure looking for a template named "post"
-
-    firstTmpl = (listToPath $ head containingDirs, postName)
-
-    templatesToSearch = firstTmpl :
-                          map (\d -> (listToPath d, "post")) containingDirs
+    firstTmpl = (listToPath $ init pathList, postName)
 
 
 ------------------------------------------------------------------------------
@@ -95,6 +102,20 @@ findFirstMatchingTemplate templatesToSearch = do
       map (First . lookupTmpl templates) templatesToSearch
 
 
+------------------------------------------------------------------------------
+cascadingTemplateFind :: [ByteString]
+                      -> ByteString
+                      -> BlaaarghMonad (Maybe (StringTemplate ByteString))
+cascadingTemplateFind directories templateName = do
+    templates <- liftM blaaarghTemplates get
+    assert (not $ null directories) (return ())
 
+    findFirstMatchingTemplate templatesToSearch
 
+  where
+    -- if requested "foo/bar/baz", then containingDirs contains
+    -- [["foo","bar"], ["foo"], []]
+    containingDirs    = tail . reverse . inits $ directories
 
+    templatesToSearch = map (\d -> (listToPath d, templateName))
+                            containingDirs