bamboo 2009.5.27 → 2009.6.6
raw patch · 68 files changed
+1874/−1413 lines, 68 filesdep +mtldep −tokyocabinet-haskelldep ~base
Dependencies added: mtl
Dependencies removed: tokyocabinet-haskell
Dependency ranges changed: base
Files
- bamboo.cabal +51/−45
- changelog.md +12/−0
- src/Bamboo/Config/Global.hs +0/−156
- src/Bamboo/Controller/Application.hs +13/−194
- src/Bamboo/Controller/Comment.hs +63/−0
- src/Bamboo/Controller/Env.hs +20/−0
- src/Bamboo/Controller/Helper.hs +131/−0
- src/Bamboo/Controller/Index.hs +51/−0
- src/Bamboo/Controller/Post.hs +42/−0
- src/Bamboo/Controller/Search.hs +36/−0
- src/Bamboo/Controller/Static.hs +37/−0
- src/Bamboo/Controller/Tag.hs +77/−0
- src/Bamboo/Controller/Type.hs +13/−0
- src/Bamboo/Env.hs +52/−0
- src/Bamboo/Helper.hs +274/−0
- src/Bamboo/Helper/ByteString.hs +8/−1
- src/Bamboo/Helper/Env.hs +0/−48
- src/Bamboo/Helper/Helper.hs +0/−194
- src/Bamboo/Helper/Html.hs +0/−24
- src/Bamboo/Helper/PreludeEnv.hs +1/−1
- src/Bamboo/Helper/StateHelper.hs +41/−14
- src/Bamboo/Helper/ThumbHelper.hs +0/−31
- src/Bamboo/Helper/Translation.hs +12/−0
- src/Bamboo/Model/Album.hs +0/−67
- src/Bamboo/Model/Comment.hs +28/−18
- src/Bamboo/Model/Counter.hs +22/−13
- src/Bamboo/Model/Env.hs +8/−0
- src/Bamboo/Model/Helper.hs +32/−9
- src/Bamboo/Model/Post.hs +38/−37
- src/Bamboo/Model/Static.hs +6/−7
- src/Bamboo/Model/Tag.hs +31/−16
- src/Bamboo/Model/Video.hs +0/−42
- src/Bamboo/Type.hs +14/−0
- src/Bamboo/Type/Cache.hs +0/−57
- src/Bamboo/Type/Class.hs +46/−0
- src/Bamboo/Type/Common.hs +4/−0
- src/Bamboo/Type/Config.hs +164/−0
- src/Bamboo/Type/Extension.hs +1/−6
- src/Bamboo/Type/Pager.hs +8/−4
- src/Bamboo/Type/Plugin.hs +0/−64
- src/Bamboo/Type/Reader.hs +5/−0
- src/Bamboo/Type/State.hs +43/−20
- src/Bamboo/Type/StaticWidget.hs +3/−6
- src/Bamboo/Type/Theme.hs +4/−17
- src/Bamboo/View/Atom/Album.hs +0/−34
- src/Bamboo/View/Atom/Comment.hs +55/−33
- src/Bamboo/View/Atom/Post.hs +30/−24
- src/Bamboo/View/Atom/Static.hs +0/−8
- src/Bamboo/View/Atom/Tag.hs +3/−7
- src/Bamboo/View/Atom/Video.hs +0/−29
- src/Bamboo/View/Control/Comment.hs +9/−9
- src/Bamboo/View/Control/Helper.hs +14/−17
- src/Bamboo/View/Control/Post.hs +21/−19
- src/Bamboo/View/Control/Search.hs +14/−10
- src/Bamboo/View/Control/Static.hs +5/−4
- src/Bamboo/View/Control/Tag.hs +10/−7
- src/Bamboo/View/Env.hs +15/−0
- src/Bamboo/View/Helper.hs +118/−0
- src/Bamboo/View/Widget/Body.hs +3/−1
- src/Bamboo/View/Widget/Footer.hs +20/−17
- src/Bamboo/View/Widget/Head.hs +22/−10
- src/Bamboo/View/Widget/Header.hs +14/−12
- src/Bamboo/View/Widget/Helper.hs +10/−8
- src/Bamboo/View/Widget/Navigation.hs +20/−11
- src/Bamboo/View/Widget/RSS.hs +50/−25
- src/Bamboo/View/Widget/SearchBar.hs +8/−5
- src/Bamboo/View/Widget/Sidebar.hs +29/−19
- src/Bamboo/View/Widget/Template.hs +13/−13
bamboo.cabal view
@@ -1,5 +1,5 @@ Name: bamboo-Version: 2009.5.27+Version: 2009.6.6 Build-type: Simple Synopsis: A simple blog middleware on hack Description: A simple blog middleware on hack@@ -14,64 +14,70 @@ data-files: readme.md, changelog.md library- ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-type-defaults- build-depends: base, cgi, network, haskell98, old-locale, old-time, time, unix, bytestring, base64-string, zlib, directory, filepath, containers, process,parsedate >= 3000.0.0, rss == 3000.0.1, xhtml, utf8-string >= 0.3.3, pandoc, parsec >= 2, gravatar >= 0.3, data-default >= 0.2, mps >= 2009.5.13, hcheat >= 2009.5.13, hack >= 2009.5.19, hack-contrib >= 2009.5.19, tokyocabinet-haskell >= 0.0.5+ ghc-options: -Wall -fno-warn-orphans + build-depends: + 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+ , xhtml, utf8-string >= 0.3.3, pandoc, parsec >= 2, gravatar >= 0.3+ , data-default >= 0.2+ , mps >= 2009.5.13, hcheat >= 2009.5.13+ , hack >= 2009.5.19, hack-contrib >= 2009.5.19 hs-source-dirs: src/ exposed-modules: Bamboo- other-modules:- Bamboo.Config.Global-+ other-modules: Bamboo.Controller.Application-- Bamboo.Helper.Helper- Bamboo.Helper.StateHelper- Bamboo.Helper.Html- Bamboo.Helper.Env- Bamboo.Helper.PreludeEnv- Bamboo.Helper.ThumbHelper+ 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- - Bamboo.Model.Tag- Bamboo.Model.Post- Bamboo.Model.Helper- Bamboo.Model.Video+ Bamboo.Helper.PreludeEnv+ Bamboo.Helper.StateHelper+ Bamboo.Helper.Translation Bamboo.Model.Comment- Bamboo.Model.Album- Bamboo.Model.Static Bamboo.Model.Counter- - - Bamboo.Type.Theme- Bamboo.Type.Plugin+ Bamboo.Model.Env+ Bamboo.Model.Helper+ Bamboo.Model.Post+ Bamboo.Model.Static+ Bamboo.Model.Tag+ Bamboo.Type+ Bamboo.Type.Class+ Bamboo.Type.Common+ Bamboo.Type.Config+ Bamboo.Type.Extension Bamboo.Type.Pager+ Bamboo.Type.Reader Bamboo.Type.State Bamboo.Type.StaticWidget- Bamboo.Type.Reader- Bamboo.Type.Extension- Bamboo.Type.Cache- - Bamboo.View.Atom.Tag- Bamboo.View.Atom.Post- Bamboo.View.Atom.Video+ Bamboo.Type.Theme Bamboo.View.Atom.Comment- Bamboo.View.Atom.Album- Bamboo.View.Atom.Static- - Bamboo.View.Control.Tag- Bamboo.View.Control.Post- Bamboo.View.Control.Helper+ 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.Widget.Template- Bamboo.View.Widget.Helper+ 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.Sidebar+ Bamboo.View.Widget.Helper Bamboo.View.Widget.Navigation- Bamboo.View.Widget.SearchBar- Bamboo.View.Widget.Head Bamboo.View.Widget.RSS- Bamboo.View.Widget.Body- Bamboo.View.Widget.Footer+ Bamboo.View.Widget.SearchBar+ Bamboo.View.Widget.Sidebar+ Bamboo.View.Widget.Template
changelog.md view
@@ -1,3 +1,15 @@+2009.6.6+--------++### Feature++* new architecture taking advantage of hack+* -Wall -fno-warn-orphans clean++### Fix++* use   instead of + 2009.5.27 ---------
− src/Bamboo/Config/Global.hs
@@ -1,156 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Bamboo.Config.Global where--import Bamboo.Helper.Helper-import Bamboo.Helper.PreludeEnv---import Data.Maybe-import Data.Default--import Bamboo.Type.StaticWidget-import Bamboo.Type.Theme ( to_theme )-import Bamboo.Type.Extension---db_id = "db"-flat_id = "."-post_id = "blog"-config_id = "config"-tag_id = "tag"-comment_id = "comment"-sidebar_id = "sidebar"-theme_id = "theme"-config_file_id = "site.txt"-album_id = "album"-image_id = "images"-public_id = "public"-static_id = "static"-topic_id = "forum/post"-thumb_id = "thumb"-stat_id = "stat"-cache_id = "cache"--db_uri = db_id-flat_uri = db_uri / flat_id-public_uri = db_uri / public_id-image_uri = public_uri / image_id--config_uri = flat_uri / config_id / config_file_id-sidebar_uri = flat_uri / config_id / sidebar_id-footer_uri = flat_uri / config_id-post_uri = flat_uri / post_id-tag_uri = flat_uri / tag_id-comment_uri = flat_uri / comment_id-theme_uri = flat_uri / config_id / theme_id--album_uri = image_uri / album_id-topic_uri = flat_uri / topic_id-stat_uri = flat_uri / stat_id-cache_uri = flat_uri / cache_id--data ConfigData = - BlogTitle- | BlogSubtitle- | HostName- | AuthorEmail- | PerPage- | Navigation- | Root- | Sidebar- | Footer- | Favicon- | AnalyticsAccountId- | Extensions- | Theme- | PostDateFormat- | CommentDateFormat- | UrlDateFormat- | UrlDateMatcher- | UrlTitleSubs- | UrlDateTitleSeperator- | Cut- | SummaryForRoot- | SummaryForTag- | SummaryForRss- | PicturePrefix- | NumberOfLatestPosts- | UseCache- deriving (Show)- --- unsafe, must restart server after changing config file, sorry about that ...--- but these configs are read only, and keep the view pure, so no monad headaches involved.--user_config = parse_config config_uri-for' x d = user_config.lookup (x.show_data) .fromMaybe d-for_int' x d = for' x d .read :: Int-for_list' x d = for' x d .parse_list-for x = for' x (x.show_data)--blog_title = for BlogTitle-blog_subtitle = for BlogSubtitle-host_name = for HostName-author_email = for AuthorEmail--per_page = for_int' PerPage "7"-navigation = for_list' Navigation "About" .(home_nav :)--bamboo_url = "http://www.haskell.org/haskellwiki/Bamboo"--root - | user_root.belongs_to ["/", ""] = "/"- | otherwise = user_root.("/" /).remove_trailing_slash- where user_root = for' Root "/"--default_reader = def--load_widget = read_static_widget default_reader > purify-sidebar = for_list' Sidebar "" .map (sidebar_uri /).select (file_exist > purify )- .map load_widget--footer = for Footer - .(footer_uri / ) - .(\x -> if x.file_exist.purify then Just $ load_widget x else Nothing)- -favicon = for' Favicon "/favicon.ico"---- extensions-analytics_account_id = for AnalyticsAccountId-extensions = for_list' Extensions "search, comment, analytics, counter" .read_data_list :: [Extension]---- theme-default_theme = def-user_theme_name = for Theme-user_theme_uri = (theme_uri / user_theme_name) ++ ".txt"--theme = if user_theme_uri.file_exist.purify- then parse_config user_theme_uri .(("name", user_theme_name) : ) .to_theme- else default_theme- --- custom-as_l s = "[" ++ s ++ "]"-post_date_format = for' PostDateFormat "%y-%m-%d"-comment_date_format = for' CommentDateFormat "%y-%m-%d %T"-url_date_format = for' UrlDateFormat "%y-%m-%d"-url_date_matcher = for' UrlDateMatcher "\\d{2}-\\d{2}-\\d{2}"-url_title_subs = for' UrlTitleSubs "" .as_l .read :: [(String, String)]-url_date_title_seperator = for' UrlDateTitleSeperator " "---- summary-cut = for' Cut "✂-----"-summary_for_root = for SummaryForRoot .parse_boolean-summary_for_tag = for SummaryForTag .parse_boolean-summary_for_rss = for SummaryForRss .parse_boolean---- album-picture_prefix = for' PicturePrefix "\\d+-"---- latest-number_of_latest_posts = for_int' NumberOfLatestPosts "15"---- count-count_meta = "count.meta"---- cache-use_cache = for UseCache .parse_boolean
src/Bamboo/Controller/Application.hs view
@@ -1,209 +1,28 @@--- the controller is the most complex module for a reason:--- models are made as simple and small as possible--- views are pure functions.---- a note on encoding:--- uniform utf-8 enforced by custom io wrapper--{-# LANGUAGE NoMonomorphismRestriction#-}+{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NamedFieldPuns #-} module Bamboo.Controller.Application where -import qualified Data.Map as Map---- env-import Bamboo.Helper.Env hiding (tag, uri)-import Bamboo.Helper.StateHelper hiding (only_for)-import qualified Bamboo.Type.State as S-import qualified Bamboo.Config.Global as G-import qualified Bamboo.Type.Pager as Pager-import Bamboo.Type.Cache-import Bamboo.Type.Extension-import Hack-import Hack.Contrib.Response (redirect)---- model-import qualified Bamboo.Model.Post as Post-import qualified Bamboo.Model.Static as Static-import qualified Bamboo.Model.Tag as Tag-import qualified Bamboo.Model.Comment as Comment-import qualified Bamboo.Model.Counter as Counter---- view-import qualified Bamboo.View.Control.Post as PostV-import qualified Bamboo.View.Control.Static as StaticV-import qualified Bamboo.View.Control.Tag as TagV-import qualified Bamboo.View.Control.Search as SearchV-import qualified Bamboo.View.Widget.RSS as RSSV--import qualified Data.ByteString.Char8 as S+import Bamboo.Controller.Env hiding (tag)+import Bamboo.Controller.Comment+import Bamboo.Controller.Index+import Bamboo.Controller.Post+import Bamboo.Controller.Search+import Bamboo.Controller.Static+import Bamboo.Controller.Tag --- helpers-blog_regex = G.url_date_matcher-init_post tags x = x.Tag.fill_tag tags.Comment.fill_comment_size-tag_list = list---- main controller+paths :: [(String, Application)] paths = [ ("$" ,index ) , ("(\\?.+)?$" ,index ) , ("rss.xml$" ,index_feed )- , (blog_regex ,blog )+ , (blog_regex ,post ) , ("static/." ,static ) , ("tag/.*/rss.xml$" ,tag_feed ) , ("tag/." ,tag ) , ("search" ,only_for Search $ search ) , ("comment/create" ,only_for Comment $ comment_create )- ] - .map_fst ((G.root /) > ("^" ++))--only_for ext x = if has_extension ext then x else const not_found--default_state = do- latest_posts <- Post.latest G.number_of_latest_posts- def { S.latest_posts = latest_posts } .return--index :: Application-index env = do- posts <- list- let p = posts.paginate env- tags <- tag_list- let nav = if p.Pager.current == 1 then home_nav else no_navigation- s <- default_state- let state = s { S.uid = G.post_id, S.tags = tags, S.pager = p, S.nav_location = nav }- - -- output_html "hi"- posts.for_current_page p .mapM (init_post tags) - >>= cache (g tags) (f state)- >>= output_plain_html- where- g tags xs = liftM2 S.append - (Post.etag_post_list xs) (Tag.etag_tag_list tags)- f state = PostV.list state > render_html > return--index_feed _ = do- posts <- list- posts.take G.number_of_latest_posts .cache g f- >>= output_plain_rss- where- g = Post.etag_post_list- f xs = xs.RSSV.rss "" "" .render_rss.to_sb.return--blog env = do- let id = env .uri .Post.uri_to_id- if has_extension Counter then Counter.hit id else return ()- blog <- get id- comments <- list_for id- tags <- tag_list-- test_data <- S.mk_human_test- s <- default_state- let state = s { S.uid = id, S.tags = tags, S.resource_title = blog.resource_title, S.human_test_data = test_data }- blog.init_post tags - >>= cache (g tags) (f state comments)- >>= output_plain_html- where- g tags x = liftM2 S.append - (Post.etag_post x) (Tag.etag_tag_list tags)- f state comments x = x.return ^ PostV.view state comments ^ render_html--static env = do- let id = env.uri- static_page <- get id- tags <- tag_list- let nav_id = static_page.Static.uid.id_to_resource- let nav = if nav_id.belongs_to G.navigation then nav_id else no_navigation- s <- default_state- let state = s { S.uid = id, S.tags = tags, S.nav_location = nav, S.resource_title = static_page.resource_title }- static_page.cache (g tags) (f state) >>= output_plain_html- where- g tags x = liftM2 S.append - (etag_data (x.Static.uid)) (Tag.etag_tag_list tags)- f state x = x.return ^ StaticV.view state ^ render_html---tag env = do- let id = env.uri- tags <- tag_list- let tag_name = Tag.get_name id- case Tag.tag_map' tags .Map.lookup tag_name of- Nothing -> not_found- Just post_set -> do- posts <- post_set.to_list.rsort.mapM (to_us > get) >>= mapM (init_post tags)- let p = posts.paginate env- s <- default_state- let state = s { S.uid = id, S.tags = tags, S.pager = p, S.resource_title = tag_name.Tag.resource_title_from_name }- posts.for_current_page p .return- >>= cache (g tags) (f state)- >>= output_plain_html- where- g tags xs = liftM2 S.append - (Post.etag_post_list xs) (Tag.etag_tag_list tags)- f state xs = xs.TagV.view state.render_html.return- -tag_feed env = do- let id = env .uri .split "/" .init .join "/"- tags <- tag_list- let tag_name = Tag.get_name id- case Tag.tag_map' tags .Map.lookup tag_name of- Nothing -> not_found- Just post_set -> do- posts <- post_set.to_list.rsort.mapM (to_us > get) ^ map (Tag.fill_tag tags)- posts.take (G.number_of_latest_posts). cache g f >>= output_plain_rss- where- g = Post.etag_post_list- f xs = xs.RSSV.rss G.tag_id tag_name.render_rss.to_sb.return- -search env = do- let s = env.param_with_default "s" ""- posts <- Post.search s-- let p = posts.paginate env- tags <- tag_list- let query = env.uri- s' <- default_state- let state = s' { S.uid = query, S.pager = p, S.tags = tags, S.resource_title = query }-- posts.mapM (init_post tags) >>= \x -> x.SearchV.view state s.output_html---comment_create env = do- let post_id = env.input_with_default (show_data Comment.PostId) (G.post_id / "nothing")- exists <- (G.flat_uri / post_id) .file_exist- let valid_path = equalFilePath G.post_id (takeDirectory post_id) - let checked = check_create env- - if [checked, valid_path, exists].and- then- env.inputs.Comment.create_comment- else- return ()- return $ def.redirect ((post_id.Post.id_to_uri.u2b).urlEncode) Nothing--get_input_data s env = env.get_input (s.show_data)--check_human = do- [l, r, op, h] <- [Comment.LeftNumber, Comment.RightNumber, Comment.Operator, Comment.HumanHack].mapM get_input_data ^ map fromJust- return $ S.simple_eval (l.read) (r.read) (op.S.read_op) .is (h.read)---- create helper, should be refactored to some common aspect-check_create env =- [ validate Comment.Author ( length > (`gt` 0))- , validate Comment.AuthorLink ( const True)- , validate Comment.Body ( length > (`gt` 0))- , validate Comment.EmptyField ( empty )- , validate Comment.LeftNumber ( belongs_to (S.nums.map show))- , validate Comment.RightNumber ( belongs_to (S.nums.map show))- , validate Comment.Operator ( belongs_to (S.ops.map S.display_op))- , validate Comment.HumanHack ( belongs_to (S.nums.map show))- , check_human- ] .map (send_to env) .and---validate s f env =- let maybe_s = get_input_data s env in- case maybe_s of- Nothing -> False- Just v -> f v+ ]+ .map_fst ((static_config.root /) > ("^" ++))
+ src/Bamboo/Controller/Comment.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NamedFieldPuns #-}++module Bamboo.Controller.Comment where++import Bamboo.Controller.Env hiding (checked)+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+ key = show_data Comment.PostId+ nothing = post_id / "nothing"+ uid = env.input_with_default key nothing++ exists <- (static_config.flat_uri / uid) .file_exist+ + let valid_path = equalFilePath post_id (takeDirectory uid) + checked = check_create+ + if [checked, valid_path, exists].and+ then env.inputs.Comment.create_comment+ else return ()+ + 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] = + [ Comment.LeftNumber+ , Comment.RightNumber+ , Comment.Operator+ , Comment.HumanHack+ ] .map (get_input_data > fromMaybe "0")+ + check_create =+ [ validate Comment.Author ( length > (`gt` 0))+ , validate Comment.AuthorLink ( const True)+ , validate Comment.Body ( length > (`gt` 0))+ , validate Comment.EmptyField ( empty )+ , validate Comment.LeftNumber ( belongs_to (S.nums.map show))+ , validate Comment.RightNumber ( belongs_to (S.nums.map show))+ , validate Comment.Operator ( belongs_to (S.ops.map S.display_op))+ , validate Comment.HumanHack ( belongs_to (S.nums.map show))+ , check_human+ ]+ .and+++ validate s f =+ let maybe_s = get_input_data s in+ case maybe_s of+ Nothing -> False+ Just v -> f v
+ src/Bamboo/Controller/Env.hs view
@@ -0,0 +1,20 @@+module Bamboo.Controller.Env+(+ module Bamboo.Env+ , module Bamboo.Controller.Helper+ , module Bamboo.View.Helper+ , 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.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
@@ -0,0 +1,131 @@+{-# LANGUAGE NoMonomorphismRestriction#-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NamedFieldPuns #-}++module Bamboo.Controller.Helper where+++import Bamboo.Env hiding (get, p)+import Bamboo.Helper.StateHelper+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.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.Contrib.Request as Request+++data CachedController = CachedController+ {+ etag_controller :: ETagController+ , controller :: Controller+ }++init_state :: Controller+init_state = fill_latest_posts >> fill_tags++params, inputs :: Env -> Assoc+params = Request.params > map_fst b2u > map_snd b2u+inputs = Request.inputs > map_fst b2u > map_snd b2u++param_with_default, input_with_default :: String -> String -> Env -> String+param_with_default s d env = env .get_param s .fromMaybe d+input_with_default s d env = env .get_input s .fromMaybe d++get_param, get_input :: String -> Env -> Maybe String+get_param s env = env .params .lookup s+get_input s env = env .inputs .lookup s++just_param, just_input :: String -> Env -> String+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++blog_regex :: String+blog_regex = static_config.url_date_matcher+++fill_latest_posts :: Part ()+fill_latest_posts = do+ s <- get+ latest_posts <- Post.latest ( s.config.number_of_latest_posts ) .io+ put s { latest_posts }++fill_tags :: Part ()+fill_tags = do+ s <- get+ tags <- list .io+ put s { tags }++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+ has_previous = current `gt` n1+ next = current + n1+ previous = current + (- n1)+ n1 = 1 :: Int+ + return def + {+ Pager.per_page = per_page'+ , current + , has_next + , has_previous + , next + , previous+ , total + }++paged :: [a] -> Part ([a], Pager)+paged xs = do+ pager <- paginate xs+ return (xs.for_current_page pager, pager)+ +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)+++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++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+ -}++not_found :: Controller+not_found = get >>= \s -> put s {S.status = 404}++not_found_response :: IO Response+not_found_response = return $ def { Hack.status = 404 }
+ src/Bamboo/Controller/Index.hs view
@@ -0,0 +1,51 @@+-- the controller is the most complex module for a reason:+-- models are made as simple and small as possible+-- views are pure functions.++-- a note on encoding:+-- uniform utf-8 enforced by custom io wrapper++{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# 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+ init_state+ + (posts, pager) <- list.io >>= (mapM init_post_meta_data) >>= paged+ + let nav_location = if pager.current == 1 then home_nav else no_navigation+ + s <- get+ put s + { uid = s.config.post_id+ , pager+ , 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+ 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
@@ -0,0 +1,42 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NamedFieldPuns #-}++module Bamboo.Controller.Post where++import Bamboo.Controller.Env+import qualified Bamboo.Model.Counter as Counter+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+ init_state+ + env <- get ^ env+ let uid = env .uri .Post.uri_to_id+ + post_model <- T.get uid .io >>= init_post_meta_data+ + let posts = [post_model]+ comments <- list_for uid .io+ + if has_extension Counter then Counter.hit uid .io else return ()+ + s <- get+ human_test_data <- S.mk_human_test .io+ put s+ { uid+ , S.resource_title = post_model.resource_title+ , human_test_data+ , 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
@@ -0,0 +1,36 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NamedFieldPuns #-}++module Bamboo.Controller.Search where++import Bamboo.Controller.Env hiding (query)+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+ init_state+ s <- get+ + let key = s.env.param_with_default "s" ""+ query = s.env.uri+ + (posts, pager) <- Post.search key .io + >>= (mapM init_post_meta_data)+ >>= paged+ + put s + { uid = query+ , pager+ , posts+ , 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
@@ -0,0 +1,37 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NamedFieldPuns #-}++module Bamboo.Controller.Static where++import Bamboo.Controller.Env+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+ init_state+ s <- get+ let uid = s.env.uri+ static_model <- T.get uid .io++ let nav_id = static_model.Static.uid.id_to_resource+ nav_location = + if nav_id.belongs_to (s.config.T.navigation)+ then nav_id+ else no_navigation+ + put s + { uid+ , S.resource_title = static_model.resource_title+ , nav_location+ , 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
@@ -0,0 +1,77 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NamedFieldPuns #-}++module Bamboo.Controller.Tag where++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 Data.Map as Map++tag_controller :: Controller+tag_controller = 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, pager) <- posts'.paged+ put s+ { uid+ , pager+ , posts+ , 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+ init_state+ s <- get+ + let uid = s.env.uri.split "/" .init .join "/"+ 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+ .take (s.config.number_of_latest_posts)+ .mapM (to_us > T.get >io)+ ^ map (Tag.fill_tag (s.tags))+ + put s+ { uid+ , 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
@@ -0,0 +1,13 @@+module Bamboo.Controller.Type where+++import Bamboo.Type.State (State)+import Control.Monad.State (StateT)+import Hack (Response)+ + +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
+ src/Bamboo/Env.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- this sets some scoping for every module, which prevents importing+-- common modules in every file++module Bamboo.Env (+ module Bamboo.Helper+ , module Bamboo.Helper.ByteString+ , module Bamboo.Helper.PreludeEnv+ , module Bamboo.Helper.Translation+ , module Bamboo.Type+ , module Control.Arrow + , module Control.Monad + , module Data.ByteString.Char8 + , module Data.Default+ , 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.Translation+import Bamboo.Type+import Control.Arrow ((>>>), (&&&), (***))+import Control.Monad (liftM2, liftM3, liftM4, liftM5) +import Data.ByteString.Char8 (pack, unpack)+import Data.Default+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)
+ src/Bamboo/Helper.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE NoMonomorphismRestriction#-}+{-# LANGUAGE NoImplicitPrelude #-}++module Bamboo.Helper where++import Bamboo.Helper.ByteString+import Bamboo.Helper.PreludeEnv hiding (at)+import Bamboo.Helper.Translation+import Bamboo.Type+import Bamboo.Type.Reader+import Bamboo.Type.StaticWidget hiding (name, body, reader)+import Control.Monad (liftM2)+import Data.Default+import Data.Maybe+import System.Directory+import System.FilePath.Posix hiding ((<.>))+import System.IO as IO+import Text.XHtml.Strict hiding (p, meta, body, select, name)+import qualified Bamboo.Type.Theme as Theme+import qualified Prelude as P+import qualified Text.XHtml.Strict as Html++gt :: (Ord a) => a -> a -> Bool+gt = (P.>)++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++parse_config :: String -> IO Assoc+parse_config x = do+ s <- read_file x+ s+ .filter_comment+ .lines.map strip+ .map (split "\\s*=\\s*")+ .map fill_snd_blank+ .map tuple2+ .return+ where+ fill_snd_blank [y] = [y,""]+ fill_snd_blank xs = xs+++write_config :: FilePath -> Assoc -> IO ()+write_config s xs = + xs.map(\(x, y) -> x ++ " = " ++ y) .join "\n" .write_file s++-- html+empty_html :: Html+empty_html = toHtml ""++-- generic+show_data :: (Show a) => a -> [Char]+show_data = show > snake_case++ifM :: (Monad m) => m Bool -> m b -> m b -> m b+ifM p t f = p >>= (\p' -> if p' then t else f)++parse_boolean :: String -> Bool+parse_boolean = belongs_to ["true", "1", "y", "yes", "yeah"]++mkdir :: String -> IO ()+mkdir = u2b > createDirectory++-- type SC = String -> String+type SIO = String -> IO ()++take_directory :: SC+take_directory = u2b > takeDirectory > b2u++with_file :: String -> IOMode -> (Handle -> IO a) -> IO a+with_file s m f = IO.withFile (s.u2b) m f++id_to_type :: SC+id_to_type x = x.split "/" .first++id_to_resource :: SC+id_to_resource x = x.split "/" .tail.join "/"++read_data :: (Read a) => String -> a+read_data s = s.camel_case.read++read_data_list :: (Read a) => [String] -> [a]+read_data_list xs = xs.map read_data++take_extension :: SC+take_extension = takeExtension -- > split "\\." > last++take_known_extension :: SC+take_known_extension s+ | ext.belongs_to exts = ext+ | otherwise = ""+ where + ext = s.take_extension+ exts = readers.only_snd.join'++drop_known_extension :: SC+drop_known_extension s+ | s.take_extension.belongs_to exts = dropExtension s+ | otherwise = s+ where exts = readers.only_snd.join'++remove_trailing_slash :: SC+remove_trailing_slash s = if s.last.is '/' then s.init else s++-- config+parse_list :: String -> [String]+parse_list s = s.split "," .map strip .reject null++static_config :: Config+static_config = purify $ do+ return def+ >>= set_blog_title ( for_s BlogTitle )+ >>= set_blog_subtitle ( for_s BlogSubtitle )+ >>= set_host_name ( for_s HostName )+ >>= set_author_email ( for_s AuthorEmail )+ >>= set_per_page ( for_i PerPage )+ >>= 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_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_post_date_format ( for_s PostDateFormat )+ >>= set_comment_date_format ( for_s CommentDateFormat )+ >>= set_url_date_format ( for_s UrlDateFormat )+ >>= set_url_date_matcher ( for_s UrlDateMatcher )+ >>= set_url_title_subs ( for_s UrlTitleSubs ^^ (as_l > read) )+ >>= set_url_date_title_seperator ( for_s UrlDateTitleSeperator )+ >>= set_cut ( for_s Cut )+ >>= set_summary_for_root ( for_b SummaryForRoot )+ >>= set_summary_for_tag ( for_b SummaryForTag )+ >>= set_summary_for_rss ( for_b SummaryForRss )+ >>= set_picture_prefix ( for_s PicturePrefix )+ >>= set_number_of_latest_posts ( for_i NumberOfLatestPosts )+ >>= set_use_cache ( for_b UseCache )+ where+ user_config = parse_config $ def.config_uri+ + for x = user_config ^ lookup (x.show_data)+ + for_s = for+ for_i = for > (^^ read)+ for_l = for > (^^ parse_list)+ for_b = for > (^^ parse_boolean)+ + clean_path user_root+ | user_root.belongs_to ["/", ""] = "/"+ | otherwise = user_root.("/" /).remove_trailing_slash+ + load_sidebar xs = xs+ .map (def.sidebar_uri /)+ .select (file_exist > purify )+ .map load_widget+ + 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)+ + as_l s = "[" ++ s ++ "]"++ get_theme Nothing = return Nothing+ get_theme (Just user_theme_name) =+ let user_theme_uri = (def.theme_uri / user_theme_name) ++ ".txt"+ in+ + if user_theme_uri.file_exist.purify+ then+ parse_config user_theme_uri + ^ (("name", user_theme_name) : )+ ^ to_theme+ ^ Just+ else return Nothing++ -- helper+ c (Just _) _ y = y+ c Nothing x _ = x++ p = fromJust+ r = return+ + set_analytics_account_id v' x = v' >>= \v -> r $ c v x $ x { analytics_account_id = p v}+ set_author_email v' x = v' >>= \v -> r $ c v x $ x { author_email = p v}+ set_bamboo_url v' x = v' >>= \v -> r $ c v x $ x { bamboo_url = p v}+ set_blog_subtitle v' x = v' >>= \v -> r $ c v x $ x { blog_subtitle = p v}+ set_blog_title v' x = v' >>= \v -> r $ c v x $ x { blog_title = p v}+ set_comment_date_format v' x = v' >>= \v -> r $ c v x $ x { comment_date_format = p v}+ set_cut v' x = v' >>= \v -> r $ c v x $ x { cut = p v}+ set_extensions v' x = v' >>= \v -> r $ c v x $ x { extensions = p v}+ set_favicon v' x = v' >>= \v -> r $ c v x $ x { favicon = p v}+ set_footer v' x = v' >>= \v -> r $ c v x $ x { footer = p v}+ set_host_name v' x = v' >>= \v -> r $ c v x $ x { host_name = p v}+ set_navigation v' x = v' >>= \v -> r $ c v x $ x { navigation = p v}+ set_number_of_latest_posts v' x = v' >>= \v -> r $ c v x $ x { number_of_latest_posts = p v}+ set_per_page v' x = v' >>= \v -> r $ c v x $ x { per_page = p v}+ set_picture_prefix v' x = v' >>= \v -> r $ c v x $ x { picture_prefix = p v}+ set_post_date_format v' x = v' >>= \v -> r $ c v x $ x { post_date_format = p v}+ set_root v' x = v' >>= \v -> r $ c v x $ x { root = p v}+ set_sidebar v' x = v' >>= \v -> r $ c v x $ x { sidebar = p v}+ 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_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}+ set_url_title_subs v' x = v' >>= \v -> r $ c v x $ x { url_title_subs = p v}+ set_use_cache v' x = v' >>= \v -> r $ c v x $ x { use_cache = p v}++db_uri :: Config -> String+flat_uri :: Config -> String+public_uri :: Config -> String+image_uri :: Config -> String+config_uri :: Config -> String+sidebar_uri :: Config -> String+footer_uri :: Config -> String+post_uri :: Config -> String+tag_uri :: Config -> String+comment_uri :: Config -> String+theme_uri :: Config -> String+album_uri :: Config -> String+topic_uri :: Config -> String+stat_uri :: Config -> String+cache_uri :: Config -> String++db_uri x = x.db_id+flat_uri x = x.db_uri / x.flat_id+public_uri x = x.db_uri / x.public_id+image_uri x = x.public_uri / x.image_id+config_uri x = x.flat_uri / x.config_id / x.config_file_id+sidebar_uri x = x.flat_uri / x.config_id / x.sidebar_id+footer_uri x = x.flat_uri / x.config_id+post_uri x = x.flat_uri / x.post_id+tag_uri x = x.flat_uri / x.tag_id+comment_uri x = x.flat_uri / x.comment_id+theme_uri x = x.flat_uri / x.config_id / x.theme_id+album_uri x = x.image_uri / x.album_id+topic_uri x = x.flat_uri / x.topic_id+stat_uri x = x.flat_uri / x.stat_id+cache_uri x = x.flat_uri / x.cache_id+++-- 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+ reader = s.take_extension.guess_reader.fromMaybe user_reader+ name = s.takeFileName.drop_known_extension+++-- Theme+to_theme :: Assoc -> Theme.Theme+to_theme xs = Theme.Theme+ { 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")
src/Bamboo/Helper/ByteString.hs view
@@ -17,6 +17,7 @@ import qualified Data.ByteString.Lazy.UTF8 as LU import qualified Prelude as P+import Data.Default class SB a where to_sb :: a -> SB.ByteString@@ -45,7 +46,7 @@ class US a where to_us :: a -> String -instance US String where+instance US String where to_us = P.id instance US LB.ByteString where@@ -54,8 +55,14 @@ instance US SB.ByteString where to_us = SU.toString +lower :: S.ByteString -> S.ByteString lower = S.map toLower +isInfixOf :: S.ByteString -> S.ByteString -> Bool isInfixOf = S.isInfixOf +read_bytestring :: String -> IO S.ByteString read_bytestring = u2b > S.readFile++instance Default S.ByteString where+ def = S.empty
− src/Bamboo/Helper/Env.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}---- this sets some scoping for every module, which prevents importing--- common modules in every file--module Bamboo.Helper.Env (- module Bamboo.Helper.PreludeEnv- , module Control.Monad - , module Control.Arrow - , module Data.List - , module Network.URI - , module Network.CGI - , module System.Locale - , module System.Time.Parse- , module Bamboo.Helper.Helper- , module Data.Maybe- , module System.FilePath- , module System.IO.UTF8- , module Text.XHtml.Strict- , module System.Time- , module System.Directory- , module Data.Foldable- , module Data.Default- , module Hack.Contrib.Utils- , module Data.ByteString.Char8 - , module Bamboo.Helper.ByteString-) where--import Bamboo.Helper.PreludeEnv hiding (FilePath)-import Control.Monad (liftM2, liftM3, liftM4, liftM5) -import Control.Arrow ((>>>), (&&&), (***))-import Data.List (isSuffixOf, isInfixOf, isPrefixOf, sortBy, intersperse) -import Network.URI-import Network.CGI hiding (Html, redirect)-import System.Locale-import System.Time.Parse-import Bamboo.Helper.Helper-import Data.Maybe (fromMaybe, fromJust, isJust, isNothing)-import System.FilePath hiding ((<.>))-import System.IO.UTF8 (readFile, writeFile)-import Text.XHtml.Strict hiding (select, sub, meta)-import System.Time-import System.Directory-import Data.Foldable (find)-import Data.Default-import Hack.Contrib.Utils (httpdate)-import Data.ByteString.Char8 (pack, unpack)-import Bamboo.Helper.ByteString hiding (lower, isInfixOf)
− src/Bamboo/Helper/Helper.hs
@@ -1,194 +0,0 @@--- helper module is a central place for reusable functions--- for this project, more general helpers are usually moved--- to MPS package, for multi-project usage--{-# LANGUAGE NoMonomorphismRestriction#-}-{-# LANGUAGE NoImplicitPrelude #-}--module Bamboo.Helper.Helper where--import Bamboo.Helper.PreludeEnv-import Network.CGI (urlDecode)--import Text.XHtml.Strict hiding (p, meta, body)-import qualified Text.XHtml.Strict as Html-import Data.Maybe-import qualified Bamboo.Type.Pager as Pager-import Data.List hiding (length)-import qualified Data.List as L -import Bamboo.Type.Reader-import System.FilePath.Posix hiding ((<.>))-import System.Time-import qualified Prelude as P-import Data.Default-import System.Directory-import System.IO as IO-import Hack-import qualified Hack.Contrib.Request as Request-import Hack.Contrib.Response-import Hack.Contrib.Constants-import Hack.Contrib.Utils-import qualified Data.ByteString.Char8 as S-import Bamboo.Helper.ByteString--gt = (P.>)---- global-parse_config_io s = read_file s ^ (\x -> x.filter_comment.lines.map strip .map (split "\\s*=\\s*") .map fill_snd_blank .map tuple2)- where fill_snd_blank [x] = [x,""]- fill_snd_blank xs = xs--parse_config = parse_config_io > purify-write_config_io s xs = xs.map(\(x, y) -> x ++ " = " ++ y) .join "\n" .write_file s---- model-take_extension = takeExtension -- > split "\\." > last-take_known_extension s- | ext.belongs_to exts = ext- | otherwise = ""- where - ext = s.take_extension- exts = readers.only_snd.join'--drop_known_extension s- | s.take_extension.belongs_to exts = dropExtension s- | otherwise = s- where exts = readers.only_snd.join'--meta = (++ ".meta")--image_extensions = ["jpg", "jpeg", "png", "gif"]-is_image x = image_extensions.any (suffix_of x)-suffix_of = flip isSuffixOf---- controller-raw_uri env = ( env.script_name ++ env.path_info ) .(urlDecode > tail > remove_trailing_slash )--remove_trailing_slash s = if s.last.is '/' then s.init else s--params = Request.params > map_fst b2u > map_snd b2u-inputs = Request.inputs > map_fst b2u > map_snd b2u--param_with_default s d env = env .get_param s .fromMaybe d-input_with_default s d env = env .get_input s .fromMaybe d--get_param s env = env .params .lookup s-get_input s env = env .inputs .lookup s--just_param s env = env .get_param s .fromJust-just_input s env = env .get_input s .fromJust--full_paginate per_page total env = Pager.Pager per_page current has_next has_previous next previous where- current = env.param_with_default "page" "1" .read- has_next = current * per_page < total.from_i- has_previous = current `gt` 1- next = current + 1- previous = current + (-1)---for_current_page p xs = xs.drop ((p.Pager.current - 1) * p.Pager.length) .take (p.Pager.length)--no_navigation = ""-home_nav = "Home"---- view-id = identifier--css_link l = itag "link" ! [rel "stylesheet", thetype "text/css", href l]-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-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]-meta_tag = Html.meta ! [httpequiv "Content-Type", content "text/html; charset=utf-8"]--div_id s = thediv ! [id s]-div_class s = thediv ! [theclass s]-div_class_id x y = thediv ! [theclass x, id y]--xml_header = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"-render_html = renderHtml > unescape_unicode_xml > to_sb-output_html = render_html > output_plain_html-render_rss = (xml_header ++) > unescape_unicode_xml > to_sb--output_plain_html x = - def - .set_status 200- .set_body (x.to_lb)- .set_content_type _TextHtmlUTF8- .return--output_plain_rss = output_plain_html- > (^ set_content_type "application/rss+xml")- - -spaced_url = gsub "/" " / "--empty_html = toHtml ""-html_if p x = if p then x else empty_html---- config-parse_list s = s.split "," .map strip .reject null-not_found = return $ def { status = 404 }----- generic-show_data = show > snake_case-ifM p t f = p >>= (\p' -> if p' then t else f)-parse_boolean = belongs_to ["true", "1", "y", "yes", "yeah"]-mkdir = u2b > createDirectory-take_directory = u2b > takeDirectory > b2u-with_file s m f = IO.withFile (s.u2b) m f---- class-class DataRenderer a where- render_data :: a -> Html---- id: /type/resoruce-id_to_type x = x.split "/" .first-id_to_resource x = x.split "/" .tail.join "/"- -class (Show a) => Resource a where- resource_title :: a -> String- resource_type :: a -> String- resource_type = show_data--class Markable a where- markup :: a -> Html- -class Datable a where- date :: a -> CalendarTime--class Addressable a where- uri :: a -> String---- class Pluggable a where--- render_plugin :: a -> String--class Gettable a where- get :: String -> IO a--type Assoc = [(String, String)]- -class Mappable a where- from_assoc :: Assoc -> IO a--class Creatable a where- create :: a -> IO ()--class Listable a where- list :: IO [a]- list = return []- - list_for :: String -> IO [a]- list_for = const list- cheat_list :: IO [a]- cheat_list = list--class FlatRead a where- flat_read :: String -> IO a--instance Default S.ByteString where- def = S.empty
− src/Bamboo/Helper/Html.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction#-}-{-# LANGUAGE NoImplicitPrelude #-}--module Bamboo.Helper.Html where--import Text.XHtml.Strict--span = thespan--div = thediv-id = identifier-klass = theclass--d = div-c x = d ! [klass x]-i x = d ! [id x]--ic x y = d ! [id x, klass y]-ci x y = ic y x--ul = ulist--link = hotlink-img = image
src/Bamboo/Helper/PreludeEnv.hs view
@@ -5,5 +5,5 @@ , 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,41 +5,63 @@ module Bamboo.Helper.StateHelper where -import Bamboo.Helper.Env hiding (path)-import qualified Bamboo.Config.Global as G+import Bamboo.Env hiding (path, cut)+import qualified Bamboo.Type.Config as C import qualified Data.ByteString.Char8 as S+import Data.ByteString (ByteString)+import Hack.Contrib.Utils+import Hack+import System.Time --- G.root = /blog+-- static_config.root = /blog -- raw_uri = blog/x -- full_uri = /blog/x -- uri = full_uri - (/blog/)++remove_root :: String -> String remove_root s- | G.root.is "/" = s- | otherwise = s.slice (G.root.length) (s.length)+ | static_config.root.is "/" = s+ | 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 )++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 -format_time = formatCalendarTime defaultTimeLocale-default_date = parse_date "%Y-%m-%d %T" "2000-1-1 00:00:00".fromJust-parse_post_date = parse_date G.post_date_format+format_time :: String -> CalendarTime -> String+format_time = formatCalendarTime defaultTimeLocale++default_date :: CalendarTime+default_date = parse_date "%Y-%m-%d %T" "2000-1-1 00:00:00".fromJust++parse_post_date :: String -> Maybe CalendarTime+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 -has_extension x = G.extensions.has x-only_for ext x = if has_extension ext then x else toHtml ""+has_extension :: Extension -> Bool+has_extension x = static_config.extensions.has x --- controller-paginate env xs = full_paginate (G.per_page) (xs.length) env+html_only_for :: Extension -> Html -> Html+html_only_for ext x = if has_extension ext then x else toHtml "" -cut = G.cut.to_sb+-- controller+cut :: ByteString+cut = static_config.C.cut.to_sb+match_cut :: ByteString -> Bool match_cut = S.lines > any (S.isPrefixOf cut)+is_cut :: ByteString -> Bool is_cut = S.isPrefixOf cut -- not used for efficiency@@ -48,11 +70,16 @@ -- model-path id = G.flat_uri / id+path :: String -> String+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/ThumbHelper.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.Helper.ThumbHelper where---- env-import Bamboo.Helper.Env hiding (match, body, quote)-import qualified Bamboo.Config.Global as G-import System.Cmd--convert_if_missing_thumb w x = do- thumb_exists <- dir_exist (thumb_path)- if thumb_exists- then return ()- else mkdir thumb_path >> convert w x - - where- thumb_path = x / G.thumb_id--convert w x = do- images <- ls x ^ filter is_image- images.map (convert_cmd w x).sequence >>= print- return ()--quote x = "\"" ++ x ++ "\""--system_utf8 = u2b > system--convert_cmd w p x = do- system_utf8 $ ["convert -resize", w.show, i, o].join " ".trace'- where- i = quote $ p / x - o = quote $ p / G.thumb_id / x
+ src/Bamboo/Helper/Translation.hs view
@@ -0,0 +1,12 @@+module Bamboo.Helper.Translation where++home_nav :: String+next_sign :: String+no_navigation :: String+previous_sign :: String+++home_nav = "Home"+next_sign = "Next Entries »"+no_navigation = ""+previous_sign = "« Previous Entries"
− src/Bamboo/Model/Album.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Bamboo.Model.Album where---- env-import Bamboo.Helper.Env hiding (title, body, size, path, meta, get)-import qualified Bamboo.Config.Global as G-import Bamboo.Helper.ThumbHelper-import List (sort)--data AlbumType = Galleria | Fade | SlideViewer | Popeye deriving (Eq, Show, Read)--instance Default AlbumType where- def = Fade--data Album = Album- { uid :: String -- album/08-06-10- , prefix :: String- , show_description :: Bool- , album_type :: AlbumType- , width :: Int- , pictures :: [String]- }- deriving (Show, Eq)--instance Resource Album where- resource_title = uid > spaced_url- --- CRUD-ls_l x = ls x ^ map (x /)-image_path id = G.image_uri / id--get pre desc t w id = do- id.image_path.convert_if_missing_thumb w- get_pictures id ^ Album id pre desc t w- -get_pictures = image_path > ls > (^ filter is_image) > (^ sort)--get_picture_title pre x - | pre.empty = x- | otherwise = x.split pre.last.dropExtension--for_post pre id = get pre def def def (G.album_id / id.id_to_resource)--picture_links x = x.pictures .map ("/" / G.image_id / x.uid /)-picture_thumbs x = x.pictures .map ("/" / G.image_id / x.uid / G.thumb_id /)-picture_titles x = x.pictures .map (get_picture_title (x.prefix))--data_list x = zip3 (x.picture_links) (x.picture_titles) (x.picture_thumbs)--data AlbumData = - Prefix- | Name- | Pictures- | ShowDescription- | Type- | Width- deriving (Show)--from_list xs = get prefix show_description t w (G.album_id / at Name) where- at x = xs.lookup (x.show_data).fromJust- at' x d = xs.lookup (x .show_data) .fromMaybe d- prefix = at' Prefix G.picture_prefix- show_description = at' ShowDescription "y" .parse_boolean- t = at' Type "fade" .camel_case .read- w = at' Width "400" .read-
src/Bamboo/Model/Comment.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NamedFieldPuns #-} module Bamboo.Model.Comment where -- env-import Bamboo.Helper.Env hiding (title, body, size, path)-import qualified Bamboo.Config.Global as G+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@@ -57,19 +58,19 @@ instance Gettable Comment where get id = do x <- flat_read id- meta <- id.path.meta.parse_config_io- let at s = meta.lookup (s.show_data) .fromJust+ meta_data <- id.path.meta.parse_config+ let at s = meta_data.lookup (s.show_data) .fromJust let author = at Author let author_email = at AuthorEmail let author_link = at AuthorLink- x { author = author, author_email = author_email, author_link = author_link } .return+ x { author, author_email , author_link } .return instance Listable Comment where list_for resource_id = do ifM (dir_exist d) (idsM >>= mapM (get :: String -> IO Comment)) (return []) where- idsM = ls d ^ reject (isSuffixOf ".meta") ^ rsort ^ map (G.comment_id / r /)- d = (G.comment_uri / r)+ idsM = ls d ^ reject (isSuffixOf ".meta") ^ rsort ^ map (static_config.comment_id / r /)+ d = (static_config.comment_uri / r) r = resource_id.id_to_resource instance Creatable Comment where@@ -78,15 +79,15 @@ instance Mappable Comment where from_assoc h = do let at s = h.lookup (s.show_data) .fromJust- let post_id = at PostId+ let post_id' = at PostId - timestamp <- ( getClockTime >>= toCalendarTime ) ^ format_time G.comment_date_format- let comment_path = post_id_to_uid post_id + timestamp <- ( getClockTime >>= toCalendarTime ) ^ format_time (static_config.comment_date_format)+ let comment_path = post_id_to_uid post_id' mkdir_p comment_path let uid = comment_path / timestamp def - { uid = uid+ { uid , body = at Body .to_sb , author = at Author , author_email = at AuthorEmail@@ -94,9 +95,10 @@ } .return +write_to :: Comment -> IO () write_to x = do S.writeFile (x.uid.u2b) (x.body)- write_config_io (x.uid.meta) meta_data+ write_config (x.uid.meta) meta_data where meta_data = [ (Author, x.author)@@ -104,17 +106,25 @@ , (AuthorEmail, x.author_email) ] .map_fst show_data +create_comment :: Assoc -> IO () create_comment x = x.from_assoc >>= (create :: Comment -> IO ()) -- extra+from_post_id :: String -> Comment from_post_id x = def { uid = post_id_to_uid x } -post_id_to_uid x = G.flat_uri / G.comment_id / x.split "/" .last-uid_to_post_id x = G.post_id / x.split "/" .last+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+uid_to_post_id x = static_config.post_id / x.split "/" .last +fill_comment_size :: Post.Post -> IO Post.Post fill_comment_size x = do- size <- x.Post.uid.(list_for :: String -> IO [Comment] ) ^ length - return $ x { Post.comment_size = size }+ n <- x.Post.uid.(list_for :: String -> IO [Comment] ) ^ length + return $ x { Post.comment_size = n } -gravatar_default_size = size 40-gravatar_link x = gravatarWith (x.author_email) def gravatar_default_size def+gravatar_link :: Comment -> String+gravatar_link x = gravatarWith (x.author_email) def gravatar_default_size def+ where+ gravatar_default_size = size 40+
src/Bamboo/Model/Counter.hs view
@@ -3,32 +3,41 @@ module Bamboo.Model.Counter where -- env-import Bamboo.Helper.Env -import qualified Bamboo.Config.Global as G+import Bamboo.Model.Env import qualified System.IO as IO -hit x = create_stat_if_none x >> x.inc_stat+hit :: String -> IO ()+hit x = create_stat_if_none x >> inc_stat+ where+ inc_stat = do+ let i = x.count_path+ c <- i.safe_read_line+ let count = c.read :: Int+ count.(+1).show.write_file i -count_name = (/ G.count_meta)-count_path = (G.stat_uri / ) > count_name+count_name :: String -> String+count_name = (/ static_config.count_meta) -default_count = 1-create_stat x = mkdir_p (x.take_directory) >> default_count.show.write_file x+count_path :: String -> String+count_path = (static_config.stat_uri / ) > count_name +safe_read_line :: String -> IO String+safe_read_line x = with_file x IO.ReadMode IO.hGetLine ++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+ + where+ create_stat x' = mkdir_p (x'.take_directory) >> default_count.show.write_file x'+ default_count = 1 :: Int -safe_read_line x = with_file x IO.ReadMode IO.hGetLine -inc_stat x = do- let i = x.count_path- c <- i.safe_read_line- c.read.(+1).show.write_file i-+read_stat :: String -> IO Int read_stat x = do create_stat_if_none x safe_read_line (x.count_path) ^ read
+ src/Bamboo/Model/Env.hs view
@@ -0,0 +1,8 @@+module Bamboo.Model.Env+(+ module Bamboo.Env+ , module Bamboo.Model.Helper+) where++import Bamboo.Env+import Bamboo.Model.Helper
src/Bamboo/Model/Helper.hs view
@@ -2,17 +2,40 @@ module Bamboo.Model.Helper where -import Bamboo.Helper.Env+import Bamboo.Env import Bamboo.Helper.StateHelper-import qualified Bamboo.Config.Global as G import Bamboo.Type.Reader-import Bamboo.Type.Plugin (apply_plugin)+import Data.ByteString (ByteString) -get_body id = id.id_to_path .read_bytestring >>= - apply_plugin_for_resource id-get_reader id = id.take_extension.guess_reader.fromMaybe G.default_reader+-- import Bamboo.Type.Plugin (apply_plugin) -apply_plugin_for_resource id- | id.id_to_type.belongs_to [G.post_id, G.static_id] = apply_plugin- | otherwise = return+get_body :: String -> IO ByteString+get_body id = id.id_to_path .read_bytestring++get_reader :: String -> Reader+get_reader id = + id+ .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")++image_extensions :: [String]+image_extensions = ["jpg", "jpeg", "png", "gif"]++is_image :: String -> Bool+is_image x = image_extensions.any (`isSuffixOf` x)++spaced_url :: String -> String+spaced_url = gsub "/" " / "+++
src/Bamboo/Model/Post.hs view
@@ -7,20 +7,14 @@ module Bamboo.Model.Post where -- env-import Bamboo.Helper.Env hiding (match, title, body, date)-import qualified MPS as MPS-import qualified Bamboo.Config.Global as G-import Bamboo.Type.Reader import Bamboo.Helper.StateHelper hiding (uri)-import Bamboo.Helper.Helper (date)-import Bamboo.Model.Helper-import Bamboo.Type.Extension import Bamboo.Model.Counter-import qualified Bamboo.Type.Cache as Cache+import Bamboo.Model.Env hiding (match, title, body)+import Bamboo.Type.Reader+import qualified Bamboo.Helper.ByteString as BS import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Char8 as S-import qualified Bamboo.Helper.ByteString as BS-import Data.List (sort)+import qualified MPS as MPS data Post = Post { uid :: String -- blog/08-09-04 blog title@@ -35,10 +29,10 @@ instance Resource Post where resource_title = title- resource_type = const G.post_id+ resource_type = const $ static_config.post_id instance Markable Post where- markup x = render_to_html (x.reader) (x.full)+ markup x = render_to_html (x.reader) (x.body) instance Datable Post where date = uid > get_date@@ -51,7 +45,7 @@ instance FlatRead Post where flat_read x = do- t <- x.Cache.cache etag_data get_body+ t <- get_body x def {body = t, uid = x} .return -- CRUD@@ -60,7 +54,7 @@ x <- flat_read id x { title = get_title id- , reader = get_reader id+ , reader = def } .fill_stat @@ -68,58 +62,65 @@ list = list_ids >>= mapM get cheat_list = fast_list -etag_post x' = do- x <- x'.fill_stat- let id = x.uid- let path = id.id_to_path- mtime <- path.file_mtime ^ httpdate- size <- path.file_size ^ show- return $ [id, mtime, size, x.comment_size.show, x.count.show] .join "," .pack+list_ids :: IO [String]+list_ids = ls (static_config.post_uri) ^ rsort ^ map (static_config.post_id /) -etag_post_list xs = xs.mapM etag_post ^ sort ^ S.intercalate (pack ",")- -list_ids = ls G.post_uri ^ rsort ^ map (G.post_id /)+fast_list :: IO [Post] fast_list = list_ids ^ map (\x -> def {uid = x, title = x.get_title}) +fill_stat :: Post -> IO Post fill_stat x | has_extension Counter = do c <- x.uid.read_stat x {count = c} .return fill_stat x = return x +get_title :: SC get_title id = id.words.tail.unwords.drop_known_extension++get_date :: String -> CalendarTime 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++search :: String -> IO [Post] search "" = return [] search s = list ^ filter (match s) +summary :: Post -> S.ByteString summary x = x.body.S.lines.takeWhile (is_cut > not) .S.unlines++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 +has_continue :: Post -> Bool has_continue = body > match_cut +latest :: Int -> IO [Post] latest n = cheat_list ^ take n -- extra-id_to_uri id = G.root / ( pretty_date ++ G.url_date_title_seperator ++ formatted_title ++ ext ) where- formatted_title = G.url_title_subs.map (\(a,b) -> gsub a b).inject (id.get_title) apply- pretty_date = id.get_date.format_time G.url_date_format++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 -uri_to_id s = G.post_id / (d ++ " " ++ t) where- (raw_d, (_, title_with_sep)) = s.MPS.match G.url_date_matcher.fromJust.fst- raw_t = title_with_sep.drop (G.url_date_title_seperator.length)- t = G.url_title_subs.map (\(a,b) -> gsub b a) .inject raw_t apply- d = raw_d.parse_date G.url_date_format .fromJust.format_time G.post_date_format+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) -- summary-markup_summary x = post_summary x +++ next where- post_summary = (reader &&& summary) > splash render_to_html- next = if x.has_continue then toHtml $ p << hotlink (x.uri) << "Read the rest of the post »" else empty_html+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 --
src/Bamboo/Model/Static.hs view
@@ -2,12 +2,10 @@ module Bamboo.Model.Static where -- env-import Bamboo.Helper.Env hiding (match, body)+import Bamboo.Env hiding (match, body) import Bamboo.Type.Reader import Bamboo.Model.Helper import qualified Data.ByteString.Char8 as S-import Bamboo.Type.Cache-import Bamboo.Helper.StateHelper data Static = Static { uid :: String@@ -28,13 +26,14 @@ -- CRUD instance FlatRead Static where flat_read x = do- t <- x.cache etag_data get_body+ t <- get_body x def {body = t, uid = x} .return instance Gettable Static where- get id = do- x <- flat_read id- x { reader = get_reader id } .return+ get id = flat_read id +get_title :: SC get_title = id_to_resource > drop_known_extension > split "/" > last++title :: Static -> String title = uid > get_title
src/Bamboo/Model/Tag.hs view
@@ -4,19 +4,19 @@ import qualified Bamboo.Model.Post as Post -- env-import Bamboo.Helper.Env hiding (name) import Bamboo.Helper.StateHelper-import qualified Data.Set as S-import qualified Bamboo.Config.Global as G-import Bamboo.Type.Cache-import Data.List (sort)+import Bamboo.Model.Env hiding (name)+import qualified Bamboo.Model.Post as Post+import qualified Bamboo.Model.Post as Post+import qualified Bamboo.Type as C import qualified Data.ByteString.Char8 as S-+import qualified Data.Map as Map+import qualified Data.Set as Set data Tag = Tag { uid :: String -- tag/name , name :: String- , resources :: S.Set S.ByteString+ , resources :: Set.Set S.ByteString } deriving (Show, Eq) @@ -28,28 +28,43 @@ get id = get_resources_set id ^ Tag id (get_name id) instance Listable Tag where- list = ls G.tag_uri ^ map (G.tag_id /) >>= mapM get+ list = ls (static_config.tag_uri) ^ map (static_config.tag_id /) >>= mapM get -etag_tag_list xs = xs.mapM (uid > etag_data) ^ sort ^ S.intercalate (pack ",")+get_name :: SC+get_name id = id.split "/" .tail.join' -get_name id = id.split "/" .tail.join'+get_resources :: String -> IO S.ByteString get_resources id = id.id_to_path.read_bytestring -get_resources_set id = id.cache etag_data get_resources ^ S.lines ^ map (bs_slash $ G.post_id.pack ) ^ to_set+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 +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-tag_map' xs = xs . map (name &&& resources) . to_h-tag_map = list ^ tag_map' +tag_map' :: [Tag] -> Map.Map String (Set.Set S.ByteString)+tag_map' xs = xs . map (name &&& resources) . to_h++tag_map :: IO (Map.Map String (Set.Set S.ByteString))+tag_map = list ^ tag_map'++for_resource :: [Tag] -> String -> [String] 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) } -- extra+sorted :: [Tag] -> [Tag] sorted xs = xs- .sortBy(compare_by (\x -> (x.resources.S.size, x.name)))+ .sortBy(compare_by (\x -> (x.resources.Set.size, x.name))) .reverse- -name_to_id x = G.tag_id / x++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/Model/Video.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Bamboo.Model.Video where---- env-import Bamboo.Helper.Env hiding (title, body, size, path, meta, get, width, height)--data VideoType = MediaPlayer deriving (Eq, Show, Read)--instance Default VideoType where- def = MediaPlayer --data Video = Video- { uid :: String -- album/08-06-10- , preview :: String- , width :: Int- , height :: Int- , video_type :: VideoType- }- deriving (Show, Eq)--instance Resource Video where- resource_title = uid > spaced_url- -data VideoData = - Link- | Preview- | Width- | Height- | Type- deriving (Show)--from_list xs = Video - { uid = at Link- , preview = at' Preview ""- , width = at' Width "400" .read- , height = at' Height "300" .read- , video_type = at' Type "media_player" .camel_case.read- } .return - where- at x = xs.lookup (x.show_data).fromJust- at' x d = xs.lookup (x .show_data) .fromMaybe d
+ src/Bamboo/Type.hs view
@@ -0,0 +1,14 @@+module Bamboo.Type (+ module Bamboo.Type.Config+ , module Bamboo.Type.Pager+ , module Bamboo.Type.Class + , module Bamboo.Type.Extension+ , module Bamboo.Type.Common+)+where++import Bamboo.Type.Config+import Bamboo.Type.Class+import Bamboo.Type.Extension+import Bamboo.Type.Pager hiding (per_page)+import Bamboo.Type.Common
− src/Bamboo/Type/Cache.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.Type.Cache (cache, cache'') where--import Bamboo.Helper.Env hiding (body, name, get)-import qualified Bamboo.Config.Global as G--import qualified Data.ByteString.Char8 as C-import qualified Database.TokyoCabinet as TC-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Char8 as S- -cache_file = G.cache_uri--set k v = TC.runTCM $ putsample cache_file [(k, v)]-get k = do- v <- TC.runTCM $ getsample cache_file k- return $ v--cache g f x =- if G.use_cache - then cache' g f x- else f x--cache'' _ f x = f x---- etag generator -> value function -> model -> value-cache' :: (a -> IO S.ByteString) -> (a -> IO S.ByteString) -> a -> (IO S.ByteString)-cache' g f x = do- k <- g x- c <- get k- case c of - Nothing -> do- v <- f x- set k v- return v- Just v -> do- -- putStrLn $ "Cached: " ++ (v.take 20.u2b)- return v---putsample :: String -> [(ByteString, ByteString)] -> TC.TCM Bool-putsample file kv =- do tc <- TC.new :: TC.TCM TC.HDB -- alternatively you can use BDB or FDB- TC.open tc file [TC.OWRITER, TC.OCREAT]- mapM (uncurry $ TC.put tc) kv- TC.close tc--getsample :: String -> ByteString -> TC.TCM (Maybe ByteString)-getsample file key =- do tc <- TC.new :: TC.TCM TC.HDB -- alternatively you can use BDB or FDB- TC.open tc file [TC.OREADER]- val <- TC.get tc key- TC.close tc- return val--
+ src/Bamboo/Type/Class.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Bamboo.Type.Class where++import Bamboo.Helper.PreludeEnv+import Bamboo.Type.Common+import System.Time+import Text.XHtml.Strict++class (Show a) => Resource a where+ resource_title :: a -> String+ resource_type :: a -> String+ resource_type = show > snake_case+ +class Markable a where+ markup :: a -> Html++class Datable a where+ date :: a -> CalendarTime++class Addressable a where+ uri :: a -> String++-- class Pluggable a where+-- render_plugin :: a -> String++class Gettable a where+ get :: String -> IO a++class Mappable a where+ from_assoc :: Assoc -> IO a++class Creatable a where+ create :: a -> IO ()++class Listable a where+ list :: IO [a]+ list = return []++ list_for :: String -> IO [a]+ list_for = const list+ cheat_list :: IO [a]+ cheat_list = list++class FlatRead a where+ flat_read :: String -> IO a
+ src/Bamboo/Type/Common.hs view
@@ -0,0 +1,4 @@+module Bamboo.Type.Common where+ +type Assoc = [(String, String)]+type SC = String -> String
+ src/Bamboo/Type/Config.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE NoImplicitPrelude #-}+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.StaticWidget (StaticWidget)+import Data.Default++data ConfigData = + BlogTitle+ | BlogSubtitle+ | HostName+ | AuthorEmail+ | PerPage+ | Navigation+ | Root+ | Sidebar+ | Footer+ | Favicon+ | AnalyticsAccountId+ | Extensions+ | Theme+ | PostDateFormat+ | CommentDateFormat+ | UrlDateFormat+ | UrlDateMatcher+ | UrlTitleSubs+ | UrlDateTitleSeperator+ | Cut+ | SummaryForRoot+ | SummaryForTag+ | SummaryForRss+ | PicturePrefix+ | NumberOfLatestPosts+ | UseCache+ | BambooUrl+ deriving (Show)+++data Config = Config+ {+ blog_title :: String+ , blog_subtitle :: String+ , host_name :: String+ , author_email :: String+ , per_page :: Int+ , navigation :: [String]+ , bamboo_url :: String+ , root :: String+ , default_reader :: Reader+ , sidebar :: [StaticWidget]+ , footer :: Maybe StaticWidget+ , favicon :: String++ -- extensions+ , analytics_account_id :: String+ , extensions :: [Extension]+ + -- theme + , theme :: Theme+ + -- custom + , post_date_format :: String+ , comment_date_format :: String+ , url_date_format :: String+ , url_date_matcher :: String+ , url_title_subs :: Assoc+ , url_date_title_seperator :: String++ -- summary+ , cut :: String+ , summary_for_root :: Bool+ , summary_for_tag :: Bool+ , summary_for_rss :: Bool++ -- album+ , picture_prefix :: String++ -- latest+ , number_of_latest_posts :: Int++ -- count+ , count_meta :: String++ -- cache+ , use_cache :: Bool+ + + -- dir structure+ , db_id :: String+ , flat_id :: String+ , post_id :: String+ , config_id :: String+ , tag_id :: String+ , comment_id :: String+ , sidebar_id :: String+ , theme_id :: String+ , config_file_id :: String+ , album_id :: String+ , image_id :: String+ , public_id :: String+ , static_id :: String+ , topic_id :: String+ , thumb_id :: String+ , stat_id :: String+ , cache_id :: String+ }+ deriving (Show)++instance Default Config where+ def = Config+ {+ blog_title = def+ , blog_subtitle = def+ , host_name = def+ , author_email = def+ , per_page = 7+ , navigation = def+ , bamboo_url = bamboo_url_current+ , root = "/"+ , default_reader = def+ , sidebar = def+ , footer = def+ , favicon = def+ , analytics_account_id = def+ , extensions = [Comment, Search, Analytics]+ , theme = def+ , post_date_format = "%y-%m-%d"+ , comment_date_format = "%y-%m-%d %T"+ , url_date_format = "%y-%m-%d"+ , url_date_matcher = "\\d{2}-\\d{2}-\\d{2}"+ , url_title_subs = def+ , url_date_title_seperator = " "+ , cut = "✂-----"+ , summary_for_root = True+ , summary_for_tag = True+ , summary_for_rss = False+ , picture_prefix = "\\d+-"+ , number_of_latest_posts = 15+ , count_meta = "count.meta"+ , use_cache = True+ , db_id = "db"+ , flat_id = "."+ , post_id = "blog"+ , config_id = "config"+ , tag_id = "tag"+ , comment_id = "comment"+ , sidebar_id = "sidebar"+ , theme_id = "theme"+ , config_file_id = "site.txt"+ , album_id = "album"+ , image_id = "images"+ , public_id = "public"+ , static_id = "static"+ , topic_id = "forum/post"+ , thumb_id = "thumb"+ , stat_id = "stat"+ , cache_id = "cache"+ }+ where+ bamboo_url_current = "http://github.com/nfjinjing/bamboo/tree/master"
src/Bamboo/Type/Extension.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.Type.Extension where -import Bamboo.Helper.Env hiding (body)+import Bamboo.Helper.PreludeEnv data Extension = Comment@@ -9,8 +9,3 @@ | Analytics | Counter deriving (Show, Read, Eq)---read_data s = s.camel_case.read-read_data_list xs = xs.map read_data-
src/Bamboo/Type/Pager.hs view
@@ -1,19 +1,23 @@+{-# LANGUAGE NoImplicitPrelude #-} module Bamboo.Type.Pager where +import Bamboo.Helper.PreludeEnv import Data.Default + data Pager = Pager {- length :: Int,+ total :: Int, current :: Int, has_next :: Bool, has_previous :: Bool, next :: Int,- previous :: Int+ previous :: Int,+ per_page :: Int } deriving (Eq, Show) instance Default Bool where def = False- + instance Default Pager where- def = Pager def def def def def def+ def = Pager def def def def def def def
− src/Bamboo/Type/Plugin.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.Type.Plugin where--import Bamboo.Helper.Env hiding (body, name)-import qualified Bamboo.Model.Album as Album-import qualified Bamboo.Model.Video as V-import qualified Bamboo.View.Atom.Album as AlbumV ()-import qualified Bamboo.View.Atom.Video as VV ()-import qualified Bamboo.Helper.ByteString as BS-import qualified Data.ByteString.Char8 as S--data PluginType = PhotoAlbum | Video | None deriving (Show, Eq)--data Plugin = Plugin - { plugin_type :: PluginType- , args :: [(String, String)]- }- deriving (Show, Eq)---- album-plugin--- plugin is simple inline substitution, since markdown handles html natively--- [[--- plugin: album,--- name: first-album,--- prefix: \d{2}-\d{2}-\d{2}--- ]]--plugin_expression = "\n\\[\\[((.|\n)*?)\\]\\]"-plugin_id = "plugin"--infix_of = flip BS.isInfixOf--optimized_match x- | pack "[[" .infix_of x = x.to_us.match plugin_expression- | otherwise = Nothing------ OK.. unless I get drunk again, I won't be able to understand how this works....--parse_plugin x = x.gsub "\n" "".split "," .map (split ":") .inner_map strip .map tuple2.parse_it where- parse_it xs = Plugin { plugin_type = xs.at plugin_id, args = xs.reject (fst > (is plugin_id)) }- at x xs = case (xs.lookup x) >>= parse_plugin_type of- Nothing -> None- Just x -> x- plugin_types = [PhotoAlbum, Video]- parse_plugin_type x = plugin_types.label_by (show_data).lookup (x)--match_result x = x.fromJust.snd.first.snd.b2u--apply_plugin :: S.ByteString -> IO S.ByteString-apply_plugin x = if r.isNothing then return x else sub_it where- r = x.optimized_match- plugin = r.match_result.parse_plugin- sub_it = case plugin.plugin_type of- None -> return x- PhotoAlbum -> do - album <- plugin.args.Album.from_list ^ render_plugin- x.to_us.sub plugin_expression album .to_sb.apply_plugin- Video -> do - video <- plugin.args.V.from_list ^ render_plugin- x.to_us.sub plugin_expression video .to_sb.apply_plugin--render_plugin x = "\n" ++ x.render_data.show
src/Bamboo/Type/Reader.hs view
@@ -17,6 +17,7 @@ instance Default Reader where def = Markdown +readers :: [(Reader, [String])] readers = [ (Markdown, ["markdown", "md"]) , (RST, ["rst"] )@@ -25,11 +26,14 @@ ] .map_snd (map ("." ++)) +reader_map :: Map.Map String Reader reader_map = readers.map gen_lookup.join'.to_h where gen_lookup (r, xs) = xs.labeling (const r) +guess_reader :: String -> Maybe Reader guess_reader ext = reader_map.Map.lookup ext +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@@ -40,4 +44,5 @@ rr HTML = to_us > primHtml rr Latex = to_us > to_html readLaTeX +render_to_html :: Reader -> S.ByteString -> Html render_to_html = rr
src/Bamboo/Type/State.hs view
@@ -1,40 +1,42 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.Type.State where -import qualified Bamboo.Type.Pager as Pager+import Bamboo.Helper (static_config)+import Bamboo.Helper.PreludeEnv+import Bamboo.Model.Post+import Bamboo.Model.Comment import Bamboo.Model.Tag+import Bamboo.Model.Static+import Bamboo.Type+import Data.Default+import Hack (Env) import Random (randomRs, mkStdGen) import System.Time+import qualified Bamboo.Type.Config as C -import Bamboo.Helper.PreludeEnv-import Data.Default-import Bamboo.Model.Post + data State = State -- model state { uid :: String -- current view resource- , pager :: Pager.Pager -- pager+ , pager :: Pager -- pager - -- theme state+ , 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) -show_left = human_test_data > left > show-show_right = human_test_data > right > show-show_op = human_test_data > op > display_op--read_op "+" = Plus-read_op "-" = Minus-read_op x = error ("can not read operator: " ++ x)--display_op Plus = "+"-display_op Minus = "-"- data HumanTestData = HumanTestData { left :: Int , right :: Int@@ -50,15 +52,34 @@ def = Plus instance Default State where- def = State def def def def def def def+ def = State def def def def def def def def def def def def def def static_config -ops = [Plus, Minus]+show_left, show_right, show_op :: State -> String+show_left = human_test_data > left > show+show_right = human_test_data > right > show+show_op = human_test_data > op > display_op++display_op :: Op -> String+display_op Plus = "+"+display_op Minus = "-"++read_op :: String -> Op+read_op "+" = Plus+read_op "-" = Minus+read_op x = error ("can not read operator: " ++ x)++nums :: [Int] nums = [0, 5, 10, 15, 20]++ops :: [Op]+ops = [Plus, Minus]++simple_eval :: Int -> Int -> Op -> Int simple_eval a b Plus = a + b simple_eval a b Minus = a - b -+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@@ -70,3 +91,5 @@ 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,8 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.Type.StaticWidget where -import Bamboo.Helper.Env hiding (body)+import Bamboo.Helper.PreludeEnv+import Bamboo.Type.Class import Bamboo.Type.Reader+ import qualified Data.ByteString.Char8 as S data StaticWidget = StaticWidget@@ -14,8 +16,3 @@ instance Markable StaticWidget where markup x = render_to_html (x.reader) (x.body)--read_static_widget default_reader s = liftM2 (StaticWidget name) body (return reader) where- body = s.read_bytestring- reader = s.take_extension.guess_reader.fromMaybe default_reader- name = s.takeFileName.drop_known_extension
src/Bamboo/Type/Theme.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.Type.Theme where -import Bamboo.Helper.Env hiding (name, header)+import Bamboo.Helper.PreludeEnv+import Data.Default ++ data Theme = Theme { name :: String , container :: String@@ -26,22 +29,6 @@ | Css | Js deriving (Eq, Show, Read)--to_theme xs = Theme- { name = at Name- , container = at Container- , header = at Header- , navigation = at Navigation- , main = at Main- , sidebar = at Sidebar- , footer = at Footer- , css = at Css .css_list- , js = at Js .js_list- }- where- at s = xs.lookup (s.show_data) .fromJust- css_list s = s.parse_list.map (\x -> "/theme/" ++ at Name ++ "/css/" ++ x ++ ".css")- js_list s = s.parse_list.map (\x -> "/theme/" ++ at Name ++ "/js/" ++ x ++ ".js") instance Default Theme where def = Theme def def def def def def def def def
− src/Bamboo/View/Atom/Album.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Atom.Album where- -import Bamboo.Helper.Env hiding (name, id)-import Bamboo.Model.Album-import Bamboo.Helper.Html--instance DataRenderer Album where- render_data = show_album---show_album x = case x.album_type of- Fade -> show_fade x- Galleria -> show_galleria x- SlideViewer -> show_slide_viewer x- Popeye -> show_popeye x--show_popeye x = c "popeye" << ul << x.data_list.map picture_li where - picture_li (l, t, i) = li << - link l << img ! [src i, alt t]--show_slide_viewer x = ul ! [id "slide-viewer", klass "svw"] << x.data_list.map picture_li where - picture_li (_, t, i) = li << - img ! [src i, alt t]--show_galleria x = ul ! [klass "gallery"] << x.data_list.map picture_li where - picture_li (_, t, i) = li << - img ! [src i, alt t]--show_fade x = ul ! [klass "fade-album"] << x.data_list.map picture_li where - picture_li (l, t, i) = li << - [ toHtml $ link l << img ! [src i, alt t]- , if x.show_description then p << t else empty_html- ]
src/Bamboo/View/Atom/Comment.hs view
@@ -1,55 +1,68 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Atom.Comment where -import Bamboo.Helper.Env hiding (title)-import qualified Bamboo.Config.Global as G import Bamboo.Helper.StateHelper-import Bamboo.Type.State hiding (uid)---- model import Bamboo.Model.Comment+import Bamboo.Type.State hiding (uid, config)+import Bamboo.View.Env hiding (title, AuthorEmail) --- render-instance DataRenderer Comment where- render_data = entry- ++entry :: Comment -> Html entry x = toHtml [ gravatar , cite << a , toHtml " says:" , br- , p ! [theclass "small"] << comment_date x+ , 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 x = toHtml $ x.date.format_time "%b %e, %Y at %I:%M %p"----- form-human_test_question state = ["What", "is", state.show_left, state.show_op, state.show_right, "?"] .join " "+ 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 x = toHtml+create :: State -> Comment -> Html+create s x = toHtml [ h2 ! [id "respond"] << "Leave a Response"- , gui (G.root / "comment/create") ! [id "commentform"] <<- [ field Author 22 1 "Name (required)"- , field AuthorEmail 22 2 "Email (hidden)"- , field AuthorLink 22 3 "Website"- , field HumanHack 22 4 (human_test_question state)- , empty_field- , hidden_field LeftNumber (state.show_left)- , hidden_field RightNumber (state.show_right)- , hidden_field Operator (state.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"]- ]+ , 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 @@ -57,9 +70,18 @@ ] 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 v x m = thespan ! [ thestyle "display: none;" ] << field_with_value v x 22 10 m -empty_field = hidden_field_with_value "" EmptyField "Leave this field empty:"+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 view
@@ -1,38 +1,44 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Atom.Post where -import Bamboo.Helper.Env hiding (name, title) import Bamboo.Helper.StateHelper hiding (uri)---- view+import Bamboo.Model.Post+import Bamboo.View.Env hiding (name, title, style) import qualified Bamboo.View.Atom.Tag as Tag --- model-import Bamboo.Model.Post --- render-instance DataRenderer Post where- render_data = entry Full- data RenderStyle = Summary | Full --- instance helpers-entry 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 x- entry_mark = p ! [theclass "small"] << [ post_date, post_tags, post_comments ].map (send_to x)+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 = x.markup_summary-show_content Full x = x.markup+ show_content Summary = x.markup_summary+ show_content Full = x.markup --- post could also be a summary-render_summary flag = if flag then entry Summary else render_data -title_link x = h2 << hotlink (x.uri) << x.title-post_date x = toHtml $ x.date.format_time "%b %e, %Y"+ title_link y = h2 << hotlink (y.uri) << y.title+ post_date y = toHtml $ y.date.format_time "%b %e, %Y" -post_tags x | x.tags.null = empty_html-post_tags x = " | " +++ "Published in " +++ x.tags.map Tag.tag_link .intersperse (", ".toHtml)+ post_tags y | y.tags.null = empty_html+ post_tags y = + " | " + +++ "Published in " + +++ y.tags.map (Tag.tag_link s) .intersperse (", ".toHtml) -post_comments x | x.comment_size.is 0 = empty_html-post_comments x = " | " +++ hotlink ( x.uri / "#comments") << (x.comment_size.show ++ " Comments")+ 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/Static.hs
@@ -1,8 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Atom.Static where- -import Bamboo.Helper.Env-import Bamboo.Model.Static--instance DataRenderer Static where- render_data = markup
src/Bamboo/View/Atom/Tag.hs view
@@ -1,12 +1,8 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Atom.Tag where -import Bamboo.Helper.Env hiding (name)-import Bamboo.Model.Tag-import qualified Bamboo.Config.Global as G--instance DataRenderer Tag where- render_data = name >>> tag_link+import Bamboo.View.Env hiding (name) -tag_link s = toHtml $ hotlink (G.root / G.tag_id / s ) << s +tag_link :: State -> String -> Html+tag_link s x = toHtml $ hotlink (s.config.root / s.config.tag_id / x ) << x
− src/Bamboo/View/Atom/Video.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Bamboo.View.Atom.Video where- -import Bamboo.Helper.Env hiding (name, id)-import Bamboo.Model.Video-import Bamboo.Helper.Html--instance DataRenderer Video where- render_data = show_video--show_video x = case x.video_type of- MediaPlayer -> show_media_player x--show_media_player x = - [ p ! [id l] << "The player will show in this paragraph"- , tag "script" ! [thetype "text/javascript"] << primHtml ( play (x.uid) (x.preview) (x.uid) )- ] .toHtml- where l = x.uid---play i p x = - [ "var s1 = new SWFObject('/flash/player.swf','player','400','348','9');"- , "s1.addParam('allowfullscreen','true');"- , "s1.addParam('allowscriptaccess','always');"- , "s1.addParam('flashvars','file=" ++ x ++ "&image=" ++ p ++ "');"- , "s1.write('" ++ i ++ "');"- ]- .join "\n"-
src/Bamboo/View/Control/Comment.hs view
@@ -1,18 +1,18 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Control.Comment where -import Bamboo.Helper.Env hiding (body, date)---- view-import Bamboo.View.Atom.Comment as Comment---- api-styled_entry alt x = li ! [theclass alt] << x.render_data+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) ]- -create = Comment.create+ where+ styled_entry alt x = li ! [theclass alt] << x.CommentVA.entry++create :: State -> Comment -> Html+create = CommentVA.create
src/Bamboo/View/Control/Helper.hs view
@@ -1,24 +1,21 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Control.Helper where -import Bamboo.Helper.Env- -import Bamboo.Type.Pager as Pager+import Bamboo.View.Env hiding (p)+import Bamboo.View.Helper +nav :: Pager -> String -> [Html] nav p r = - [ div_class "alignleft" << nav_previous p r- , div_class "alignright" << nav_next p r+ [ div_class "alignleft" << nav_previous+ , div_class "alignright" << nav_next ]- -nav_previous p r = if p.Pager.has_previous - then toHtml $ hotlink ( r' ++ "page=" ++ p.Pager.previous.show ) << previous_sign- else spaceHtml- where r' = if isSuffixOf "&" r then r else r ++ "?"+ 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 p r = if p.Pager.has_next- then toHtml $ hotlink ( r' ++ "page=" ++ p.Pager.next.show ) << next_sign- else spaceHtml- where r' = if isSuffixOf "&" r then r else r ++ "?"--next_sign = "Next Entries »"-previous_sign = "« Previous Entries"+ 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 view
@@ -2,30 +2,32 @@ module Bamboo.View.Control.Post where -- env-import Bamboo.Helper.Env--import qualified Bamboo.Type.State as State-import qualified Bamboo.Config.Global as G--import Bamboo.Type.Extension import Bamboo.Helper.StateHelper---- model-import qualified Bamboo.Model.Comment as Comment-import Bamboo.View.Atom.Post import Bamboo.Model.Post---- view+import Bamboo.Type.State hiding (uid)+import Bamboo.View.Atom.Post import Bamboo.View.Control.Helper-import qualified Bamboo.View.Control.Comment as CommentV+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 :: State.State -> [Comment.Comment] -> Post -> Html-view state xs x = (x.render_data +++ comment_view ).page state- where comment_view = only_for Comment $ CommentV.list xs +++ CommentV.create state (x.uid.Comment.from_post_id)+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 state = map render > p_eval' > (+++ nav p G.root) > page state where - p = state.State.pager- render = render_summary G.summary_for_root+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 view
@@ -1,14 +1,18 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Control.Search where -import Bamboo.Helper.Env-import qualified Bamboo.Type.State as State-import qualified Bamboo.Config.Global as G---- view-import Bamboo.View.Control.Helper-import Bamboo.View.Widget.Template--view state s = for_current_page p >>> map render_data >>> (+++ nav p ( (G.root / "search") ++ "?s=" ++ s ++ "&")) >>> page state- where p = state.State.pager+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 view
@@ -2,8 +2,9 @@ module Bamboo.View.Control.Static where -import Bamboo.Helper.Env-import Bamboo.View.Atom.Static ()-import Bamboo.View.Widget.Template+import Bamboo.View.Env+import Bamboo.View.Widget.Template (page)+import Bamboo.Type.State (static) -view state = render_data >>> page state+view :: Widget+view s = s.static.markup.page s
src/Bamboo/View/Control/Tag.hs view
@@ -2,18 +2,21 @@ module Bamboo.View.Control.Tag where -import Bamboo.Helper.Env+import Bamboo.View.Env hiding (p, tag_id)+import Bamboo.Type.State import qualified Bamboo.Type.State as State-import qualified Bamboo.Config.Global as G+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 state = map render > p_eval' > (+++ nav p ( G.root / tag_id)) >>> page state where- p = state.State.pager- tag_id = state.State.uid- render = render_summary G.summary_for_tag+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 view
@@ -0,0 +1,15 @@+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 view
@@ -0,0 +1,118 @@+{-# 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 view
@@ -2,8 +2,10 @@ module Bamboo.View.Widget.Body where -- env-import Bamboo.Helper.Env+import Bamboo.View.Env+import Bamboo.View.Helper +body_content :: Html -> Html body_content x = div_id "maincontent" << div_class "content" << x
@@ -1,23 +1,26 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Widget.Footer where -import Bamboo.Helper.Env-import qualified Bamboo.Config.Global as G+import Bamboo.View.Env +import qualified Bamboo.Type.Config as C+import qualified Bamboo.Type.Theme as T -static_footer = toHtml- [ toHtml $ copyright- , toHtml $ "2008 "- , toHtml $ G.blog_title- , toHtml $ br- , toHtml $ "Powered by "- , toHtml $ hotlink G.bamboo_url << "Bamboo"- , toHtml $ " using "- , toHtml $ hotlink "http://www.haskell.org/" << "Haskell"- ]- -custom_footer - | G.footer.isJust = G.footer.fromJust.markup- | otherwise = static_footer -footer c = div_class_id c "footer" << custom_footer+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 view
@@ -1,17 +1,29 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Widget.Head where -import Bamboo.Helper.Env-import qualified Bamboo.Config.Global as G-import Bamboo.Type.Theme hiding (header)-import qualified Bamboo.Type.State as S+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 state = header << ([meta_tag, title_tag state, favicon_tag, rss_tag state] ++ G.theme.css.map css_link ++ G.theme.js.map js_link ) -title_tag state = thetitle << [G.blog_title ++ state.S.resource_title.format_title]-rss_tag state = rss_link $ rss_url_link_pair state .fst-favicon_tag = favicon_link G.favicon+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] -format_title [] = ""-format_title s = " / " ++ s+ 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 view
@@ -1,18 +1,20 @@+{-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Widget.Header where -import Bamboo.Helper.Env hiding (header)-import Prelude hiding ((.), (/), (^), id, span)-import qualified Bamboo.Config.Global as G-import Bamboo.View.Widget.SearchBar+import Bamboo.View.Env hiding (header)+import Bamboo.View.Widget.SearchBar (search_bar)+import qualified Bamboo.Type.Theme as T -header c =- div_class_id c "header" << - [ search_bar- , site_name+header :: Widget+header s =+ div_class_id (s.config.theme.T.header) "header" << + [ search_bar s+ , site_name s ] -site_name = toHtml $- [ toHtml $ hotlink G.root ! [theclass "logo"] << ""- , h1 << G.blog_title- , div_class "description" << G.blog_subtitle+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 view
@@ -1,20 +1,22 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Widget.Helper where -import Bamboo.Helper.Env+import Bamboo.View.Env hiding (link) -import qualified Bamboo.Config.Global as G+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 = +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 ( G.tag_id / tag_name) tag_name- else link "" "Home"+ link ( s.config.tag_id / tag_name) tag_name+ else link "" home_nav where- uid = State.uid state+ uid = State.uid s tagged = uid.match "^tag/.+" .isJust- url r = G.root / r / "rss.xml"- link r s = (url r, hotlink (url r) ! [ theclass "feedlink" ] << s)+ url r = s.config.root / r / "rss.xml"+ link r x = (url r, hotlink (url r) ! [ theclass "feedlink" ] << x)
@@ -1,19 +1,28 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Widget.Navigation where -import Bamboo.Helper.Env hiding (header)-import qualified Bamboo.Config.Global as G+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 c state = - div_class_id c "nav" <<+navigation :: Widget+navigation s = + div_class_id (s.config.theme.T.navigation) "nav" << div_class "content" <<- ulist << G.navigation.map (nav_item (state.State.nav_location))+ ulist << s.config.C.navigation.map nav_item -nav_item nav s = li ! [theclass (home_tag ++ "page_item" ++ current)] << link s where- home_tag = if s == home_nav then "first " else ""- current = if s == nav then " current_page_item" else ""- link x = if x == home_nav then home_link else static_link x+ 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 G.root << home_nav-static_link s = hotlink (G.root / "static" / s) << s.drop_known_extension+ 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 view
@@ -1,39 +1,64 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NamedFieldPuns #-}+ module Bamboo.View.Widget.RSS where -- env-import Bamboo.Helper.Env hiding (render_rss)-import qualified Bamboo.Config.Global as G-import Text.RSS+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 as Post+import Bamboo.Model.Post hiding (title)+import qualified Bamboo.Model.Post as Post -- RSS-channel_rss_template = [ RSS.Language "en-us" ]--render_rss x | G.summary_for_rss.is True = x.markup_summary.show- | otherwise = x.markup.show--item_rss_template x = - [ Title $ x.Post.title- , Description $ x.render_rss- , Author $ G.author_email- , Link $ x.item_uri- , PubDate $ x.date- ]- instance Default URI where def = nullURI -item_uri x = def { uriScheme = "http://", uriPath = host_link (x.uri) }-rss_uri x = def { uriScheme = "http://", uriPath = host_link x }+data RSS = RSS+ {+ title :: RSS.Title+ , link :: RSS.Link+ , description :: RSS.Description+ , channel_elems :: [RSS.ChannelElem]+ , items :: [RSS.Item]+ } -rss categary s xs = RSS title (rss_uri link) title channel_rss_template (xs.map item_rss_template)- .rssToXML.showXML- where- link = categary / s- title = if s.empty then G.blog_title else G.blog_title ++ " / " ++ s+to_rss :: RSS -> RSS.RSS+to_rss x = RSS.RSS + (x.title) (x.link) (x.description) (x.channel_elems) (x.items) -host_link s = G.host_name ++ (G.root / s)+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 view
@@ -1,9 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Widget.SearchBar where -import Bamboo.Helper.Env hiding (header)-import qualified Bamboo.Config.Global as G-import Bamboo.Type.Extension-import Bamboo.Helper.StateHelper+import Bamboo.View.Env hiding (header)+import Bamboo.Helper.StateHelper (html_only_for) -search_bar = only_for Search $ div_id "search" << form ! [action (G.root / "search"), method "get"] << thediv << textfield "s"+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 view
@@ -1,37 +1,47 @@ {-# LANGUAGE NoImplicitPrelude #-} module Bamboo.View.Widget.Sidebar where -import Bamboo.Helper.Env hiding (rss_link)-import qualified Bamboo.Type.State as State -import qualified Data.Set as Set-import qualified Bamboo.Config.Global as G-import qualified Bamboo.Type.StaticWidget as Sidebar+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 c state = - div_class_id c "sidebar" << unordList formatted_list+sidebar :: Widget+sidebar s = + div_class_id (s.config.theme.T.sidebar) "sidebar" << unordList formatted_list where stock_list = - [ feed state- , tag_list $ state.State.tags+ [ feed+ , tag_list $ s.State.tags ] - custom_list = G.sidebar.map (\x -> h2 << x.Sidebar.name +++ x.markup)+ custom_list =+ s+ .config+ .C.sidebar+ .map (\x -> h2 << x.Sidebar.name +++ x.markup)+ formatted_list = (stock_list ++ custom_list) .intersperse hr -feed state = toHtml- [ h2 << "Subscribe"- , p ! [theclass "feed"] << rss_link state- ]+ 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]+ rss_link = rss_url_link_pair >>> snd+ tag_list tags = toHtml+ [ h2 << "Tags"+ , unordList $ tags.Tag.sorted.map tag_link] -tag_link x = ( hotlink (G.root / x.Tag.uid) << x.Tag.name ) +++ ( " (" ++ x.Tag.resources.Set.size.show ++ ")" )+ 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 view
@@ -9,26 +9,26 @@ import Bamboo.View.Widget.Sidebar import Bamboo.View.Widget.Footer import qualified Text.XHtml.Strict as Html-import qualified Bamboo.Config.Global as G import qualified Bamboo.Type.Theme as T -import Bamboo.Helper.Env hiding (header, body)+import Bamboo.View.Env hiding (header, body) -- extension-import Bamboo.Type.Extension-import Bamboo.Helper.StateHelper+import Bamboo.Helper.StateHelper (html_only_for) import Web.HCheat -body t state x = Html.body << +body :: Container+body s x = Html.body << [ div_class (t.T.container) << - [ header (t.T.header)- , navigation (t.T.navigation) state- , div_id "page" << [ div_class (t.T.main) << body_content x, sidebar (t.T.sidebar) state ]- , footer (t.T.footer)+ [ header s+ , navigation s+ , div_id "page" + << [ div_class (t.T.main) << body_content x, sidebar s ]+ , footer s ]- , only_for Analytics $ primHtml (analytics G.analytics_account_id)+ , html_only_for Analytics $ primHtml (analytics $ s.config.analytics_account_id) ]--template t state x = [html_head state, body t state x] .toHtml+ where t = s.config.theme -page = template G.theme+page :: Container+page s x = [html_head s, body s x] .toHtml