blogination 0.3 → 0.4
raw patch · 2 files changed
+84/−38 lines, 2 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- blogination.cabal +1/−1
- library/Text/Blogination.hs +83/−37
blogination.cabal view
@@ -1,5 +1,5 @@ name: blogination-version: 0.3+version: 0.4 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
library/Text/Blogination.hs view
@@ -11,12 +11,15 @@ ,highlight) where +import Control.Applicative 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.Monoid+import Data.Ord import Data.Time.Format import Data.Time.Clock import Prelude hiding (readFile,writeFile)@@ -32,7 +35,6 @@ 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@@ -64,26 +66,25 @@ renderIndexRSS :: Blogination () renderIndexRSS = do- getEntryNames >>= renderEntriesRSS . take 5 + getEntryNames >>= renderEntriesRSS . take 5 >>= liftIO . writeFile "rss.xml" renderTags :: [FilePath] -> Blogination ()-renderTags entries = mapM_ (renderTag entries) =<< getTags+renderTags entries = do+ mapM_ (renderTag entries) =<< getTags renderTag :: [FilePath] -> FilePath -> Blogination () renderTag entries tag = do - changedInThisTag <- (intersect entries) `fmap` getTagEntryNames tag+ blog@Blog{..} <- lift get+ changedInThisTag <- intersect entries <$> getTagEntryNames tag when (not $ null changedInThisTag) $ do getTagEntryNames tag >>= renderEntriesRSS . take 5+ >>= liftIO . writeFile (blogTags</>tag++".xml") 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+renderEntriesRSS names =+ showElement . xmlRSS . flip (RSS "2.0" []) [] <$> renderToRSS names renderToRSS :: [FilePath] -> Blogination RSSChannel renderToRSS names = do@@ -95,18 +96,27 @@ entryToItem path = do blog@Blog{..} <- lift get let get = liftIO . readFile . (blogEntries</>)- fmap (item . (getTitle &&& write) . read) . get $ path where+ item (title,content) = (nullItem title) + { rssItemDescription =+ Just $ showHtmlFragment content + , rssItemPubDate = show `fmap` makeDate path + , rssItemLink = Just $ blogURL ++ "/html/" ++ path ++ ".html" }+ fmap (item . (getTitle &&& (write . hideTitle)) . read) . get $ path where read = readMarkdown defaultParserState write = writeHtml defaultWriterOptions- item (title,content) = (nullItem title) - { rssItemDescription =- Just $ showHtmlFragment content - , rssItemPubDate = show `fmap` makeDate path } +hideTitle :: Pandoc -> Pandoc+hideTitle (Pandoc meta blocks) = Pandoc meta newblocks where+ newblocks = case blocks of+ (Header 1 _:content) -> content+ content -> content+ renderTagHtml :: FilePath -> Blogination () renderTagHtml tag = do blog@Blog{..} <- lift get+ alltags <- getTags links <- mapM getEntryLink =<< getTagEntryNames tag+ tags <- mapM (entryTags alltags) =<< getEntryNames anal <- analytics let html = [head,thebody] head = header << [toHtml $ map style blogCSS@@ -116,46 +126,71 @@ thebody = body << [back,hr,name,menu,hr,back,anal] title = tag ++ " - " ++ blogName name = h2 << ("Tag: " ++ tag)- menu = ulist << map ((li<<) . showLink) links+ menu = ulist << (map ((li<<) . showLink blog) $ zip links tags) 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+ liftIO $ fmap dateSort $ filterM (doesFileExist . (blogEntries</>)) names renderIndex :: Blogination () renderIndex = do blog@Blog{..} <- lift get- links <- mapM getEntryLink =<< getEntryNames+ entries <- getEntryNames+ links <- mapM getEntryLink entries alltags <- getTags+ tagEntries <- mapM getTagEntryNames alltags+ entryTags <- mapM (entryTags alltags) entries anal <- analytics- let html = toHtml [header<<[title,encoding,rss]+ let html = toHtml [header<<[title,encoding,rss,toHtml $ map style blogCSS] ,body<<[name,menu,tags,anal]] title = thetitle << blogName name = h1 << blogName- menu = h2 << "Posts" +++ ul (map showLink links)- tags = h2 << "Tags" +++ ul (map (mkTagLink blog) alltags)+ menu = h2 << "Posts" +++ ul (map (showLink blog) $ zip links entryTags)+ tags = h2 << "Tags" +++ ul (map (mkTagLink blog) $ zip alltags tagEntries) ul l = ulist << map (li<<) l rss = thelink ! [rel "alternate",thetype "application/rss+xml" ,href $ blogRoot++"rss.xml"] << noHtml+ style css = thelink ! [rel "stylesheet",href (blogRoot++css)]+ << noHtml liftIO $ writeFile "index.html" $ showHtml html- where showLink (url,title) = hotlink url << title -getEntryLink :: FilePath -> Blogination (URL,String)+showLink :: Blog -> ((URL,String,UTCTime,ClockTime),[FilePath]) -> Html+showLink blog@Blog{..} ((url,name,created,modified),tags) = toHtml+ [p ! [theclass "link"] << hotlink url << name+ ,p ! [theclass "dates"]+ << [small << ("Created: " +++ showTime created)+ ,toHtml ", "+ ,small << ("Modified: " +++ showTime modified')]+ ,p ! [theclass "tagged"]+ << small << tag]+ where showTime = formatTime defaultTimeLocale blogDate+ modified' = clockToUTCTime modified+ tag = list noHtml (("Tags: " +++) . mconcat . intersperse (toHtml ", ")) taglinks+ taglinks = map (mkTagLink blog) $ zip tags (repeat [])++clockToUTCTime :: ClockTime -> UTCTime+clockToUTCTime = readTime l "%Y%m%d%H%M%S" + . formatCalendarTime l "%Y%m%d%H%M%S" . toUTCTime+ where l = defaultTimeLocale++getEntryLink :: FilePath -> Blogination (URL,String,UTCTime,ClockTime) getEntryLink path = do blog@Blog{..} <- lift get liftIO $ do contents <- readFile (blogEntries</>path)+ modified <- getModificationTime (blogEntries</>path) return (blogRoot++blogHtml++"/"++path++".html"- ,getTitle $ read $ contents)+ ,getTitle $ read $ contents+ ,fromMaybe undefined $ makeDate path+ ,modified) where read = readMarkdown defaultParserState renderEntries :: Blogination [FilePath]@@ -184,14 +219,18 @@ renderEntry path = do blog@Blog{..} <- lift get alltags <- getTags- tagEntries <- mapM getTagEntryNames alltags- let tags = map fst . filter (any (==path) . snd) $ zip alltags tagEntries+ tags <- entryTags alltags path liftIO $ do contents <- readFile (blogEntries</>path) writeFile (blogHtml</>path++".html") $ showHtml $ pageToHtml blog path tags contents where match = map fst . filter (any (== path) . snd) +entryTags :: [FilePath] -> FilePath -> Blogination [FilePath]+entryTags tags path = do+ tagEntries <- mapM getTagEntryNames tags+ return $ map fst . filter (any (==path) . snd) $ zip tags tagEntries+ getEntryNames :: Blogination [FilePath] getEntryNames = do Blog{..} <- lift get@@ -204,7 +243,7 @@ filterPlain = filter (all (flip any [isLetter,isSpace,isDigit] . flip ($))) -fileClean = reverse . sort . filter (not . all (=='.'))+fileClean = dateSort . filter (not . all (=='.')) ensureProperState :: Blogination () ensureProperState = do@@ -240,10 +279,10 @@ back = toHtml $ p << hotlink blogRoot << ("« Back to " ++ blogName) style css = thelink ! [rel "stylesheet",href (blogRoot++css)] << noHtml- tagndate = p << (small << (date +++ ", " +++ tag))+ tagndate = p << (small << (date +++ tag)) date = "Date: " +++ (maybe noHtml showTime $ makeDate path)- tag = "Tags: " +++ (mconcat $ intersperse (toHtml ", ") taglinks)- taglinks = map (mkTagLink blog) tags+ tag = list noHtml ((", Tags: " +++) . mconcat . intersperse (toHtml ", ")) taglinks+ taglinks = map (mkTagLink blog) $ zip tags (repeat []) showTime = toHtml . formatTime defaultTimeLocale blogDate analytics :: Blogination Html@@ -264,9 +303,12 @@ \ var pageTracker = _gat._getTracker(\"" ++ blogAnalytics ++ "\"); \ \ pageTracker._trackPageview(); } catch(err) {}</script>" -mkTagLink :: Blog -> FilePath -> Html-mkTagLink Blog{..} tag = - toHtml $ hotlink (blogRoot++"tags/"++tag++".html") << tag+mkTagLink :: Blog -> (FilePath,[FilePath]) -> Html+mkTagLink Blog{..} (tag,entries) = + toHtml $ hotlink (blogRoot++"tags/"++tag++".html") << tag ++++ if null entries + then noHtml + else toHtml $ " (" ++ show (length entries) ++ ")" makeDate :: FilePath -> Maybe UTCTime makeDate path = @@ -294,9 +336,10 @@ tryHighlight other = other highlightOpts :: String -> Maybe (String,String)-highlightOpts = langAndCode . break isSpace where- langAndCode ('$':lang,code) = Just (lang,drop 1 code)- langAndCode _ = Nothing+highlightOpts ('$':rest) = langAndCode $ break (=='$') $ rest where+ langAndCode (lang,'$':code) = Just (lang,dropWhile isSpace code)+ langAndCode _ = Nothing+highlightOpts _ = Nothing highlightWith :: String -> String -> Block highlightWith lang code = RawHtml $ showHtml html where@@ -307,3 +350,6 @@ encoding = meta ! [httpequiv "Content-Type" ,content "text/html; charset=utf-8"]++dateSort :: [String] -> [String]+dateSort = sortBy (flip $ comparing makeDate)