[Initial import. prb@mult.ifario.us**20080103220159] { adddir ./json adddir ./json/src adddir ./json/src/Text adddir ./perpubplat adddir ./perpubplat/src adddir ./perpubplat/src/Blog adddir ./perpubplat/src/Blog/BackEnd adddir ./perpubplat/src/Blog/FrontEnd adddir ./perpubplat/src/Blog/Model adddir ./perpubplat/src/Blog/Widgets adddir ./perpubplat/src/Text adddir ./perpubplat_import adddir ./perpubplat_import/src adddir ./perpubplat_servlet adddir ./perpubplat_servlet/src addfile ./json/LICENSE addfile ./json/Setup.lhs hunk ./json/Setup.lhs 1 +#!/usr/bin/env runghc + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain addfile ./json/json.cabal hunk ./json/json.cabal 1 - +name: json +version: 0.1 +copyright: Masahiro Sakai +description: JSON parsing library using Parsec +license: OtherLicense +license-file: LICENSE +author: sakai@tom.sfc.keio.ac.jp +homepage: http://www.tom.sfc.keio.ac.jp/~sakai/d/?date=20060427#p02 +maintainer: Paul Brown +build-depends: base >= 2.0, parsec >= 2.0, containers >= 0.1, + pretty >= 1.0 +exposed-modules: Text.Json +hs-source-dirs: src +ghc-options: -O -Werror -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches addfile ./json/src/Text/Json.hs hunk ./json/src/Text/Json.hs 1 +----------------------------------------------------------------------------- +-- | +-- Module : JSON +-- Copyright : (c) Masahiro Sakai & Jun Mukai 2006 +-- License : BSD-style +-- +-- Maintainer : sakai@tom.sfc.keio.ac.jp +-- Stability : experimental +-- Portability : portable +-- +----------------------------------------------------------------------------- + +module Text.Json + ( Value (..) + , parse + , json + , stringify + , stringify' + , toDoc + , toDoc' + ) where + +import Control.Monad hiding (join) +import Text.ParserCombinators.Parsec hiding (parse) +import qualified Text.ParserCombinators.Parsec as P +import Text.PrettyPrint.HughesPJ hiding (char) +import Text.Printf (printf) +import Data.Char (ord, chr, isControl) +import Data.List (unfoldr) +import Data.Bits +import qualified Data.Map as M + +-- --------------------------------------------------------------------------- +-- The Value data type + +data Value + = String String + | Number !Double + | Object !(M.Map String Value) + | Array [Value] + | Bool !Bool + | Null + deriving (Eq,Show) + +{- +instance Show Value where + showsPrec p = showsPrec p . toDoc +-} + +-- --------------------------------------------------------------------------- +-- The JSON Parser + +parse :: String -> Maybe Value +parse s = case P.parse json "JSON.parse" s of + Left _ -> Nothing + Right v -> Just v + +json :: Parser Value +json = spaces >> tok value + +tok :: Parser a -> Parser a +tok p = do{ x <- p; spaces; return x } + +value :: Parser Value +value = msum + [ liftM String str + , liftM Number number + , liftM Object object + , liftM Array array + , string "true" >> return (Bool True) + , string "false" >> return (Bool False) + , string "null" >> return Null + ] + +str :: Parser String +str = liftM decodeSurrogatePairs $ + between (char '"') (char '"') $ many c1 + where c1 = satisfy (\c -> not (c=='"' || c=='\\' || isControl c)) + <|> (char '\\' >> c2) + c2 = msum + [ char '"' + , char '\\' + , char '/' + , char 'b' >> return '\b' + , char 'f' >> return '\f' + , char 'n' >> return '\n' + , char 'r' >> return '\r' + , char 't' >> return '\t' + , char 'u' >> do xs <- count 4 hexDigit + return $ read $ "'\\x"++xs++"'" + ] + +number :: Parser Double +number = liftM read $ int >>+ option "" frac >>+ option "" exp + where digits = many1 digit + int = option "" (string "-") >>+ digits + frac = char '.' >>: digits + exp = e >>+ digits + e = oneOf "eE" >>: option "" (string "+" <|> string "-") + (>>+) = liftM2 (++) + (>>:) = liftM2 (:) + +object :: Parser (M.Map String Value) +object = liftM M.fromList $ + between (tok (char '{')) (char '}') $ + tok member `sepBy` tok (char ',') + where member = do k <- tok str + tok (char ':') + v <- value + return (k,v) + +array :: Parser [Value] +array = between (tok (char '[')) (char ']') $ + tok value `sepBy` tok (char ',') + +decodeSurrogatePairs :: String -> String +decodeSurrogatePairs = unfoldr phi + where + phi :: String -> Maybe (Char, String) + phi (h:l:xs) + | '\xD800' <= h && h <= '\xDBFF' && '\xDC00' <= l && l <= '\xDFFF' + = seq c $ Just (c, xs) + where c = chr $ ((ord h .&. 1023) `shiftL` 10 .|. ord l .&. 1023) + 0x10000 + phi (x:xs) = Just (x, xs) + phi [] = Nothing + +-- --------------------------------------------------------------------------- +-- The JSON Printer + +stringify :: Value -> String +stringify = stringify' (const False) + +stringify' :: (Char -> Bool) -> Value -> String +stringify' needEscape = show . toDoc' needEscape + +toDoc :: Value -> Doc +toDoc = toDoc' (const False) + +toDoc' :: (Char -> Bool) -> Value -> Doc +toDoc' needEscape = go + where + go :: Value -> Doc + go (String s) = strToDoc s + go (Number x) + | isInfinite x = error "can't stringify infinity" + | isNaN x = error "can't stringify NaN" + | otherwise = double x + go (Object m) = lbrace <+> join comma members $+$ rbrace + where members = [fsep [strToDoc k <> colon, nest 2 (go v)] + | (k,v) <- M.toList m] + go (Array xs) = lbrack <+> join comma (map go xs) <+> rbrack + go (Bool b) = text $ if b then "true" else "false" + go Null = text "null" + + strToDoc :: String -> Doc + strToDoc = doubleQuotes . text . concatMap f + where f '"' = "\\\"" + f '\\' = "\\\\" + f '\b' = "\\b" + f '\f' = "\\f" + f '\n' = "\\n" + f '\r' = "\\r" + f '\t' = "\\t" + f c | isControl c || needEscape c = + if c < '\x10000' + then printf "\\u%04x" c + else case makeSurrogatePair c of + (h,l) -> printf "\\u%04x\\u%04x" h l + | otherwise = [c] + +join :: Doc -> [Doc] -> Doc +join s = fcat . punctuate s + +makeSurrogatePair :: Char -> (Char,Char) +makeSurrogatePair c = (chr h, chr l) + where c' = ord c + h = (c' - 0x10000) `shiftR` 10 .|. 0xd800 + l = c' .&. 1023 .|. 0xdc00 addfile ./perpubplat/Setup.lhs hunk ./perpubplat/Setup.lhs 1 +#!/usr/bin/env runghc + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain addfile ./perpubplat/perpubplat.cabal hunk ./perpubplat/perpubplat.cabal 1 +name: perpubplat +version: 0.1 +copyright: Copyright 2007 Multifarious, Inc. +description: Personal publishing (i.e., blog) platform. +license: GPL +license-file: LICENSE +author: Paul Brown +homepage: http://datapr0n.com/perpubplat +maintainer: Paul Brown +build-depends: base >= 2.0, parsec >= 2.0, xhtml >= 3000, stm >= 2.0, haskell98, filepath >= 1.0 +exposed-modules: Blog.Entry, Blog.Storage, Blog.Presentation, + Blog.Routes, Blog.Views, Blog.Constants, + Text.Atom +hs-source-dirs: src +ghc-options: -O -Werror -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches addfile ./perpubplat/src/Blog/BackEnd/DataController.hs hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 1 +module Blog.BackEnd.DataController where + +import Blog.Model.Entry +import qualified Blog.BackEnd.ModelTransformations as MT + +import Control.Concurrent ( ThreadId, forkIO ) +import Control.Concurrent.Chan ( Chan, newChan, writeChan, readChan ) + +import System.Log.Logger + +data Request = GetModel { response_channel :: Chan Model } + | IngestDraft { draft_name :: String, + response_channel :: Chan Model } + +data DataController = DataController { request_channel :: Chan Request, + thread_id :: ThreadId } + +spawn_controller :: Model -> IO DataController +spawn_controller m = do { rc <- newChan + ; t <- forkIO (loop rc m) + ; return $ DataController rc t } + +send :: DataController -> Request -> IO () +send = writeChan . request_channel + +get_model :: DataController -> IO Model +get_model c = do { cb <- newChan + ; send c (GetModel cb) + ; readChan cb } + +ingest_draft :: DataController -> String -> IO Model +ingest_draft dc s = do { cb <- newChan + ; send dc $ IngestDraft s cb + ; readChan cb } + +loop :: Chan Request -> Model -> IO () +loop c m = do { req <- readChan c + ; case req of + (GetModel resp) -> + do {writeChan (response_channel req) m + ; loop c m } + (IngestDraft d resp) -> + do { (s,m') <- MT.ingest_draft m d + ; writeChan (response_channel req) m' + ; loop c m' } + } addfile ./perpubplat/src/Blog/BackEnd/IoOperations.hs hunk ./perpubplat/src/Blog/BackEnd/IoOperations.hs 1 - +-- | Assemblage of functions for loading and saving an 'Item' from/to +-- a file. The storage system works on the assumption that a post is +-- stored in a directory named for its permatitle and that comments +-- are then stored in subdirectories. +module Blog.BackEnd.IoOperations where + +import qualified Blog.Model.Entry as B +import qualified Blog.Model.EntryParser as EP +import qualified Blog.Constants as C +import Utilities (readFile') + +-- import System.Log.Logger + +import qualified System.IO as I +import qualified System.FilePath as F +import qualified System.Directory as D +import System.FilePath ((), splitPath) +import Control.Monad (filterM, liftM, msum, mplus) +import List (intersperse,sortBy,sort) + +-- | Load all posts from disk. +boot :: IO B.Model +boot = do { all <- find_all is_content_file is_subdirectory C.content_storage_dir + ; content <- mapM readFile' all + ; return $ B.build_model (map (uncurry EP.item_from_string) (zip all content)) } + +find_all :: (FilePath -> FilePath -> IO Bool) + -> (FilePath -> FilePath -> IO Bool) + -> FilePath -> IO [ FilePath ] +find_all file_test dir_test root = + do { dir_contents <- D.getDirectoryContents root + ; subdirs <- filterM (dir_test root) dir_contents + ; files <- filterM (file_test root) dir_contents + ; others <- mapM (find_all file_test dir_test) (absolutize root subdirs) + ; return $ (absolutize root files) ++ (concat others) } + +absolutize :: FilePath -> [FilePath] -> [FilePath] +absolutize d = map (d ) + +is_content_file :: FilePath -> FilePath -> IO Bool +is_content_file d f = do { is_file <- D.doesFileExist (d f) + ; let is_content = ((last $ splitPath f) == "content.ppp") + ; return $ is_file && is_content } + +is_subdirectory :: FilePath -> FilePath -> IO Bool +is_subdirectory d sd = do { is_dir <- D.doesDirectoryExist (d sd) + ; let is_not_dots = not (sd `elem` [".",".."]) + ; return $ is_dir && is_not_dots } + +save :: B.Model -> B.Item -> IO () +save m i = do { let d = (C.content_storage_dir (B.ancestor_path m i)) + ; D.createDirectoryIfMissing True d + ; writeFile (d "content.ppp") (B.to_string i) } + +dump :: B.Model -> IO () +dump m = mapM_ (save m) (B.all_items m) + +load_content :: FilePath -> IO B.Item +load_content f = load_ $ C.content_storage_dir f "content.ppp" + +load_draft :: FilePath -> IO B.Item +load_draft f = do { content <- readFile' $ C.draft_dir f + ; return $ EP.draft_from_string f $! content } + +load_ :: FilePath -> IO B.Item +load_ f = do { content <- readFile' f + ; return $ EP.item_from_string f $! content } + +update_item :: B.Model -> B.Item -> IO B.Model +update_item m i = do { content <- load_content $ B.ancestor_path m i + ; m' <- B.alter (const content) m i + ; save m' (B.item_by_id m' $ B.internal_id i) + ; return m' } addfile ./perpubplat/src/Blog/BackEnd/ModelTransformations.hs hunk ./perpubplat/src/Blog/BackEnd/ModelTransformations.hs 1 +module Blog.BackEnd.ModelTransformations where + +import Blog.Model.Entry -- unqualified. +import qualified Blog.Constants as C +import qualified Blog.BackEnd.IoOperations as I +import Utilities ( now ) + +import qualified System.Directory as D +import System.FilePath ( () ) +import Data.Char +import Text.ParserCombinators.Parsec + +import System.Time + +ingest_draft :: Model -> String -> IO (String, Model) +ingest_draft model path = do { i <- I.load_draft path + ; let t = to_permatitle $ title i + ; let pt = uniquify_permatitle model t 0 + ; ts <- now + ; let new_item = i { internal_id = next_id model + , permatitle = pt + , created = ts + , updated = ts + , kind = Post } + ; let model' = insert model new_item + ; let plink = permatitle new_item + ; I.save model' new_item + ; return (plink, model') } + + + +-- | Add a comment to the model and storage system, including filling +-- in any necessary fields. All comments are initially set to +-- invisible. +ingest_comment :: Model -> Item -> Item -> IO Model +ingest_comment model p c = do {ts <- now + ; let int_id = next_id model + ; let new_comment = c { internal_id = int_id + , parent = Just $ internal_id p + , created = ts + , updated = ts + , permatitle = "comment-" ++ (show int_id) + , kind = Comment } + ; return $ insert model new_comment } + +to_permatitle :: String -> String +to_permatitle = reverse . snip . reverse . snip . (squish_dashes "") . clean_chars . demarkup + where + snip = dropWhile $ (==) '-' + +clean_chars :: String -> String +clean_chars [] = [] +clean_chars (x:xs) = (t:(clean_chars xs)) + where + t = case (generalCategory x) of + Space -> '-' + UppercaseLetter -> (toLower x) + LowercaseLetter -> x + DecimalNumber -> x + _ -> '-' + +squish_dashes :: String -> String -> String +squish_dashes s [] = reverse s +squish_dashes [] (x:xs) = squish_dashes [x] xs +squish_dashes s@(t:ts) (x:xs) | (t == x) && (x=='-') = squish_dashes s xs + | otherwise = squish_dashes (x:s) xs + +demarkup :: String -> String +demarkup t = case (parse demarkup_parser t t) of + Left err -> error $ show err + Right t' -> concat t' + +demarkup_parser :: Parser [String] +demarkup_parser = many $ try element_parser + <|> try entity_parser + <|> nonmarkup_parser + +nonmarkup_parser :: Parser String +nonmarkup_parser = many1 $ noneOf "&<" + +element_parser :: Parser String +element_parser = char '<' >> (many $ noneOf ">") >> char '>' >> return "" + +entity_parser :: Parser String +entity_parser = char '&' >> (many $ noneOf ";") >> char ';' >> return "" + +uniquify_permatitle :: Model -> String -> Int -> String +uniquify_permatitle m t n = if permatitle_exists m t' then + uniquify_permatitle m t (n+1) + else + t' + where + t' = if n==0 then + t + else + t ++ "-" ++ (show n) addfile ./perpubplat/src/Blog/Constants.hs hunk ./perpubplat/src/Blog/Constants.hs 1 - +-- Constants.hs +module Blog.Constants where + +anonymous_author :: String +anonymous_author = "anonymous coward" + +blog_title :: String +blog_title = "mult.ifario.us" + +blog_title_for_urn :: String +blog_title_for_urn = blog_title + +blog_tagline :: String +blog_tagline = "Software, business, and random related items." + +blog_root :: String +blog_root = "http://mult.ifario.us" + +author_name :: String +author_name = "Paul R. Brown" + +author_email :: Maybe String +author_email = Just "paulrbrown@gmail.com" + +author_uri :: Maybe String +author_uri = Just base_url + +generator_name :: String +generator_name = "perpubplat" + +generator_uri :: String +generator_uri = "http://datapr0n.com/perpubplat" + +generator_version :: String +generator_version = "0.9" + +generator_desc :: String +generator_desc = "Paul's Personal Publishing Platform" + +content_storage_dir :: String +content_storage_dir = "/tmp/content" + +draft_dir :: String +draft_dir = "/tmp/drafts" + +base_url :: String +base_url = "http://localhost:7007" + +stylesheet_url :: String +stylesheet_url = "/static/styles.css" + +default_page_size :: Int +default_page_size = 7 + +feed_length :: Int +feed_length = 25 + +license_xhtml :: String +license_xhtml = "" + ++ "\"Creative" + ++ " Except where otherwise noted, this work is licensed under a " + ++ "Creative Commons Attribution-Share Alike 3.0 United States License." + +tags_to_show :: Int +tags_to_show = 40 + +first_datetime :: String +first_datetime = "1970-01-01T00:00:00Z" addfile ./perpubplat/src/Blog/FrontEnd/Actions.hs hunk ./perpubplat/src/Blog/FrontEnd/Actions.hs 1 +module Blog.FrontEnd.Actions where + +data Action = Ingest { draft :: String } + deriving ( Show, Eq ) addfile ./perpubplat/src/Blog/FrontEnd/Feeds.hs hunk ./perpubplat/src/Blog/FrontEnd/Feeds.hs 1 +module Blog.FrontEnd.Feeds + ( Feed ( AllPosts, ByTag, ByTags, PostComments, AllComments), + DiscoverableFeed ( feed_title, feed_url ), + Feedable ( items, categories, build_id, title, self_url, home_url, discoverable_feed ), + articles_feed, all_comments_feed, comments_feed, tags_feed + ) where + +import qualified Blog.FrontEnd.Urls as U +import qualified Blog.Constants as C +import qualified Blog.Model.Entry as B +import Utilities (subst) + +import List (intersperse) + +data Feed = AllPosts + | ByTag { tag :: String } + | ByTags { tags :: [String] } + | PostComments { permalink :: String } + | AllComments + deriving ( Show, Eq ) + +type Iri = String + +data DiscoverableFeed = DiscoverableFeed { feed_title :: String, feed_url :: String } + deriving ( Show ) + +class Feedable f where + -- | construct the posts for the feed from a list of all visible posts in time-sorted order + items :: f -> B.Model -> [B.Item] + -- | construct a set of categories, potentially empty + categories :: f -> [String] + -- | construct the @rel="self"@ URL for the feed + self_url :: f -> String + -- | construct the home URL for the feed + home_url :: f -> String + -- | construct the @atom:id@ for the feed + build_id :: f -> Iri + -- | construct the title for the feed + title :: f -> String + -- | construct the autodiscovery feed for this feed + discoverable_feed :: f -> DiscoverableFeed + discoverable_feed f = DiscoverableFeed { feed_title = title f, feed_url = self_url f} + +instance Feedable Feed where + items AllPosts m = (take C.feed_length) . B.all_posts $ m + items (ByTag t) m = (take C.feed_length) . (B.tag_filter t) . B.all_posts $ m + items (ByTags t) m = (take C.feed_length) . (B.tags_filter t) . B.all_posts $ m + items AllComments m = ((take C.feed_length) . (B.concat_comments m) . B.all_posts) m + items (PostComments t) m = ((take C.feed_length) . (B.concat_comments m) . (B.plink_filter t) . B.all_posts) m + + categories (AllPosts) = [] + categories (ByTag t) = [t] + categories (ByTags t) = t + categories (AllComments) = [] + categories (PostComments _) = [] + + self_url AllPosts = feed_ "a" + self_url (ByTag t) = feed_ ("t/" ++ t) + self_url (ByTags t) = feed_ ("t/" ++ (U.tags_fragment t)) + self_url (PostComments t) = feed_ ("c/p/" ++ t) + self_url AllComments = feed_ "c" + + home_url AllPosts = U.all_posts + home_url (ByTag t) = U.posts_by_tag t + home_url (ByTags t) = U.posts_by_tags t + home_url (PostComments t) = U.post t + home_url AllComments = U.all_posts + + title AllPosts = C.blog_title ++ " - All Posts" + title (ByTags t) = C.blog_title ++ " - Posts Tagged {" + ++ (concat $ intersperse ", " t) ++ "}" + title (ByTag t) = C.blog_title ++ " - Posts Tagged {" ++ t ++ "}" + title (PostComments t) = C.blog_title ++ " - Comments on " ++ t + title AllComments = C.blog_title ++ " - Comments on Recent Posts" + + + build_id AllPosts = ppp_urn ++ "posts:atom:all" + build_id (ByTags t) = ppp_urn ++ "posts:atom:by_tags(" ++ (U.tags_fragment t) ++ ")" + build_id (ByTag t) = ppp_urn ++ "posts:atom:by_tags(" ++ t ++ ")" + build_id (PostComments t) = ppp_urn ++ "comments:atom:by_permatitle(" ++ t ++ ")" + build_id AllComments = ppp_urn ++ "comments:atom:all" + +ppp_urn :: String +ppp_urn = "urn:perpubplat:" ++ C.blog_title_for_urn ++ ":" + +feed_ :: String -> String +feed_ s = C.base_url ++ "/f/" ++ s ++ "/atom.xml" + +articles_feed :: DiscoverableFeed +articles_feed = discoverable_feed AllPosts + +all_comments_feed :: DiscoverableFeed +all_comments_feed = discoverable_feed AllComments + +comments_feed :: String -> DiscoverableFeed +comments_feed = discoverable_feed . PostComments + +tags_feed :: [String] -> DiscoverableFeed +tags_feed = discoverable_feed . ByTags + +tag_feed :: String -> DiscoverableFeed +tag_feed = discoverable_feed . ByTag + +pad_ :: Int -> String +pad_ i | i < 10 = "-0" ++ (show i) + | otherwise = ('-':(show i)) addfile ./perpubplat/src/Blog/FrontEnd/Presentation.hs hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 1 +-- | Module for presentation of entries and lists of entries as XHTML +-- fragments and/or pages, as appropriate. +module Blog.FrontEnd.Presentation where + +import Text.XHtml.Strict +import qualified Blog.Model.Entry as B +import qualified Blog.Constants as C +import qualified Blog.FrontEnd.Views as V +import qualified Blog.FrontEnd.Feeds as F +import qualified Blog.FrontEnd.Urls as U +import qualified Blog.Widgets.TagCloud as TC +import qualified Blog.Widgets.DeliciousBadge as DB +import qualified Blog.Widgets.DeliciousSidebarBadge as DSB +import qualified Blog.Widgets.RedditBadge as RB +import qualified Blog.Widgets.FlickrBadge as FB + +import List + +-- | Put the page together, including navigation at the top or bottom, +-- stylesheet, feeds URLs, etc. +assemble_page :: (V.Viewable v) => v -- ^ the kind of page to display + -> B.Model -- ^ all of the posts in the blog + -> String +assemble_page v m | paged_posts == [] = "" + | otherwise = showHtml ( header ( (thetitle . stringToHtml $ V.title v) + +++ (build_base) + +++ (build_discoverable_feeds v) + +++ stylesheet + +++ (robots v) + ) + +++ body ( container ( heading + +++ (post_div $ phunk + +++ bottom_nav v m) + +++ (sidebar v m paged_posts) + +++ footer ) + ) + ) + where + posts = (V.lens v) . B.all_posts $ m + paged_posts = (V.page v) $ posts + phunk = renderer v m $ paged_posts + +robots :: (V.Viewable v) => v -> Html +robots w = if (V.kind w == V.Single) then + meta ! [ name "ROBOTS", content "INDEX, FOLLOW"] + else + meta ! [ name "ROBOTS", content "NOINDEX, FOLLOW"] + +container :: Html -> Html +container h = thediv ! [ identifier "container" ] << h + +post_div :: Html -> Html +post_div h = thediv ! [ identifier "posts" ] << h + +nav_blurb :: (V.Viewable v) => v -> B.Model -> Html +nav_blurb w m = concatHtml [ bold . stringToHtml $ V.title w + , stringToHtml " contains " + , bold . stringToHtml . show $ length ((V.lens w) . B.all_posts $ m) + , stringToHtml" items in " + , bold . stringToHtml . show $ V.page_count w m + , stringToHtml " pages of " + , bold . stringToHtml . show $ V.page_size w + , stringToHtml " items each: " ] + +bottom_nav :: (V.Viewable v) => v -> B.Model -> Html +bottom_nav w m | (V.kind w == V.Single) || ((V.page_count w m) == 1) = noHtml + | otherwise = thediv ! [ identifier "bottomnav" ] << + ( p . concatHtml $ [ nav_blurb w m + , br + , pages w m ] ) + +sidebar_nav :: (V.Viewable v) => v -> B.Model -> Html +sidebar_nav w m | (V.kind w == V.Single) || ((V.page_count w m) == 1) = noHtml + | otherwise = (h3 << stringToHtml "Navigation") + +++ ( p ! [ theclass "navigation" ] << ( concatHtml $ [ nav_blurb w m + , br + , pages w m ] ) ) + +pages :: (V.Viewable v) => v -> B.Model -> Html +pages w m = concatHtml + $ (intersperse $ stringToHtml " ") + $ page_nav (V.first_page w) n current_page 1 + where + n = V.page_count w m + current_page = unwrap $ V.page_number w + +page_nav :: (V.Viewable v) => v -> Int -> Int -> Int -> [Html] +page_nav w n current_page i = atm:ps + where + pln = bold . stringToHtml $ show i + lnk = _at (V.url w) (show i) + atm = if (i == current_page) then + pln + else + lnk + ps = if (n==i) then + [] + else + page_nav (V.next_page w) n current_page (i+1) + +unwrap :: Maybe Int -> Int +unwrap Nothing = 1 +unwrap (Just n) = n + +heading :: Html +heading = thediv ! [ identifier "header" ] << ( (h1 $ _at (V.url $ V.All Nothing) C.blog_title) + +++ + (h2 $ stringToHtml C.blog_tagline) ) + +footer :: Html +footer = thediv ! [ identifier "footer" ] << concatHtml [ p ! [ theclass "copyright" ] + << primHtml C.license_xhtml + , p ! [ theclass "generator" ] + << generator_tagline ] + where + generator_tagline = concatHtml [ stringToHtml "Running " + , _at C.generator_uri C.generator_name + , stringToHtml " version " + , stringToHtml C.generator_version ] + +-- Come back to this +sidebar :: (V.Viewable v) => v -> B.Model -> [B.Item] -> Html +sidebar w b p = thediv ! [ identifier "sidebar" ] + << concatHtml [ sidebar_nav w b + , contents_block "sidebarcontents" w b p + , h3 $ stringToHtml "Tags" + , TC.tag_cloud (B.all_posts b) C.tags_to_show +-- , sharing_block w b p + , h3 $ stringToHtml "Pictures" + , FB.flickr_badge ] + + +sharing_block :: (V.Viewable v) => v -> B.Model -> [B.Item] -> Html +sharing_block w b p | (V.kind w /= V.Single) = noHtml + | otherwise = concatHtml [ h3 $ stringToHtml "Sharing" + , DSB.delicious_sidebar_badge + , RB.reddit_badge (B.permalink b $ head p) "" ] + +contents_block :: (V.Viewable v) => String -> v -> B.Model -> [B.Item] -> Html +contents_block s w b i | (V.kind w == V.Single) = noHtml + | otherwise = concatHtml [ h3 . stringToHtml $ concat [ "Page " + , maybe_page_number + , " Contents"] + + , thediv ! [ theclass s ] << + ( concatHtml . (map (p . (contents_item b))) $ i) ] + where + maybe_page_number = if (V.page_count w b) > 1 then + show . unwrap . V.page_number $ w + else + "" + +contents_item :: B.Model -> B.Item -> Html +contents_item m i = stringToHtml ((take 10 $ B.created i) ++ " > ") +++ _a (B.permalink m i) (primHtml $ B.title i) + +build_base :: Html +build_base = thebase ! [ href C.base_url ] + +build_discoverable_feeds ::(V.Viewable v) => v -> Html +build_discoverable_feeds v = concatHtml $ map disc_feed (V.discoverable_feeds v) + +disc_feed :: F.DiscoverableFeed -> Html +disc_feed f = thelink ! [ rel "alternate", + thetype "application/atom+xml", + title $ F.feed_title f, + href $ F.feed_url f ] << noHtml + +stylesheet :: Html +stylesheet = thelink ! [ href C.stylesheet_url, rel "stylesheet", thetype "text/css" ] << noHtml + +-- Paging should occur before this function is applied. +renderer :: (V.Viewable v) => v -> B.Model -> [B.Item] -> Html +renderer v _ [] = no_posts $ V.no_posts_message v +renderer v m l = if (V.kind v == V.Single) then + render_post_detail m $ head l + else + render_posts m l + + +no_posts :: String -> Html +no_posts s = p ! [ theclass "no_posts" ] << (stringToHtml s) + +-- | Render a detail view of a single post, i.e., the post body +-- along with the comments. +render_post_detail :: B.Model -> B.Item -> Html +render_post_detail = render_ render_comments_as_text + +-- | Render a list of posts with the post bodies and comments as counts +-- only. +render_posts :: B.Model -> [B.Item] -> Html +render_posts m = concatHtml . map (render_ render_comments_as_count m) + +render_ :: (B.Model -> B.Item -> Html) -> B.Model -> B.Item -> Html +render_ render_comments m i + = ( thediv ( (post_heading m i) + +++ (render_body "entry" i) + +++ (render_tags i) ) + ! [ theclass "entry_wrapper" ] ) + +++ (render_comments m i) + +render_comments_as_count :: B.Model -> B.Item -> Html +render_comments_as_count m i = p << case (length $ B.children m i) of + 0 -> stringToHtml "No comments." + 1 -> _at (U.comments $ B.permalink m i) "One comment." + n -> _at (U.comments $ B.permalink m i) ((show n) ++ " comments.") + +render_comments_as_count' :: B.Model -> B.Item -> Html +render_comments_as_count' m i = p << anchor ! [ name "comments" ] << stringToHtml x + where + x = case (length $ B.children m i) of + 0 -> "No comments." + 1 -> "One comment." + n -> ((show n) ++ " comments.") + + +-- Render a list of comments from the post +render_comments_as_text :: B.Model -> B.Item -> Html +render_comments_as_text m i = thediv ( (render_comments_as_count' m i) +++ x ) ! [ theclass "comments" ] + where + x = case (length $ B.children m i) of + 0 -> noHtml + _ -> concatHtml (map (render_comment_as_text m i) (B.children m i)) + +-- Render a single comment +render_comment_as_text :: B.Model -> B.Item -> B.Item -> Html +render_comment_as_text m px i = thediv ( (comment_heading m px i) + +++ (render_body "comment" i) ) + ! [ theclass "commentwrapper" ] + +post_heading :: B.Model -> B.Item -> Html +post_heading m i = h2 (_a (B.permalink m i) (primHtml$B.title i)) + +++ p ( ( post_author$B.author i) + +++ (timestamp i)) + +{- +no_sharing :: B.Item -> Html +no_sharing = const $ noHtml + +sharing_as_badges :: B.Item -> Html +sharing_as_badges i = concatHtml [ h3 ! [ theclass "sharing" ] + << ( stringToHtml "Share \"" + +++ title + +++ stringToHtml "\"" ) + , RB.reddit_badge (post_permalink i) ("test") + , DB.delicious_badge ] + where + title = primHtml $ B.title i +-} + +comment_heading :: B.Model -> B.Item -> B.Item -> Html +comment_heading model px comment + = p ( (stringToHtml "Comment from ") + +++ (comment_author$B.author comment) + +++ (timestamp comment) + +++ (stringToHtml " ") + +++ (anchor ! [ name (B.permatitle comment)] << stringToHtml "#") + +++ (stringToHtml " ") + +++ (_at (B.permalink model comment) "permalink")) + ! [ theclass "commentattribution" ] + +timestamp :: B.Item -> Html +timestamp post = stringToHtml( " @ " ++ (B.created post)) + +comment_author :: B.Author -> Html +comment_author (B.Author n (Just u) _ _) = emphasize ( _at u n ) +comment_author (B.Author n Nothing _ _) = emphasize (stringToHtml n) + +post_author :: B.Author -> Html +post_author (B.Author n _ (Just e) True) = emphasize (_at ("mailto:" ++ e) n) +post_author (B.Author n _ _ False) = emphasize (stringToHtml n) + +_a :: String -> Html -> Html +_a s h = toHtml (hotlink s h) + +_at :: String -> String -> Html +_at s t = toHtml (hotlink s (stringToHtml t)) + +{- Come back and add comment count. -} +render_heading :: B.Model -> B.Item -> Html +render_heading m i = h2 ( _at (B.permalink m i) (B.title i) ) + ! [ theclass "title entry-title" ] + +-- | Compute the link for a specific tag; uses the base URL for the app. +tag_link :: String -- ^ the tag + -> String +tag_link tag = "/t/" ++ tag + +-- | Render a single tag as a hyperlinked word +render_tag :: String -- ^ the tag name + -> Html +render_tag tag = (_a (tag_link tag) t) + ! [ rel "tag" ] + where + t = stringToHtml ("[" ++ tag ++ "]") + +-- | Render the tags from a post as Html +render_tags :: B.Item -- ^ the post + -> Html +render_tags b | (B.tags b) == [] = p ( stringToHtml "No tags." ) + ! [ theclass "tags" ] +render_tags b = p ( (stringToHtml "Tags: ") + +++ concatHtml ( intersperse (stringToHtml " ") + (map render_tag ( B.tags b)) ) ) + ! [ theclass "tags" ] + +unM :: Maybe String -> String +unM Nothing = error "Shouldn't try to unwrap Nothing..." +unM (Just s) = s + +sub_for_nothing :: String -> Maybe String -> String +sub_for_nothing s Nothing = s +sub_for_nothing s (Just t) = t + +-- | Wrap a raw text post body in a @
@. +render_body :: String -- ^ the CSS class to apply + -> B.Item -- ^ the item containing the body + -> Html +render_body clazz b = thediv ( primHtml$B.body b ) + ! [ theclass clazz ] addfile ./perpubplat/src/Blog/FrontEnd/Routes.hs hunk ./perpubplat/src/Blog/FrontEnd/Routes.hs 1 +-- | +module Blog.FrontEnd.Routes (parse_uri, + Route (XhtmlView, AtomFeed, NoSuchUri, Command, + view, feed, uri, command) + ) where + +import Text.ParserCombinators.Parsec +import List (sort, intersperse) +import qualified Blog.FrontEnd.Views as V +import qualified Blog.FrontEnd.Feeds as F +import qualified Blog.FrontEnd.Actions as A + +data Route = XhtmlView { view :: V.View } + | AtomFeed { feed :: F.Feed } + | Command { command :: A.Action } + | NoSuchUri { uri :: String } + deriving (Show, Eq) + +parse_uri :: String -> Route +parse_uri u = case (parse uriParser "" u) of + Left err -> NoSuchUri $ u + Right v -> v + +uriParser :: Parser Route +uriParser = try pages + <|> try commands + <|> do { s <- many anyChar + ; return $ NoSuchUri s } + +pages :: Parser Route +pages = do { get_method + ; try single_article + <|> try articles_by_tags + <|> try articles + <|> feeds } + +get_method :: Parser String +get_method = do { string "GET " } + +post_method :: Parser String +post_method = do { string "POST " } + +commands :: Parser Route +commands = do { post_method + ; (try $ string "/commands") <|> string "/c" + ; ingest_draft } + +ingest_draft :: Parser Route +ingest_draft = do { string "/post-draft/" + ; s <- many1 anyChar + ; return $ Command $ A.Ingest s } + +feeds :: Parser Route +feeds = do { (try $ string "/feeds") <|> string "/f" + ; try articles_feed + <|> try comments_feeds + <|> try tag_feed + <|> try tags_feed + <|> article_comments_feed } + +articles_feed :: Parser Route +articles_feed = do { (try $ string "/articles") <|> string "/a" + ; atom_xml + ; return $ AtomFeed F.AllPosts } + +comments_feeds :: Parser Route +comments_feeds = try all_comments_feed + <|> article_comments_feed + +all_comments_feed :: Parser Route +all_comments_feed = do { (try $ string "/comments") <|> string "/c" + ; atom_xml + ; return $ AtomFeed F.AllComments } + +article_comments_feed :: Parser Route +article_comments_feed = do { (try $ string "/comments/p/") <|> string "/c/p/" + ; t <- p_plink_title + ; atom_xml + ; return $ AtomFeed $ F.PostComments t } + +tag_feed :: Parser Route +tag_feed = do { string "/tag/" + ; t <- p_tag_name + ; atom_xml + ; return $ AtomFeed $ F.ByTag t } + +tags_feed :: Parser Route +tags_feed = do { (try $ string "/tags/") <|> string "/t/" + ; ts <- (p_tag_name `sepBy1` (char ',')) + ; atom_xml + ; return $ AtomFeed $ F.ByTags (sort ts) } + +atom_xml :: Parser () +atom_xml = do { string "/atom.xml" + ; eof } + +articles :: Parser Route +articles = do { (try $ string "/articles") <|> string "/a" + ; try all_articles + <|> try single_article + <|> try articles_by_date + <|> try articles_by_tag + <|> articles_by_tags } + +all_articles :: Parser Route +all_articles = do { p <- page + ; return $ XhtmlView $ V.All p } + +single_article :: Parser Route +single_article = do { string "/p/" + ; t <- p_plink_title + ; eof + ; return $ XhtmlView $ V.ByPermatitle t } + +articles_by_tag :: Parser Route +articles_by_tag = do { string "/tag/" + ; t <- p_tag_name + ; p <- page + ; return $ XhtmlView $ V.ByTag t p } + +articles_by_tags :: Parser Route +articles_by_tags = do { (try $ string "/t/") <|> string "/tags/" + ; ts <- (p_tag_name `sepBy1` (char ',')) + ; p <- page + ; return $ XhtmlView $ V.ByTags (sort ts) p } + +articles_by_date :: Parser Route +articles_by_date = do { char '/' + ; y <- p_int + ; try $ do { p <- page + ; return $ XhtmlView $ V.ByYear y p } + <|> do { char '/' + ; m <- p_int + ; try $ do { p <- page + ; return $ XhtmlView $ V.ByMonth y m p } + <|> do { char '/' + ; d <- p_int + ; try $ do { p <- page + ; return $ XhtmlView $ V.ByDay y m d p } + <|> do { char '/' + ; title <- p_plink_title + ; eof + ; return $ XhtmlView $ V.ByYMDPermatitle y m d title } + } + } + } + +page :: Parser (Maybe Int) +page = do { try $ do { eof + ; return Nothing } + <|> do { (try $ string "/p/") <|> string "/page/" + ; i <- p_int + ; eof + ; return $ Just i } } + +p_plink_title :: Parser String +p_plink_title = many1 (alphaNum <|> char '-' <|> char '_') + +p_int :: Parser Int +p_int = do { i <- many1 digit "digits" + ; return (read i) } + +-- todo : tolerate spaces in tags? +p_tag_name :: Parser String +p_tag_name = many1 (alphaNum <|> char '-' <|> char '_') addfile ./perpubplat/src/Blog/FrontEnd/Syndication.hs hunk ./perpubplat/src/Blog/FrontEnd/Syndication.hs 1 - +module Blog.FrontEnd.Syndication ( assemble_feed ) where + +import qualified Blog.Model.Entry as B +import qualified Blog.Constants as C +import qualified Blog.FrontEnd.Feeds as F +import qualified Text.Atom as A + +assemble_feed :: (F.Feedable f) => f -> B.Model -> String +assemble_feed g m + = A.toXml $ A.Feed ( [ A.Author C.author_name C.author_uri C.author_email ] + ++ (map A.Category categories) + ++ [ A.Generator C.generator_name C.generator_uri C.generator_version + , A.Id $ F.build_id g + , A.Link "self" $ F.self_url g + , A.Title $ A.AtomContent A.XHTML (F.title g) + , A.Updated l_u] + ++ map (to_entry m) items ) + where + l_u = if (items == []) then + C.first_datetime + else + last_updated (B.flatten m items) + items = F.items g m + categories = F.categories g + +atomize_author :: B.Author -> A.AtomElement +atomize_author a = A.Author { A.author_name = anonymize_blank $ B.name a + , A.author_uri = B.uri a + , A.author_email = if B.show_email a then + B.email a + else + Nothing } + +anonymize_blank :: String -> String +anonymize_blank "" = C.anonymous_author +anonymize_blank s = s + +last_updated :: [B.Item] -> String +last_updated [] = C.first_datetime +last_updated is = maximum $ map B.updated is + +to_entry :: B.Model -> B.Item -> A.AtomElement +to_entry m i = A.Entry ( [ atomize_author $ B.author i ] + ++ ( map A.Category (B.tags i) ) + ++ [ A.Content $ A.AtomContent A.XHTML (B.body i) + , A.Id ( plink ) + , A.Link { A.rel = "alternate" + , A.href = plink } + , A.Published $ B.created i ] + ++ atomize_summary i + ++ [ A.Title $ A.AtomContent A.XHTML (B.title i) + , A.Updated $ B.updated i ] ) + where + plink = B.permalink m i + +atomize_summary :: B.Item -> [ A.AtomElement ] +atomize_summary i | B.summary i == Nothing = [] + | otherwise = [ A.Summary $ A.AtomContent A.XHTML s ] + where + s = unwrap $ B.summary i + +unwrap :: Maybe a -> a +unwrap (Just s) = s addfile ./perpubplat/src/Blog/FrontEnd/Urls.hs hunk ./perpubplat/src/Blog/FrontEnd/Urls.hs 1 - +module Blog.FrontEnd.Urls where + +import Blog.Constants as C +import List (intersperse) + +all_posts :: String +all_posts = C.base_url ++ "/articles" + +posts_by_tag :: String -> String +posts_by_tag t = "/t/" ++ t + +posts_by_tags :: [String] -> String +posts_by_tags t = "/t/" ++ (tags_fragment t) + +post :: String -> String +post p = C.base_url ++ "/p" ++ p + +comments :: String -> String +comments p = p ++ "#comments" + +tags_fragment :: [String] -> String +tags_fragment = concat . (intersperse ",") addfile ./perpubplat/src/Blog/FrontEnd/Views.hs hunk ./perpubplat/src/Blog/FrontEnd/Views.hs 1 - +module Blog.FrontEnd.Views + ( View ( All, ByYear, ByMonth, ByDay, + ByTag, ByTags, + ByYMDPermatitle, ByPermatitle + ), + Viewable ( url, kind, lens, title, discoverable_feeds, + page_number, page_size, no_posts_message, next_page, + first_page ), + ViewKind ( Single, Multiple ), + page, last_page, page_count, page_ + ) where + +import qualified Blog.Constants as C +import qualified Blog.Model.Entry as B +import qualified Blog.FrontEnd.Feeds as F +import Text.XHtml.Strict (renderHtml) +import List (sort, intersperse, isPrefixOf, isSuffixOf) +import Utilities (subst) + +data View = All { page_n :: Maybe Int } + | ByYear { year :: Int, page_n :: Maybe Int } + | ByMonth { year :: Int, month :: Int, page_n :: Maybe Int } + | ByDay { year :: Int, month :: Int, day :: Int, page_n :: Maybe Int } + | ByTags { tags :: [String], page_n :: Maybe Int } + | ByTag { tag :: String, page_n :: Maybe Int } + | ByYMDPermatitle { year :: Int, month :: Int, day :: Int, + permalink :: String } + | ByPermatitle { permalink :: String } + deriving ( Show, Eq ) + +data ViewKind = Single | Multiple + deriving ( Show, Eq ) + +class Viewable v where + url :: v -> String + kind :: v -> ViewKind + lens :: v -> [B.Item] -> [B.Item] + title :: v -> String + discoverable_feeds :: v -> [F.DiscoverableFeed] + page_number :: v -> Maybe Int + page_size :: v -> Int + no_posts_message :: v -> String + next_page :: v -> v + first_page :: v -> v + +url_ :: View -> String +url_ (All _) = "/a" +url_ (ByYear y _) = "/a/" ++ (show y) +url_ (ByTag t _) = "/t/" ++ t +url_ (ByTags t _) = "/t/" ++ (concat $ intersperse "," t) +url_ (ByMonth y m _) = "/a/" ++ (show y) ++ "/" ++ (pad_ m) +url_ (ByDay y m d _) = "/a/" ++ (show y) ++ "/" ++ (pad_ m) ++ "/" ++ (pad_ d) +url_ (ByPermatitle t) = "/p/" ++ t +url_ (ByYMDPermatitle y m d t) = "/p/" ++ t + + +instance Viewable View where + page_number (ByYMDPermatitle _ _ _ _) = Nothing + page_number (ByPermatitle _) = Nothing + page_number v = page_n v + + url v = (url_ v) ++ ((page_suffix . page_number) v) + + page_size (All _) = C.default_page_size + page_size (ByYear _ _) = C.default_page_size + page_size (ByMonth _ _ _) = C.default_page_size + page_size (ByDay _ _ _ _) = C.default_page_size + page_size (ByTag _ _) = C.default_page_size + page_size (ByTags _ _) = C.default_page_size + page_size (ByYMDPermatitle _ _ _ _) = 1 + page_size (ByPermatitle _) = 1 + + no_posts_message (ByYear y _) = "No posts from year " ++ (show y) ++ " were found." + no_posts_message (ByMonth y m _) = "No posts from " ++ (show y) ++ (pad_ m) ++ " were found." + no_posts_message (ByDay y m d _) = "No posts were made on " ++ (show y) ++ (pad_ m) ++ (pad_ d) ++ "." + no_posts_message (ByTags t _) = "No posts are in the intersection of the tags {" ++ + (concat $ intersperse "," t) ++ "}." + no_posts_message (ByTag t _) = "No posts are tagged " ++ t ++ "." + no_posts_message (ByYMDPermatitle y m d t) = "No posts with permatitle " ++ t ++ " were made on" + ++ (show y) ++ (pad_ m) ++ (pad_ d) + ++ "; try the same URL without the " + ++ "/" ++ (show y) ++ "/" ++ (pad_ m) ++ "/" + ++ (pad_ d) ++ " fragment." + no_posts_message (ByPermatitle t) = "No post with permatitle " ++ t ++ " was found." + no_posts_message (All _) = "No posts were found at all... Something's fishy." + + discoverable_feeds (All _) = [F.articles_feed, F.all_comments_feed] + discoverable_feeds (ByYear _ _) = [F.articles_feed, F.all_comments_feed] + discoverable_feeds (ByMonth _ _ _) = [F.articles_feed, F.all_comments_feed] + discoverable_feeds (ByDay _ _ _ _) = [F.articles_feed, F.all_comments_feed] + discoverable_feeds (ByYMDPermatitle _ _ _ t) = [F.articles_feed, F.all_comments_feed, F.comments_feed t] + discoverable_feeds (ByPermatitle t) = [F.articles_feed, F.all_comments_feed, F.comments_feed t] + discoverable_feeds (ByTag t _) = [F.articles_feed, F.all_comments_feed, F.tags_feed [t]] + discoverable_feeds (ByTags t _) = [F.articles_feed, F.all_comments_feed, F.tags_feed t] + + kind (All _) = Multiple + kind (ByYear _ _) = Multiple + kind (ByMonth _ _ _) = Multiple + kind (ByDay _ _ _ _) = Multiple + kind (ByTag _ _) = Multiple + kind (ByTags _ _) = Multiple + kind (ByYMDPermatitle _ _ _ _) = Single + kind (ByPermatitle _) = Single + + lens (All _) = filter $ ((==) B.Post) . B.kind + lens (ByYear y _) = B.year_filter y + lens (ByMonth y m _) = B.month_filter y m + lens (ByDay y m d _) = B.day_filter y m d + lens (ByTag t _) = B.tag_filter t + lens (ByTags t _) = B.tags_filter t + lens (ByYMDPermatitle y m d t) = B.ymd_plink_finder y m d t + lens (ByPermatitle t) = B.plink_filter t + + title (All _) = "All Posts" + title (ByYear y _) = show y + title (ByMonth y m _) = (show y) ++ "/" ++ (show m) + title (ByDay y m d _) = (show y) ++ "/" ++ (show m) ++ "/" ++ (show d) + title (ByTag t _) = "Posts tagged \"" ++ t ++ "\"" + title (ByTags t _) = "Posts tagged " ++ (show t) + title (ByYMDPermatitle _ _ _ t) = t + title (ByPermatitle t) = t + + first_page (All _) = All $ Just 1 + first_page (ByYear y _) = ByYear y $ Just 1 + first_page (ByMonth y m _) = ByMonth y m $ Just 1 + first_page (ByDay y m d _) = ByDay y m d $ Just 1 + first_page (ByTag t _) = ByTag t $ Just 1 + first_page (ByTags t _) = ByTags t $ Just 1 + + next_page (All Nothing) = All $ Just 2 + next_page (All (Just a)) = All $ Just (a+1) + next_page (ByYear y Nothing) = ByYear y $ Just 2 + next_page (ByYear y (Just a)) = ByYear y $ Just (a+1) + next_page (ByMonth y m Nothing) = ByMonth y m $ Just 2 + next_page (ByMonth y m (Just a)) = ByMonth y m $ Just (a+1) + next_page (ByDay y m d Nothing) = ByDay y m d $ Just 2 + next_page (ByDay y m d (Just a)) = ByDay y m d $ Just (a+1) + next_page (ByTag t Nothing) = ByTag t $ Just 2 + next_page (ByTag t (Just a)) = ByTag t $ Just (a+1) + next_page (ByTags ts Nothing) = ByTags ts $ Just 2 + next_page (ByTags ts (Just a)) = ByTags ts $ Just (a+1) + + +page_suffix :: Maybe Int -> String +page_suffix Nothing = "" +page_suffix (Just n) = "/page/" ++ (show n) + +page :: (Viewable v) => v -> [a] -> [a] +page v = page_ (page_size v) (one_if_nothing $ page_number v) + +one_if_nothing :: Maybe Int -> Int +one_if_nothing Nothing = 1 +one_if_nothing (Just s) = s + +page_ :: Int -- ^ the page size + -> Int -- ^ the page index, starting from 1 + -> [a] -- ^ the list to page through + -> [a] +page_ _ _ [] = [] +page_ s i l | i < 1 = page_ s 1 l + | i <= last_page s l = take s (drop (s*(i-1)) l) + | otherwise = page_ s (last_page s l) l + +last_page :: Int -> [a] -> Int +last_page s as = (((length as) - 1) `div` s) + 1 + +page_count :: (Viewable v) => v -> B.Model -> Int +page_count w m = last_page (page_size w) ((lens w) (B.all_items m)) + +pad_ :: Int -> String +pad_ n | n < 10 = '0':(show n) + | otherwise = show n addfile ./perpubplat/src/Blog/Model/Entry.hs hunk ./perpubplat/src/Blog/Model/Entry.hs 1 - +-- | Data structures for an item (post or comment) and the +-- overall structure in terms of parents and children. +module Blog.Model.Entry where + +import qualified Blog.FrontEnd.Urls as U +import Utilities +import qualified Blog.Constants as C + +import Maybe +import List ( sortBy, groupBy, isPrefixOf, intersperse) +import qualified Data.Map as M +import Data.Map ( (!) ) + +type ISO8601DatetimeString = String +type XhtmlString = String + +-- | Overall data model for the runtime. +data Model = Model { -- | + by_permatitle :: M.Map String Item, + by_int_id :: M.Map Int Item, + child_map :: M.Map Int [Int], + all_items :: [Item], + next_id :: Int } + +empty :: Model +empty = Model M.empty M.empty M.empty [] 0 + +data Kind = Post | Comment | Trackback + deriving (Show, Read, Eq) + +build_model :: [Item] -> Model +build_model items = Model (map_by permatitle sorted_items) + bid + (build_child_map sorted_items) + (sorted_items) + (n+1) + where + sorted_items = sort_by_created_reverse items + bid = (map_by internal_id sorted_items) + n = fst . M.findMax $ bid + +build_child_map :: [Item] -> M.Map Int [Int] +build_child_map i = build_child_map_ (M.fromList $ (map (\x -> (internal_id x,[])) i)) i + +-- Constructed to take advantage of the input being in sorted order. +build_child_map_ :: M.Map Int [Int] -> [Item] -> M.Map Int [Int] +build_child_map_ m [] = m +build_child_map_ m (i:is) = if (parent i == Nothing) then + build_child_map_ m is + else + build_child_map_ (M.insertWith (++) (unwrap $ parent i) [internal_id i] m) is + +-- | Insert an item, presuming that all of its data other than +-- internal identifier have been correctly set and that its parent, if +insert :: Model -> Item -> Model +insert m i = m { by_permatitle = M.insert (permatitle i') i' $ by_permatitle m + , by_int_id = M.insert (internal_id i') i' $ by_int_id m + , child_map = if (parent i == Nothing) then + M.insert (internal_id i') [] $ child_map m + else + M.insert p_id (insert_comment_ m p i') $ child_map m + , all_items = insert_ (all_items m) i' + , next_id = n + 1 } + where + n = next_id m + i' = i { internal_id = n } + p_id = unwrap $ parent i + p = item_by_id m p_id + +insert_comment_ :: Model -> Item -> Item -> [Int] +insert_comment_ m p c = map internal_id (insert_ (children m p) c) + +insert_ :: [Item] -> Item -> [Item] +insert_ [] y = [y] +insert_ s@(x:xs) y = if (x `before` y) then + (y:s) + else + (x:(insert_ xs y)) + +before :: Item -> Item -> Bool +before a b = (created a) < (created b) + +-- | Apply a structure-preserving function, i.e., one that does not +-- change parent/child relationships or ids, to a specific item. +alter :: (Item -> Item) -> Model -> Item -> IO Model +alter f m i = do { ts <- now + ; let i' = (f i) { updated = ts } + ; return $ m { by_permatitle = M.insert (permatitle i') i' $ by_permatitle m + , by_int_id = M.insert (internal_id i') i' $ by_int_id m + , child_map = if (parent i == Nothing) then + child_map m + else + M.insert p_id resort_siblings $ child_map m + , all_items = insert_ all_but i' } } + where + not_i = \item -> (internal_id item) /= (internal_id i) + all_but = filter not_i $ all_items m + p_id = unwrap $ parent i + p = item_by_id m p_id + resort_siblings = map internal_id (insert_ (filter not_i $ children m p) i) + +cloak :: Model -> Item -> IO Model +cloak = alter (\i -> i { visible = False }) + +uncloak :: Model -> Item -> IO Model +uncloak = alter (\i -> i { visible = True }) + +permatitle_exists :: Model -> String -> Bool +permatitle_exists = (flip M.member) . by_permatitle + +max_id :: Model -> Int +max_id = fst . M.findMax . by_int_id + +range :: (a->b) -> [a] -> [(b,a)] +range f is = zip (map f is) is + +map_by :: (Ord b) => (a -> b) -> [a] -> M.Map b a +map_by f is = M.fromList $ range f is + +post_by_permatitle :: Model -> String -> Item +post_by_permatitle = (!) . by_permatitle + +item_by_id :: Model -> Int -> Item +item_by_id = (!) . by_int_id + +children :: Model -> Item -> [Item] +children m i = map (item_by_id m) ((child_map m) ! (internal_id i)) + +unwrap :: Maybe a -> a +unwrap (Just x) = x +unwrap Nothing = error "Can't unwrap nothing!" + +data Author = Author { name :: String, + uri :: Maybe String, + email :: Maybe String, + show_email :: Bool + } + deriving ( Show,Read,Eq ) + +-- | General purpose runtime data structure for holding a post or +-- comment. For a comment, a number of the fields will be ignored +-- (e.g., comments and tags) until/if the presentation and syndication +-- system gets fancier. +data Item = Item { -- | an internal unique number for this post + internal_id :: Int, + -- | the kind of item that this represents + kind :: Kind, + -- | the title of the post, as it should be rendered on + -- the web or inserted in an Atom feed; this should be a + -- valid XHTML fragment. + title :: XhtmlString, + -- | the summary of the post, as it should be rendered on + -- the web or intersted into an Atom feed; this should be + -- a valid XHTML fragment. + summary :: Maybe XhtmlString, + -- | the body of the post as an XHTML fragment. This + -- will be wrapped in an XHTML @
@ when rendered on + -- the web or in a feed. + body :: XhtmlString, + -- | tags for the post, if any, expected to be in + -- alphabetical order and consisting of letters, digits, + -- dashes, and/or underscores. + tags :: [String], + -- | a generated UID for the post; this is expected to be + -- suitable for use as an Atom GUID. The expectation is + -- that it will be supplied by the implementation when + -- the post is ingested. + uid :: String, + -- | a permanent title for the item, consisting of only + -- lowercase letters, digits, and dashes. + permatitle :: String, + -- | the timestamp, as an ISO8601 datetime, when the post + -- came into being. This is never blank and would be + -- supplied by the implementation when the post is + -- ingested. + created :: ISO8601DatetimeString, + -- | the timestamp, as an ISO8601 datetime, when the post + -- was updated. Initially, this is equal to the value of + -- the 'created' field. + updated :: ISO8601DatetimeString, + -- | the author of the post, expected to be hardwired to + -- the author of the blog + author :: Author, + -- | whether or not the item is to be displayed. + visible :: Bool, + -- | this item's parent, if any. + parent :: Maybe Int + } + deriving ( Show, Read, Eq ) + +-- | Compute a permalink for the item relative to the supplied base URL. +permalink :: Model + -> Item -- ^ the item + -> String +permalink m i = U.post (relative_url m i) + +relative_url :: Model -> Item -> String +relative_url m = _form_permalink . (ancestors m) + +_form_permalink :: [Item] -> String +_form_permalink [] = "" +_form_permalink [i] = let s = permatitle i in + if (kind i == Post) then + "/" ++ s + else + "#" ++ s +_form_permalink (i:is) = if (kind i == Post) then + ("/" ++ permatitle i) ++ (_form_permalink is) + else + (_form_permalink is) + + +ancestor_path :: Model -> Item -> String +ancestor_path m i = concat . (intersperse "/") . (map permatitle) $ ancestors m i + +ancestors :: Model -> Item -> [Item] +ancestors m i = ancestors_ m [] (Just $ internal_id i) + +ancestors_ :: Model -> [Item] -> Maybe Int -> [Item] +ancestors_ _ is Nothing = is +ancestors_ m is (Just i) = ancestors_ m (i':is) (parent i') + where + i' = item_by_id m i + +lastUpdated :: [Item] -> ISO8601DatetimeString +lastUpdated ps = maximum (map updated ps) + +drop_invisible :: [Item] -> [Item] +drop_invisible = filter visible + +sort_by_created :: [Item] -> [Item] +sort_by_created = sortBy created_sort + +created_sort :: Item -> Item -> Ordering +created_sort a b = compare (created a) (created b) + +sort_by_created_reverse :: [Item] -> [Item] +sort_by_created_reverse = sortBy created_sort_reverse + +created_sort_reverse :: Item -> Item -> Ordering +created_sort_reverse a b = compare (created b) (created a) + +-- | Filter a list of items according to a date fragment +date_fragment_filter_ :: ISO8601DatetimeString -> [Item] -> [Item] +date_fragment_filter_ s = filter ((s `isPrefixOf`) . created) + +-- | Filter a list of posts for those made in a specific year. +year_filter :: Int -- ^ year + -> [Item] -> [Item] +year_filter y = date_fragment_filter_ $ show y + +-- | Filter a list of posts for those made in a specific month. +month_filter :: Int -- ^ year + -> Int -- ^ month + -> [Item] -> [Item] +month_filter y m | (0 < m) && (m < 13) = date_fragment_filter_ ((show y) ++ (pad_ m)) + | otherwise = const [] + +-- | Filter a list of posts for those made on a specific day +day_filter :: Int -- ^ year + -> Int -- ^ month + -> Int -- ^ day + -> [Item] -> [Item] +day_filter y m d = date_fragment_filter_ ((show y) ++ (pad_ m) ++ (pad_ d)) + +-- | Utility function to zero pad months and days in date expressions. +pad_ :: Int -> String +pad_ i | i < 10 = "-0" ++ (show i) + | otherwise = ('-':(show i)) + +-- to do: make this faster using the sortedness. +tags_filter :: [String] -> [Item] -> [Item] +tags_filter t p = foldl (flip ($)) p (map tag_filter t) + +tag_filter :: String -> [Item] -> [Item] +tag_filter t = filter ((t `elem`) . tags) + +plink_filterf :: String -> Item -> Bool +plink_filterf = flip $ (==) . permatitle + +plink_filter :: String -> [Item] -> [Item] +plink_filter = filter . plink_filterf + +ymd_plink_finder :: Int -> Int -> Int -> String -> [Item] -> [Item] +ymd_plink_finder y m d t = (plink_filter t) . (day_filter y m d) + +all_posts :: Model -> [Item] +all_posts = (filter (\x -> Post == kind x)) . all_items + +flatten :: Model -> [Item] -> [Item] +flatten m = flatten_ (children m) + +flatten_ :: (a -> [a]) -> [a] -> [a] +flatten_ _ [] = [] +flatten_ f (i:is) = (i:(flatten_ f (f i))) ++ (flatten_ f is) + +concat_comments :: Model -> [Item] -> [Item] +concat_comments m = (foldr (++) []) . (map $ children m) + +() :: String -> String -> String +s t = s ++ ('/':t) + +to_string :: Item -> String +to_string i = concat [metadata i, "\n", body_block i, "\n", summary_block i] + +metadata :: Item -> String +metadata i = unlines $ apply i [ ("internal_id",show . internal_id), + ("parent", show . parent), + ("title",title), + ("tags",show_no_quotes . tags), + ("permatitle",permatitle), + ("kind",show . kind), + ("uid",uid), + ("created",created), + ("updated",updated), + ("author",show . author), + ("visible",show . visible) ] + +show_no_quotes :: [String] -> String +show_no_quotes = concat . (intersperse ", ") + +apply :: Item -> [(String,(Item -> String))] -> [String] +apply i [] = [] +apply i (x:xs) = ((concat [fst x, ": ", (snd x) i]) : (apply i xs)) + +body_block :: Item -> String +body_block i = concat ["--- START BODY ---\n", + (body i), + "\n--- END BODY ---\n"] + +summary_block :: Item -> String +summary_block i | summary i == Nothing = "" + | otherwise = concat ["--- START SUMMARY ---\n", + (unwrap $ summary i), + "\n--- END SUMMARY ---\n"] + +default_author :: Author +default_author = Author C.author_name C.author_uri C.author_email True addfile ./perpubplat/src/Blog/Model/EntryParser.hs hunk ./perpubplat/src/Blog/Model/EntryParser.hs 1 - +module Blog.Model.EntryParser where + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Error (messageString) +import qualified Blog.Model.Entry as B +import qualified Blog.Constants as C + +item_from_string :: String -> String -> B.Item +item_from_string = fromString parse_item + +draft_from_string :: String -> String -> B.Item +draft_from_string = fromString parse_draft + +fromString :: Parser B.Item -> String -> String -> B.Item +fromString p path datum = case (parse p path datum) of + Left err -> error $ show err + Right item -> item + +parse_draft :: Parser B.Item +parse_draft = do { title <- parse_field "title" + ; tags <- parse_tags + ; body <- parse_block "BODY" + ; summary <- parse_summary + ; return $ B.Item 0 B.Post title summary body tags + "uid" "permatitle" "created" "updated" B.default_author True Nothing } + +parse_item :: Parser B.Item +parse_item = do { int_id <- parse_field "internal_id" + ; parent <- parse_field "parent" + ; title <- parse_field "title" + ; tags <- parse_tags + ; ptitle <- parse_field "permatitle" + ; kind <- parse_field "kind" + ; uid <- parse_field "uid" + ; created <- parse_field "created" + ; updated <- parse_field "updated" + ; author <- parse_field "author" + ; visible <- parse_field "visible" + ; body <- parse_block "BODY" + ; summary <- parse_summary + ; return $ B.Item (read int_id) (read kind) title summary + body tags uid ptitle created updated (read author) + (read visible) (read parent) } + +parse_field :: String -> Parser String +parse_field s = do { string s + ; char ':' + ; skipMany (char ' ' <|> char '\t') + ; v <- manyTill anyChar newline + ; return v } + +parse_tags :: Parser [String] +parse_tags = do { string "tags:" + ; skipMany (char ' ' <|> char '\t') + ; tags <- parse_tag `sepBy` (many1 $ oneOf ", ") + ; newline + ; return tags } + +parse_tag :: Parser String +parse_tag = many1 (letter <|> digit <|> (oneOf "_-.")) + "Expected a combination of letters, digits, -. and _" + +parse_block :: String -> Parser String +parse_block s = do { skipMany newline + ; string $ concat ["--- START ", s, " ---\n"] + ; manyTill anyChar (try $ string $ concat ["\n--- END ", s, " ---\n"]) } + +parse_summary :: Parser (Maybe String) +parse_summary = (try $ do { s <- parse_block "SUMMARY" + ; return $ Just s } ) + <|> return Nothing addfile ./perpubplat/src/Blog/Widgets/FlickrBadge.hs hunk ./perpubplat/src/Blog/Widgets/FlickrBadge.hs 1 - +module Blog.Widgets.FlickrBadge ( flickr_badge ) where + +import qualified Blog.Model.Entry as B +import Text.XHtml.Strict ( Html, script, (!), (<<), stringToHtml, (+++), + thetype, src, concatHtml, noHtml, identifier, primHtml, thediv ) + +flickr_badge :: Html +flickr_badge = thediv ! [ identifier "filckr_badge_uber_wrapper"] + << ( thediv ! [ identifier "flickr_badge_wrapper" ] + << ( concatHtml [ script ! [ thetype "text/javascript", + src flickr_script ] << noHtml + , flickr_link ] ) ) + +flickr_link :: Html +flickr_link = primHtml $ "" + ++ "www.flick" + ++ "r.com" + +flickr_count :: String +flickr_count = show 10 + +flickr_script :: String +flickr_script = "http://www.flickr.com/badge_code_v2.gne?count=" + ++ flickr_count + ++ "&display=random&size=t&layout=x&source=user&user=92922008%40N00" addfile ./perpubplat/src/Blog/Widgets/TagCloud.hs hunk ./perpubplat/src/Blog/Widgets/TagCloud.hs 1 +module Blog.Widgets.TagCloud ( tag_cloud ) where + +import Blog.Model.Entry +import Blog.FrontEnd.Urls +import Text.XHtml.Strict ( thespan, thestyle, Html, stringToHtml , (!), (<<), + concatHtml, noHtml, toHtml, hotlink, theclass, thediv ) +import Data.List ( maximum, group, sortBy, sort, intersperse ) + +tag_cloud :: [Item] -> Int -> Html +tag_cloud = tag_cloud_ . sort . concat . (map tags) + +d :: Int -> Double +d = fromIntegral + +tag_cloud_ :: [String] -> Int -> Html +tag_cloud_ ts n = thediv ! [ theclass "tagcloud" ] + << ( concatHtml + . (intersperse $ stringToHtml " ") + $ map (tag_atom . tag_tuple) ts'' ) + where + ts' = group ts + ts'' = take n $ (sortBy (flip $ snd >< compare) $ map (\y -> (head y, length y)) ts') + max_count = maximum $ map snd ts'' + min_count = minimum $ map snd ts'' + relative_color = \y -> hotness ((d $ y - min_count) / (d $ max_count - min_count)) + relative_size = \y -> 75 + ((75 * (y-min_count)) `div` (max_count - min_count)) + tag_tuple = \(x,y) -> (x, relative_color y, y, relative_size y) + +(><) :: (x -> y) -> (y -> y -> z) -> x -> x -> z +(><) f g x1 x2 = g (f x1) (f x2) + +tag_atom :: (String, String, Int, Int) -> Html +tag_atom (nm,c,n,sz) = thespan ( toHtml ( hotlink (posts_by_tag nm) + (stringToHtml $ (show n) ++ ":" ++ nm) ) + ! [ thestyle $ "color: " ++ c ++ "; font-size: " + ++ (show sz) ++ "%"] ) + ! [ theclass "tagcloud" ] + + +-- | Function to compute an HTML color value (three 0x00-0xFF hex digits +-- of RGB color space) from a [0,1] temperature. The implementation is a +-- close approximation of a line connecting (0,100,100) and (270,100,70) +-- in HSB color space where one maps to the bright red (0,100,100) and zero +-- maps to the cool purple. +hotness :: Double -- ^ the hotness + -> String +hotness a | a < 0 = error "Can't be cooler than zero." +hotness a | a > 1 = error "Can't be hotter than one." +hotness a = rgb_to_htmlcolor ((r x) + (rs x), g x, b x) + where + x = round(shape(a) * 270) + r = lump (-120,-60,60,120) 200 + g = lump (0,60,180,240) 150 + b = lump (120,180,300,360) 120 + rs = lump (240,300,420,480) 200 + +-- Derived from (1/(5*a+1))-(a/6) +shape :: Double -> Double +shape a = (6-a-5*a*a)/(30*a+6) + +-- | Ramp up, hold, ramp down and zero elsewhere function. +lump :: (Int,Int,Int,Int) -- ^ four-tuple consisting of start of up ramp, end of up ramp, start of down ramp, end of down ramp + -> Int -- ^ height for the hold portion + -> Int -- ^ the input to the function + -> Int +lump (su,eu,sd,ed) h x | x < su || x > ed = 0 + | x > eu && x < sd = h + | x >= su && x <= eu = (h*(x-su)) `div` (eu-su) + | x >= sd && x <= ed = (h*(ed-x)) `div` (ed-sd) + +digits :: String +digits = "0123456789ABCDEF" + +hex :: [String] +hex = [ [digits!!a,digits!!b] | a <- [0..15], b <- [0..15] ] + +rgb_to_htmlcolor :: (Int,Int,Int) -> String +rgb_to_htmlcolor (a,b,c) = "#" ++ (hex!!(clip a)) + ++ (hex!!(clip b)) ++ (hex!!(clip c)) + where + clip = \x -> min (max x 0) 255 addfile ./perpubplat/src/Text/Atom.hs hunk ./perpubplat/src/Text/Atom.hs 1 - +{- + +Reduced but acceptable profile of the Atom syndication format[1] +suitable for blog publishing. Primary assumptions: + + * Place the onus on the user (i.e., the user of this API) to ensure + that correct Atom is constructed. + + * Sidestep namespace qualification issues by just declaring the + atom: prefix on the root feed element and then reusing it + throughout. + + * Content comes in either the plain "text" flavor or the "xhtml" + flavor. + + * The atom:generator structure always includes uri and version. + + * The atom:link structures only and always include rel and href + attributes. + + * atom:contributor is not supported. + + * Entities are expected to be formatted correctly (text escaped, + dates rendered, ids prepared) before being put in this structure. + This includes attribute values. + + * atom:source is not supported. + + * Pretty printing is irrelevant. + +REFERENCES: + [1] http://www.atomenabled.org/developers/syndication/atom-format-spec.php + +AUTHOR: + prb@mult.ifario.us + +COPYRIGHT: + This file is in the public domain. + +-} + +module Text.Atom (AtomElement( Feed,Entry,Content, Author, + Category,Generator,Id,Icon,Link, + Logo,Published,Rights,Subtitle,Summary,Title,Updated, + author_name, author_uri, author_email, rel, href + ), + AtomContent(AtomContent), + ContentType(XHTML,TEXT), + toXml,feed_link,feed_link_alt) where + +import qualified Text.XHtml.Strict as X +import Maybe + +{- +This is the main data structure. As-is, the structure makes no effort +to enforce correct Atom structure (order/presence of elements), +although that could be done. The onus is on the user of the API to +put things together correctly, which isn't too much to ask. +-} +data AtomElement = Feed [AtomElement] + | Entry [AtomElement] + | Content AtomContent + | Author { author_name :: String, + author_uri :: Maybe String, + author_email :: Maybe String } + | Category String + | Generator { gen_name :: String, + gen_uri :: String, + gen_version :: String } + | Id String + | Icon String + | Link { rel :: String, + href :: String } + | Logo String + | Published String + | Rights AtomContent + | Subtitle AtomContent + | Summary AtomContent + | Title AtomContent + | Updated String + deriving (Show) -- just for show; see toXml + +{- +As with the other structures, the body content of an AtomContent +instance is expected to contain correctly formatted/escaped content, +i.e., entity-escaped "text" or valid "xhtml". The implementation +assumes that the xhtml is a fragment and wraps it in the required +XHTML
. (The div wrapper also sets the default namespace to +XHTML.) +-} +data AtomContent = AtomContent { contentType :: ContentType, + body :: String } + deriving (Show) -- just for show; see toXml + +-- Convenience enum for types of content +data ContentType = XHTML | TEXT + deriving (Eq,Show,Enum) + +-- Render an AtomElement fragment as XML, no declaration. +toXml :: AtomElement -> String +toXml (Feed xs) = wrap_ns "feed" (content_ xs) +toXml (Entry xs) = wrap_ns "entry" (content_ xs) + +toXml' :: AtomElement -> String +toXml' (Entry xs) = wrap "entry" (content_ xs) +toXml' (Category s) = clopen "category" [("term",s)] +toXml' (Id s) = wrap "id" s +toXml' (Icon s) = wrap "icon" s +toXml' (Link r h) = clopen "link" [("rel",r),("href",h)] +toXml' (Logo s) = wrap "logo" s +toXml' (Published s) = wrap "published" s +toXml' (Updated s) = wrap "updated" s +toXml' (Author s u e) = wrap "author" ((wrap "name" s) + ++ (wrap_m "uri" u) + ++ (wrap_m "email" e)) +toXml' (Generator n u v) = wrap_ "generator" [("uri",u),("version",v)] n +toXml' (Content a) = atom_text "content" a +toXml' (Rights a) = atom_text "rights" a +toXml' (Subtitle a) = atom_text "subtitle" a +toXml' (Summary a) = atom_text "summary" a +toXml' (Title a) = atom_text "title" a + +content_ :: [AtomElement] -> String +content_ = concat.(map toXml') + +-- Render an Atom text construct as XML. +atom_text :: String -> AtomContent -> String +atom_text s (AtomContent XHTML t) = wrap_ s [("type","xhtml")] (start_div ++ t ++ end_div) +atom_text s (AtomContent TEXT t) = wrap_ s [("type","text")] t + +-- Format a clopen element with a list of attributes. +clopen :: String -> [(String,String)] -> String +clopen s [] = "<" ++ s ++ "/>" +clopen s xs = "<" ++ s ++ (nv_to_s "" xs) ++ "/>" + +-- Wrap a string in an element. +wrap :: String -> String -> String +wrap s t = "<" ++ s ++ ">" ++ t ++ "" + +-- If a value is present (i.e., not Nothing), wrap it in an element. +wrap_m :: String -> Maybe String -> String +wrap_m _ Nothing = "" +wrap_m s (Just t) = wrap s t + +-- Wrap an element with attributes around a string. +wrap_ :: String -> [(String,String)] -> String -> String +wrap_ s [] t = wrap s t +wrap_ s xs t = "<" ++ s ++ (nv_to_s "" xs) ++ ('>':t) + ++ "" + +wrap_ns :: String -> String -> String +wrap_ns s t = wrap_ s [("xmlns",atom_uri)] t + +-- Format a list of name-value pairs as attributes. +nv_to_s :: String -> [(String,String)] -> String +nv_to_s = foldl att + +att :: String -> (String,String) -> String +att s (n,v) = s ++ (' ':(n ++ "=\"" ++ v ++ "\"")) + +atom_uri :: String +atom_uri = "http://www.w3.org/2005/Atom" + +-- Convenience constants. +start_feed :: String +start_feed = "" + +end_feed :: String +end_feed = "" + +-- | A @
@ with the XHTML namespace declared as text; used to wrap +-- entry content. +start_div :: String +start_div = "
" + +-- | A @
@ as text; used to wrap entry content. +end_div :: String +end_div = "
" + +-- | Output a @rel=@-style autodiscovery link; see +-- . +link_ :: Bool -- ^ whether or not the feed is for the current document. + -> String -- ^ the URL + -> String -- ^ the title for the feed + -> X.Html -- ^ the link +link_ alt u t = X.thelink ( X.noHtml ) + X.! [ X.rel feed_kind, X.thetype "application/atom+xml", + X.href u, X.title t ] + where + feed_kind = if alt then "feed alternate" + else "feed" + +-- | Convenience for creating a @rel=\"feed\"@ type @@. +feed_link :: String -> String -> X.Html +feed_link = link_ False + +-- | Convenience for creating a @rel=\"feed alternate\"@ type @@. +feed_link_alt :: String -> String -> X.Html +feed_link_alt = link_ True addfile ./perpubplat/src/Utilities.hs hunk ./perpubplat/src/Utilities.hs 1 - +module Utilities (subst,hotness,readFile',now) where + +import List +import System.IO +import System.IO.Unsafe +import Foreign +import Data.Char +import System.Time + +data KMP a = KMP + { done :: Bool + , next :: (a -> KMP a) + } + +-- | KMP-like implementation of string containment. Pulled from +-- +subst :: String -- ^ the string to search for + -> String -- ^ the string to search in + -> Bool +subst as bs = any done $ scanl next (makeTable as) bs + +makeTable :: Eq a => [a] -> KMP a +makeTable xs = table + where table = makeTable' xs (const table) + +makeTable' [] failure = KMP True failure +makeTable' (x:xs) failure = KMP False test + where test c = if c == x then success else failure c + success = makeTable' xs (next (failure x)) + +-- | Function to compute an HTML color value (three 0x00-0xFF hex digits +-- of RGB color space) from a [0,1] temperature. The implementation is a +-- close approximation of a line connecting (0,100,100) and (270,100,70) +-- in HSB color space where one maps to the bright red (0,100,100) and zero +-- maps to the cool purple. +hotness :: Double -- ^ the hotness + -> String +hotness a | a < 0 = error "Can't be cooler than zero." +hotness a | a > 1 = error "Can't be hotter than one." +hotness a = rgb_to_htmlcolor ((r x) + (rs x), g x, b x) + where + x = round(shape(a) * 270) + r = lump (-120,-60,60,120) 255 + g = lump (0,60,180,240) 195 + b = lump (120,180,300,360) 135 + rs = lump (240,300,420,480) 255 + +-- Derived from (1/(5*a+1))-(a/6) +shape :: Double -> Double +shape a = (6-a-5*a*a)/(30*a+6) + +-- | Ramp up, hold, ramp down and zero elsewhere function. +lump :: (Int,Int,Int,Int) -- ^ four-tuple consisting of start of up ramp, end of up ramp, start of down ramp, end of down ramp + -> Int -- ^ height for the hold portion + -> Int -- ^ the input to the function + -> Int +lump (su,eu,sd,ed) h x | x < su || x > ed = 0 + | x > eu && x < sd = h + | x >= su && x <= eu = (h*(x-su)) `div` (eu-su) + | x >= sd && x <= ed = (h*(ed-x)) `div` (ed-sd) + +digits :: String +digits = "0123456789ABCDEF" + +hex :: [String] +hex = [ [digits!!a,digits!!b] | a <- [0..15], b <- [0..15] ] + +rgb_to_htmlcolor :: (Int,Int,Int) -> String +rgb_to_htmlcolor (a,b,c) = "#" ++ (hex!!(clip a)) + ++ (hex!!(clip b)) ++ (hex!!(clip c)) + where + clip = \x -> min (max x 0) 255 + + +readFile' f = do + h <- openFile f ReadMode + s <- hFileSize h + fp <- mallocForeignPtrBytes (fromIntegral s) + len <- withForeignPtr fp $ \buf -> hGetBuf h buf (fromIntegral s) + lazySlurp fp 0 len + +buf_size = 4096 :: Int + +lazySlurp :: ForeignPtr Word8 -> Int -> Int -> IO String +lazySlurp fp ix len + | fp `seq` False = undefined + | ix >= len = return [] + | otherwise = do + cs <- unsafeInterleaveIO (lazySlurp fp (ix + buf_size) len) + ws <- withForeignPtr fp $ \p -> loop (min (len-ix) buf_size - 1) + ((p :: Ptr Word8) `plusPtr` ix) cs + return ws + where + loop :: Int -> Ptr Word8 -> String -> IO String + loop len p acc + | len `seq` p `seq` False = undefined + | len < 0 = return acc + | otherwise = do + w <- peekElemOff p len + loop (len-1) p (chr (fromIntegral w):acc) + +now :: IO String +now = do { x <- getClockTime + ; let d = toUTCTime x + ; return $ concat [ yy d, "-", mm d, "-", dd d, "T", + hh d, ":", mmmm d, ":", ss d , "Z" ] } + +yy :: CalendarTime -> String +yy = show . ctYear + +mm :: CalendarTime -> String +mm = zpad . show . (1+) . fromEnum . ctMonth + +dd :: CalendarTime -> String +dd = zpad . show . ctDay + +hh :: CalendarTime -> String +hh = zpad . show . ctHour + +mmmm :: CalendarTime -> String +mmmm = zpad . show . ctMin + +ss :: CalendarTime -> String +ss = zpad . show . ctSec + +zpad :: String -> String +zpad [] = "00" +zpad [a] = '0':[a] +zpad s = s addfile ./perpubplat_import/Setup.lhs hunk ./perpubplat_import/Setup.lhs 1 +#!/usr/bin/env runghc + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain addfile ./perpubplat_import/perpubplat_import.cabal hunk ./perpubplat_import/perpubplat_import.cabal 1 +name: PerpubplatImporter +version: 0.1 +copyright: Copyright 2007 Multifarious, Inc. +description: Convert JSON exported from Typo into the internal perpubplat format. +license: GPL +license-file: LICENSE +author: Paul Brown +homepage: http://datapr0n.com/perpubplat +maintainer: Paul Brown +build-depends: base >= 2.0, parsec >= 2.0, xhtml >= 3000, json >= 0.1, perpubplat >= 0.1 + + +executable: import-typo +main-is: typo_importer.hs +hs-source-dirs: src +ghc-options: -O -Werror -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches addfile ./perpubplat_import/src/Import.hs hunk ./perpubplat_import/src/Import.hs 1 +module Import where + +import qualified Blog.Entry as B +import qualified Blog.Constants as C +import qualified Blog.Storage.IoOperations as I + +import qualified System.Directory as D +import qualified Utilities as U + +import qualified System.FilePath as F +import System.FilePath (()) +import qualified Text.Json as J +import qualified Data.Map as M +import Data.Map (Map, (!)) +import List +import qualified Text.ParserCombinators.Parsec as P +import Monad + +import qualified Blog.Storage.StmSequenceNumberGenerator as S + +type JsonEntry = Map String J.Value + +unR (Right r) = r + +unO :: J.Value -> JsonEntry +unO (J.Object o) = o + +unA :: J.Value -> [J.Value] +unA (J.Array a) = a + +unV :: J.Value -> String +unV (J.String s) = s +unV (J.Null) = "" + +{- Functions for extracting specific values from a JSON representation of an entry or comment or trackback. -} +published_at_ :: JsonEntry -> String +published_at_ = munge . unV . (M.! "published_at") + +created_at_ :: JsonEntry -> String +created_at_ = munge . unV . (M.! "created_at") + +body_ :: JsonEntry -> String +body_ = unV . (M.! "body") + +updated_at_ :: JsonEntry -> String +updated_at_ = munge . unV . (M.! "updated_at") + +tags_ :: JsonEntry -> [String] +tags_ = words . unV . (M.! "keywords") + +title_ :: JsonEntry -> String +title_ = unV . (M.! "title") + +excerpt_ :: JsonEntry -> Maybe String +excerpt_ = blankIsNothing . unV . (M.! "excerpt") + +guid_ :: JsonEntry -> String +guid_ = unV . (M.! "guid") + +categories_ :: JsonEntry -> [String] +categories_ = const [] + +permatitle_ :: JsonEntry -> String +permatitle_ = unV . (M.! "permalink") + +published_ :: JsonEntry -> Bool +published_ m = ((unV . (M.! "published")) m) == "1" + +id_ :: JsonEntry -> String +id_ = unV . (M.! "id") + +article_id_ :: JsonEntry -> String +article_id_ = unV . (M.! "article_id") + +email_ :: JsonEntry -> Maybe String +email_ = blankIsNothing . unV . (M.! "email") + +author_ :: JsonEntry -> String +author_ = unV . (M.! "author") + +uri_ :: JsonEntry -> Maybe String +uri_ = blankIsNothing . unV . (M.! "url") + +author = B.Author "Paul Brown" (Just "http://mult.ifario.us") (Just "prb@mult.ifario.us") True + +{- pull a JSON dump of Typo entries into memory -} +load_typo_entries :: String -> IO [JsonEntry] +load_typo_entries file = (liftM (map unpack2)) (unpack1 json) + where unpack1 = liftM (unA.unR) + unpack2 = unO . (M.! "attributes") . unO + json = (P.parseFromFile J.json file) + + +-- | Convert a typo article into a top-level blog posting. +convert_typo_entry :: S.Generator -> JsonEntry ->IO B.Item +convert_typo_entry g m = do { n <- S.get_next g + ; return $ B.Item n (B.Post) (title_ m) (excerpt_ m) + (cleanup_ $ body_ m) ((tags_ m) ++ (categories_ m)) ("http://mult.ifario.us/p/" ++ ptitle) + (ptitle) (published_at_ m) + (updated_at_ m) author (published_ m) Nothing } + where + ptitle = fix_up_permalink $ permatitle_ m + +{- Convert a comment or trackback into a blog posting ready to be appended to a specific top-level post. -} +convert_typo_comment :: S.Generator -> JsonEntry -> IO B.Item +convert_typo_comment g m = do { c <- (convert_typo_entry g m) + ; return c { B.author = comment_author m, + B.kind = B.Comment, + B.permatitle = "comment-" ++ (show $ B.internal_id c)} } + +comment_author :: JsonEntry -> B.Author +comment_author m = B.Author (author_ m) (uri_ m) (email_ m) False + +{- Down and dirty conversion from, e.g., 2007-01-01 12:00:00 to 2007-01-01T12:00:00Z -} +munge :: String -> String +munge s = (date s) ++ 'T':(time s) ++ "Z" + where + date = (take 10) + time = reverse.(take 8).reverse + +{- most of the permalinks are relative -} +fix_up_permalink :: String -> String +fix_up_permalink s = fix_up_permalink_ [] s + +fix_up_permalink_ :: String -> String -> String +fix_up_permalink_ s [] = reverse s +fix_up_permalink_ t s | (take 5 s == "8220-") || + (take 5 s == "8221-") || + (take 5 s == "-8221") || + (take 5 s == "-8220") = fix_up_permalink_ t (drop 5 s) +fix_up_permalink_ t (s:ss) = fix_up_permalink_ (s:t) ss + +group_comments :: [JsonEntry] -> [[JsonEntry]] +group_comments = groupBy (\x y -> (article_id_ x) == (article_id_ y)) + +presort_comments :: [[JsonEntry]] -> [[JsonEntry]] +presort_comments = map (sortBy (\x y -> compare (created_at_ x) (created_at_ y))) + +type LegacyId = String +type Permatitle = String +type LegacyIdToPermatitleMap = Map LegacyId Permatitle + +map_legacy_ids :: [JsonEntry] -> LegacyIdToPermatitleMap +map_legacy_ids p = map_legacy_ids_ p M.empty + +map_legacy_ids_ :: [JsonEntry] -> LegacyIdToPermatitleMap -> LegacyIdToPermatitleMap +map_legacy_ids_ [] m = m +map_legacy_ids_ (p:ps) m = map_legacy_ids_ ps (M.insert (id_ p) (permatitle_ p) m) + +-- | Map permatitle to the list of comments/trackbacks on it. +type CommentMap = Map String [B.Item] + +map_comments :: S.Generator -> LegacyIdToPermatitleMap -> [[JsonEntry]] -> IO CommentMap +map_comments g lipm c = map_comments_ g lipm c M.empty + +map_comments_ :: S.Generator -> LegacyIdToPermatitleMap -> [[JsonEntry]] -> CommentMap -> IO CommentMap +map_comments_ g _ [] m = return m +map_comments_ g lipm (c:cs) m = do { cx <- mapM (convert_typo_comment g) c + ; map_comments_ g lipm cs + (M.insert ((M.! (article_id_$head c)) lipm) cx m) } + +set_parent :: B.Item -> B.Item -> B.Item +set_parent par chil = chil { B.parent = Just ( B.internal_id par ), + B.uid = (B.uid par) ++ "#" ++ (B.permatitle chil) } + +blankIsNothing :: String -> Maybe String +blankIsNothing "" = Nothing +blankIsNothing s = Just s + +uniquify_permatitles :: [String] -> [B.Item] -> [B.Item] -> [B.Item] +uniquify_permatitles _ p [] = p +uniquify_permatitles t d (n:ns) = if ((B.permatitle n) `elem` t) then + uniquify_permatitles (pt:t) ((n { B.permatitle = (uniquify t pt)}):d) ns + else + uniquify_permatitles (pt:t) (n:d) ns + where + pt = B.permatitle n + +uniquify :: [String] -> String -> String +uniquify s t = t ++ '-':(show $ length (filter ((==) t) s)) + +number :: S.Generator -> B.Item -> IO B.Item +number g i = do { n <- S.get_next g + ; return i { B.internal_id = n} } + +apply_parents :: Map String B.Item -> [(String,[B.Item])] -> [B.Item] +apply_parents pi cm = concat $ map (\(x,y) -> (map (set_parent (pi ! (fix_up_permalink x))) y)) cm + +build_content :: [String] -> [String] -> IO () +build_content entry_json_files comment_json_files = + do { g <- S.new_counter 0 + ; raw_entries <- (liftM concat) $ mapM load_typo_entries entry_json_files + ; raw_comments <- (liftM concat) $ mapM load_typo_entries comment_json_files + ; entries' <- mapM (convert_typo_entry g) raw_entries + ; let li = map_legacy_ids raw_entries + ; cm <- map_comments g li ((presort_comments . group_comments) raw_comments) + ; let permatitle_x_item = M.fromList (zip (map B.permatitle entries') entries') + ; let comments = apply_parents permatitle_x_item (M.toList cm) + ; I.dump $ B.build_model (entries' ++ comments) } + +replace_with :: String -> String -> String -> String +replace_with old new source = replace_with_ old (reverse new) source [] + +replace_with_ :: String -> String -> String -> String -> String +replace_with_ old wen [] work = reverse work +replace_with_ old wen inp@(i:is) work | old `isPrefixOf` inp = replace_with_ old wen (drop (length old) inp) (wen ++ work) + | otherwise = replace_with_ old wen is (i:work) + +-- A few automated clean-ups to help things along. +cleanup_ :: String -> String +cleanup_ = (replace_with "—" "—") + . (replace_with " " " ") + . (replace_with "»" "»") + . (replace_with "«" "«") + . (replace_with "’" "'") + . (replace_with "" "
")
+           . (replace_with "" "
") + . (replace_with "" "
")
+           . (replace_with "" "
")
+           . (replace_with "" "
")
+           . (replace_with "" "
")
+           . (replace_with "" "
")
addfile ./perpubplat_import/src/typo_importer.hs
hunk ./perpubplat_import/src/typo_importer.hs 1
-
+import Import
+
+q :: String -> String
+q s = "/Users/prb/work/hblog/data/" ++ s
+
+main :: IO ()
+main = build_content
+       [q "entries.json",q "other_entries.json"]
+       [q "comments.json", q "trackbacks.json"]
addfile ./perpubplat_servlet/Setup.lhs
hunk ./perpubplat_servlet/Setup.lhs 1
+#!/usr/bin/env runghc
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain
addfile ./perpubplat_servlet/perpubplat_servlet.cabal
hunk ./perpubplat_servlet/perpubplat_servlet.cabal 1
+name:			PerpubplatFastCgiServlet
+version:		0.1
+copyright:		Copyright 2007 Multifarious, Inc.
+description:		Convert JSON exported from Typo into the internal perpubplat format.
+license:        	GPL
+license-file:   	LICENSE
+author:			Paul Brown 
+homepage:		http://datapr0n.com/perpubplat
+maintainer:		Paul Brown 
+build-depends:		base >= 2.0, parsec >= 2.0, xhtml >= 3000,
+			fastcgi >= 3001.0.0, perpubplat >= 0.1
+
+
+executable:		perpubplat.fcgi
+main-is:		blog.hs
+hs-source-dirs:		src
+ghc-options:		-O -Werror -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches
addfile ./perpubplat_servlet/src/blog.hs
hunk ./perpubplat_servlet/src/blog.hs 1
-
+-- blog.hs: servlet to run the blog.
+
+import qualified Blog.Model.Entry as B
+import qualified Blog.Constants as C
+import Utilities
+import qualified Blog.FrontEnd.Presentation as P
+import qualified Blog.FrontEnd.Syndication as S
+--import qualified Blog.Errors as E
+import qualified Blog.BackEnd.DataController as DataC
+import qualified Blog.BackEnd.IoOperations as O
+import Blog.FrontEnd.Routes
+import qualified Blog.FrontEnd.Views as V
+import qualified Blog.FrontEnd.Feeds as F
+import qualified Blog.FrontEnd.Actions as A
+import Control.Concurrent ( forkIO )
+import Network.FastCGI 
+import Network.URI ( uriPath )
+import System.Log.Logger 
+import System.Log.Handler.Simple
+
+serve :: DataC.DataController -> CGI CGIResult
+serve dc = do { u <- requestURI
+              ; p <- progURI
+              ; m <- requestMethod
+              ; let c = m ++ " " ++ drop (length $ uriPath p) (uriPath u)
+              ; let route = parse_uri c
+--              ; liftIO $ infoM "perpubplat" ("Responding to " ++ c)
+              ; case route of 
+                  (NoSuchUri u) -> outputNotFound u
+                  (XhtmlView v) -> serve_content dc v 
+                  (AtomFeed f) -> serve_feed dc f
+                  (Command c) -> perform_command dc c }
+
+serve_content :: (V.Viewable v) => DataC.DataController -> v -> CGI CGIResult
+serve_content dc v = do { m <- liftIO $ DataC.get_model dc
+                        ; setStatus 200 "OK"
+                        -- ; setHeader "Content-type" "application/xhtml+xml"
+                        ; output $ P.assemble_page v m }                     
+
+serve_feed :: (F.Feedable f) => DataC.DataController -> f -> CGI CGIResult
+serve_feed dc f = do { m <- liftIO $ DataC.get_model dc
+                     ; setStatus 200 "OK"
+                     ; setHeader "Content-type" "application/atom+xml"
+                     ; output $ S.assemble_feed f m }
+
+perform_command :: DataC.DataController -> A.Action -> CGI CGIResult
+perform_command dc c = do { setHeader "Content-type" "text/plain"
+                          ; case c of
+                              (A.Ingest d) -> liftIO ( DataC.ingest_draft dc d )
+                          ; output $ show c }
+
+main :: IO ()
+main = do { {-root_logger <- getLogger "perpubplat"
+          ; logfile <- fileHandler "/tmp/perpubplat.log" INFO
+          ; updateGlobalLogger "perpubplat" (setLevel DEBUG . addHandler logfile)
+          ; infoM "perpubplat" "Starting perpubplat system." -}
+          ; m <- O.boot
+          ; dc <- DataC.spawn_controller m
+          ; infoM "perpubplat" "Startup complete; forking FastCGI handlers."
+          ; runFastCGIConcurrent' forkIO 50 (serve dc) }
}