From 313e6a863be0931752aa21cf99f96195a6e2b8c6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 29 Mar 2015 04:18:59 +0200 Subject: Now generating RSS feeds for all lists --- build/generate-rss.hs | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++ clean.do | 1 + default.nix | 2 +- htdocs.do | 2 +- index.md.do | 3 +- rss/default.rss.do | 4 +++ 6 files changed, 91 insertions(+), 3 deletions(-) create mode 100755 build/generate-rss.hs create mode 100644 rss/default.rss.do diff --git a/build/generate-rss.hs b/build/generate-rss.hs new file mode 100755 index 0000000..18d2d6f --- /dev/null +++ b/build/generate-rss.hs @@ -0,0 +1,82 @@ +#!/usr/bin/env runhaskell + +import System.Environment (getArgs) +import qualified Control.Monad.State as S +import Control.Monad (sequence) + +import Text.Feed.Constructor +import Text.Feed.Util +import Text.Feed.Export +import Text.Feed.Types + +import Text.Pandoc +import Text.Pandoc.Pretty + +import qualified System.Time as T +import qualified System.Posix.Files as F +import qualified Text.XML.Light.Output as X +import qualified System.FilePath as FP +import System.Posix.Types + +import Data.Maybe (fromMaybe) +import Data.List (dropWhileEnd, isSuffixOf) + +type FeedState = (Feed, Maybe T.ClockTime) + +feedKind = RSSKind $ Just "test" -- DEBUG + +extract_title :: Pandoc -> String +extract_title d@(Pandoc m _) = do + title <- render Nothing $ cat $ map pretty (docTitle m) + return title + where pretty :: Inline -> Doc + pretty (Str s) = text s + pretty Space = space + pretty _ = empty + +main :: IO () +main = do + (title:entries) <- getArgs + currentTime <- T.getClockTime + let feed = withFeedHome "http://dirty-haskell.org" $ withFeedTitle title $ newFeed feedKind + (populatedFeed, itemTime) <- S.execStateT (sequence $ map addItem' entries) (feed, Nothing) + let populatedFeed' = withFeedDate (toFeedDateString feedKind $ fromMaybe currentTime itemTime) populatedFeed + putStrLn $ X.ppElement $ xmlFeed populatedFeed' + +addItem' :: FilePath -> S.StateT FeedState IO () +addItem' mdFile = do + url <- S.liftIO $ mkUrl mdFile + fileStatus <- S.liftIO $ F.getFileStatus mdFile + fileContents <- S.liftIO $ readFile mdFile + let title = extract_title $ document + contents = writeAsciiDoc def document + document = readMarkdown def fileContents + (feed, time) <- S.get + let fileTime = maximum ([F.modificationTime, F.statusChangeTime] <-> fileStatus) :: System.Posix.Types.EpochTime + fileTime' = T.TOD (toInteger $ fromEnum fileTime) 0 + let item = [ withItemTitle title + , withItemLink url + , withItemDate $ toFeedDateString feedKind fileTime' + , withItemDescription contents + ] <--> (newItem feedKind) :: Item + S.put (addItem item feed, if (Just fileTime' > time) then Just fileTime' else time) + +mkUrl :: FilePath -> IO String +mkUrl link = do + status <- F.getFileStatus link + if F.isSymbolicLink status then + F.readSymbolicLink link >>= mkUrl + else + return $ mkUrl' link +mkUrl' :: FilePath -> String +mkUrl' path = (++) "http://dirty-haskell.org/posts/" $ switchExt ".md" ".html" $ FP.takeFileName path + +switchExt prev after str = if ('.':prev) `isSuffixOf` str then (dropWhileEnd (/= '.') str) ++ after else str + +(<->) :: [(a -> b)] -> a -> [b] +[] <-> _ = [] +(f:fs) <-> x = (f x:fs <-> x) + +(<-->) :: [(a -> a)] -> a -> a +[] <--> x = x +(f:fs) <--> x = fs <--> (f x) diff --git a/clean.do b/clean.do index 3b75ee7..3444aab 100644 --- a/clean.do +++ b/clean.do @@ -1,3 +1,4 @@ find -name '*.html' -not -path './nginx/*' -not -path './htdocs/*' -delete find -name '*.md' -not -path './posts/*' -not -name 'about.md' -delete +find -name '*.rss' -not -path './htdocs/*' -delete rm tex -rf \ No newline at end of file diff --git a/default.nix b/default.nix index 4b377cb..f808b8b 100644 --- a/default.nix +++ b/default.nix @@ -7,6 +7,6 @@ in rec { name = "blog-env"; version = "1"; src = ./.; - buildInputs = [ hs.pandoc hs.pandocTypes hs.cryptohash hs.strict ]; + buildInputs = [ hs.pandoc hs.pandocTypes hs.cryptohash hs.strict hs.feed ]; }; } diff --git a/htdocs.do b/htdocs.do index 6e70576..280bfee 100644 --- a/htdocs.do +++ b/htdocs.do @@ -1,3 +1,3 @@ redo-ifchange all -find . \( -name '*.html' -or -name '*.css' -or -name '*.svg' \) -and -not \( -path '*/.cabal-sandbox/*' -or -path '*/htdocs/*' -or -path '*/build/*' \) -print0 | \ +find . \( -name '*.html' -or -name '*.css' -or -name '*.svg' -or -name '*.rss' \) -and -not \( -path '*/.cabal-sandbox/*' -or -path '*/htdocs/*' -or -path '*/build/*' \) -print0 | \ xargs -0 -I '{}' -- rsync -Rav --delete '{}' htdocs >&2 diff --git a/index.md.do b/index.md.do index 605bbb0..f9def9c 100644 --- a/index.md.do +++ b/index.md.do @@ -7,6 +7,7 @@ done < <(find lists -maxdepth 1 -mindepth 1 -type d -not -name '.*' -print0 | so for x in "${LISTS[@]}"; do printf "%s.html\0" "$x" + printf "rss/%s.rss\0" "$(basename $x)" done | xargs -r -0 redo-ifchange cat <