Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 119 lines (90 sloc) 4.59 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
{-# LANGUAGE OverloadedStrings #-}

module Blaaargh.Internal.Templates
  ( findFourOhFourTemplate
  , findTemplateForPost
  , findTemplateForDirectory )
where


------------------------------------------------------------------------------
import Control.Exception
import Control.Monad.State
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString)
import Data.List
import Data.Monoid
import Happstack.Server
import Prelude hiding (catch)
import Text.StringTemplate
------------------------------------------------------------------------------
import Blaaargh.Internal.Types
import Blaaargh.Internal.Util.Templates


------------------------------------------------------------------------------
findFourOhFourTemplate :: ServerPartT BlaaarghMonad (Maybe Template)
findFourOhFourTemplate = do
    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
                                      -- \"@content\/foo\/bar\/baz.md@\" then
                                      -- this list will contain
                                      -- @["foo", "bar", "baz"]@
                    -> BlaaarghMonad (Maybe (Template))
findTemplateForPost pathList = do
    xformTmpl <- liftM blaaarghExtraTmpl get
    templates <- liftM blaaarghTemplates get
    assert (not $ null pathList) (return ())

    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

    -- search for a template specific to this post first, then walk up
    -- the directory structure looking for a template named "post"
    firstTmpl = (listToPath $ init pathList, postName)


------------------------------------------------------------------------------
findTemplateForDirectory :: [ByteString]
                         -> BlaaarghMonad (Maybe (Template))
findTemplateForDirectory pathList = do
    templates <- liftM blaaarghTemplates get
    xformTmpl <- liftM blaaarghExtraTmpl get
    assert (not $ null pathList) (return ())

    let mbT = lookupTmpl templates (listToPath pathList, "index")
    return $ xformTmpl `fmap` mbT


------------------------------------------------------------------------------
-- local functions follow
------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- | look up whether a particular template exists
lookupTmpl :: TemplateDirectory -- ^ templates
           -> (String, ByteString) -- ^ (dir, template), where "dir"
                                    -- starts with "./"
           -> Maybe (StringTemplate ByteString)
lookupTmpl tmpls (d,t) =
    lookupDirgroup d tmpls >>= getStringTemplate (B.unpack t)


------------------------------------------------------------------------------
-- | Take a path list @[\"foo\",\"bar\",\"baz\"]@ and turn it into
-- @\"./foo/bar/baz\"@
listToPath :: [ByteString] -> String
listToPath l = B.unpack . B.concat $ intersperse "/" (".":l)


------------------------------------------------------------------------------
findFirstMatchingTemplate :: [(String,ByteString)]
                          -> BlaaarghMonad (Maybe (StringTemplate ByteString))
findFirstMatchingTemplate templatesToSearch = do
    templates <- liftM blaaarghTemplates get

    return . getFirst . mconcat $
      map (First . lookupTmpl templates) templatesToSearch


------------------------------------------------------------------------------
cascadingTemplateFind :: [ByteString]
                      -> ByteString
                      -> BlaaarghMonad (Maybe (StringTemplate ByteString))
cascadingTemplateFind directories templateName = do
    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
Something went wrong with that request. Please try again.