diff --git a/bamboo.cabal b/bamboo.cabal --- a/bamboo.cabal +++ b/bamboo.cabal @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 --------- diff --git a/src/Bamboo/Config/Global.hs b/src/Bamboo/Config/Global.hs deleted file mode 100644 --- a/src/Bamboo/Config/Global.hs +++ /dev/null @@ -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 diff --git a/src/Bamboo/Controller/Application.hs b/src/Bamboo/Controller/Application.hs --- a/src/Bamboo/Controller/Application.hs +++ b/src/Bamboo/Controller/Application.hs @@ -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 /) > ("^" ++)) diff --git a/src/Bamboo/Controller/Comment.hs b/src/Bamboo/Controller/Comment.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Controller/Comment.hs @@ -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 diff --git a/src/Bamboo/Controller/Env.hs b/src/Bamboo/Controller/Env.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Controller/Env.hs @@ -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) diff --git a/src/Bamboo/Controller/Helper.hs b/src/Bamboo/Controller/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Controller/Helper.hs @@ -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 } diff --git a/src/Bamboo/Controller/Index.hs b/src/Bamboo/Controller/Index.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Controller/Index.hs @@ -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 diff --git a/src/Bamboo/Controller/Post.hs b/src/Bamboo/Controller/Post.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Controller/Post.hs @@ -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 diff --git a/src/Bamboo/Controller/Search.hs b/src/Bamboo/Controller/Search.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Controller/Search.hs @@ -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 diff --git a/src/Bamboo/Controller/Static.hs b/src/Bamboo/Controller/Static.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Controller/Static.hs @@ -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 diff --git a/src/Bamboo/Controller/Tag.hs b/src/Bamboo/Controller/Tag.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Controller/Tag.hs @@ -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 diff --git a/src/Bamboo/Controller/Type.hs b/src/Bamboo/Controller/Type.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Controller/Type.hs @@ -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 diff --git a/src/Bamboo/Env.hs b/src/Bamboo/Env.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Env.hs @@ -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) diff --git a/src/Bamboo/Helper.hs b/src/Bamboo/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Helper.hs @@ -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") diff --git a/src/Bamboo/Helper/ByteString.hs b/src/Bamboo/Helper/ByteString.hs --- a/src/Bamboo/Helper/ByteString.hs +++ b/src/Bamboo/Helper/ByteString.hs @@ -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 diff --git a/src/Bamboo/Helper/Env.hs b/src/Bamboo/Helper/Env.hs deleted file mode 100644 --- a/src/Bamboo/Helper/Env.hs +++ /dev/null @@ -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) diff --git a/src/Bamboo/Helper/Helper.hs b/src/Bamboo/Helper/Helper.hs deleted file mode 100644 --- a/src/Bamboo/Helper/Helper.hs +++ /dev/null @@ -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 = ("").primHtml -ie6_tag x = ("").primHtml -ie7_tag x = ("").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 = "\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 diff --git a/src/Bamboo/Helper/Html.hs b/src/Bamboo/Helper/Html.hs deleted file mode 100644 --- a/src/Bamboo/Helper/Html.hs +++ /dev/null @@ -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 diff --git a/src/Bamboo/Helper/PreludeEnv.hs b/src/Bamboo/Helper/PreludeEnv.hs --- a/src/Bamboo/Helper/PreludeEnv.hs +++ b/src/Bamboo/Helper/PreludeEnv.hs @@ -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) diff --git a/src/Bamboo/Helper/StateHelper.hs b/src/Bamboo/Helper/StateHelper.hs --- a/src/Bamboo/Helper/StateHelper.hs +++ b/src/Bamboo/Helper/StateHelper.hs @@ -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 +-} diff --git a/src/Bamboo/Helper/ThumbHelper.hs b/src/Bamboo/Helper/ThumbHelper.hs deleted file mode 100644 --- a/src/Bamboo/Helper/ThumbHelper.hs +++ /dev/null @@ -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 diff --git a/src/Bamboo/Helper/Translation.hs b/src/Bamboo/Helper/Translation.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Helper/Translation.hs @@ -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" diff --git a/src/Bamboo/Model/Album.hs b/src/Bamboo/Model/Album.hs deleted file mode 100644 --- a/src/Bamboo/Model/Album.hs +++ /dev/null @@ -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 - diff --git a/src/Bamboo/Model/Comment.hs b/src/Bamboo/Model/Comment.hs --- a/src/Bamboo/Model/Comment.hs +++ b/src/Bamboo/Model/Comment.hs @@ -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 + diff --git a/src/Bamboo/Model/Counter.hs b/src/Bamboo/Model/Counter.hs --- a/src/Bamboo/Model/Counter.hs +++ b/src/Bamboo/Model/Counter.hs @@ -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 diff --git a/src/Bamboo/Model/Env.hs b/src/Bamboo/Model/Env.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Model/Env.hs @@ -0,0 +1,8 @@ +module Bamboo.Model.Env +( + module Bamboo.Env + , module Bamboo.Model.Helper +) where + +import Bamboo.Env +import Bamboo.Model.Helper diff --git a/src/Bamboo/Model/Helper.hs b/src/Bamboo/Model/Helper.hs --- a/src/Bamboo/Model/Helper.hs +++ b/src/Bamboo/Model/Helper.hs @@ -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 "/" " / " + + + diff --git a/src/Bamboo/Model/Post.hs b/src/Bamboo/Model/Post.hs --- a/src/Bamboo/Model/Post.hs +++ b/src/Bamboo/Model/Post.hs @@ -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 - - diff --git a/src/Bamboo/Model/Static.hs b/src/Bamboo/Model/Static.hs --- a/src/Bamboo/Model/Static.hs +++ b/src/Bamboo/Model/Static.hs @@ -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 diff --git a/src/Bamboo/Model/Tag.hs b/src/Bamboo/Model/Tag.hs --- a/src/Bamboo/Model/Tag.hs +++ b/src/Bamboo/Model/Tag.hs @@ -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 ",") diff --git a/src/Bamboo/Model/Video.hs b/src/Bamboo/Model/Video.hs deleted file mode 100644 --- a/src/Bamboo/Model/Video.hs +++ /dev/null @@ -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 diff --git a/src/Bamboo/Type.hs b/src/Bamboo/Type.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Type.hs @@ -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 diff --git a/src/Bamboo/Type/Cache.hs b/src/Bamboo/Type/Cache.hs deleted file mode 100644 --- a/src/Bamboo/Type/Cache.hs +++ /dev/null @@ -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 - - diff --git a/src/Bamboo/Type/Class.hs b/src/Bamboo/Type/Class.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Type/Class.hs @@ -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 diff --git a/src/Bamboo/Type/Common.hs b/src/Bamboo/Type/Common.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Type/Common.hs @@ -0,0 +1,4 @@ +module Bamboo.Type.Common where + +type Assoc = [(String, String)] +type SC = String -> String diff --git a/src/Bamboo/Type/Config.hs b/src/Bamboo/Type/Config.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/Type/Config.hs @@ -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" diff --git a/src/Bamboo/Type/Extension.hs b/src/Bamboo/Type/Extension.hs --- a/src/Bamboo/Type/Extension.hs +++ b/src/Bamboo/Type/Extension.hs @@ -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 - diff --git a/src/Bamboo/Type/Pager.hs b/src/Bamboo/Type/Pager.hs --- a/src/Bamboo/Type/Pager.hs +++ b/src/Bamboo/Type/Pager.hs @@ -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 diff --git a/src/Bamboo/Type/Plugin.hs b/src/Bamboo/Type/Plugin.hs deleted file mode 100644 --- a/src/Bamboo/Type/Plugin.hs +++ /dev/null @@ -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 diff --git a/src/Bamboo/Type/Reader.hs b/src/Bamboo/Type/Reader.hs --- a/src/Bamboo/Type/Reader.hs +++ b/src/Bamboo/Type/Reader.hs @@ -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 diff --git a/src/Bamboo/Type/State.hs b/src/Bamboo/Type/State.hs --- a/src/Bamboo/Type/State.hs +++ b/src/Bamboo/Type/State.hs @@ -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)) + + diff --git a/src/Bamboo/Type/StaticWidget.hs b/src/Bamboo/Type/StaticWidget.hs --- a/src/Bamboo/Type/StaticWidget.hs +++ b/src/Bamboo/Type/StaticWidget.hs @@ -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 diff --git a/src/Bamboo/Type/Theme.hs b/src/Bamboo/Type/Theme.hs --- a/src/Bamboo/Type/Theme.hs +++ b/src/Bamboo/Type/Theme.hs @@ -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 diff --git a/src/Bamboo/View/Atom/Album.hs b/src/Bamboo/View/Atom/Album.hs deleted file mode 100644 --- a/src/Bamboo/View/Atom/Album.hs +++ /dev/null @@ -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 - ] diff --git a/src/Bamboo/View/Atom/Comment.hs b/src/Bamboo/View/Atom/Comment.hs --- a/src/Bamboo/View/Atom/Comment.hs +++ b/src/Bamboo/View/Atom/Comment.hs @@ -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:" + diff --git a/src/Bamboo/View/Atom/Post.hs b/src/Bamboo/View/Atom/Post.hs --- a/src/Bamboo/View/Atom/Post.hs +++ b/src/Bamboo/View/Atom/Post.hs @@ -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 diff --git a/src/Bamboo/View/Atom/Static.hs b/src/Bamboo/View/Atom/Static.hs deleted file mode 100644 --- a/src/Bamboo/View/Atom/Static.hs +++ /dev/null @@ -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 diff --git a/src/Bamboo/View/Atom/Tag.hs b/src/Bamboo/View/Atom/Tag.hs --- a/src/Bamboo/View/Atom/Tag.hs +++ b/src/Bamboo/View/Atom/Tag.hs @@ -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 diff --git a/src/Bamboo/View/Atom/Video.hs b/src/Bamboo/View/Atom/Video.hs deleted file mode 100644 --- a/src/Bamboo/View/Atom/Video.hs +++ /dev/null @@ -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" - diff --git a/src/Bamboo/View/Control/Comment.hs b/src/Bamboo/View/Control/Comment.hs --- a/src/Bamboo/View/Control/Comment.hs +++ b/src/Bamboo/View/Control/Comment.hs @@ -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 diff --git a/src/Bamboo/View/Control/Helper.hs b/src/Bamboo/View/Control/Helper.hs --- a/src/Bamboo/View/Control/Helper.hs +++ b/src/Bamboo/View/Control/Helper.hs @@ -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 ++ "?" diff --git a/src/Bamboo/View/Control/Post.hs b/src/Bamboo/View/Control/Post.hs --- a/src/Bamboo/View/Control/Post.hs +++ b/src/Bamboo/View/Control/Post.hs @@ -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 diff --git a/src/Bamboo/View/Control/Search.hs b/src/Bamboo/View/Control/Search.hs --- a/src/Bamboo/View/Control/Search.hs +++ b/src/Bamboo/View/Control/Search.hs @@ -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) ++ "&" diff --git a/src/Bamboo/View/Control/Static.hs b/src/Bamboo/View/Control/Static.hs --- a/src/Bamboo/View/Control/Static.hs +++ b/src/Bamboo/View/Control/Static.hs @@ -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 diff --git a/src/Bamboo/View/Control/Tag.hs b/src/Bamboo/View/Control/Tag.hs --- a/src/Bamboo/View/Control/Tag.hs +++ b/src/Bamboo/View/Control/Tag.hs @@ -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) diff --git a/src/Bamboo/View/Env.hs b/src/Bamboo/View/Env.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/View/Env.hs @@ -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 diff --git a/src/Bamboo/View/Helper.hs b/src/Bamboo/View/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Bamboo/View/Helper.hs @@ -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 = ("").primHtml +ie6_tag x = ("").primHtml +ie7_tag x = ("").primHtml + + +xml_header :: String +xml_header = "\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 + diff --git a/src/Bamboo/View/Widget/Body.hs b/src/Bamboo/View/Widget/Body.hs --- a/src/Bamboo/View/Widget/Body.hs +++ b/src/Bamboo/View/Widget/Body.hs @@ -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 diff --git a/src/Bamboo/View/Widget/Footer.hs b/src/Bamboo/View/Widget/Footer.hs --- a/src/Bamboo/View/Widget/Footer.hs +++ b/src/Bamboo/View/Widget/Footer.hs @@ -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 diff --git a/src/Bamboo/View/Widget/Head.hs b/src/Bamboo/View/Widget/Head.hs --- a/src/Bamboo/View/Widget/Head.hs +++ b/src/Bamboo/View/Widget/Head.hs @@ -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 diff --git a/src/Bamboo/View/Widget/Header.hs b/src/Bamboo/View/Widget/Header.hs --- a/src/Bamboo/View/Widget/Header.hs +++ b/src/Bamboo/View/Widget/Header.hs @@ -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 ] diff --git a/src/Bamboo/View/Widget/Helper.hs b/src/Bamboo/View/Widget/Helper.hs --- a/src/Bamboo/View/Widget/Helper.hs +++ b/src/Bamboo/View/Widget/Helper.hs @@ -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) diff --git a/src/Bamboo/View/Widget/Navigation.hs b/src/Bamboo/View/Widget/Navigation.hs --- a/src/Bamboo/View/Widget/Navigation.hs +++ b/src/Bamboo/View/Widget/Navigation.hs @@ -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 + diff --git a/src/Bamboo/View/Widget/RSS.hs b/src/Bamboo/View/Widget/RSS.hs --- a/src/Bamboo/View/Widget/RSS.hs +++ b/src/Bamboo/View/Widget/RSS.hs @@ -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 diff --git a/src/Bamboo/View/Widget/SearchBar.hs b/src/Bamboo/View/Widget/SearchBar.hs --- a/src/Bamboo/View/Widget/SearchBar.hs +++ b/src/Bamboo/View/Widget/SearchBar.hs @@ -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" diff --git a/src/Bamboo/View/Widget/Sidebar.hs b/src/Bamboo/View/Widget/Sidebar.hs --- a/src/Bamboo/View/Widget/Sidebar.hs +++ b/src/Bamboo/View/Widget/Sidebar.hs @@ -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 ++ ")" ) diff --git a/src/Bamboo/View/Widget/Template.hs b/src/Bamboo/View/Widget/Template.hs --- a/src/Bamboo/View/Widget/Template.hs +++ b/src/Bamboo/View/Widget/Template.hs @@ -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