diff --git a/changelog.markdown b/changelog.markdown --- a/changelog.markdown +++ b/changelog.markdown @@ -1,3 +1,10 @@ +2008.12.14 +---------- + +### Feature + +* Photo album plugin + 2008.11.7 --------- diff --git a/panda.cabal b/panda.cabal --- a/panda.cabal +++ b/panda.cabal @@ -1,5 +1,5 @@ Name: panda -Version: 2008.11.7 +Version: 2008.12.14 Build-type: Simple Synopsis: A simple static blog engine Description: A simple static blog engine @@ -11,11 +11,11 @@ Cabal-version: >= 1.2 category: Web homepage: http://www.haskell.org/haskellwiki/Panda -data-files: readme.markdown, changelog.markdown +data-files: readme.markdown, changelog.markdown 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, directory, filepath, containers, mps >= 2008.11.6, parsedate >= 3000.0.0, rss >= 3000.0.1, xhtml, kibro >= 0.4.2, utf8-string >= 0.3.3, pandoc, parsec >= 2, MissingH, gravatar >= 0.3, data-default >= 0.2, hcheat >= 2008.11.6 + build-depends: base, cgi, network, haskell98, old-locale, old-time, directory, filepath, containers, process, mps >= 2008.11.6, parsedate >= 3000.0.0, rss >= 3000.0.1, xhtml, kibro >= 0.4.2, utf8-string >= 0.3.3, pandoc, parsec >= 2, MissingH, gravatar >= 0.3, data-default >= 0.2, hcheat >= 2008.11.6 hs-source-dirs: src/ exposed-modules: Panda @@ -28,6 +28,7 @@ Panda.Helper.Helper Panda.Helper.PreludeEnv Panda.Helper.StateHelper + Panda.Helper.ThumbHelper Panda.Model.Comment Panda.Model.Post diff --git a/src/Panda/Config/Global.hs b/src/Panda/Config/Global.hs --- a/src/Panda/Config/Global.hs +++ b/src/Panda/Config/Global.hs @@ -5,7 +5,7 @@ import Panda.Helper.Helper import Panda.Helper.PreludeEnv -import Control.Arrow ((>>>)) + import Data.Maybe import Data.Default @@ -23,9 +23,17 @@ 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" 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 @@ -35,6 +43,9 @@ 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 + data ConfigData = BlogTitle | BlogSubtitle @@ -59,6 +70,8 @@ | SummaryForRoot | SummaryForTag | SummaryForRss + | PicturePrefix + | NumberOfLatestPosts deriving (Show) -- unsafe, must restart server after changing config file, sorry about that ... @@ -76,7 +89,7 @@ author_email = for AuthorEmail per_page = for_int' PerPage "7" -navigation = for_list' Navigation "About" .("Home" :) +navigation = for_list' Navigation "About" .(home_nav :) panda_url = "http://www.haskell.org/haskellwiki/Panda" @@ -87,8 +100,8 @@ default_reader = def -load_widget = read_static_widget default_reader >>> purify -sidebar = for_list' Sidebar "" .map (sidebar_uri /).select (file_exist >>> purify ) +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 @@ -121,10 +134,13 @@ -- summary cut = for' Cut "✂-----" -parse_boolean = belongs_to ["true", "1", "y", "yes", "yeah"] 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" diff --git a/src/Panda/Controller/Application.hs b/src/Panda/Controller/Application.hs --- a/src/Panda/Controller/Application.hs +++ b/src/Panda/Controller/Application.hs @@ -38,12 +38,12 @@ u = liftIO blog_regex = G.url_date_matcher init_post tags x = x.Tag.fill_tag tags.Comment.fill_comment_size.u -tag_list = Tag.list.u +tag_list = list.u -- main controller -pages = +pages = ( [ ("$" ,index ) , ("(\\?.+)?$" ,index ) , ("rss.xml$" ,index_feed ) @@ -53,47 +53,52 @@ , ("tag/." ,tag ) , ("search" ,only_for Search $ search ) , ("comment/create" ,only_for Comment $ comment_create ) - ] .map_fst ((G.root /) >>> ("^" ++)) + ] .map_fst ((G.root /) > ("^" ++)) ++ [ ("^" ++ G.root ++ "$" ,index ) , ("^" ++ G.root ++ "?" ,index ) - ] - + ] ).map_snd (set_header >>) only_for ext x = if has_extension ext then x else not_found +default_state = do + latest_posts <- Post.latest G.number_of_latest_posts.u + def { S.latest_posts = latest_posts } .return + index = do - posts <- Post.list.u + posts <- list.u p <- paginate posts tags <- tag_list let nav = if p.Pager.current == 1 then home_nav else no_navigation - let state = def { S.uid = G.post_id, S.pager = p, S.tags = tags, S.nav_location = nav } + s <- default_state + let state = s { S.uid = G.post_id, S.tags = tags, S.pager = p, S.nav_location = nav } posts.mapM (init_post tags) ^ PostV.list state >>= output_html index_feed = do - posts <- Post.list.u + posts <- list.u posts.RSSV.rss "" "" .output blog = do id <- uri ^ Post.uri_to_id - blog <- Post.get id .u - comments <- Comment.list_for id .u + blog <- get id .u + comments <- list_for id .u tags <- tag_list test_data <- S.mk_human_test .u - let state = def { S.uid = id, S.tags = tags, S.resource_title = blog.resource_title, S.human_test_data = test_data } + 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) ^ PostV.view state comments >>= output_html static = do id <- uri - static_page <- Static.get id .u + static_page <- get id .u 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 - let state = def { S.uid = id, S.tags = tags, S.nav_location = nav, S.resource_title = static_page.resource_title } + s <- default_state + let state = s { S.uid = id, S.tags = tags, S.nav_location = nav, S.resource_title = static_page.resource_title } StaticV.view state static_page .output_html tag = do @@ -103,19 +108,20 @@ case Tag.tag_map' tags .Map.lookup tag_name of Nothing -> not_found Just post_set -> do - posts <- post_set.to_list.rsort.mapM (Post.get) .u >>= mapM (init_post tags) + posts <- post_set.to_list.rsort.mapM (get) .u >>= mapM (init_post tags) p <- paginate posts - let state = def { S.uid = id, S.pager = p, S.tags = tags, S.resource_title = tag_name.Tag.resource_title_from_name } + 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.TagV.view state.output_html tag_feed = do - id <- uri ^ (split "/" >>> init >>> join "/") + id <- 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 (Post.get) .u ^ map (Tag.fill_tag tags) + posts <- post_set.to_list.rsort.mapM (get) .u ^ map (Tag.fill_tag tags) posts.RSSV.rss G.tag_id tag_name.output search = do @@ -125,7 +131,8 @@ p <- paginate posts tags <- tag_list query <- uri - let state = def { S.uid = query, S.pager = p, S.tags = tags, S.resource_title = query } + 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 @@ -137,12 +144,12 @@ if [checked, valid_path, exists].and then - inputs >>= (Comment.create >>> u) + inputs >>= (Comment.create_comment > u) else return () redirect $ (post_id.Post.id_to_uri.u2b).urlEncode -get_input_data = show_data >>> get_input +get_input_data = show_data > get_input check_human = do [l, r, op, h] <- [Comment.LeftNumber, Comment.RightNumber, Comment.Operator, Comment.HumanHack].mapM get_input_data ^ map fromJust @@ -150,9 +157,9 @@ -- create helper, should be refactored to some common aspect check_create = - [ validate Comment.Author ( length >>> (> 0)) + [ validate Comment.Author ( length > (`gt` 0)) , validate Comment.AuthorLink ( const True) - , validate Comment.Body ( length >>> (> 0)) + , 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)) diff --git a/src/Panda/Helper/Env.hs b/src/Panda/Helper/Env.hs --- a/src/Panda/Helper/Env.hs +++ b/src/Panda/Helper/Env.hs @@ -35,7 +35,7 @@ import Data.Maybe (fromMaybe, fromJust, isJust, isNothing) import System.FilePath hiding ((<.>)) import System.IO.UTF8 (readFile, writeFile) -import Text.XHtml.Strict hiding (select) +import Text.XHtml.Strict hiding (select, sub, meta) import System.Time import System.Directory import Data.Foldable (find) diff --git a/src/Panda/Helper/Helper.hs b/src/Panda/Helper/Helper.hs --- a/src/Panda/Helper/Helper.hs +++ b/src/Panda/Helper/Helper.hs @@ -10,8 +10,9 @@ import Panda.Helper.PreludeEnv import Network.URI import Network.CGI -import Control.Arrow ((>>>)) -import Text.XHtml.Strict hiding (p) + +import Text.XHtml.Strict hiding (p, meta) +import qualified Text.XHtml.Strict as Html import Control.Monad hiding (join) import Data.Maybe import qualified Panda.Type.Pager as Pager @@ -21,28 +22,47 @@ import Panda.Type.Reader import System.FilePath.Posix hiding ((<.>)) import System.Time +import qualified Prelude as P +import Data.Default +import Data.Map (Map) +import System.Directory (/) :: FilePath -> FilePath -> FilePath (/) = () infixl 5 / +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 +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_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 = requestURI ^ (uriPath >>> urlDecode >>> tail >>> remove_trailing_slash ) +raw_uri = requestURI ^ (uriPath > urlDecode > tail > remove_trailing_slash ) remove_trailing_slash s = if s.last.is '/' then s.init else s @@ -52,7 +72,7 @@ '?':s -> s.formDecode .map_snd ( unescape_unicode_xml ) .return _ -> return [] -inputs = getInputs ^ map_snd (strip >>> unescape_unicode_xml) +inputs = getInputs ^ map_snd (strip > unescape_unicode_xml > b2u) param_with_default s d = get_param s ^ fromMaybe d input_with_default s d = get_input s ^ fromMaybe d @@ -65,63 +85,103 @@ full_paginate length total = liftM5 ( Pager.Pager length ) current has_next has_previous next previous where current = param_with_default "page" "1" ^ read - has_next = current ^ ( (* length) >>> (< total.from_i) ) - has_previous = current ^ (> 1) + has_next = current ^ ( (* length) > (< 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) --- id: /type/resoruce -id_to_type x = x.split "/" .first -id_to_resource x = x.split "/" .tail.join "/" no_navigation = "" home_nav = "Home" +default_content_type = "text/html; charset=UTF-8" +set_content_type = setHeader "Content-type" +set_header = set_content_type default_content_type -- 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 = meta ! [httpequiv "Content-Type", content "text/html; charset=utf-8"] +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] -output_html = output ... renderHtml +xml_header = "\n" +output_html x = x.renderHtml.output 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 = getVar "REQUEST_URI" >>= (fromMaybe "" >>> outputNotFound) +not_found = getVar "REQUEST_URI" >>= (fromMaybe "" > outputNotFound) -- generic -show_data = show >>> snake_case +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 -- class class DataRenderer a where - render_data :: a -> Html + render_data :: a -> Html -class Resource a where - resource_title :: a -> String +-- 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 + markup :: a -> Html class Datable a where - date :: a -> CalendarTime + date :: a -> CalendarTime class Addressable a where - uri :: a -> String + 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 diff --git a/src/Panda/Helper/PreludeEnv.hs b/src/Panda/Helper/PreludeEnv.hs --- a/src/Panda/Helper/PreludeEnv.hs +++ b/src/Panda/Helper/PreludeEnv.hs @@ -1,10 +1,18 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction #-} module Panda.Helper.PreludeEnv ( module MPSUTF8 , module Prelude + , (>) + , strip ) where -import Prelude hiding ((.), (/), (^), id, span, readFile, writeFile) -import MPSUTF8 hiding (base, col, date, sub) +import Prelude hiding ((.), (/), (^), id, span, readFile, writeFile, div, (>)) +import MPSUTF8 hiding (base, col, date, strip) +import qualified MPSUTF8 as MPS +import Control.Arrow ((>>>)) +(>) = (>>>) +infixl 8 > + +strip x = MPS.strip (x.u2b) .b2u diff --git a/src/Panda/Helper/StateHelper.hs b/src/Panda/Helper/StateHelper.hs --- a/src/Panda/Helper/StateHelper.hs +++ b/src/Panda/Helper/StateHelper.hs @@ -19,7 +19,6 @@ uri = raw_uri ^ b2u ^ remove_root -- uri = raw_uri - -- global parse_date format s = case maybe_d of Nothing -> Nothing @@ -36,10 +35,14 @@ only_for ext x = if has_extension ext then x else toHtml "" -- controller -paginate = length >>> full_paginate (G.per_page) +paginate = length > full_paginate (G.per_page) cut = G.cut cut_re = "^\\s*" ++ cut -match_cut = match cut_re -is_cut = match_cut >>> isJust +match_cut = is_cut +is_cut = isInfixOf cut split_cut = split cut_re + + +-- model +path id = G.flat_uri / id diff --git a/src/Panda/Helper/ThumbHelper.hs b/src/Panda/Helper/ThumbHelper.hs new file mode 100644 --- /dev/null +++ b/src/Panda/Helper/ThumbHelper.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Panda.Helper.ThumbHelper where + +-- env +import Panda.Helper.Env hiding (match, body, quote) +import qualified Panda.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/Panda/Model/Comment.hs b/src/Panda/Model/Comment.hs --- a/src/Panda/Model/Comment.hs +++ b/src/Panda/Model/Comment.hs @@ -3,7 +3,7 @@ module Panda.Model.Comment where -- env -import Panda.Helper.Env hiding (title, body, size, path, meta) +import Panda.Helper.Env hiding (title, body, size, path) import qualified Panda.Config.Global as G import Panda.Type.Reader import qualified Panda.Model.Post as Post @@ -36,7 +36,7 @@ deriving (Show) instance Resource Comment where - resource_title = uid >>> spaced_url + resource_title = uid > spaced_url instance Markable Comment where markup x = render_to_html Markdown (x.body) @@ -48,55 +48,64 @@ def = Comment def def def def def -- CRUD -list_for post_id = do - has_comments <- dir_exist d - if has_comments - then ls d ^ reject (isSuffixOf ".meta") ^ rsort ^ map (G.comment_id / r /) >>= mapM get - else return [] - where - d = (G.comment_uri / r) - r = post_id.id_to_resource +instance FlatRead Comment where + flat_read x = do + t <- x.path.read_file + def {body = t, uid = x} .return -path id = G.flat_uri / id -meta = (++ ".meta") +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 + 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 -get id = do - meta_exists <- id.path.meta.file_exist - if meta_exists - then get_from_new_format id - else get_from_old_format id +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) + r = resource_id.id_to_resource -get_from_new_format id = do - body <- id.path.read_file - meta <- id.path.meta.parse_config_io - let at s = meta.lookup (s.show_data) .fromJust - let author = at Author - let author_email = at AuthorEmail - let author_link = at AuthorLink - return $ Comment id author body author_email author_link +instance Creatable Comment where + create = write_to -get_from_old_format id = do - xs <- id.path.read_file ^ lines - let author = xs.first - let author_email = "" - let author_link = xs.drop 2.first - let body = xs.drop 4.unlines - return $ Comment id author body author_email author_link +instance Mappable Comment where + from_assoc h = do + let at s = h.lookup (s.show_data) .fromJust + let body = at Body + let post_id = at PostId -create h = do - let at s = h.lookup (s.show_data) .fromJust - let body = at Body - let post_id = at PostId + timestamp <- ( getClockTime >>= toCalendarTime ) ^ format_date G.comment_date_format + let comment_path = post_id_to_uid post_id + mkdir_p comment_path - timestamp <- ( getClockTime >>= toCalendarTime ) ^ format_date G.comment_date_format - let comment_path = post_id_to_uid post_id - mkdir_p comment_path - - let uid = comment_path / timestamp - write_file uid body - let meta = [Author, AuthorLink, AuthorEmail] .labeling at .map_fst show_data - write_config_io (uid ++ ".meta") meta + let uid = comment_path / timestamp + def + { uid = uid + , body = at Body + , author = at Author + , author_email = at AuthorEmail + , author_link = at AuthorLink + } + .return +write_to x = do + write_file (x.uid) (x.body) + write_config_io (x.uid.meta) meta_data + where + meta_data = + [ (Author, x.author) + , (AuthorLink, x.author_link) + , (AuthorEmail, x.author_email) + ] .map_fst show_data + +create_comment x = x.from_assoc >>= (create :: Comment -> IO ()) + -- extra from_post_id x = def { uid = post_id_to_uid x } @@ -104,7 +113,7 @@ uid_to_post_id x = G.post_id / x.split "/" .last fill_comment_size x = do - size <- x.Post.uid.list_for ^ length + size <- x.Post.uid.(list_for :: String -> IO [Comment] ) ^ length return $ x { Post.comment_size = size } gravatar_default_size = size 40 diff --git a/src/Panda/Model/Post.hs b/src/Panda/Model/Post.hs --- a/src/Panda/Model/Post.hs +++ b/src/Panda/Model/Post.hs @@ -13,7 +13,9 @@ import Panda.Type.Reader import Panda.Helper.StateHelper hiding (uri) import Panda.Helper.Helper (date) +import Panda.Model.Helper + data Post = Post { uid :: String -- blog/08-09-04 blog title , title :: String @@ -26,44 +28,65 @@ instance Resource Post where resource_title = title + resource_type = const G.post_id instance Markable Post where markup x = render_to_html (x.reader) (x.full) instance Datable Post where - date = uid >>> get_date + date = uid > get_date instance Addressable Post where - uri = uid >>> id_to_uri + uri = uid > id_to_uri +instance Default Post where + def = Post def def def def def def + +instance FlatRead Post where + flat_read x = do + t <- get_body x + def {body = t, uid = x} .return + -- CRUD -list = ls G.post_uri ^ rsort ^ map (G.post_id /) >>= mapM get +instance Gettable Post where + get id = do + x <- flat_read id + x { + title = get_title id + , reader = get_reader id + } + .return -get id = liftM4 (Post id (get_title id) ) (get_body id) (return []) (return 0) (return $ get_reader id) -get_extension = takeExtension +instance Listable Post where + list = list_ids >>= mapM get + cheat_list = fast_list + +list_ids = ls G.post_uri ^ rsort ^ map (G.post_id /) +fast_list = list_ids ^ map (\x -> def {uid = x, title = x.get_title}) + + get_title id = id.words.tail.unwords.drop_known_extension -get_body id = (G.flat_uri / id) .read_file -get_reader id = id.take_extension.guess_reader.fromMaybe G.default_reader get_date id = id.words.first.split "/".last.default_parse_date -match s x = [title, body] .map (send_to x >>> lower >>> isInfixOf (s.lower)) .or +match s x = [title, body] .map (send_to x > lower > isInfixOf (s.lower)) .or search "" = return [] search s = list ^ filter (match s) -summary = body >>> split_cut >>> first -full x | x.body.match_cut.isNothing = x.body +summary x = x.body.lines.takeWhile (is_cut > not) .unlines +full x | x.body.match_cut.not = x.body full x = ( xs.takeWhile not_cut ++ xs.dropWhile not_cut .tail ).unlines where - not_cut = is_cut >>> not + not_cut = is_cut > not xs = x.body.lines -has_continue = body >>> match_cut >>> isJust +has_continue = body > match_cut +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_date G.url_date_format - ext = id.get_extension + 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 @@ -74,6 +97,8 @@ -- summary markup_summary x = post_summary x +++ next where - post_summary = (reader &&& summary) >>> splash render_to_html - next = if x.has_continue then toHtml $ hotlink (x.uri) << "Read the rest of the post »" else empty_html + 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 + + diff --git a/src/Panda/Model/Static.hs b/src/Panda/Model/Static.hs --- a/src/Panda/Model/Static.hs +++ b/src/Panda/Model/Static.hs @@ -5,6 +5,7 @@ import Panda.Helper.Env hiding (match, body) import qualified Panda.Config.Global as G import Panda.Type.Reader +import Panda.Model.Helper data Static = Static { uid :: String @@ -14,15 +15,24 @@ deriving (Show, Eq) instance Resource Static where - resource_title = uid >>> spaced_url + resource_title x = ("static" / x.uid.get_title) .spaced_url instance Markable Static where markup x = render_to_html (x.reader) (x.body) - + +instance Default Static where + def = Static def def def + -- CRUD -get id = liftM2 (Static id) (get_body id) (return $ get_reader id) -get_title = id_to_resource >>> drop_known_extension -get_body id = (G.flat_uri / id) .read_file -get_reader id = id.take_extension.guess_reader.fromMaybe G.default_reader +instance FlatRead Static where + flat_read x = do + t <- get_body x + def {body = t, uid = x} .return -title = uid >>> get_title +instance Gettable Static where + get id = do + x <- flat_read id + x { reader = get_reader id } .return + +get_title = id_to_resource > drop_known_extension > split "/" > last +title = uid > get_title diff --git a/src/Panda/Model/Tag.hs b/src/Panda/Model/Tag.hs --- a/src/Panda/Model/Tag.hs +++ b/src/Panda/Model/Tag.hs @@ -17,23 +17,27 @@ deriving (Show, Eq) instance Resource Tag where - resource_title = uid >>> spaced_url + resource_title = uid > spaced_url -- CRUD -list = ls G.tag_uri ^ map (G.tag_id /) >>= mapM get +instance Gettable Tag where + get id = get_resources id ^ Tag id (get_name id) -get id = get_resources id ^ Tag id (get_name id) +instance Listable Tag where + list = ls G.tag_uri ^ map (G.tag_id /) >>= mapM get + + get_name id = id.split "/" .tail.join' get_resources id = (G.flat_uri / id) .read_file ^ filter_comment ^ lines ^ map (G.post_id / ) ^ to_set -resource_title_from_name = name_to_id >>> spaced_url +resource_title_from_name x = ("tag" / x) .spaced_url tag_map' xs = xs . map (name &&& resources) . to_h tag_map = list ^ tag_map' -for_resource xs x = xs.select (resources >>> has x) .map name +for_resource xs x = xs.select (resources > has x) .map name fill_tag xs x = x { Post.tags = for_resource xs (x.Post.uid) } -- extra -sorted xs = xs.sortBy(compare_by (resources >>> S.size)).reverse +sorted xs = xs.sortBy(compare_by (resources > S.size)).reverse name_to_id x = G.tag_id / x diff --git a/src/Panda/Type/Reader.hs b/src/Panda/Type/Reader.hs --- a/src/Panda/Type/Reader.hs +++ b/src/Panda/Type/Reader.hs @@ -5,9 +5,10 @@ import Panda.Helper.PreludeEnv import qualified Data.Map as Map import Text.Pandoc -import Control.Arrow ((>>>)) + import Text.XHtml.Strict import Data.Default +import Panda.Helper.Html data Reader = Markdown | RST | HTML | Latex deriving (Show, Eq) @@ -27,14 +28,14 @@ guess_reader ext = reader_map.Map.lookup ext -to_html r = r defaultParserState >>> writeHtml defaultWriterOptions +to_html r = r defaultParserState > writeHtml defaultWriterOptions -- this list can go on, as long as there is a library that does -- the convertion. pretty extensible, isn't it. rr :: Reader -> String -> Html rr Markdown = to_html readMarkdown rr RST = to_html readRST -rr HTML = primHtml +rr HTML = escape_html_unicode > primHtml rr Latex = to_html readLaTeX render_to_html = rr diff --git a/src/Panda/Type/State.hs b/src/Panda/Type/State.hs --- a/src/Panda/Type/State.hs +++ b/src/Panda/Type/State.hs @@ -5,9 +5,10 @@ import Panda.Model.Tag import Random (randomRs, mkStdGen) import System.Time -import Control.Arrow ((>>>)) + import Panda.Helper.PreludeEnv import Data.Default +import Panda.Model.Post data State = State -- model state @@ -19,12 +20,13 @@ , nav_location :: String , resource_title :: String , human_test_data :: HumanTestData + , latest_posts :: [Post] } deriving (Show) -show_left = human_test_data >>> left >>> show -show_right = human_test_data >>> right >>> show -show_op = human_test_data >>> op >>> display_op +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 @@ -48,7 +50,7 @@ def = Plus instance Default State where - def = State def def def def def def + def = State def def def def def def def ops = [Plus, Minus] @@ -65,6 +67,6 @@ where make_sample [a,b,c] = ((get_num a), (get_num b), (get_op c)) make_sample _ = error "human test sample fail" - good_test = splash3 simple_eval >>> belongs_to nums + 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/Panda/Type/Theme.hs b/src/Panda/Type/Theme.hs --- a/src/Panda/Type/Theme.hs +++ b/src/Panda/Type/Theme.hs @@ -27,7 +27,7 @@ | Js deriving (Eq, Show, Read) -to_theme xs = Theme +to_theme xs = Theme { name = at Name , container = at Container , header = at Header diff --git a/src/Panda/View/Atom/Comment.hs b/src/Panda/View/Atom/Comment.hs --- a/src/Panda/View/Atom/Comment.hs +++ b/src/Panda/View/Atom/Comment.hs @@ -7,7 +7,7 @@ import Panda.Type.State hiding (uid) -- model -import Panda.Model.Comment hiding (create) +import Panda.Model.Comment -- render instance DataRenderer Comment where diff --git a/src/Panda/View/Control/Post.hs b/src/Panda/View/Control/Post.hs --- a/src/Panda/View/Control/Post.hs +++ b/src/Panda/View/Control/Post.hs @@ -21,6 +21,7 @@ import Panda.View.Widget.Template -- 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) diff --git a/src/Panda/View/Widget/Template.hs b/src/Panda/View/Widget/Template.hs --- a/src/Panda/View/Widget/Template.hs +++ b/src/Panda/View/Widget/Template.hs @@ -29,6 +29,6 @@ , only_for Analytics $ primHtml (analytics G.analytics_account_id) ] -template t state x = [html_head state, body t state x] +template t state x = [html_head state, body t state x] .toHtml page = template G.theme