bamboo 2009.6.6 → 2009.6.8
raw patch · 55 files changed
+384/−1125 lines, 55 filesdep −rssdep ~base
Dependencies removed: rss
Dependency ranges changed: base
Files
- bamboo.cabal +17/−35
- changelog.md +8/−0
- src/Bamboo.hs +5/−8
- src/Bamboo/Controller/Application.hs +29/−13
- src/Bamboo/Controller/Comment.hs +10/−16
- src/Bamboo/Controller/Env.hs +5/−6
- src/Bamboo/Controller/Helper.hs +18/−36
- src/Bamboo/Controller/Index.hs +4/−20
- src/Bamboo/Controller/Post.hs +4/−10
- src/Bamboo/Controller/Search.hs +3/−10
- src/Bamboo/Controller/Static.hs +2/−8
- src/Bamboo/Controller/Tag.hs +11/−26
- src/Bamboo/Controller/Type.hs +5/−7
- src/Bamboo/Env.hs +6/−23
- src/Bamboo/Helper.hs +42/−32
- src/Bamboo/Helper/ByteString.hs +6/−8
- src/Bamboo/Helper/PreludeEnv.hs +3/−1
- src/Bamboo/Helper/StateHelper.hs +16/−33
- src/Bamboo/Helper/Translation.hs +0/−1
- src/Bamboo/Model/Comment.hs +25/−15
- src/Bamboo/Model/Counter.hs +5/−7
- src/Bamboo/Model/Helper.hs +0/−7
- src/Bamboo/Model/Post.hs +59/−31
- src/Bamboo/Model/Static.hs +6/−6
- src/Bamboo/Model/Tag.hs +14/−10
- src/Bamboo/Type.hs +5/−4
- src/Bamboo/Type/Common.hs +1/−1
- src/Bamboo/Type/Config.hs +7/−5
- src/Bamboo/Type/Pager.hs +7/−7
- src/Bamboo/Type/Reader.hs +4/−6
- src/Bamboo/Type/State.hs +29/−23
- src/Bamboo/Type/StaticWidget.hs +6/−5
- src/Bamboo/Type/Theme.hs +4/−18
- src/Bamboo/Type/ThemeInterface.hs +18/−0
- src/Bamboo/View/Atom/Comment.hs +0/−87
- src/Bamboo/View/Atom/Post.hs +0/−44
- src/Bamboo/View/Atom/Tag.hs +0/−8
- src/Bamboo/View/Control/Comment.hs +0/−18
- src/Bamboo/View/Control/Helper.hs +0/−21
- src/Bamboo/View/Control/Post.hs +0/−33
- src/Bamboo/View/Control/Search.hs +0/−18
- src/Bamboo/View/Control/Static.hs +0/−10
- src/Bamboo/View/Control/Tag.hs +0/−22
- src/Bamboo/View/Env.hs +0/−15
- src/Bamboo/View/Helper.hs +0/−118
- src/Bamboo/View/Widget/Body.hs +0/−11
- src/Bamboo/View/Widget/Footer.hs +0/−26
- src/Bamboo/View/Widget/Head.hs +0/−29
- src/Bamboo/View/Widget/Header.hs +0/−20
- src/Bamboo/View/Widget/Helper.hs +0/−22
- src/Bamboo/View/Widget/Navigation.hs +0/−28
- src/Bamboo/View/Widget/RSS.hs +0/−64
- src/Bamboo/View/Widget/SearchBar.hs +0/−12
- src/Bamboo/View/Widget/Sidebar.hs +0/−47
- src/Bamboo/View/Widget/Template.hs +0/−34
bamboo.cabal view
@@ -1,5 +1,5 @@ Name: bamboo-Version: 2009.6.6+Version: 2009.6.8 Build-type: Simple Synopsis: A simple blog middleware on hack Description: A simple blog middleware on hack@@ -16,9 +16,9 @@ library ghc-options: -Wall -fno-warn-orphans build-depends: - base > 4 && < 5, cgi, network, mtl, haskell98, old-locale, old-time+ base >= 4 && < 5, cgi, network, mtl, haskell98, old-locale, old-time , time, unix, bytestring, base64-string, zlib, directory, filepath- , containers, process, parsedate >= 3000.0.0, rss == 3000.0.1+ , containers, process, parsedate >= 3000.0.0 , xhtml, utf8-string >= 0.3.3, pandoc, parsec >= 2, gravatar >= 0.3 , data-default >= 0.2 , mps >= 2009.5.13, hcheat >= 2009.5.13@@ -26,17 +26,6 @@ hs-source-dirs: src/ exposed-modules: Bamboo- other-modules: - Bamboo.Controller.Application- Bamboo.Controller.Comment- Bamboo.Controller.Env- Bamboo.Controller.Helper- Bamboo.Controller.Index- Bamboo.Controller.Post- Bamboo.Controller.Search- Bamboo.Controller.Static- Bamboo.Controller.Tag- Bamboo.Controller.Type Bamboo.Env Bamboo.Helper Bamboo.Helper.ByteString@@ -60,24 +49,17 @@ Bamboo.Type.State Bamboo.Type.StaticWidget Bamboo.Type.Theme- Bamboo.View.Atom.Comment- Bamboo.View.Atom.Post- Bamboo.View.Atom.Tag- Bamboo.View.Control.Comment- Bamboo.View.Control.Helper- Bamboo.View.Control.Post- Bamboo.View.Control.Search- Bamboo.View.Control.Static- Bamboo.View.Control.Tag- Bamboo.View.Env- Bamboo.View.Helper- Bamboo.View.Widget.Body- Bamboo.View.Widget.Footer- Bamboo.View.Widget.Head- Bamboo.View.Widget.Header- Bamboo.View.Widget.Helper- Bamboo.View.Widget.Navigation- Bamboo.View.Widget.RSS- Bamboo.View.Widget.SearchBar- Bamboo.View.Widget.Sidebar- Bamboo.View.Widget.Template+ Bamboo.Type.ThemeInterface+ Bamboo.Controller.Application+ Bamboo.Controller.Comment+ Bamboo.Controller.Env+ Bamboo.Controller.Helper+ Bamboo.Controller.Index+ Bamboo.Controller.Post+ Bamboo.Controller.Search+ Bamboo.Controller.Static+ Bamboo.Controller.Tag+ Bamboo.Controller.Type+ ++
changelog.md view
@@ -1,3 +1,11 @@+2009.6.8+--------++### Feature++* completely separate view+* new theme interface+ 2009.6.6 --------
src/Bamboo.hs view
@@ -1,12 +1,9 @@-module Bamboo- (- bamboo- ) where--import Bamboo.Controller.Application (paths)+module Bamboo ( bamboo_with_theme ) where +import Bamboo.Controller.Application (paths_with_theme) import Hack import Hack.Contrib.Middleware.RawRouter+import Bamboo.Type.ThemeInterface (Theme) -bamboo :: Middleware-bamboo = route paths +bamboo_with_theme :: Theme -> Middleware+bamboo_with_theme x = route (paths_with_theme x)
src/Bamboo/Controller/Application.hs view
@@ -4,25 +4,41 @@ module Bamboo.Controller.Application where -import Bamboo.Controller.Env hiding (tag)+import Bamboo.Controller.Env import Bamboo.Controller.Comment import Bamboo.Controller.Index import Bamboo.Controller.Post import Bamboo.Controller.Search import Bamboo.Controller.Static import Bamboo.Controller.Tag-+import qualified Bamboo.Type.ThemeInterface as I+import Control.Monad.State -paths :: [(String, Application)]-paths = - [ ("$" ,index )- , ("(\\?.+)?$" ,index )- , ("rss.xml$" ,index_feed )- , (blog_regex ,post )- , ("static/." ,static )- , ("tag/.*/rss.xml$" ,tag_feed )- , ("tag/." ,tag )- , ("search" ,only_for Search $ search )- , ("comment/create" ,only_for Comment $ comment_create )+paths_with_theme :: I.Theme -> [(String, Application)]+paths_with_theme t = + [ x "$" I.Index index + , x "(\\?.+)?$" I.Index index + , x "rss.xml$" I.IndexFeed index_feed + , x blog_regex I.Post post + , x "static/." I.Static static + , x "tag/.*/rss.xml$" I.TagFeed tag_feed + , x "tag/." I.Tag tag+ , for_extension Search $ x "search" I.Search search + , for_extension Comment $ Just ("comment/create", comment_create ) ]+ .filter isJust+ .map fromJust .map_fst ((static_config.root /) > ("^" ++))+ + where+ x a b c = Just (a, render_with_theme t (b, c))++render_with_theme :: I.Theme -> (I.Interface, Controller) -> Application+render_with_theme t (i, c) = \env -> do+ execStateT c def {env} >>= t i++for_extension :: Extension -> Maybe a -> Maybe a+for_extension ext x = + if has_extension ext + then x + else Nothing
src/Bamboo/Controller/Comment.hs view
@@ -4,35 +4,34 @@ module Bamboo.Controller.Comment where -import Bamboo.Controller.Env hiding (checked)+import Bamboo.Controller.Env+import Hack.Contrib.Response (redirect)+import Network.CGI (urlEncode)+import System.FilePath (equalFilePath, takeDirectory) import qualified Bamboo.Model.Comment as Comment import qualified Bamboo.Model.Post as Post-import qualified Bamboo.Type as T import qualified Bamboo.Type.State as S-import Hack.Contrib.Response (redirect) comment_create :: Application comment_create env = do- let post_id = static_config.T.post_id+ let post_uid = static_config.post_id key = show_data Comment.PostId- nothing = post_id / "nothing"+ nothing = post_uid / "nothing" uid = env.input_with_default key nothing exists <- (static_config.flat_uri / uid) .file_exist - let valid_path = equalFilePath post_id (takeDirectory uid) + let valid_path = equalFilePath post_uid (takeDirectory uid) checked = check_create - if [checked, valid_path, exists].and- then env.inputs.Comment.create_comment- else return ()+ when ([checked, valid_path, exists].and) $+ env.inputs.Comment.create_comment return $ def.redirect ((uid.Post.id_to_uri.u2b).urlEncode) Nothing where get_input_data s = env.get_input (s.show_data)- check_human = S.simple_eval (l.read) (r.read) (op.S.read_op) .is (h.read) where [l, r, op, h] = @@ -55,9 +54,4 @@ ] .and -- validate s f =- let maybe_s = get_input_data s in- case maybe_s of- Nothing -> False- Just v -> f v+ validate s f = get_input_data s .maybe False f
src/Bamboo/Controller/Env.hs view
@@ -2,19 +2,18 @@ ( module Bamboo.Env , module Bamboo.Controller.Helper- , module Bamboo.View.Helper+ , module Bamboo.Controller.Type+ , module Bamboo.Helper.StateHelper , module Bamboo.Type.State , module Control.Monad.State- , module Bamboo.Helper.StateHelper- , module Bamboo.Controller.Type , module Hack ) where -import Bamboo.Env hiding (navigation, sidebar, footer, get, uri) import Bamboo.Controller.Helper import Bamboo.Controller.Type-import Bamboo.View.Helper+import Bamboo.Env hiding (footer, get, uri)+import Bamboo.Helper.StateHelper (has_extension, uri) import Bamboo.Type.State hiding (resource_title, static, tag_name) import Control.Monad.State (get, put)-import Bamboo.Helper.StateHelper (has_extension, uri) import Hack (Env, Response, Application)+
src/Bamboo/Controller/Helper.hs view
@@ -4,32 +4,24 @@ module Bamboo.Controller.Helper where --import Bamboo.Env hiding (get, p)-import Bamboo.Helper.StateHelper+import Bamboo.Controller.Type+import Bamboo.Env hiding (get) import Bamboo.Type.State import Control.Monad.State import Data.Default import Data.List hiding (length) import Data.Maybe import Hack-import Bamboo.Controller.Type-import qualified Hack import System.IO as IO+import qualified Bamboo.Model.Comment as Comment import qualified Bamboo.Model.Post as Post import qualified Bamboo.Model.Tag as Tag-import qualified Bamboo.Model.Comment as Comment import qualified Bamboo.Type.Pager as Pager import qualified Bamboo.Type.State as S+import qualified Hack import qualified Hack.Contrib.Request as Request -data CachedController = CachedController- {- etag_controller :: ETagController- , controller :: Controller- }- init_state :: Controller init_state = fill_latest_posts >> fill_tags @@ -49,9 +41,6 @@ just_param s env = env .get_param s .fromJust just_input s env = env .get_input s .fromJust -only_for :: Extension -> (a -> IO Response) -> a -> IO Response-only_for ext x = if has_extension ext then x else const not_found_response- io :: (MonadIO m) => IO a -> m a io = liftIO @@ -74,15 +63,15 @@ paginate :: [a] -> Part Pager paginate xs = do s <- get- let per_page' = s.config.per_page- current = s.env.param_with_default "page" "1" .read- total = xs.length- has_next = current * per_page' < total.from_i+ let per_page' = s.config.per_page+ current = s.env.param_with_default "page" "1" .read+ total = xs.length+ has_next = current * per_page' < total.from_i has_previous = current `gt` n1 next = current + n1 previous = current + (- n1)- n1 = 1 :: Int- + n1 = 1 :: Int+ return def { Pager.per_page = per_page'@@ -101,28 +90,21 @@ for_current_page :: Pager -> [a] -> [a] for_current_page p xs = - xs.drop ((p.current - 1) * p.Pager.per_page) .take (p.Pager.per_page)+ xs+ .drop ((p.current - 1) * p.Pager.per_page)+ .take (p.Pager.per_page) init_post_meta_data :: Post.Post -> Part Post.Post init_post_meta_data x = do tags <- get ^ tags- x.Tag.fill_tag tags.Comment.fill_comment_size.io+ x+ .Tag.fill_tag tags+ .Comment.fill_comment_size+ .io run :: Controller -> View -> Application-run x v env = do- s <- execStateT x def {env}- v s- - - {- cache should-- * get tag from env- * get tag from current controller- * if equal- then return unmodify- else return data- -}+run x v env = execStateT x def {env} >>= v not_found :: Controller not_found = get >>= \s -> put s {S.status = 404}
src/Bamboo/Controller/Index.hs view
@@ -10,14 +10,10 @@ {-# LANGUAGE NamedFieldPuns #-} module Bamboo.Controller.Index where- import Bamboo.Controller.Env-import qualified Bamboo.View.Control.Post as PostV-import qualified Bamboo.View.Widget.RSS as RSSV --index_controller :: Controller-index_controller = do+index :: Controller+index = do init_state (posts, pager) <- list.io >>= (mapM init_post_meta_data) >>= paged@@ -31,21 +27,9 @@ , nav_location , posts } --index_view :: View-index_view = PostV.list > output_html--index :: Application-index = run index_controller index_view--index_feed_controller :: Controller-index_feed_controller = do+index_feed :: Controller+index_feed = do s <- get posts <- list .io ^ take (s.config.number_of_latest_posts) put s { posts } -index_feed_view :: View-index_feed_view s = RSSV.rss s "" "" .render_rss .to_sb .output_plain_rss--index_feed :: Application-index_feed = run index_feed_controller index_feed_view
src/Bamboo/Controller/Post.hs view
@@ -9,10 +9,9 @@ import qualified Bamboo.Model.Post as Post import qualified Bamboo.Type as T import qualified Bamboo.Type.State as S-import qualified Bamboo.View.Control.Post as PostV -post_controller :: Controller-post_controller = do+post :: Controller+post = do init_state env <- get ^ env@@ -23,7 +22,8 @@ let posts = [post_model] comments <- list_for uid .io - if has_extension Counter then Counter.hit uid .io else return ()+ when (has_extension Counter) $+ Counter.hit uid .io s <- get human_test_data <- S.mk_human_test .io@@ -34,9 +34,3 @@ , posts , comments }--post_view :: View-post_view = PostV.view > output_html--post :: Application-post = run post_controller post_view
src/Bamboo/Controller/Search.hs view
@@ -4,13 +4,12 @@ module Bamboo.Controller.Search where -import Bamboo.Controller.Env hiding (query)+import Bamboo.Controller.Env import qualified Bamboo.Model.Post as Post import qualified Bamboo.Type.State as S-import qualified Bamboo.View.Control.Search as SearchV -search_controller :: Controller-search_controller = do+search :: Controller+search = do init_state s <- get @@ -28,9 +27,3 @@ , S.resource_title = query , search_key = key }--search_view :: View-search_view = SearchV.view > output_html--search :: Application-search = run search_controller search_view
src/Bamboo/Controller/Static.hs view
@@ -8,10 +8,9 @@ import qualified Bamboo.Model.Static as Static import qualified Bamboo.Type as T import qualified Bamboo.Type.State as S-import qualified Bamboo.View.Control.Static as StaticV -static_controller :: Controller-static_controller = do+static :: Controller+static = do init_state s <- get let uid = s.env.uri@@ -30,8 +29,3 @@ , S.static = static_model } -static_view :: View-static_view = StaticV.view > output_html--static :: Application-static = run static_controller static_view
src/Bamboo/Controller/Tag.hs view
@@ -6,26 +6,27 @@ import Bamboo.Controller.Env import qualified Bamboo.Model.Tag as Tag-import qualified Bamboo.Type.State as S import qualified Bamboo.Type as T-import qualified Bamboo.View.Control.Tag as TagV-import qualified Bamboo.View.Widget.RSS as RSSV+import qualified Bamboo.Type.State as S import qualified Data.Map as Map -tag_controller :: Controller-tag_controller = do+tag :: Controller+tag = do init_state s <- get let uid = s.env.uri tag_name = Tag.get_name uid- case Tag.tag_map' (s.tags) .Map.lookup tag_name of Nothing -> not_found Just post_set -> do- posts' <- post_set.to_list.rsort.mapM (to_us > T.get > io)- >>= mapM (init_post_meta_data)+ posts' <-+ post_set+ .to_list+ .rsort+ .mapM (to_us > T.get > io)+ >>= mapM (init_post_meta_data) (posts, pager) <- posts'.paged put s@@ -35,14 +36,8 @@ , S.resource_title = tag_name.Tag.resource_title_from_name } -tag_view :: View-tag_view = TagV.view > output_html--tag :: Application-tag = run tag_controller tag_view--tag_feed_controller :: Controller-tag_feed_controller = do+tag_feed :: Controller+tag_feed = do init_state s <- get @@ -65,13 +60,3 @@ , posts , S.tag_name = tag_name }--tag_feed_view :: View-tag_feed_view s = - RSSV.rss s (s.config.tag_id) (s.S.tag_name)- .render_rss- .to_sb- .output_plain_rss--tag_feed :: Application-tag_feed = run tag_feed_controller tag_feed_view
src/Bamboo/Controller/Type.hs view
@@ -1,13 +1,11 @@ module Bamboo.Controller.Type where - import Bamboo.Type.State (State) import Control.Monad.State (StateT) import Hack (Response)- - ++type Controller = StateController ()+type ETagController = StateController String+type Part a = StateT State IO a type StateController a = StateT State IO a-type Controller = StateController ()-type ETagController = StateController String-type View = State -> IO Response-type Part a = StateT State IO a+type View = State -> IO Response
src/Bamboo/Env.hs view
@@ -16,37 +16,20 @@ , module Data.Foldable , module Data.List , module Data.Maybe- , module Hack.Contrib.Utils- , module Network.CGI - , module Network.URI - , module System.Directory- , module System.FilePath- , module System.IO.UTF8- , module System.Locale - , module System.Time- , module System.Time.Parse , module Text.XHtml.Strict ) where import Bamboo.Helper-import Bamboo.Helper.ByteString hiding (lower, isInfixOf)-import Bamboo.Helper.PreludeEnv hiding (FilePath)+import Bamboo.Helper.ByteString (to_sb, to_lb, to_us, read_bytestring)+import Bamboo.Helper.PreludeEnv import Bamboo.Helper.Translation import Bamboo.Type import Control.Arrow ((>>>), (&&&), (***))-import Control.Monad (liftM2, liftM3, liftM4, liftM5) +import Control.Monad (liftM2, liftM3, liftM4, liftM5, when) import Data.ByteString.Char8 (pack, unpack)-import Data.Default+import Data.Default (Default, def) import Data.Foldable (find) import Data.List (isSuffixOf, isInfixOf, isPrefixOf, sortBy, intersperse) import Data.Maybe (fromMaybe, fromJust, isJust, isNothing)-import Hack.Contrib.Utils (httpdate)-import Network.CGI hiding (Html, redirect)-import Network.URI-import System.Directory-import System.FilePath hiding ((<.>))-import System.IO.UTF8 (readFile, writeFile)-import System.Locale-import System.Time-import System.Time.Parse-import Text.XHtml.Strict hiding (select, sub, meta)+import Text.XHtml.Strict (toHtml, Html)+
src/Bamboo/Helper.hs view
@@ -9,7 +9,7 @@ import Bamboo.Type import Bamboo.Type.Reader import Bamboo.Type.StaticWidget hiding (name, body, reader)-import Control.Monad (liftM2)+import Control.Monad (liftM2, when) import Data.Default import Data.Maybe import System.Directory@@ -23,11 +23,15 @@ gt :: (Ord a) => a -> a -> Bool gt = (P.>) -ffmap :: (Functor f, Functor f1) => (a -> b) -> f1 (f a) -> f1 (f b)+ffmap :: (Functor f, Functor f1) => + (a -> b) -> f1 (f a) -> f1 (f b) ffmap f = fmap (fmap f) (^^) :: (Functor f, Functor f1) => f1 (f a) -> (a -> b) -> f1 (f b) (^^) x f = fmap (fmap f) x +whenM :: (Monad m) => m Bool -> m () -> m ()+whenM b x = b >>= flip when x+ parse_config :: String -> IO Assoc parse_config x = do s <- read_file x@@ -120,12 +124,12 @@ >>= set_root ( for_s Root ^^ clean_path ) >>= set_navigation ( for_l Navigation ^^ (home_nav :) ) >>= set_bamboo_url ( for_s BambooUrl )- >>= set_sidebar ( for_l Sidebar ^^ load_sidebar )- >>= set_footer ( for_s Footer ^^ load_footer )+ >>= set_sidebar ( for_l Sidebar >>= load_sidebar )+ >>= set_footer ( for_s Footer >>= load_footer ) >>= set_favicon ( for_s Favicon ) >>= set_analytics_account_id ( for_s AnalyticsAccountId ) >>= set_extensions ( for_l Extensions ^^ read_data_list )- >>= set_theme ( for_s Theme >>= get_theme )+ >>= set_theme_config ( for_s Theme >>= get_theme_config ) >>= set_post_date_format ( for_s PostDateFormat ) >>= set_comment_date_format ( for_s CommentDateFormat ) >>= set_url_date_format ( for_s UrlDateFormat )@@ -152,26 +156,37 @@ clean_path user_root | user_root.belongs_to ["/", ""] = "/" | otherwise = user_root.("/" /).remove_trailing_slash++ load_widget x = do+ exists <- x.file_exist+ if exists+ then do+ w <- read_static_widget def x+ return $ (Just w)+ else+ return Nothing++ load_sidebar_item = (def.footer_uri / ) > load_widget - load_sidebar xs = xs- .map (def.sidebar_uri /)- .select (file_exist > purify )- .map load_widget+ load_sidebar Nothing = return Nothing+ load_sidebar (Just xs) = + xs+ . mapM load_sidebar_item+ ^ filter isJust+ ^ map fromJust+ ^ Just - load_widget = read_static_widget def > purify-- load_footer s = s- .(def.footer_uri / ) - .(\x -> if x.file_exist.purify then Just $ load_widget x else Nothing)+ load_footer Nothing = return Nothing+ load_footer (Just s) = (def.footer_uri / s) .load_widget ^ Just as_l s = "[" ++ s ++ "]" - get_theme Nothing = return Nothing- get_theme (Just user_theme_name) =+ get_theme_config Nothing = return Nothing+ get_theme_config (Just user_theme_name) = do let user_theme_uri = (def.theme_uri / user_theme_name) ++ ".txt"- in - if user_theme_uri.file_exist.purify+ exists <- user_theme_uri.file_exist+ if exists then parse_config user_theme_uri ^ (("name", user_theme_name) : )@@ -207,7 +222,7 @@ set_summary_for_root v' x = v' >>= \v -> r $ c v x $ x { summary_for_root = p v} set_summary_for_rss v' x = v' >>= \v -> r $ c v x $ x { summary_for_rss = p v} set_summary_for_tag v' x = v' >>= \v -> r $ c v x $ x { summary_for_tag = p v}- set_theme v' x = v' >>= \v -> r $ c v x $ x { theme = p v}+ set_theme_config v' x = v' >>= \v -> r $ c v x $ x { theme_config = p v} set_url_date_format v' x = v' >>= \v -> r $ c v x $ x { url_date_format = p v} set_url_date_matcher v' x = v' >>= \v -> r $ c v x $ x { url_date_matcher = p v} set_url_date_title_seperator v' x = v' >>= \v -> r $ c v x $ x { url_date_title_seperator = p v}@@ -250,25 +265,20 @@ -- Widget read_static_widget :: Reader -> String -> IO StaticWidget read_static_widget user_reader s = liftM2 (StaticWidget name) body (return reader) where- body = s.read_bytestring+ body = s.read_bytestring reader = s.take_extension.guess_reader.fromMaybe user_reader- name = s.takeFileName.drop_known_extension-+ name = s.takeFileName.drop_known_extension -- Theme-to_theme :: Assoc -> Theme.Theme-to_theme xs = Theme.Theme+to_theme :: Assoc -> Theme.ThemeConfig+to_theme xs = Theme.ThemeConfig { Theme.name = at Theme.Name- , Theme.container = at Theme.Container- , Theme.header = at Theme.Header- , Theme.navigation = at Theme.Navigation- , Theme.main = at Theme.Main- , Theme.sidebar = at Theme.Sidebar- , Theme.footer = at Theme.Footer , Theme.css = at Theme.Css .css_list , Theme.js = at Theme.Js .js_list } where at s = xs.lookup (s.show_data) .fromJust- css_list s = s.parse_list.map (\x -> "/theme/" ++ at Theme.Name ++ "/css/" ++ x ++ ".css")- js_list s = s.parse_list.map (\x -> "/theme/" ++ at Theme.Name ++ "/js/" ++ x ++ ".js")+ css_list s = s.parse_list.map + (\x -> "/theme/" ++ at Theme.Name ++ "/css/" ++ x ++ ".css")+ js_list s = s.parse_list.map + (\x -> "/theme/" ++ at Theme.Name ++ "/js/" ++ x ++ ".js")
src/Bamboo/Helper/ByteString.hs view
@@ -4,20 +4,18 @@ module Bamboo.Helper.ByteString where +import Bamboo.Helper.PreludeEnv import Data.Char (toLower)+import Data.Default+import qualified Data.ByteString as SB import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.UTF8 as U import qualified Data.ByteString.Char8 as S-import Bamboo.Helper.PreludeEnv---import qualified Data.ByteString as SB-import qualified Data.ByteString.UTF8 as SU import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.UTF8 as LU-+import qualified Data.ByteString.UTF8 as SU+import qualified Data.ByteString.UTF8 as U import qualified Prelude as P-import Data.Default+ class SB a where to_sb :: a -> SB.ByteString
src/Bamboo/Helper/PreludeEnv.hs view
@@ -5,5 +5,7 @@ , module Prelude ) where -import Prelude hiding ((.), (/), (^), id, span, readFile, writeFile, div, (>), (^^))+import Prelude hiding (+ (.), (/), (^), id, span, readFile, writeFile, div, (>), (^^)+ ) import MPSUTF8 hiding (base, date, format_time)
src/Bamboo/Helper/StateHelper.hs view
@@ -5,38 +5,37 @@ module Bamboo.Helper.StateHelper where -import Bamboo.Env hiding (path, cut)-import qualified Bamboo.Type.Config as C-import qualified Data.ByteString.Char8 as S+import Bamboo.Env hiding (cut) import Data.ByteString (ByteString)-import Hack.Contrib.Utils import Hack+import Hack.Contrib.Utils+import Network.CGI (urlDecode) import System.Time+import System.Locale (defaultTimeLocale)+import System.Time.Parse (parseCalendarTime)+import qualified Bamboo.Type.Config as C+import qualified Data.ByteString.Char8 as S -- static_config.root = /blog -- raw_uri = blog/x -- full_uri = /blog/x -- uri = full_uri - (/blog/)- remove_root :: String -> String remove_root s | static_config.root.is "/" = s- | otherwise = s.slice (static_config.root.length) (s.length)+ | otherwise = s.slice (static_config.root.length) (s.length) raw_uri :: Env -> String-raw_uri env = ( env.script_name ++ env.path_info ) .(urlDecode > tail > remove_trailing_slash )+raw_uri env = ( env.script_name ++ env.path_info )+ .(urlDecode > tail > remove_trailing_slash ) uri :: Env ->String uri env = raw_uri env .b2u .remove_root--- uri = raw_uri -- global parse_date :: String -> String -> Maybe CalendarTime-parse_date format s = case maybe_d of- Nothing -> Nothing- Just d -> Just $ if d.ctYear < 1910 then d {ctYear = d.ctYear + 100} else d - where- maybe_d = parseCalendarTime defaultTimeLocale format s+parse_date format s = parseCalendarTime defaultTimeLocale format s ^+ (\d -> if d.ctYear < 1910 then d {ctYear = d.ctYear + 100} else d ) format_time :: String -> CalendarTime -> String format_time = formatCalendarTime defaultTimeLocale@@ -48,7 +47,7 @@ parse_post_date = parse_date $ static_config.post_date_format default_parse_date :: String -> CalendarTime-default_parse_date s = s.parse_post_date .fromMaybe default_date+default_parse_date = parse_post_date > fromMaybe default_date has_extension :: Extension -> Bool has_extension x = static_config.extensions.has x@@ -58,28 +57,12 @@ -- controller cut :: ByteString-cut = static_config.C.cut.to_sb-match_cut :: ByteString -> Bool+cut = static_config.C.cut.to_sb+match_cut, is_cut :: ByteString -> Bool match_cut = S.lines > any (S.isPrefixOf cut)-is_cut :: ByteString -> Bool is_cut = S.isPrefixOf cut --- not used for efficiency--- cut_re = "^\\s*" ++ cut--- split_cut = split cut_re-- -- model-path :: String -> String+path, id_to_path :: SC path id = static_config.flat_uri / id-id_to_path :: String -> String id_to_path = path--{--etag_data :: String -> IO ByteString-etag_data id = do- let path = id.id_to_path- mtime <- path.file_mtime ^ httpdate- size <- path.file_size ^ show- return $ [id, mtime, size] .join "," .pack--}
src/Bamboo/Helper/Translation.hs view
@@ -5,7 +5,6 @@ no_navigation :: String previous_sign :: String - home_nav = "Home" next_sign = "Next Entries »" no_navigation = ""
src/Bamboo/Model/Comment.hs view
@@ -3,21 +3,22 @@ module Bamboo.Model.Comment where --- env-import Bamboo.Model.Env hiding (title, body, size, path, Comment, AuthorEmail, author_email, at, size)-import qualified Bamboo.Type as C-import Bamboo.Type.Reader-import qualified Bamboo.Model.Post as Post import Bamboo.Helper.StateHelper+import Bamboo.Model.Env hiding (Comment, AuthorEmail, author_email, at)+import Bamboo.Type.Reader+import System.Time (getClockTime, toCalendarTime) import Network.Gravatar+import qualified Bamboo.Model.Post as Post+import qualified Bamboo.Type as C import qualified Data.ByteString.Char8 as S + data Comment = Comment- { uid :: String -- comment/08-09-04 blog title- , author :: String- , body :: S.ByteString- , author_email :: String- , author_link :: String+ { uid :: String -- comment/08-09-04 blog title+ , author :: String+ , body :: S.ByteString+ , author_email :: String+ , author_link :: String } deriving (Show, Eq) @@ -67,10 +68,16 @@ instance Listable Comment where list_for resource_id = do- ifM (dir_exist d) (idsM >>= mapM (get :: String -> IO Comment)) (return [])+ ifM (dir_exist d) + (idsM >>= mapM (get :: String -> IO Comment))+ (return []) where- idsM = ls d ^ reject (isSuffixOf ".meta") ^ rsort ^ map (static_config.comment_id / r /)- d = (static_config.comment_uri / r)+ idsM = ls d + ^ reject (".meta" `isSuffixOf`) + ^ rsort + ^ map (static_config.comment_id / r /)+ + d = static_config.comment_uri / r r = resource_id.id_to_resource instance Creatable Comment where@@ -81,7 +88,9 @@ let at s = h.lookup (s.show_data) .fromJust let post_id' = at PostId - timestamp <- ( getClockTime >>= toCalendarTime ) ^ format_time (static_config.comment_date_format)+ timestamp <- ( getClockTime >>= toCalendarTime )+ ^ format_time (static_config.comment_date_format)+ let comment_path = post_id_to_uid post_id' mkdir_p comment_path @@ -115,7 +124,8 @@ post_id_to_uid :: SC uid_to_post_id :: SC-post_id_to_uid x = static_config.flat_uri / static_config.comment_id / x.split "/" .last+post_id_to_uid x = + static_config.flat_uri / static_config.comment_id / x.split "/" .last uid_to_post_id x = static_config.post_id / x.split "/" .last fill_comment_size :: Post.Post -> IO Post.Post
src/Bamboo/Model/Counter.hs view
@@ -2,7 +2,6 @@ module Bamboo.Model.Counter where --- env import Bamboo.Model.Env import qualified System.IO as IO @@ -27,13 +26,12 @@ create_stat_if_none :: String -> IO () create_stat_if_none x = do let i = x.count_path- has_stat <- i.file_exist- if has_stat- then return ()- else i.create_stat- + whenM (i.file_exist ^ not) $+ i.create_stat+ where- create_stat x' = mkdir_p (x'.take_directory) >> default_count.show.write_file x'+ create_stat x' = mkdir_p (x'.take_directory) + >> default_count.show.write_file x' default_count = 1 :: Int
src/Bamboo/Model/Helper.hs view
@@ -7,8 +7,6 @@ import Bamboo.Type.Reader import Data.ByteString (ByteString) --- import Bamboo.Type.Plugin (apply_plugin)- get_body :: String -> IO ByteString get_body id = id.id_to_path .read_bytestring @@ -18,11 +16,6 @@ .take_extension .guess_reader .fromMaybe (static_config.default_reader)---- --- apply_plugin_for_resource id--- | id.id_to_type.belongs_to [static_config.post_id, static_config.static_id] = apply_plugin--- | otherwise = return meta :: String -> String meta = (++ ".meta")
src/Bamboo/Model/Post.hs view
@@ -1,29 +1,26 @@ {-# LANGUAGE NoImplicitPrelude #-} --- what about performance?--- Haskell takes care of that, since IOs are also lazy.--- Posts are not read unless specifically required, i.e. after pagination- module Bamboo.Model.Post where --- env import Bamboo.Helper.StateHelper hiding (uri) import Bamboo.Model.Counter-import Bamboo.Model.Env hiding (match, title, body)+import Bamboo.Model.Env hiding (match) import Bamboo.Type.Reader+import System.Time (CalendarTime)+import Text.XHtml.Strict ((+++), (<<), hotlink, p) import qualified Bamboo.Helper.ByteString as BS import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Char8 as S import qualified MPS as MPS data Post = Post - { uid :: String -- blog/08-09-04 blog title- , title :: String- , body :: S.ByteString- , tags :: [String]- , comment_size :: Int- , reader :: Reader- , count :: Int+ { uid :: String -- blog/08-09-04 blog title+ , title :: String+ , body :: S.ByteString+ , tags :: [String]+ , comment_size :: Int+ , reader :: Reader+ , count :: Int } deriving (Show, Eq) @@ -32,7 +29,7 @@ resource_type = const $ static_config.post_id instance Markable Post where- markup x = render_to_html (x.reader) (x.body)+ markup = (reader &&& body) > splash render_to_html instance Datable Post where date = uid > get_date@@ -81,7 +78,9 @@ get_date id = id.words.first.split "/".last.default_parse_date match :: String -> Post -> Bool-match s x = [title > to_sb, body] .map (send_to x > BS.lower > BS.isInfixOf (s.lower.to_sb)) .or+match s x = [title > to_sb, body]+ .map (send_to x > BS.lower > BS.isInfixOf (s.lower.to_sb))+ .or search :: String -> IO [Post] search "" = return []@@ -92,9 +91,10 @@ full :: Post -> S.ByteString full x | x.body.match_cut.not = x.body-full x = ( xs.takeWhile not_cut ++ xs.dropWhile not_cut .tail ).S.unlines where- not_cut = is_cut > not- xs = x.body.S.lines+full x = ( xs.takeWhile not_cut ++ xs.dropWhile not_cut .tail ).S.unlines+ where+ not_cut = is_cut > not+ xs = x.body.S.lines has_continue :: Post -> Bool has_continue = body > match_cut@@ -102,25 +102,53 @@ latest :: Int -> IO [Post] latest n = cheat_list ^ take n --- extra- id_to_uri :: SC-id_to_uri id = static_config.root / ( pretty_date ++ static_config.url_date_title_seperator ++ formatted_title ++ ext ) where- formatted_title = static_config.url_title_subs.map (\(a,b) -> gsub a b).inject (id.get_title) apply- pretty_date = id.get_date.format_time (static_config.url_date_format)- ext = id.take_known_extension+id_to_uri id = + static_config.root / + [ pretty_date+ , static_config.url_date_title_seperator+ , formatted_title+ , ext+ ]+ .join'+ where+ formatted_title = + static_config+ .url_title_subs+ .map (\(a,b) -> gsub a b)+ .inject (id.get_title) apply+ + pretty_date = id.get_date.format_time (static_config.url_date_format)+ ext = id.take_known_extension uri_to_id :: SC-uri_to_id s = static_config.post_id / (d ++ " " ++ t) where- (raw_d, (_, title_with_sep)) = s.MPS.match (static_config.url_date_matcher).fromJust.fst- raw_t = title_with_sep.drop (static_config.url_date_title_seperator.length)- t = static_config.url_title_subs.map (\(a,b) -> gsub b a) .inject raw_t apply- d = raw_d.parse_date (static_config.url_date_format) .fromJust.format_time (static_config.post_date_format)-+uri_to_id s = static_config.post_id / (d ++ " " ++ t)+ where+ (raw_d, (_, title_with_sep)) = + s.MPS.match (static_config.url_date_matcher).fromJust.fst+ + raw_t = + title_with_sep+ .drop (static_config.url_date_title_seperator.length)+ + t = + static_config+ .url_title_subs+ .map (\(a,b) -> gsub b a)+ .inject raw_t apply+ + d = + raw_d+ .parse_date (static_config.url_date_format)+ .fromJust+ .format_time (static_config.post_date_format) -- summary markup_summary :: Post -> Html markup_summary x = post_summary +++ rest where post_summary = render_to_html (x.reader) (x.summary)- rest = if x.has_continue then toHtml $ p << hotlink (x.uri) << "Read the rest of the post »" else empty_html+ rest = + if x.has_continue+ then toHtml $ p << hotlink (x.uri) << "Read the rest of the post »"+ else empty_html
src/Bamboo/Model/Static.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.Model.Static where --- env-import Bamboo.Env hiding (match, body)-import Bamboo.Type.Reader+import Bamboo.Env hiding (match) import Bamboo.Model.Helper+import Bamboo.Type.Reader import qualified Data.ByteString.Char8 as S + data Static = Static { uid :: String , body :: S.ByteString@@ -15,10 +15,10 @@ deriving (Show, Eq) instance Resource Static where- resource_title x = ("static" / x.uid.get_title) .spaced_url+ resource_title x = (static_config.static_id / x.uid.get_title) .spaced_url instance Markable Static where- markup x = render_to_html (x.reader) (x.body)+ markup = (reader &&& body) > splash render_to_html instance Default Static where def = Static def S.empty def@@ -33,7 +33,7 @@ get id = flat_read id get_title :: SC-get_title = id_to_resource > drop_known_extension > split "/" > last+get_title = id_to_resource > drop_known_extension > split "/" > last title :: Static -> String title = uid > get_title
src/Bamboo/Model/Tag.hs view
@@ -3,9 +3,9 @@ import qualified Bamboo.Model.Post as Post --- env+ import Bamboo.Helper.StateHelper-import Bamboo.Model.Env hiding (name)+import Bamboo.Model.Env import qualified Bamboo.Model.Post as Post import qualified Bamboo.Model.Post as Post import qualified Bamboo.Type as C@@ -25,10 +25,12 @@ -- CRUD instance Gettable Tag where- get id = get_resources_set id ^ Tag id (get_name id)+ get id = get_resources_set id ^ Tag id (get_name id) instance Listable Tag where- list = ls (static_config.tag_uri) ^ map (static_config.tag_id /) >>= mapM get+ list = ls (static_config.tag_uri) + ^ map (static_config.tag_id /)+ >>= mapM get get_name :: SC get_name id = id.split "/" .tail.join'@@ -37,13 +39,18 @@ get_resources id = id.id_to_path.read_bytestring get_resources_set :: String -> IO (Set.Set S.ByteString)-get_resources_set id = id.get_resources ^ S.lines ^ map (bs_slash $ static_config.post_id.pack ) ^ to_set+get_resources_set id = + id+ .get_resources+ ^ S.lines+ ^ map (bs_slash $ static_config.post_id.pack )+ ^ to_set bs_slash :: S.ByteString -> S.ByteString -> S.ByteString bs_slash x y = S.concat [x, "/".pack, y.S.dropWhile (is '/')] resource_title_from_name :: SC-resource_title_from_name x = ("tag" / x) .spaced_url+resource_title_from_name x = (static_config.tag_id / x) .spaced_url tag_map' :: [Tag] -> Map.Map String (Set.Set S.ByteString) tag_map' xs = xs . map (name &&& resources) . to_h@@ -55,9 +62,8 @@ for_resource xs x = xs.select (resources > has (x.to_sb)) .map name fill_tag :: [Tag] -> Post.Post -> Post.Post-fill_tag xs x = x { Post.tags = for_resource xs (x.Post.uid) }+fill_tag xs x = x { Post.tags = for_resource xs (x.Post.uid) } --- extra sorted :: [Tag] -> [Tag] sorted xs = xs@@ -66,5 +72,3 @@ name_to_id :: SC name_to_id x = static_config.tag_id / x---- etag_tag_list xs = xs.mapM (uid > etag_data) ^ sort ^ S.intercalate (pack ",")
src/Bamboo/Type.hs view
@@ -1,14 +1,15 @@ module Bamboo.Type ( module Bamboo.Type.Config- , module Bamboo.Type.Pager , module Bamboo.Type.Class - , module Bamboo.Type.Extension , module Bamboo.Type.Common+ , module Bamboo.Type.Extension+ , module Bamboo.Type.Pager ) where -import Bamboo.Type.Config import Bamboo.Type.Class+import Bamboo.Type.Common+import Bamboo.Type.Config import Bamboo.Type.Extension import Bamboo.Type.Pager hiding (per_page)-import Bamboo.Type.Common+
src/Bamboo/Type/Common.hs view
@@ -1,4 +1,4 @@ module Bamboo.Type.Common where type Assoc = [(String, String)]-type SC = String -> String+type SC = String -> String
src/Bamboo/Type/Config.hs view
@@ -2,11 +2,11 @@ module Bamboo.Type.Config where import Bamboo.Helper.PreludeEnv-import Bamboo.Type.Reader-import Bamboo.Type.Extension-import Bamboo.Type.Theme (Theme) import Bamboo.Type.Common+import Bamboo.Type.Extension+import Bamboo.Type.Reader import Bamboo.Type.StaticWidget (StaticWidget)+import Bamboo.Type.Theme (ThemeConfig) import Data.Default data ConfigData = @@ -37,6 +37,8 @@ | NumberOfLatestPosts | UseCache | BambooUrl+ | Js+ | Css deriving (Show) @@ -60,7 +62,7 @@ , extensions :: [Extension] -- theme - , theme :: Theme+ , theme_config :: ThemeConfig -- custom , post_date_format :: String@@ -127,7 +129,7 @@ , favicon = def , analytics_account_id = def , extensions = [Comment, Search, Analytics]- , theme = def+ , theme_config = def , post_date_format = "%y-%m-%d" , comment_date_format = "%y-%m-%d %T" , url_date_format = "%y-%m-%d"
src/Bamboo/Type/Pager.hs view
@@ -6,13 +6,13 @@ data Pager = Pager {- total :: Int,- current :: Int,- has_next :: Bool,- has_previous :: Bool,- next :: Int,- previous :: Int,- per_page :: Int+ total :: Int,+ current :: Int,+ has_next :: Bool,+ has_previous :: Bool,+ next :: Int,+ previous :: Int,+ per_page :: Int } deriving (Eq, Show)
src/Bamboo/Type/Reader.hs view
@@ -2,16 +2,16 @@ module Bamboo.Type.Reader where +import Bamboo.Helper.ByteString import Bamboo.Helper.PreludeEnv-import qualified Data.Map as Map+import Data.Default import Text.Pandoc- import Text.XHtml.Strict-import Data.Default import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Char8 as S-import Bamboo.Helper.ByteString+import qualified Data.Map as Map + data Reader = Markdown | RST | HTML | Latex deriving (Show, Eq) instance Default Reader where@@ -36,8 +36,6 @@ to_html :: (ParserState -> a -> Pandoc) -> a -> Html to_html r = r defaultParserState > writeHtml defaultWriterOptions --- this list can go on, as long as there is a library that does--- the convertion. pretty extensible, isn't it. rr :: Reader -> S.ByteString -> Html rr Markdown = to_us > to_html readMarkdown rr RST = to_us > to_html readRST
src/Bamboo/Type/State.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}+ module Bamboo.Type.State where import Bamboo.Helper (static_config)@@ -15,25 +16,23 @@ import qualified Bamboo.Type.Config as C - data State = State -- model state- { uid :: String -- current view resource- , pager :: Pager -- pager-- , status :: Int- , tag_name :: String- , search_key :: String- , tags :: [Tag]- , nav_location :: String- , resource_title :: String- , human_test_data :: HumanTestData- , latest_posts :: [Post]- , posts :: [Post]- , comments :: [Comment]- , static :: Static- , env :: Env- , config :: C.Config+ { uid :: String -- current view resource+ , pager :: Pager -- pager+ , status :: Int+ , tag_name :: String+ , search_key :: String+ , tags :: [Tag]+ , nav_location :: String+ , resource_title :: String+ , human_test_data :: HumanTestData+ , latest_posts :: [Post]+ , posts :: [Post]+ , comments :: [Comment]+ , static :: Static+ , env :: Env+ , config :: C.Config } deriving (Show) @@ -52,7 +51,8 @@ def = Plus instance Default State where- def = State def def def def def def def def def def def def def def static_config+ def = State def def def def def def + def def def def def def def def static_config show_left, show_right, show_op :: State -> String@@ -82,14 +82,20 @@ mk_human_test :: IO HumanTestData mk_human_test = do seed <- (getClockTime >>= toCalendarTime) ^ ctPicosec ^ from_i- let (a,b,c) = randomRs (0,100) (mkStdGen seed) .in_group_of 3 .map make_sample .lb good_test .first+ let (a,b,c) = + randomRs (0,100) (mkStdGen seed)+ .in_group_of 3+ .map make_sample+ .lb good_test+ .first return $ HumanTestData a b c where make_sample [a,b,c] = ((get_num a), (get_num b), (get_op c))- make_sample _ = error "human test sample fail"- good_test = splash3 simple_eval > belongs_to nums- get_num n = nums.at (n `mod` (nums.length))- get_op n = ops.at (n `mod` (ops.length))+ make_sample _ = error "human test sample fail"+ good_test = splash3 simple_eval > belongs_to nums+ get_num n = nums.at (n `mod` (nums.length))+ get_op n = ops.at (n `mod` (ops.length))+
src/Bamboo/Type/StaticWidget.hs view
@@ -1,18 +1,19 @@ {-# LANGUAGE NoImplicitPrelude #-}+ module Bamboo.Type.StaticWidget where import Bamboo.Helper.PreludeEnv import Bamboo.Type.Class import Bamboo.Type.Reader-+import Control.Arrow ((&&&)) import qualified Data.ByteString.Char8 as S data StaticWidget = StaticWidget- { name :: String- , body :: S.ByteString- , reader :: Reader+ { name :: String+ , body :: S.ByteString+ , reader :: Reader } deriving (Show, Eq) instance Markable StaticWidget where- markup x = render_to_html (x.reader) (x.body)+ markup = (reader &&& body) > splash render_to_html
src/Bamboo/Type/Theme.hs view
@@ -4,31 +4,17 @@ import Bamboo.Helper.PreludeEnv import Data.Default ---data Theme = Theme+data ThemeConfig = ThemeConfig { name :: String- , container :: String- , header :: String- , navigation :: String- , main :: String- , sidebar :: String- , footer :: String , css :: [String] , js :: [String] } deriving (Show, Read) -data ThemeData = +data ThemeConfigData = Name- | Container- | Header- | Navigation- | Main- | Sidebar- | Footer | Css | Js deriving (Eq, Show, Read) -instance Default Theme where- def = Theme def def def def def def def def def+instance Default ThemeConfig where+ def = ThemeConfig def def def
+ src/Bamboo/Type/ThemeInterface.hs view
@@ -0,0 +1,18 @@+module Bamboo.Type.ThemeInterface where++import Bamboo.Type.State (State)+import Hack (Response)++data ThemeConfig = ThemeConfig++data Interface = + Index+ | IndexFeed+ | Post+ | Static+ | Tag+ | TagFeed+ | Search+ deriving (Show, Eq)++type Theme = Interface -> State -> IO Response
− src/Bamboo/View/Atom/Comment.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Atom.Comment where--import Bamboo.Helper.StateHelper-import Bamboo.Model.Comment-import Bamboo.Type.State hiding (uid, config)-import Bamboo.View.Env hiding (title, AuthorEmail)---entry :: Comment -> Html-entry x = toHtml - [ gravatar- , cite << a- , toHtml " says:"- , br- , p ! [theclass "small"] << comment_date- , x.markup- ]- where- l = x.author_link- a = if l.null then x.author.toHtml else toHtml $ hotlink formatted_link << x.author- formatted_link = if l.starts_with "http://" then l else "http://" ++ l- gravatar = - thediv ! [theclass "gravatar"] - << image ! [src (gravatar_link x)]- comment_date = toHtml $ x.date.format_time "%b %e, %Y at %I:%M %p"--create :: State -> Comment -> Html-create s x = toHtml- [ h2 ! [id "respond"] << "Leave a Response"- , gui (s.config.root / "comment/create") ! [id "commentform"] <<- [ field Author n22 n1 "Name (required)"- , field AuthorEmail n22 n2 "Email (hidden)"- , field AuthorLink n22 n3 "Website"- , field HumanHack n22 n4 human_test_question- , empty_field- , hidden_field LeftNumber (s.show_left)- , hidden_field RightNumber (s.show_right)- , hidden_field Operator (s.show_op)- , p << hidden (show_data PostId) (x.uid.uid_to_post_id)- , p << textarea ! - [ name (show_data Body)- , id "comment"- , cols "10"- , rows "20"- , strAttr "tabindex" "5"- ] << ""- , p << submit "submit" "Submit Comment" ! [strAttr "tabindex" "6"]- ]- ]- where- human_test_question = - ["What", "is", s.show_left, s.show_op, s.show_right, "?"] .join " "--n22, n1, n2, n3, n4, n10 :: Int-n22 = 22 :: Int-n1 = 1 :: Int-n2 = 2 :: Int-n3 = 3 :: Int-n4 = 4 :: Int-n10 = 10 :: Int- - -field_with_value :: (Show a, Show b, Show c, HTML d) => - String -> a -> b -> c -> d -> Html-field_with_value v x' s t m = p <<- [ label ! [thefor x] << small << m- , br - , textfield x ! [size (s.show), strAttr "tabindex" (t.show), value v]- ]- where x = x'.show_data--field :: (Show a, Show b, Show c, HTML d) => a -> b -> c -> d -> Html-field x s t m = field_with_value "" x s t m--hidden_field :: (Show a) => a -> String -> Html-hidden_field x m = hidden_field_with_value m x m--hidden_field_with_value :: (Show a, HTML b) => String -> a -> b -> Html-hidden_field_with_value v x m = - thespan ! [ thestyle "display: none;" ] << field_with_value v x n22 n10 m--empty_field :: Html-empty_field = hidden_field_with_value "" EmptyField hidden_note- where- hidden_note = "Leave this field empty:"-
− src/Bamboo/View/Atom/Post.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Atom.Post where- -import Bamboo.Helper.StateHelper hiding (uri)-import Bamboo.Model.Post-import Bamboo.View.Env hiding (name, title, style)-import qualified Bamboo.View.Atom.Tag as Tag---data RenderStyle = Summary | Full--entry' :: State -> RenderStyle -> Post -> Html-entry' s style x = div_class "post" << [entry_title, entry_mark, entry_body] - where- entry_title = x.title_link- entry_body = div_class "entry" << show_content style- entry_mark = p ! [theclass "small"] - << [ post_date, post_tags, post_comments ].map (send_to x)-- show_content Summary = x.markup_summary- show_content Full = x.markup--- title_link y = h2 << hotlink (y.uri) << y.title- post_date y = toHtml $ y.date.format_time "%b %e, %Y"-- post_tags y | y.tags.null = empty_html- post_tags y = - " | " - +++ "Published in " - +++ y.tags.map (Tag.tag_link s) .intersperse (", ".toHtml)-- post_comments y | y.comment_size.is 0 = empty_html- post_comments y = - " | " - +++ hotlink ( y.uri / "#comments") - << (y.comment_size.show ++ " Comments")- -entry :: State -> Post -> Html-entry s = render_summary s (s.config.summary_for_root)--render_summary :: State -> Bool -> Post -> Html-render_summary s t = - if t then entry' s Summary else entry' s Full
− src/Bamboo/View/Atom/Tag.hs
@@ -1,8 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Atom.Tag where- -import Bamboo.View.Env hiding (name)--tag_link :: State -> String -> Html-tag_link s x = toHtml $ hotlink (s.config.root / s.config.tag_id / x ) << x-
− src/Bamboo/View/Control/Comment.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Control.Comment where- -import Bamboo.Model.Comment (Comment)-import Bamboo.View.Env hiding (body, date, alt, create)-import qualified Bamboo.View.Atom.Comment as CommentVA--list :: [Comment] -> [Html]-list [] = []-list xs = - [ h2 ! [id "comments"] << "Responses"- , olist ! [theclass "commentlist" ] << xs.zip (cycle ["comments-alt", ""]).map (splash styled_entry)- ]- where- styled_entry alt x = li ! [theclass alt] << x.CommentVA.entry--create :: State -> Comment -> Html-create = CommentVA.create
− src/Bamboo/View/Control/Helper.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Control.Helper where--import Bamboo.View.Env hiding (p)-import Bamboo.View.Helper--nav :: Pager -> String -> [Html]-nav p r = - [ div_class "alignleft" << nav_previous- , div_class "alignright" << nav_next- ]- where- nav_previous = if p.has_previous - then toHtml $ hotlink ( r' ++ "page=" ++ p.previous.show ) << previous_sign- else space_html- where r' = if isSuffixOf "&" r then r else r ++ "?"- - nav_next = if p.has_next- then toHtml $ hotlink ( r' ++ "page=" ++ p.next.show ) << next_sign- else space_html- where r' = if isSuffixOf "&" r then r else r ++ "?"
− src/Bamboo/View/Control/Post.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Control.Post where---- env-import Bamboo.Helper.StateHelper-import Bamboo.Model.Post-import Bamboo.Type.State hiding (uid)-import Bamboo.View.Atom.Post-import Bamboo.View.Control.Helper-import Bamboo.View.Env hiding (p)-import Bamboo.View.Widget.Template-import qualified Bamboo.Model.Comment as Comment-import qualified Bamboo.Type as C-import qualified Bamboo.View.Control.Comment as CommentV----- entry view-view :: Widget-view s = (x.render +++ comment_view ).page s- where- x = s.posts.first- render = entry s- xs = s.comments- comment_view = html_only_for Comment $ - CommentV.list xs - +++ CommentV.create s (x.uid.Comment.from_post_id)---- list view-list :: Widget-list s = s.posts.(map render > (+++ nav p (s.config.root)) > page s)- where - p = s.pager- render = entry s
− src/Bamboo/View/Control/Search.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Control.Search where- -import Bamboo.View.Env-import Bamboo.View.Widget.Template (page)-import Bamboo.Type.State-import Bamboo.View.Atom.Post (entry)-import Bamboo.View.Control.Helper (nav)--view :: Widget-view s = - s- .posts- .map (entry s)- .(+++ nav (s.pager) nav_url)- .page s- where- nav_url = (s.config.root / "search") ++ "?s=" ++ (s.search_key) ++ "&"
− src/Bamboo/View/Control/Static.hs
@@ -1,10 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Bamboo.View.Control.Static where- -import Bamboo.View.Env-import Bamboo.View.Widget.Template (page)-import Bamboo.Type.State (static)--view :: Widget-view s = s.static.markup.page s
− src/Bamboo/View/Control/Tag.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Bamboo.View.Control.Tag where- -import Bamboo.View.Env hiding (p, tag_id)-import Bamboo.Type.State-import qualified Bamboo.Type.State as State-import qualified Bamboo.Type as C-import Bamboo.Type (root, summary_for_tag)---- view-import Bamboo.View.Atom.Post-import Bamboo.View.Control.Helper-import Bamboo.View.Widget.Template--view :: Widget-view s = s.posts.(map render > (+++ nav p ( s.config.root / tag_id)) > page s) - where- p = s.pager- tag_id = s.uid- render = render_summary s (s.config.summary_for_tag)-
− src/Bamboo/View/Env.hs
@@ -1,15 +0,0 @@-module Bamboo.View.Env-(- module Bamboo.Env- , module Bamboo.View.Helper- , module Bamboo.Type.State- , Widget- , Container-) where--import Bamboo.Env hiding (navigation, sidebar, footer)-import Bamboo.View.Helper-import Bamboo.Type.State (config, nav_location, State)--type Widget = State -> Html-type Container = State -> Html -> Html
− src/Bamboo/View/Helper.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction#-}-{-# LANGUAGE NoImplicitPrelude #-}--module Bamboo.View.Helper where---import Bamboo.Env-import Bamboo.Helper.ByteString-import Data.Default-import Hack-import Hack.Contrib.Constants-import Hack.Contrib.Response-import Text.XHtml.Strict hiding (p, meta, body)-import Data.ByteString-import qualified Prelude as P-import qualified Text.XHtml.Strict as Html---id :: String -> HtmlAttr-id = identifier--css_link :: String -> Html-js_link :: String -> Html-js_src :: String -> Html-rss_link :: String -> Html-favicon_link :: String -> Html--css_link l = itag "link" ! [rel "stylesheet", thetype "text/css", href l]-js_link l = itag "script" ! [thetype "text/javascript", src l]-js_src s = tag "script" ! [thetype "text/javascript"] << s-rss_link l = itag "link" ! [rel "alternate", thetype "application/rss+xml", href l, title "RSS 2.0"]-favicon_link l = itag "link" ! [rel "icon", thetype "image/png", href l]--div_id :: String -> Html -> Html -div_id s = thediv ! [id s]--div_class :: String -> Html -> Html-div_class s = thediv ! [theclass s]--div_class_id :: String -> String -> Html -> Html-div_class_id x y = thediv ! [theclass x, id y]--meta_tag :: Html-meta_tag = Html.meta ! [httpequiv "Content-Type", content "text/html; charset=utf-8"]--ie_tag :: (Show a) => a -> Html-ie6_tag :: (Show a) => a -> Html-ie7_tag :: (Show a) => a -> Html--ie_tag x = ("<!--[if IE]>" ++ x.show ++ "<![endif]-->").primHtml-ie6_tag x = ("<!--[if lt IE 7]>" ++ x.show ++ "<![endif]-->").primHtml-ie7_tag x = ("<!--[if IE 7]>" ++ x.show ++ "<![endif]-->").primHtml---xml_header :: String-xml_header = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"--render_html :: Html -> ByteString-render_html = renderHtml > unescape_unicode_xml > to_sb--output_html :: Html -> IO Response-output_html = render_html > output_plain_html--render_rss :: String -> ByteString-render_rss = (xml_header ++) > unescape_unicode_xml > to_sb--output_plain_html :: ByteString -> IO Response-output_plain_html x = - def - .set_status 200- .set_body (x.to_lb)- .set_content_type _TextHtmlUTF8- .return--output_plain_rss :: ByteString -> IO Response-output_plain_rss = output_plain_html- > (^ set_content_type "application/rss+xml")- --html_if :: Bool -> Html -> Html-html_if b x = if b then x else empty_html---- html alias--img :: Html-space_html :: Html--img = image-space_html = primHtml " "---span :: Html -> Html-div :: Html -> Html-d :: Html -> Html-ul :: Html -> Html--span = thespan-div = thediv-d = div-ul = ulist---klass :: String -> HtmlAttr-klass = theclass--c :: String -> Html -> Html-c x = d ! [klass x]-i :: String -> Html -> Html-i x = d ! [id x]--ic :: String -> String -> Html -> Html-ic x y = d ! [id x, klass y]-ci :: String -> String -> Html -> Html-ci x y = ic y x--link :: String -> Html -> HotLink-link = hotlink-
− src/Bamboo/View/Widget/Body.hs
@@ -1,11 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Widget.Body where---- env-import Bamboo.View.Env-import Bamboo.View.Helper--body_content :: Html -> Html-body_content x = div_id "maincontent" <<- div_class "content" << x-
@@ -1,26 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Widget.Footer where- -import Bamboo.View.Env--import qualified Bamboo.Type.Config as C-import qualified Bamboo.Type.Theme as T---footer :: Widget-footer s = div_class_id (s.config.theme.T.footer) "footer" << custom_footer- where- static_footer = toHtml- [ toHtml $ copyright- , toHtml $ "2008 "- , toHtml $ s.config.blog_title- , toHtml $ br- , toHtml $ "Powered by "- , toHtml $ hotlink (s.config.bamboo_url) << "Bamboo"- , toHtml $ " using "- , toHtml $ hotlink "http://www.haskell.org/" << "Haskell"- ]-- custom_footer- | s.config.C.footer.isJust = s.config.C.footer.fromJust.markup- | otherwise = static_footer
− src/Bamboo/View/Widget/Head.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Widget.Head where--import Bamboo.Type.Theme (css, js)-import Bamboo.View.Env-import Bamboo.View.Widget.Helper-import qualified Bamboo.Type as C-import qualified Bamboo.Type.State as S---html_head :: Widget-html_head s = header << (- [ meta_tag, title_tag- , favicon_tag- , rss_tag- ] - ++ s.config.theme.css.map css_link- ++ s.config.theme.js.map js_link- )- - where- title_tag = thetitle << - [s.config.blog_title ++ s.S.resource_title.format_title]-- rss_tag = rss_link $ rss_url_link_pair s .fst- favicon_tag = favicon_link $ s.config.favicon-- format_title [] = ""- format_title x = " / " ++ x
− src/Bamboo/View/Widget/Header.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Widget.Header where- -import Bamboo.View.Env hiding (header)-import Bamboo.View.Widget.SearchBar (search_bar)-import qualified Bamboo.Type.Theme as T--header :: Widget-header s =- div_class_id (s.config.theme.T.header) "header" << - [ search_bar s- , site_name s- ]--site_name :: Widget-site_name s = toHtml $- [ toHtml $ hotlink (s.config.root) ! [theclass "logo"] << ""- , h1 << s.config.blog_title- , div_class "description" << s.config.blog_subtitle- ]
− src/Bamboo/View/Widget/Helper.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Widget.Helper where--import Bamboo.View.Env hiding (link)- -import qualified Bamboo.Type as C-import Bamboo.Type (tag_id, root)-import qualified Bamboo.Type.State as State-import qualified Bamboo.Model.Tag as Tag--rss_url_link_pair :: State.State -> (String, HotLink)-rss_url_link_pair s = - if tagged - then- let tag_name = Tag.get_name uid in- link ( s.config.tag_id / tag_name) tag_name- else link "" home_nav- where- uid = State.uid s- tagged = uid.match "^tag/.+" .isJust- url r = s.config.root / r / "rss.xml"- link r x = (url r, hotlink (url r) ! [ theclass "feedlink" ] << x)
@@ -1,28 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Widget.Navigation where- -import Bamboo.View.Env hiding (header, current, link)-import qualified Bamboo.Type.State as State-import qualified Bamboo.Type.Config as C-import qualified Bamboo.Type.Theme as T--navigation :: Widget-navigation s = - div_class_id (s.config.theme.T.navigation) "nav" <<- div_class "content" <<- ulist << s.config.C.navigation.map nav_item-- where- nav_item x = - li ! [theclass (home_tag ++ "page_item" ++ current)] - << link- where- nav = s.State.nav_location- home_tag = if x == home_nav then "first " else ""- current = if x == nav then " current_page_item" else ""- link = if x == home_nav then home_link else static_link-- home_link = hotlink (s.config.root) << home_nav- static_link = hotlink (s.config.root / "static" / x) - << x.drop_known_extension-
− src/Bamboo/View/Widget/RSS.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE NamedFieldPuns #-}--module Bamboo.View.Widget.RSS where---- env-import Bamboo.View.Env hiding (render_rss, title, link, config)-import Bamboo.Type.State-import Bamboo.Type ( author_email, blog_title, host_name, root, summary_for_rss)-import Text.RSS hiding (RSS)-import qualified Text.RSS as RSS---- model-import Bamboo.Model.Post hiding (title)-import qualified Bamboo.Model.Post as Post ---- RSS-instance Default URI where- def = nullURI--data RSS = RSS- {- title :: RSS.Title- , link :: RSS.Link- , description :: RSS.Description- , channel_elems :: [RSS.ChannelElem]- , items :: [RSS.Item]- }--to_rss :: RSS -> RSS.RSS-to_rss x = RSS.RSS - (x.title) (x.link) (x.description) (x.channel_elems) (x.items)--rss :: State -> String -> String -> String-rss s categary title' = RSS- {- title- , link- , description = title'- , channel_elems = [ RSS.Language "en-us" ]- , items- }- .to_rss.rssToXML.showXML- where- full_uri x = def { uriScheme = "http://", uriPath = host_link x }- host_link x = s.config.host_name ++ (s.config.root / x)- link = full_uri (categary / title)- title = - if title'.empty - then s.config.blog_title- else s.config.blog_title ++ " / " ++ title'- items = s.posts.map item_rss_template- - item_rss_template x = - [ Title $ x.Post.title- , Description $ x.render_rss- , Author $ s.config.author_email- , Link $ full_uri (x.uri)- , PubDate $ x.date- ]- - render_rss x - | s.config.summary_for_rss.is True = x.markup_summary.show- | otherwise = x.markup.show
− src/Bamboo/View/Widget/SearchBar.hs
@@ -1,12 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Widget.SearchBar where- -import Bamboo.View.Env hiding (header)-import Bamboo.Helper.StateHelper (html_only_for)--search_bar :: Widget-search_bar s = html_only_for Search $ - div_id "search" - << form ! [action (s.config.root / "search"), method "get"]- << thediv- << textfield "s"
− src/Bamboo/View/Widget/Sidebar.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Widget.Sidebar where---import Bamboo.View.Env hiding (rss_link)-import Bamboo.View.Widget.Helper-import qualified Bamboo.Type.StaticWidget as Sidebar-import qualified Bamboo.Type.Config as C-import qualified Bamboo.Type.State as State-import qualified Data.Set as Set-import qualified Bamboo.Type.Theme as T----- model-import qualified Bamboo.Model.Tag as Tag---- view--sidebar :: Widget-sidebar s = - div_class_id (s.config.theme.T.sidebar) "sidebar" << unordList formatted_list- where- stock_list = - [ feed- , tag_list $ s.State.tags- ] - custom_list =- s- .config- .C.sidebar- .map (\x -> h2 << x.Sidebar.name +++ x.markup)- - formatted_list = (stock_list ++ custom_list) .intersperse hr-- feed = toHtml- [ h2 << "Subscribe"- , p ! [theclass "feed"] << rss_link s- ]-- rss_link = rss_url_link_pair >>> snd- tag_list tags = toHtml- [ h2 << "Tags"- , unordList $ tags.Tag.sorted.map tag_link]- - tag_link x = - ( hotlink (s.config.root / x.Tag.uid) << x.Tag.name ) - +++ ( " (" ++ x.Tag.resources.Set.size.show ++ ")" )
− src/Bamboo/View/Widget/Template.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction#-}-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Widget.Template (page) where--import Bamboo.View.Widget.Head-import Bamboo.View.Widget.Body-import Bamboo.View.Widget.Header-import Bamboo.View.Widget.Navigation-import Bamboo.View.Widget.Sidebar-import Bamboo.View.Widget.Footer-import qualified Text.XHtml.Strict as Html-import qualified Bamboo.Type.Theme as T--import Bamboo.View.Env hiding (header, body)---- extension-import Bamboo.Helper.StateHelper (html_only_for)-import Web.HCheat--body :: Container-body s x = Html.body << - [ div_class (t.T.container) << - [ header s- , navigation s- , div_id "page" - << [ div_class (t.T.main) << body_content x, sidebar s ]- , footer s - ]- , html_only_for Analytics $ primHtml (analytics $ s.config.analytics_account_id)- ]- where t = s.config.theme--page :: Container-page s x = [html_head s, body s x] .toHtml