diff --git a/blogination.cabal b/blogination.cabal --- a/blogination.cabal +++ b/blogination.cabal @@ -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 diff --git a/library/Text/Blogination.hs b/library/Text/Blogination.hs --- a/library/Text/Blogination.hs +++ b/library/Text/Blogination.hs @@ -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 (blogTagstag++".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 (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 + 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 (blogEntriespath) + modified <- getModificationTime (blogEntriespath) 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 (blogEntriespath) writeFile (blogHtmlpath++".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) {}" -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)