Permalink
Browse files

Reorganize code and give haddock some love

  • Loading branch information...
1 parent d2457cc commit b2af34e264fa14b4367c32262a099f23ab3633ee @gregorycollins committed Aug 7, 2009
View
19 blaaargh.cabal
@@ -1,7 +1,6 @@
Name: Blaaargh
Version: 0.3
-Synopsis: A simple content-management system for Happstack,
- suitable for small-to-medium-sized websites
+Synopsis: A simple filesystem-based content management system for Happstack
License: GPL
License-file: COPYING
Author: Gregory Collins
@@ -16,14 +15,14 @@ Library
hs-source-dirs:
src
exposed-modules: Blaaargh
- , Blaaargh.Time
- , Blaaargh.Exception
- , Blaaargh.Util.ExcludeList
- , Blaaargh.Util.Templates
- , Blaaargh.Types
- , Blaaargh.Post
- , Blaaargh.Templates
- , Blaaargh.Handlers
+ other-modules: Blaaargh.Internal.Time
+ , Blaaargh.Internal.Exception
+ , Blaaargh.Internal.Util.ExcludeList
+ , Blaaargh.Internal.Util.Templates
+ , Blaaargh.Internal.Types
+ , Blaaargh.Internal.Post
+ , Blaaargh.Internal.Templates
+ , Blaaargh.Internal.Handlers
ghc-options: -Wall -funbox-strict-fields -O2 -fvia-C -optc-O3 -funfolding-use-threshold=16
View
230 src/Blaaargh.hs
@@ -1,9 +1,212 @@
+{-|
+
+\"Blaaargh\!\" is a simple filesystem-based content management system for static or
+semi-static publishing. You can run it standalone (...or will be able to soon)
+or integrate it as a component in a larger happstack application.
+
+Like the venerable blosxom (<http://blosxom.sourceforge.net/>) package,
+Blaaargh\! relies on plain-text files on the file system as its content
+database.
+
+FEATURES:
+
+* simple on-disk content database
+
+* posts\/pages written in markdown format
+
+* pages formatted into HTML by a flexible cascading template system based on
+ HStringTemplate (http://hackage.haskell.org/package/HStringTemplate). Page
+ templates can be overridden on a per-page or per-folder basis.
+
+* directories can be given indices using the templating system. Various views
+ of the directory contents (e.g. N most recent pages, pages in forward/reverse
+ chronological order, pages in alphabetical order) are exposed to the index
+ templates.
+
+* directories with defined indices get Atom-format syndication feeds
+
+* configuration parameters (site title, site URL, base URL, etc.) specified in
+ an INI-style config file
+
+
+MISSING FEATURES:
+
+* a web-accessible \"administrative area\"
+
+* a comment system (for my homepage I'm currently just outsourcing this to
+ Disqus)
+
+
+
+INSTRUCTIONS:
+
+The Blaaargh directory consists of the following contents:
+
+ [@config@] an INI-style configuration file
+
+ [@templates\/@] a tree of @.st@ template files, served by HStringTemplate
+
+ [@content\/@] a tree of content files. Markdown-formatted files (with
+ @.md@ extensions) are parsed and read as \"posts\" that
+ are rendered to HTML via the templating mechanism. Other
+ files are served as static content.
+
+
+Let's say you have some files in here:
+
+> config
+> content/grumble.md
+> content/index.md
+> content/posts/bar.md
+> content/posts/bar/photo.jpg
+> content/posts/foo.md
+> content/static/spatula.md
+> templates/404.st
+> templates/post.st
+> templates/static/index.st
+> templates/static/post.st
+> templates/static/spatula.st
+
+Think of it like this -- you request content, either a single post, a
+directory, or an atom feed (hardcoded as @\/[dir]\/feed.xml@). Blaaargh
+searches for the closest matching template.
+
+For @.md@ files (\"posts\" or \"pages\"), the templates /cascade/: e.g. for a
+file @content\/foo\/bar\/baz.md@, we would search @templates\/@ for the following
+templates, in order:
+
+* @foo\/bar\/baz.st@
+
+* @foo\/bar\/post.st@
+
+* @foo\/post.st@
+
+* @post.st@
+
+* @404.st@
+
+For directories, the templates don't cascade; a directory needs to have a
+matching template in order to be served. E.g. for a directory
+@\/foo\/bar\/quux@, we search @templates\/@ for \"@foo\/bar\/quux\/index.st@\",
+and if @content\/foo\/bar\/quux\/index.md@ exists, we read it into the template
+as content text. (More about this in \"TEMPLATING\" below.)
+
+
+CONFIGURATION
+
+A Blaaargh\! @config@ file looks like this:
+
+> [default]
+> # what's the domain name?
+> siteurl = http://example.com
+>
+> # blaaargh content will be served at this base URL
+> baseurl = /foo
+>
+> [feed]
+> # site title
+> title = Example dot com
+> # authors
+> authors = John Smith <john@example.com>
+> # Atom icon
+> icon = /static/icon.png
+>
+> # posts on this list (or directories containing posts) won't be included in
+> # directory indices, nor in atom feeds
+> skipurls = static
+
+Blaaargh\! uses the ConfigFile library for configuration and post header
+parsing. (<http://hackage.haskell.org/package/ConfigFile>)
+
+
+POST FORMATTING
+
+Posts are (mostly) in Markdown format, with the exception of a key-value header
+prefixed by pipe (@\|@) characters. Example:
+
+> | title: Example post
+> | author: John Smith <john@example.com>
+> | published: 2009-09-15T21:18:00-0400
+> | summary: A short summary of the post contents
+>
+> This is an example post in *markdown* format.
+>
+
+Blaaargh\! accepts the following key-values for posts:
+
+ [@title@] The title of the post
+
+ [@author@] The post's author
+
+ [@authors@] same as @author@
+
+ [@summary@] a summary of the post
+
+ [@updated@] the post's last update time in RFC3339 format
+
+ [@published@] the post's publish date in RFC3339 format
+
+The headers are parsed as follows: any lines starting with the @\|@ character
+(up until the first line not starting with @\|@) have the prefix stripped and
+are sent through ConfigFile.
+
+Please see its haddock for input syntax.
+
+
+DATA MODEL
+
+The documents get indexed into a key-value mapping by id. (Where an \"id\" for
+a post is defined as its relative path from @content\/@, with the @.md@ suffix
+removed.)
+
+Files with an @\'.md\'@ suffix are treated as \"posts\"\/\"pages\", and are
+expected to be in markdown format. Files with other suffices are served as
+static files.
+
+
+TEMPLATING
+
+Blaaargh\! uses templates to present the content of posts and lists of posts in
+HTML.
+
+For an individual post (either postname-specific @/postname/.st@ or generic
+@post.st@), Blaaargh exports a template variable called @$post$@ which is a map
+containing the following attributes:
+
+@
+ $id$
+ $date$
+ $url$
+ $title$
+ $content$
+ $summary$
+ $authors$
+@
+
+So in other words, within your template the post's URL can be accessed using
+@$post.id$@.
+
+For directory templates (@index.st@), we collect the posts within that
+directory and present them to the templating system as a list of post objects
+(i.e. containing the @$id$@\/@$date$@\/etc. fields listed above):
+
+@
+ $alphabeticalPosts$
+ $recentPosts$ -- N.B. 5 most recent posts
+ $chronologicalPosts$
+ $reverseChronologicalPosts$
+@
+
+-}
+
+
module Blaaargh
( initBlaaargh
, serveBlaaargh
, runBlaaarghHandler
, addExtraTemplateArguments
, BlaaarghException
+ , blaaarghExceptionMsg
, BlaaarghMonad
, BlaaarghHandler
, BlaaarghState
@@ -24,16 +227,25 @@ import qualified Text.Atom.Feed as Atom
import Text.Printf
------------------------------------------------------------------------------
-import Blaaargh.Handlers
-import Blaaargh.Post
-import Blaaargh.Types
-import qualified Blaaargh.Util.ExcludeList as EL
-import Blaaargh.Util.ExcludeList (ExcludeList)
-import Blaaargh.Util.Templates
+import Blaaargh.Internal.Handlers
+import Blaaargh.Internal.Post
+import Blaaargh.Internal.Types
+import qualified Blaaargh.Internal.Util.ExcludeList as EL
+import Blaaargh.Internal.Util.ExcludeList (ExcludeList)
+import Blaaargh.Internal.Util.Templates
------------------------------------------------------------------------------
-initBlaaargh :: FilePath -> IO BlaaarghState
+{-|
+
+ Initialize a Blaaargh instance. Given the name of a directory on the disk,
+ 'initBlaaargh' searches it for configuration, content, and template files,
+ and produces a finished 'BlaaarghState' value. Throws a 'BlaaarghException'
+ if there was an error reading the state.
+
+-}
+initBlaaargh :: FilePath -- ^ path to blaaargh directory
+ -> IO BlaaarghState
initBlaaargh path = do
-- make sure directories exist
mapM_ failIfNotDir [path, contentDir, templateDir]
@@ -71,6 +283,8 @@ initBlaaargh path = do
templateDir = path </> "templates"
+------------------------------------------------------------------------------
+
getM :: Cfg.Get_C a => Cfg.ConfigParser -> String -> String -> Maybe a
getM cp section = either (const Nothing) Just . Cfg.get cp section
@@ -122,5 +336,3 @@ readConfig fp = do
parseConfig :: FilePath -> IO (Either Cfg.CPError Cfg.ConfigParser)
parseConfig = Cfg.readfile Cfg.emptyCP
-
-
View
14 src/Blaaargh/Exception.hs
@@ -1,14 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-
-module Blaaargh.Exception where
-
-import Control.Exception
-import Data.Typeable
-import Prelude hiding (catch)
-
-
-
-data BlaaarghException = BlaaarghException String
- deriving (Show, Typeable)
-
-instance Exception BlaaarghException
View
23 src/Blaaargh/Internal/Exception.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Blaaargh.Internal.Exception
+( BlaaarghException(..)
+, blaaarghExceptionMsg )
+where
+
+import Control.Exception
+import Data.Typeable
+import Prelude hiding (catch)
+
+
+-- | 'BlaaarghException' is the exception type thrown when Blaaargh encounters
+-- an error.
+data BlaaarghException = BlaaarghException String
+ deriving (Show, Typeable)
+
+instance Exception BlaaarghException
+
+
+-- | Obtain the error message from a 'BlaaarghException'
+blaaarghExceptionMsg :: BlaaarghException -> String
+blaaarghExceptionMsg (BlaaarghException s) = s
View
35 src/Blaaargh/Handlers.hs → src/Blaaargh/Internal/Handlers.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
-module Blaaargh.Handlers where
+module Blaaargh.Internal.Handlers ( serveBlaaargh ) where
import Control.Monad.State
import qualified Data.ByteString.Char8 as B
@@ -19,10 +19,10 @@ import Text.Printf
import Text.StringTemplate
------------------------------------------------------------------------------
-import Blaaargh.Post
-import Blaaargh.Templates
-import Blaaargh.Types
-import qualified Blaaargh.Util.ExcludeList as EL
+import Blaaargh.Internal.Post
+import Blaaargh.Internal.Templates
+import Blaaargh.Internal.Types
+import qualified Blaaargh.Internal.Util.ExcludeList as EL
------------------------------------------------------------------------------
@@ -35,6 +35,15 @@ showPath = B.unpack . B.intercalate "/"
------------------------------------------------------------------------------
+
+{-|
+
+The top-level happstack handler. The 'BlaaarghHandler' is a 'ServerPartT' over
+a state monad; you \"run\" this handler by feeding it a BlaaarghState using
+'runBlaaarghHandler'. It handles requests on its base url (defined in the
+@{blaaargh_dir}/config@ file) and serves up content from the content area.
+
+-}
serveBlaaargh :: BlaaarghHandler
serveBlaaargh = do
methodOnly GET
@@ -67,7 +76,7 @@ serveBlaaargh = do
(B.unpack a)
if a == "feed.xml" then
- lift $ serveFeed soFar content
+ serveFeed soFar content
else
maybe (do
debug $ printf "serveFile: 404: soFar=%s a=%s"
@@ -76,7 +85,7 @@ serveBlaaargh = do
mzero)
(\f -> case f of
(ContentStatic fp) -> serveStatic fp
- (ContentPost post) -> lift $ servePost (soFar ++ [a]) post
+ (ContentPost post) -> servePost (soFar ++ [a]) post
(ContentDirectory _ d) -> serveIndex (soFar ++ [a]) d)
(Map.lookup a content)
@@ -130,10 +139,10 @@ instance ToMessage HtmlResponse where
------------------------------------------------------------------------------
-servePost :: [ByteString] -> Post -> BlaaarghMonad Response
+servePost :: [ByteString] -> Post -> BlaaarghHandler
servePost soFar post = do
- state <- get
- mbTmpl <- findTemplateForPost soFar
+ state <- lift get
+ mbTmpl <- lift $ findTemplateForPost soFar
tmpl <- maybe mzero return mbTmpl
let title = concat
@@ -229,16 +238,16 @@ addSiteURL siteURL (Post p) =
------------------------------------------------------------------------------
-serveFeed :: [ByteString] -> ContentMap -> BlaaarghMonad Response
+serveFeed :: [ByteString] -> ContentMap -> BlaaarghHandler
serveFeed soFar content = do
- state <- get
+ state <- lift get
let excludes' = blaaarghFeedExcludes state
let excludes = foldl' (flip EL.descend) excludes' soFar
let siteURL' = blaaarghSiteURL state
let posts = map (addSiteURL siteURL') $ recentPosts excludes content 5
- hasTemplate <- liftM isJust $ findTemplateForDirectory soFar
+ hasTemplate <- lift $ liftM isJust $ findTemplateForDirectory soFar
if null posts || not hasTemplate
then mzero
View
10 src/Blaaargh/Post.hs → src/Blaaargh/Internal/Post.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
-module Blaaargh.Post
+module Blaaargh.Internal.Post
( getTimeStamp
, parsePersons
, collectPosts
@@ -56,10 +56,10 @@ import qualified Text.Pandoc as Pandoc
import Text.Printf
import Text.XML.Light
------------------------------------------------------------------------
-import Blaaargh.Time
-import Blaaargh.Types
-import qualified Blaaargh.Util.ExcludeList as EL
-import Blaaargh.Util.ExcludeList (ExcludeList)
+import Blaaargh.Internal.Time
+import Blaaargh.Internal.Types
+import qualified Blaaargh.Internal.Util.ExcludeList as EL
+import Blaaargh.Internal.Util.ExcludeList (ExcludeList)
------------------------------------------------------------------------
View
17 src/Blaaargh/Templates.hs → src/Blaaargh/Internal/Templates.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
-module Blaaargh.Templates
+module Blaaargh.Internal.Templates
( findFourOhFourTemplate
, findTemplateForPost
, findTemplateForDirectory )
@@ -18,8 +18,8 @@ import Happstack.Server
import Prelude hiding (catch)
import Text.StringTemplate
------------------------------------------------------------------------------
-import Blaaargh.Types
-import Blaaargh.Util.Templates
+import Blaaargh.Internal.Types
+import Blaaargh.Internal.Util.Templates
------------------------------------------------------------------------------
@@ -32,11 +32,11 @@ findFourOhFourTemplate = do
------------------------------------------------------------------------------
findTemplateForPost :: [ByteString] -- ^ path to the post, relative
- -- to the "content/" directory;
+ -- to the \"content\/\" directory;
-- if the file is in
- -- "content/foo/bar/baz.md" then
+ -- \"@content\/foo\/bar\/baz.md@\" then
-- this list will contain
- -- ["foo", "bar", "baz"]
+ -- @["foo", "bar", "baz"]@
-> BlaaarghMonad (Maybe (Template))
findTemplateForPost pathList = do
xformTmpl <- liftM blaaarghExtraTmpl get
@@ -76,7 +76,7 @@ findTemplateForDirectory pathList = do
------------------------------------------------------------------------------
-- | look up whether a particular template exists
-lookupTmpl :: TemplateDirs -- ^ templates
+lookupTmpl :: TemplateDirectory -- ^ templates
-> (String, ByteString) -- ^ (dir, template), where "dir"
-- starts with "./"
-> Maybe (StringTemplate ByteString)
@@ -85,7 +85,8 @@ lookupTmpl tmpls (d,t) =
------------------------------------------------------------------------------
--- | Take a path list ["foo","bar","baz"] and turn it into "./foo/bar/baz"
+-- | 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)
View
2 src/Blaaargh/Time.hs → src/Blaaargh/Internal/Time.hs
@@ -1,4 +1,4 @@
-module Blaaargh.Time where
+module Blaaargh.Internal.Time where
import Data.Time.Clock
import Data.Time.Format
View
196 src/Blaaargh/Internal/Types.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+
+module Blaaargh.Internal.Types
+ ( module Blaaargh.Internal.Exception
+ , Post(..)
+ , getPostTime
+ , ContentMap
+ , ContentItem(..)
+ , BlaaarghState(..)
+ , BlaaarghMonad(..)
+ , BlaaarghHandler
+ , liftB
+ , runBlaaarghHandler
+ , addExtraTemplateArguments
+ )
+where
+
+------------------------------------------------------------------------------
+import Control.Monad.State
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.Maybe
+import Data.Time.LocalTime
+import Happstack.Server
+import qualified Text.Atom.Feed as Atom
+import qualified Text.Atom.Feed.Export as Atom
+import Text.StringTemplate
+import Text.StringTemplate.Classes
+import qualified Text.XML.Light.Output as XML
+------------------------------------------------------------------------------
+import Blaaargh.Internal.Exception
+import Blaaargh.Internal.Time
+import Blaaargh.Internal.Util.ExcludeList
+import Blaaargh.Internal.Util.Templates
+
+
+
+-- to make things super-easy on us, we'll define our internal post
+-- format to be the same as our Atom feed.
+newtype Post = Post { unPost :: Atom.Entry }
+ deriving (Show)
+
+
+getPostTime :: Post -> ZonedTime
+getPostTime (Post p) = parseAtomTime $ fromMaybe upd pub
+ where
+ pub = Atom.entryPublished p
+ upd = Atom.entryUpdated p
+
+
+instance ToSElem Atom.EntryContent where
+ toSElem (Atom.TextContent s) = toSElem s
+ toSElem (Atom.HTMLContent s) = toSElem s
+ toSElem _ = toSElem (""::String)
+
+
+instance ToSElem Atom.TextContent where
+ toSElem (Atom.TextString s) = toSElem s
+ toSElem (Atom.HTMLString s) = toSElem s
+ toSElem _ = toSElem (""::String)
+
+
+instance ToSElem Atom.Person where
+ toSElem (Atom.Person name _ email _) = toSElem $ name ++ em
+ where
+ em = maybe "" (\e -> " <" ++ e ++ ">") email
+
+
+instance ToSElem Post where
+ toSElem post@(Post p) = SM $ Map.fromList attrs
+ where
+ url = Atom.entryId p
+ body = fromMaybe (Atom.TextContent "") $ Atom.entryContent p
+ summary = fromMaybe (Atom.HTMLString "") $ Atom.entrySummary p
+
+ attrs = [ ("id", toSElem url)
+ , ("date", toSElem $ friendlyTime $ getPostTime post)
+ , ("url", toSElem url)
+ , ("title", toSElem $ Atom.entryTitle p)
+ , ("content", toSElem body)
+ , ("summary", toSElem summary)
+ , ("authors", toSElemList $ Atom.entryAuthors p) ]
+
+
+
+instance ToMessage Atom.Feed where
+ toContentType _ = "application/atom+xml"
+ toMessage f = L.pack $ XML.showElement $ Atom.xmlFeed f
+
+
+
+type ContentMap = Map ByteString ContentItem
+
+data ContentItem =
+ ContentPost Post -- ^ a post
+ | ContentDirectory ByteString ContentMap -- ^ a path prefix + content
+ -- mapping
+ | ContentStatic FilePath -- ^ a static file
+ deriving (Show)
+
+
+{-|
+
+BlaaarghState is an opaque data type that holds Blaaargh internal state.
+
+-}
+data BlaaarghState = BlaaarghState
+ { blaaarghPath :: FilePath -- ^ path on disk
+ , blaaarghSiteURL :: String -- ^ site URL, minus slash
+ -- (e.g. http://foo.com)
+ , blaaarghBaseURL :: String -- ^ base URL of content section,
+ -- e.g. "/posts"
+ , blaaarghPostMap :: ContentMap -- ^ content
+ , blaaarghTemplates :: TemplateDirectory -- ^ templates
+ , blaaarghFeedInfo :: Atom.Feed -- ^ feed info
+
+ , blaaarghFeedExcludes :: ExcludeList -- ^ these URLs won't appear in
+ -- feeds or in post listings
+
+ , blaaarghExtraTmpl :: Template -> Template
+ -- ^ extra template variables get
+ -- inserted here
+ }
+
+
+{-|
+
+A BlaaarghMonad is a state monad over IO.
+
+-}
+newtype BlaaarghMonad a =
+ BlaaarghMonad { unBlaaarghMonad :: StateT BlaaarghState IO a }
+ deriving (Monad, MonadIO, MonadState BlaaarghState)
+
+
+{-|
+
+The 'ServerPartT' happstack handler type is a monad transformer; here we define
+'BlaaarghHandler' as a 'ServerPartT' around our 'BlaaarghMonad' type.
+
+-}
+type BlaaarghHandler = ServerPartT BlaaarghMonad Response
+
+
+liftB :: ServerPartT IO a -> ServerPartT BlaaarghMonad a
+liftB = mapServerPartT liftIO
+
+
+
+{-|
+
+Given Blaaargh state and a happstack 'ServerPartT' over a 'BlaaarghMonad',
+'runBlaaarghHandler' produces a 'ServerPartT' over 'IO' that you can pass to
+happstack.
+
+-}
+runBlaaarghHandler ::
+ BlaaarghState -- ^ blaaargh state, obtained from calling
+ -- 'initBlaaargh'
+ -> ServerPartT BlaaarghMonad a -- ^ a blaaargh handler
+ -> ServerPartT IO a
+runBlaaarghHandler s = mapServerPartT $ \m -> do
+ (a,_) <- runStateT (unBlaaarghMonad m) s
+ return a
+
+
+{-|
+
+Sometimes you want to pass extra key-value mappings to be served in Blaaargh
+templates. For example:
+
+@
+lift (addExtraTemplateArguments [(\"foo\", \"foovalue\")]) \>\> serveBlaaargh
+@
+
+will cause the value @$foo$@ to be expanded as \"foovalue\" within templates
+served by Blaaargh.
+
+-}
+addExtraTemplateArguments :: ToSElem a =>
+ [(String,a)]
+ -> BlaaarghMonad ()
+addExtraTemplateArguments args = do
+ modify $ \t ->
+ t { blaaarghExtraTmpl = foldl f (blaaarghExtraTmpl t) args }
+
+ where
+ f :: ToSElem a => (Template -> Template) -> (String, a) -> (Template -> Template)
+ f xtmpl (k,v) = (setAttribute k v) . xtmpl
View
2 src/Blaaargh/Util/ExcludeList.hs → src/Blaaargh/Internal/Util/ExcludeList.hs
@@ -1,4 +1,4 @@
-module Blaaargh.Util.ExcludeList
+module Blaaargh.Internal.Util.ExcludeList
( empty
, fromPathList
, fromPath
View
55 src/Blaaargh/Util/Templates.hs → src/Blaaargh/Internal/Util/Templates.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
-module Blaaargh.Util.Templates
- ( TemplateDirs
+module Blaaargh.Internal.Util.Templates
+ ( TemplateDirectory
, Template
, TemplateGroup
, readTemplateDir
@@ -23,20 +23,28 @@ import System.FilePath
import Text.StringTemplate
------------------------------------------------------------------------------
-import Blaaargh.Exception
-import Blaaargh.Util.ExcludeList
+import Blaaargh.Internal.Exception
+import Blaaargh.Internal.Util.ExcludeList
------------------------------------------------------------------------------
-data TemplateDirs =
- TemplateDirs TemplateGroup -- ^ top-level template group
- (Map ByteString TemplateDirs) -- ^ template group
- -- for subdirs
+{-|
-instance Show TemplateDirs where
+'TemplateDirectory' is a directory structure of 'StringTemplate's. 'Template's
+are indexed by path from a root path \".\", e.g. \"./dir/foo\", and templates
+can invoke other templates (from the same directory or a parent directory) by
+name.
+
+-}
+
+data TemplateDirectory =
+ TemplateDirectory TemplateGroup (Map ByteString TemplateDirectory)
+
+
+instance Show TemplateDirectory where
show x = help 0 x
where
- help n (TemplateDirs _ s) =
+ help n (TemplateDirectory _ s) =
"{\n" ++ concatMap (sone n) assocs
++ "\n"
++ (replicate n '\t')
@@ -50,13 +58,20 @@ instance Show TemplateDirs where
(help (n+1) v)
+-- | TemplateGroup is a type alias for a StringTemplate over ByteStrings.
+type Template = StringTemplate B.ByteString
+
+-- | TemplateGroup is a type alias for a STGroup over ByteStrings.
type TemplateGroup = STGroup B.ByteString
-type Template = StringTemplate B.ByteString
------------------------------------------------------------------------------
-readTemplateDir :: FilePath -> IO TemplateDirs
+
+
+-- | Given a directory on the filesystem, crawl it for ".st" files and
+-- produce a TemplateDirectory.
+readTemplateDir :: FilePath -> IO TemplateDirectory
readTemplateDir d = do
mp <- help d
return $ fixup mp
@@ -82,21 +97,21 @@ readTemplateDir d = do
return (B.pack f,t))
dirs
- return $ TemplateDirs grp $ Map.fromList subDirs
+ return $ TemplateDirectory grp $ Map.fromList subDirs
- addGroup grp (TemplateDirs g sub) =
- TemplateDirs (addSuperGroup g grp) sub
+ addGroup grp (TemplateDirectory g sub) =
+ TemplateDirectory (addSuperGroup g grp) sub
- fixup (TemplateDirs grp sub) =
- TemplateDirs grp newsub
+ fixup (TemplateDirectory grp sub) =
+ TemplateDirectory grp newsub
where
sub' = fmap (addGroup grp) sub
newsub = fmap fixup sub'
-lookupDirgroup :: FilePath -> TemplateDirs -> Maybe TemplateGroup
+lookupDirgroup :: FilePath -> TemplateDirectory -> Maybe TemplateGroup
lookupDirgroup path t = help pl t
where
stripDot [] = []
@@ -105,7 +120,7 @@ lookupDirgroup path t = help pl t
pl = stripDot $ fromPath $ B.pack path
- help [] (TemplateDirs grp _) = Just grp
- help (a:b) (TemplateDirs _ sub) = do
+ help [] (TemplateDirectory grp _) = Just grp
+ help (a:b) (TemplateDirectory _ sub) = do
td <- Map.lookup a sub
help b td
View
274 src/Blaaargh/Types.hs
@@ -1,274 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-
-module Blaaargh.Types
- ( module Blaaargh.Exception
- , Post(..)
- , getPostTime
- , ContentMap
- , ContentItem(..)
- , BlaaarghState(..)
- , BlaaarghMonad
- , BlaaarghHandler
- , liftB
- , runBlaaarghHandler
- , addExtraTemplateArguments
- )
-where
-
-------------------------------------------------------------------------------
-import Control.Monad.State
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as L
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.Map as Map
-import Data.Map (Map)
-import Data.Maybe
-import Data.Time.LocalTime
-import Happstack.Server
-import qualified Text.Atom.Feed as Atom
-import qualified Text.Atom.Feed.Export as Atom
-import Text.StringTemplate
-import Text.StringTemplate.Classes
-import qualified Text.XML.Light.Output as XML
-------------------------------------------------------------------------------
-import Blaaargh.Exception
-import Blaaargh.Time
-import Blaaargh.Util.ExcludeList
-import Blaaargh.Util.Templates
-
-------------------------------------------------------------------------------
---
--- .-""-. Abandon hope all ye who enter here .-""-.
--- / _ _ \ / _ _ \
--- |(_)(_)| i.e. I wouldn't build against any of this yet |(_)(_)|
--- (_ /\ _) (_ /\ _)
--- L====J L====J
--- '-..-' '-..-'
---
-------------------------------------------------------------------------------
-
--- TODO: check the following text for outright fabrications/lies
-
--- | Blaaargh! is a simple filesystem-based content management system
--- for static or semi-static publishing. You can^H^H^H will be able to
--- run it standalone or integrate it as a component in a larger
--- happstack application.
---
--- Features:
---
--- * takes a collection of markdown-formatted content (pages/posts/articles)
--- in a "content area" on the filesystem and formats it into HTML using
--- user-supplied cascading templates
---
--- * requesting a directory will invoke a custom template called
--- "index.st". We expose various views of the list of posts to the
--- templates, i.e.:
---
--- $recentPosts:{ post | <li><a href="$post.url$">$post.title$</a></li>}$
--- $chronologicalPosts:...$
---
--- * can spit out atom feeds for directories in the content area (if
--- they have index templates)
---
--- * can read configurable parameters (title, directories to be
--- excluded from the feed, etc) from an ini-style file
---
---
--- Missing features:
---
--- * support for any content that wouldn't make sense as an entry in an atom
--- feed
---
--- * a web-accessible "administrative area"
---
--- * a comment system (currently just outsourcing this to Disqus)
---
---
--- A post on the disk is stored in the content area:
--- $(blaaargh_dir)/content/. Let's say you have some files in here:
---
--- config
--- content/posts/foo.md
--- content/posts/bar.md
--- content/posts/bar/photo.jpg
--- content/static/spatula.md
--- templates/static/post.st -- called when a post is requested
--- templates/static/home.st -- called when /static is requested
--- templates/static/spatula.st -- you can have a special template for
--- one page
---
---
--- Think of it like this -- you request content, either a single post,
--- a directory, or an atom feed (hardcoded as feed.xml). Blaaargh
--- searches for the closest matching template. For a content file
--- /foo/bar/baz.md, we would search templates/ for:
---
--- * foo/bar/baz.st
--- * foo/bar/post.st
--- * foo/post.st
--- * post.st
--- * 404.st
---
--- For a directory /foo/bar/quux, we search templates/ for
--- "foo/bar/quux/index.st".
---
--- (i.e. we don't walk up the directory structure)
---
--- And if content/foo/bar/quux/index.md exists, we read it into the template
--- as content text.
---
---
--- The documents get indexed into a map by id. The '.md' suffices get
--- stripped off and those files are treated as posts, and other files
--- are served as static files:
---
--- posts/foo
--- posts/bar
--- posts/bar/photo.jpg -- served as static
--- static/hamster
---
---
--- Nothing else fancy is going on yet --- blaaargh will not yet automatically
--- organize your posts by time (e.g. /posts/2009/05/26/post-slug), although
--- it's easy to do so by hand.
---
--- A couple of things blaaargh WILL give you:
---
--- * a request for a directory ending in feed.xml (e.g. /posts/2009/feed.xml)
--- will return an RSS feed of the last N within (configurable), in reverse
--- chronological order
---
--- * requesting a directory (e.g. /posts/) will render a "post list" using a
--- custom stringtemplate. Template variables filled include:
---
--- ** lists
--- $alphabeticalPosts$
--- $recentPosts$
--- $chronologicalPosts$
--- $reverseChronologicalPosts$
---
--- a post is served to the template with the following attributes:
--- $url$
--- $title$
--- $date$
--- $body$
--- $summary$
--- etc
---
--- When serving a single page, the post data is stored in the template
--- variable "post", i.e. writing $post.url$ will substitute as
--- expected.
-
-
--- to make things super-easy on us, we'll define our internal post
--- format to be the same as our Atom feed.
-newtype Post = Post { unPost :: Atom.Entry }
- deriving (Show)
-
-
-getPostTime :: Post -> ZonedTime
-getPostTime (Post p) = parseAtomTime $ fromMaybe upd pub
- where
- pub = Atom.entryPublished p
- upd = Atom.entryUpdated p
-
-
-instance ToSElem Atom.EntryContent where
- toSElem (Atom.TextContent s) = toSElem s
- toSElem (Atom.HTMLContent s) = toSElem s
- toSElem _ = toSElem (""::String)
-
-
-instance ToSElem Atom.TextContent where
- toSElem (Atom.TextString s) = toSElem s
- toSElem (Atom.HTMLString s) = toSElem s
- toSElem _ = toSElem (""::String)
-
-
-instance ToSElem Atom.Person where
- toSElem (Atom.Person name _ email _) = toSElem $ name ++ em
- where
- em = maybe "" (\e -> " <" ++ e ++ ">") email
-
-
-instance ToSElem Post where
- toSElem post@(Post p) = SM $ Map.fromList attrs
- where
- url = Atom.entryId p
- body = fromMaybe (Atom.TextContent "") $ Atom.entryContent p
- summary = fromMaybe (Atom.HTMLString "") $ Atom.entrySummary p
-
- attrs = [ ("id", toSElem url)
- , ("date", toSElem $ friendlyTime $ getPostTime post)
- , ("url", toSElem url)
- , ("title", toSElem $ Atom.entryTitle p)
- , ("content", toSElem body)
- , ("summary", toSElem summary)
- , ("authors", toSElemList $ Atom.entryAuthors p) ]
-
-
-
-instance ToMessage Atom.Feed where
- toContentType _ = "application/atom+xml"
- toMessage f = L.pack $ XML.showElement $ Atom.xmlFeed f
-
-
-
-type ContentMap = Map ByteString ContentItem
-
-data ContentItem =
- ContentPost Post -- ^ a post
- | ContentDirectory ByteString ContentMap -- ^ a path prefix + content
- -- mapping
- | ContentStatic FilePath -- ^ a static file
- deriving (Show)
-
-
-data BlaaarghState = BlaaarghState
- { blaaarghPath :: FilePath -- ^ path on disk
- , blaaarghSiteURL :: String -- ^ site URL, minus slash
- -- (e.g. http://foo.com)
- , blaaarghBaseURL :: String -- ^ base URL of content section,
- -- e.g. "/posts"
- , blaaarghPostMap :: ContentMap -- ^ content
- , blaaarghTemplates :: TemplateDirs -- ^ templates
- , blaaarghFeedInfo :: Atom.Feed -- ^ feed info
-
- , blaaarghFeedExcludes :: ExcludeList -- ^ these URLs won't appear in
- -- feeds or in post listings
-
- , blaaarghExtraTmpl :: Template -> Template
- -- ^ extra template variables get
- -- inserted here
- }
-
-
-type BlaaarghMonad = StateT BlaaarghState IO
-type BlaaarghHandler = ServerPartT BlaaarghMonad Response
-
-
-liftB :: ServerPartT IO a -> ServerPartT BlaaarghMonad a
-liftB = mapServerPartT liftIO
-
-
-runBlaaarghHandler :: BlaaarghState
- -> ServerPartT BlaaarghMonad a
- -> ServerPartT IO a
-runBlaaarghHandler s = mapServerPartT $ \m -> do
- (a,_) <- runStateT m s
- return a
-
-
-
-addExtraTemplateArguments :: ToSElem a =>
- [(String,a)]
- -> BlaaarghMonad ()
-addExtraTemplateArguments args = do
- modify $ \t ->
- t { blaaarghExtraTmpl = foldl f (blaaarghExtraTmpl t) args }
-
- where
- f :: ToSElem a => (Template -> Template) -> (String, a) -> (Template -> Template)
- f xtmpl (k,v) = (setAttribute k v) . xtmpl

0 comments on commit b2af34e

Please sign in to comment.