Now generating RSS feeds for all lists

6 files changed, 91 insertions, 3 deletions

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 <<EOF
@@ -21,6 +22,6 @@ EOF
 for x in "${LISTS[@]}"; do
     printf "* [%s](%s)\n" "$(<$x/title)" "$x.html"
     while read -r -d $'\n'; do
-        printf "    %s\n" "$REPLY"
+        printf "    %s ([RSS](rss/%s))\n" "$REPLY" "$(basename $x).rss"
     done < "$x/preview"
 done
diff --git a/rss/default.rss.do b/rss/default.rss.do
new file mode 100644
index 0000000..a10b032
--- /dev/null
+++ b/rss/default.rss.do
@@ -0,0 +1,4 @@
+redo-ifchange ../lists/$2.html
+
+find ../lists/$2 -maxdepth 1 -mindepth 1 -not -name 'preview' -not -name 'title' -print0 | \
+                xargs -x -0 -- ../build/generate-rss.hs "$(printf "Dirty-Haskell.org — %s" "$(cat ../lists/$2/title)")"