diff --git a/blogination.cabal b/blogination.cabal --- a/blogination.cabal +++ b/blogination.cabal @@ -1,5 +1,5 @@ name: blogination -version: 0.1 +version: 0.2 synopsis: Very simple static blog software description: Blogination reads files written in markdown and outputs xhtml. Supports syntax highlighting. Philosophy is simplicity. Can be used as a library, in a web application for example. Intended use is a simple commandline program to run after changes are made. Ideally use darcs or git with it. category: Web @@ -13,7 +13,7 @@ Data-Files: sample-blog.conf library - build-depends: base,filepath,directory,pandoc,xhtml,highlighting-kate,higherorder,mtl,utf8-string + build-depends: base,filepath,directory,pandoc,xhtml,highlighting-kate,higherorder,mtl,utf8-string,old-locale,regex-compat,time,xml,feed exposed-modules: Text.Blogination hs-source-dirs: library/ diff --git a/executable/Main.hs b/executable/Main.hs --- a/executable/Main.hs +++ b/executable/Main.hs @@ -2,7 +2,9 @@ import Control.Applicative import Control.Monad import Control.Monad.Error +import Prelude hiding (readFile,writeFile) import System +import System.IO.UTF8 (readFile,writeFile) import Text.Blogination import qualified Data.ConfigFile as C @@ -21,9 +23,13 @@ getConf :: FilePath -> IO (Either (C.CPErrorData,String) Blog) getConf filePath = runErrorT $ do - config <- join $ liftIO $ C.readfile C.emptyCP filePath + contents <- liftIO $ readFile filePath + config <- C.readstring C.emptyCP contents let get = C.get config "BLOG" Blog <$> get "name" <*> get "root" <*> (read <$> get "css") <*> get "entries" <*> get "html" <*> get "author" - <*> (return False) + <*> return False + <*> get "date" + <*> return "tags" + <*> get "url" diff --git a/library/Text/Blogination.hs b/library/Text/Blogination.hs --- a/library/Text/Blogination.hs +++ b/library/Text/Blogination.hs @@ -11,21 +11,28 @@ ,highlight) where -import Control.Arrow +import Control.Arrow hiding ((+++)) import Control.Monad.State import Control.Monad.Error import Data.Char hiding (Space) import Data.List.Higher import Data.Maybe +import Data.Time.Format +import Data.Time.Clock import Prelude hiding (readFile,writeFile) import Text.Highlighting.Kate import Text.Pandoc import Text.Printf +import Text.RSS.Export +import Text.RSS.Syntax import Text.XHtml.Strict +import Text.XML.Light.Output import System.Directory import System.FilePath import System.IO.UTF8 (readFile,writeFile) import System.Time +import System.Locale +import Data.Monoid data Blog = Blog { blogName :: String -- e.g. Chris Done's Blog @@ -35,7 +42,11 @@ , blogHtml :: FilePath , blogAuthor :: String , blogForce :: Bool - } deriving (Read,Show) + , blogDate :: String -- date format e.g. + -- "%A %d %b, %Y" makes "Tuesday 10 Feb, 2009" + , blogTags :: FilePath + , blogURL :: String -- e.g. "http://chrisdone.com/blog" + } deriving (Read,Show) type Blogination = ErrorT String (StateT Blog IO) @@ -44,17 +55,94 @@ buildBlog :: Blogination () buildBlog = do ensureProperState - anyChanges <- renderEntries - when anyChanges renderIndex + changed <- renderEntries + when (not $ null changed) $ do + renderTags changed + renderIndex + renderIndexRSS +renderIndexRSS :: Blogination () +renderIndexRSS = do + getEntryNames >>= renderEntriesRSS . take 5 + >>= liftIO . writeFile "rss.xml" + +renderTags :: [FilePath] -> Blogination () +renderTags entries = mapM_ (renderTag entries) =<< getTags + +renderTag :: [FilePath] -> FilePath -> Blogination () +renderTag entries tag = do + changedInThisTag <- (intersect entries) `fmap` getTagEntryNames tag + when (not $ null changedInThisTag) $ do + getTagEntryNames tag >>= renderEntriesRSS . take 5 + renderTagHtml tag + +renderEntriesRSS :: [FilePath] -> Blogination String +renderEntriesRSS names = do + channel <- renderToRSS names + let rss = RSS "2.0" [] channel [] + xml = xmlRSS rss + string = showElement xml + return string + +renderToRSS :: [FilePath] -> Blogination RSSChannel +renderToRSS names = do + blog@Blog{..} <- lift get + items <- mapM entryToItem names + return $ (nullChannel blogName blogURL) { rssItems = items } + +entryToItem :: FilePath -> Blogination RSSItem +entryToItem path = do + blog@Blog{..} <- lift get + let get = liftIO . readFile . (blogEntries) + fmap (item . (getTitle &&& write) . read) . get $ path where + read = readMarkdown defaultParserState + write = writeHtml defaultWriterOptions + item (title,content) = (nullItem title) + { rssItemDescription = + Just $ showHtmlFragment content + , rssItemPubDate = show `fmap` makeDate path } + +renderTagHtml :: FilePath -> Blogination () +renderTagHtml tag = do + blog@Blog{..} <- lift get + links <- mapM getEntryLink =<< getTagEntryNames tag + let html = [head,thebody] + head = header << [toHtml $ map style blogCSS + ,encoding + ,thetitle << title + ,rss] + thebody = body << [back,hr,name,menu,hr,back] + title = tag ++ " - " ++ blogName + name = h2 << ("Tag: " ++ tag) + menu = ulist << map ((li<<) . showLink) links + back = toHtml $ p << hotlink blogRoot << ("« Back to " ++ blogName) + style css = thelink ! [rel "stylesheet",href (blogRoot++css)] + << noHtml + rss = thelink ! [rel "alternate",thetype "application/rss+xml" + ,href $ blogRoot++"tags/"++tag++".xml"] << noHtml + liftIO $ writeFile (blogTagstag++".html") $ showHtml html + where showLink (url,title) = hotlink url << title + +getTagEntryNames :: FilePath -> Blogination [FilePath] +getTagEntryNames path = do + blog@Blog{..} <- lift get + names <- lines `fmap` liftIO (readFile (blogTagspath)) + liftIO $ fmap (reverse . sort) $ filterM (doesFileExist . (blogEntries)) names + renderIndex :: Blogination () renderIndex = do blog@Blog{..} <- lift get links <- mapM getEntryLink =<< getEntryNames - let html = toHtml [title,name,menu] + alltags <- getTags + let html = toHtml [header<<[title,encoding,rss] + ,body<<[name,menu,tags]] title = thetitle << blogName name = h1 << blogName - menu = ulist << map ((li<<) . showLink) links + menu = h2 << "Posts" +++ ul (map showLink links) + tags = h2 << "Tags" +++ ul (map (mkTagLink blog) alltags) + ul l = ulist << map (li<<) l + rss = thelink ! [rel "alternate",thetype "application/rss+xml" + ,href $ blogRoot++"rss.xml"] << noHtml liftIO $ writeFile "index.html" $ showHtml html where showLink (url,title) = hotlink url << title @@ -63,11 +151,11 @@ blog@Blog{..} <- lift get liftIO $ do contents <- readFile (blogEntriespath) - return (blogRoot++"/"++blogHtml++"/"++path++".html" + return (blogRoot++blogHtml++"/"++path++".html" ,getTitle $ read $ contents) where read = readMarkdown defaultParserState -renderEntries :: Blogination Bool +renderEntries :: Blogination [FilePath] renderEntries = do blog@Blog{..} <- lift get names <- getEntryNames @@ -80,7 +168,7 @@ toChange | blogForce = names | otherwise = updated mapM_ renderEntry toChange - return $ not $ null toChange + return toChange getModificationTime' :: FilePath -> IO (Maybe ClockTime) getModificationTime' path = do @@ -92,16 +180,29 @@ renderEntry :: FilePath -> Blogination () renderEntry path = do blog@Blog{..} <- lift get + alltags <- getTags + tagEntries <- mapM getTagEntryNames alltags + let tags = map fst . filter (any (==path) . snd) $ zip alltags tagEntries liftIO $ do contents <- readFile (blogEntriespath) - writeFile (blogHtmlpath++".html") $ showHtml $ pageToHtml blog contents + writeFile (blogHtmlpath++".html") $ + showHtml $ pageToHtml blog path tags contents + where match = map fst . filter (any (== path) . snd) getEntryNames :: Blogination [FilePath] getEntryNames = do Blog{..} <- lift get - return . clean =<< liftIO (getDirectoryContents blogEntries) - where clean = reverse . sort . filter (not . all (=='.')) + fileClean `fmap` liftIO (getDirectoryContents blogEntries) +getTags :: Blogination [FilePath] +getTags = do + Blog{..} <- lift get + (fileClean . filterPlain) `fmap` liftIO (getDirectoryContents blogTags) + +filterPlain = filter (all (flip any [isLetter,isSpace,isDigit] . flip ($))) + +fileClean = reverse . sort . filter (not . all (=='.')) + ensureProperState :: Blogination () ensureProperState = do Blog{..} <- lift get @@ -111,24 +212,45 @@ blogEntries return () liftIO $ createDirectoryIfMissing False blogHtml + fixBlogRoot -pageToHtml :: Blog -> String -> Html -pageToHtml blog = html . second write . (getTitle &&& highlight) . read where +fixBlogRoot :: Blogination () +fixBlogRoot = do + Blog{..} <- lift get + modify $ \s -> s { blogRoot = fix blogRoot } + where fix = (++"/") . reverse . dropWhile (=='/') . reverse + +pageToHtml :: Blog -> FilePath -> [String] -> String -> Html +pageToHtml blog fname tags = + html . second write . (getTitle &&& highlight) . read where read = readMarkdown defaultParserState write = writeHtml defaultWriterOptions - html = template blog + html = template blog fname tags -template :: Blog -> (String,Html) -> Html -template Blog{..} (title,html) = toHtml [head,thebody] where +template :: Blog -> FilePath -> [String] -> (String,Html) -> Html +template blog@Blog{..} path tags (title,html) = toHtml [head,thebody] where head = header << [toHtml $ map style blogCSS - ,meta ! [httpequiv "Content-Type" - ,content "text/html; charset=utf-8"] + ,encoding ,thetitle << title] - thebody = body << [back,hr,html,hr,back] + thebody = body << [back,hr,tagndate,html,hr,back] back = toHtml $ p << hotlink blogRoot << ("« Back to " ++ blogName) - style css = thelink ! [rel "stylesheet",href (blogRoot++"/"++css)] + style css = thelink ! [rel "stylesheet",href (blogRoot++css)] << noHtml + tagndate = p << (small << (date +++ ", " +++ tag)) + date = "Date: " +++ (maybe noHtml showTime $ makeDate path) + tag = "Tags: " +++ (mconcat $ intersperse (toHtml ", ") taglinks) + taglinks = map (mkTagLink blog) tags + showTime = toHtml . formatTime defaultTimeLocale blogDate +mkTagLink :: Blog -> FilePath -> Html +mkTagLink Blog{..} tag = + toHtml $ hotlink (blogRoot++"tags/"++tag++".html") << tag + +makeDate :: FilePath -> Maybe UTCTime +makeDate path = + parse $ take (length "0000-00-00") path + where parse = parseTime defaultTimeLocale "%Y-%m-%d" + getTitle :: Pandoc -> String getTitle (Pandoc meta blocks) = title blocks where title = list "" head . catMaybes . map getHeading @@ -160,3 +282,6 @@ format = formatAsXHtml [] lang highlight = highlightAs lang code def = pre << code + +encoding = meta ! [httpequiv "Content-Type" + ,content "text/html; charset=utf-8"] diff --git a/sample-blog.conf b/sample-blog.conf --- a/sample-blog.conf +++ b/sample-blog.conf @@ -5,3 +5,5 @@ css = ["blog.css","highlight.css"] entries = entries html = html +date = %A %d %b, %Y +url = http://mysite.com/blog