Parsing atom feeds and running middleware on them

This commit is contained in:
Mats Rauhala 2021-11-11 23:17:57 +02:00
parent 595d5090fe
commit e1b4155a25
5 changed files with 25 additions and 9 deletions

View File

@ -32,7 +32,9 @@ executable FeedMonad-demo
build-depends: build-depends:
base ^>=4.14.3.0, base ^>=4.14.3.0,
FeedMonad, FeedMonad,
containers containers,
lens,
regex-tdfa
hs-source-dirs: app hs-source-dirs: app
default-language: Haskell2010 default-language: Haskell2010

View File

@ -3,8 +3,13 @@ module Main where
import FeedMonad import FeedMonad
import Data.Category import Data.Category
import Data.URL (URL(..)) import Data.URL (URL(..), _URL)
import Database (FeedId(..)) import Database (FeedId(..))
import Middleware
import qualified Data.Set as S
import Data.Entry
import Data.List.Lens (prefixed)
import Control.Lens
myFeeds :: [ Category FeedId ] myFeeds :: [ Category FeedId ]
myFeeds = myFeeds =
@ -12,6 +17,13 @@ myFeeds =
[Leaf (FeedId (URL "https://github.com/feediron/feediron-recipes/commits/master.atom"))] [Leaf (FeedId (URL "https://github.com/feediron/feediron-recipes/commits/master.atom"))]
] ]
myFilters :: Middleware
myFilters =
modifyScore (has (tags . ix (Tag "github"))) (+10) .
modifyScore (has (tags . ix (Tag "haskell"))) (+20) .
modifyTags (has (url . _URL . prefixed "tag:github.com")) (S.insert (Tag "github"))
main :: IO () main :: IO ()
main = do main = do
defaultMain defaultConfig{feeds = myFeeds } defaultMain defaultConfig{feeds = myFeeds, filters = myFilters }

View File

@ -1,11 +1,14 @@
{ mkDerivation, base, FeedMonad, lib }: { mkDerivation, base, containers, FeedMonad, lens, lib, regex-tdfa
}:
mkDerivation { mkDerivation {
pname = "FeedMonad-demo"; pname = "FeedMonad-demo";
version = "0.1.0.0"; version = "0.1.0.0";
src = ./.; src = ./.;
isLibrary = false; isLibrary = false;
isExecutable = true; isExecutable = true;
executableHaskellDepends = [ base FeedMonad ]; executableHaskellDepends = [
base containers FeedMonad lens regex-tdfa
];
license = "unknown"; license = "unknown";
hydraPlatforms = lib.platforms.none; hydraPlatforms = lib.platforms.none;
} }

View File

@ -13,7 +13,7 @@ import Network.HTTP.Client.TLS (newTlsManager)
import Control.Monad.App (runApp) import Control.Monad.App (runApp)
import Data.Environment import Data.Environment
import Control.Monad.Trans (liftIO) import Control.Monad.Trans (liftIO)
import Data.Foldable (for_) import Data.Foldable (for_, traverse_)
import Control.Monad.HTTP (fetch, execute) import Control.Monad.HTTP (fetch, execute)
import Text.Feed.Import (parseFeedSource) import Text.Feed.Import (parseFeedSource)
import Text.Feed.Types import Text.Feed.Types
@ -77,7 +77,7 @@ defaultMain f =
feed <- parseFeedSource <$> liftIO (execute mgr (fetch u)) feed <- parseFeedSource <$> liftIO (execute mgr (fetch u))
case feed of case feed of
Nothing -> pure () Nothing -> pure ()
Just (AtomFeed atom) -> liftIO $ print $ parseAtom atom Just (AtomFeed atom) -> liftIO (traverse (execute mgr . filters f pure) (parseAtom atom) >>= traverse_ print)
Just (RSSFeed _rssFeed) -> liftIO $ putStrLn "rssFeed" Just (RSSFeed _rssFeed) -> liftIO $ putStrLn "rssFeed"
Just (RSS1Feed _rss1Feed) -> liftIO $ putStrLn "rss1Feed" Just (RSS1Feed _rss1Feed) -> liftIO $ putStrLn "rss1Feed"
Just (XMLFeed _xmlFeed) -> liftIO $ putStrLn "xmlFeed" Just (XMLFeed _xmlFeed) -> liftIO $ putStrLn "xmlFeed"

View File

@ -26,8 +26,7 @@ import Control.Monad.HTTP (FetchM)
-- modifyScoreOnTag "crypto" (\x -> x - 100) -- modifyScoreOnTag "crypto" (\x -> x - 100)
-- @ -- @
-- XXX The IO should probably be restricted? type Middleware = (Entry -> FetchM Entry) -> (Entry -> FetchM Entry)
type Middleware = (URL -> FetchM Entry) -> (URL -> FetchM Entry)
-- * Low-level interface for the middlewares -- * Low-level interface for the middlewares