blogination 0.1 → 0.2

raw patch · 4 files changed

+158/−25 lines, 4 filesdep +feeddep +old-localedep +regex-compatPVP ok

version bump matches the API change (PVP)

Dependencies added: feed, old-locale, regex-compat, time, xml

API changes (from Hackage documentation)

Files

• blogination.cabal +2/−2
• executable/Main.hs +8/−2
• library/Text/Blogination.hs +146/−21
• sample-blog.conf +2/−0

@@ -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/ 

@@ -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"

@@ -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 (blogTags</>tag++".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 (blogTags</>path))+  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 (blogEntries</>path)-    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 (blogEntries</>path)-    writeFile (blogHtml</>path++".html") $ showHtml $ pageToHtml blog contents+    writeFile (blogHtml</>path++".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"]

@@ -5,3 +5,5 @@ css = ["blog.css","highlight.css"] entries = entries html = html+date = %A %d %b, %Y+url = http://mysite.com/blog