merge feeds

4 files changed, 77 insertions, 13 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 35e675a..99daa6e 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,37 +1,86 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 module Main where
 
 import Conduit
+import Control.Exception
 import Data.Maybe
+import Data.Text qualified as T
 import Data.XML.Types
 import Network.HTTP.Conduit
 import Text.Atom.Conduit.Parse
 import Text.Atom.Conduit.Render
+import Text.Atom.Types
 import Text.XML.Stream.Parse
 import Text.XML.Stream.Render
 import Text.XML.Unresolved (elementToEvents)
 
+env_FEED_TITLE :: T.Text
+env_FEED_TITLE = "code.nomath.org"
+
+env_FEED_ID :: T.Text
+env_FEED_ID = "code.nomath.org"
+
+env_FEED_URLS :: [String]
+env_FEED_URLS =
+  [ "https://code.nomath.org/anissue/atom",
+    "https://code.nomath.org/apaperless/atom",
+    "https://code.nomath.org/abuilder/atom",
+    "https://code.nomath.org/infra/atom",
+    "https://code.nomath.org/json2sql/atom",
+    "https://code.nomath.org/nomath-org/atom",
+    "https://code.nomath.org/static-nomath-org/atom"
+  ]
+
 main :: IO ()
 main = do
-  request <- parseRequest "https://code.nomath.org/abuilder/atom"
   manager <- newManager tlsManagerSettings
   runResourceT do
-    response <- http request manager
-    runConduit $
-      ( \feed ->
-          renderAtomFeed feed
-            .| renderBytes def
-            .| printC
-      )
-        . fromJust
-        =<< responseBody response
-          .| parseBytes def
-          .| massage
-          .| atomFeed
+    feeds <- mapM (getFeed manager) env_FEED_URLS
+    let feed = merge feeds
+    runConduit do
+      renderAtomFeed feed
+        .| renderBytes def
+        .| sinkFile "output.atom"
+
+merge :: [AtomFeed] -> AtomFeed
+merge feeds =
+  AtomFeed
+    { feedAuthors = concatMap (.feedAuthors) feeds,
+      feedCategories = concatMap (.feedCategories) feeds,
+      feedContributors = concatMap (.feedContributors) feeds,
+      feedEntries = concatMap (.feedEntries) feeds,
+      feedGenerator = Nothing,
+      feedIcon = Nothing,
+      feedId = env_FEED_ID,
+      feedLinks = concatMap (.feedLinks) feeds,
+      feedLogo = Nothing,
+      feedRights = Nothing,
+      feedSubtitle = Nothing,
+      feedTitle = AtomPlainText TypeText env_FEED_TITLE,
+      feedUpdated = minimum (map (.feedUpdated) feeds)
+    }
+
+data ParserError = ParserError String
+  deriving (Show)
+
+instance Exception ParserError
+
+getFeed :: Manager -> String -> ResourceT IO AtomFeed
+getFeed manager url = do
+  request <- parseRequest url
+  response <- http request manager
+  fromMaybe (throw (ParserError url))
+    <$> runConduit do
+      responseBody response
+        .| parseBytes def
+        .| massage
+        .| atomFeed
 
 massage :: ConduitT Event Event (ResourceT IO) ()
 massage = do
diff --git a/atom-conduit.patch b/atom-conduit.patch
new file mode 100644
index 0000000..241a05e
--- /dev/null
+++ b/atom-conduit.patch
@@ -0,0 +1,13 @@
+diff --git a/src/Text/Atom/Conduit/Parse.hs b/src/Text/Atom/Conduit/Parse.hs
+index ee77987..7fc3b59 100644
+--- a/src/Text/Atom/Conduit/Parse.hs
++++ b/src/Text/Atom/Conduit/Parse.hs
+@@ -88,7 +88,7 @@ tagIgnoreAttrs' :: MonadThrow m => Text -> ConduitM Event o m a -> ConduitM Even
+ tagIgnoreAttrs' name handler = tagName' name ignoreAttrs $ const handler
+
+ xhtmlContent :: MonadThrow m => ConduitM Event o m XML.Element
+-xhtmlContent = force "element" $ many_ takeAnyTreeContent .| mapC (Nothing, ) .| Unresolved.elementFromEvents
++xhtmlContent = force "element" $ ignoreContent *> many_ takeAnyTreeContent .| mapC (Nothing, ) .| Unresolved.elementFromEvents
+
+
+ projectC :: Monad m => Traversal' a b -> ConduitT a b m ()
diff --git a/default.nix b/default.nix
index 830ada3..c0a928f 100644
--- a/default.nix
+++ b/default.nix
@@ -2,6 +2,7 @@
 let
   haskellPackages = pkgs.haskellPackages.override {
     overrides = self: super: {
+      atom-conduit = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendPatch super.atom-conduit ./atom-conduit.patch);
       feed-nomath-org = self.callCabal2nix "feed-nomath-org" ./. { };
     };
   };
diff --git a/feed-nomath-org.cabal b/feed-nomath-org.cabal
index 0ceecfa..9678557 100644
--- a/feed-nomath-org.cabal
+++ b/feed-nomath-org.cabal
@@ -21,5 +21,6 @@ executable feed-nomath-org
         conduit,
         http-conduit,
         resourcet,
+        text,
         xml-conduit,
         xml-types