Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add 404 page support

  • Loading branch information...
commit 1fa756fc92bd16638a51738e9c6fe2f7bbbedb88 1 parent 8df94af
@gregorycollins authored
View
2  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
View
18 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 []
View
43 src/Blaaargh/Templates.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
module Blaaargh.Templates
- ( findTemplateForPost
+ ( findFourOhFourTemplate
+ , findTemplateForPost
, findTemplateForDirectory )
where
@@ -14,6 +15,7 @@ import Data.ByteString.Char8 (ByteString)
import Data.List
import Data.Maybe
import Data.Monoid
+import Happstack.Server
import Prelude hiding (catch)
import Text.StringTemplate
------------------------------------------------------------------------------
@@ -22,6 +24,15 @@ 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;
-- if the file is in
@@ -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
Please sign in to comment.
Something went wrong with that request. Please try again.