diff --git a/FeedMonad-demo/app/Main.hs b/FeedMonad-demo/app/Main.hs index 36cc4b0..f53c6df 100644 --- a/FeedMonad-demo/app/Main.hs +++ b/FeedMonad-demo/app/Main.hs @@ -4,11 +4,12 @@ module Main where import FeedMonad import Data.Category import Data.URL (URL(..)) +import Database (FeedId(..)) -myFeeds :: [ Category URL ] +myFeeds :: [ Category FeedId ] myFeeds = [ Category "News" - [ Leaf (URL "https://github.com/feediron/feediron-recipes/commits/master.atom")] + [Leaf (FeedId (URL "https://github.com/feediron/feediron-recipes/commits/master.atom"))] ] main :: IO () diff --git a/FeedMonad/src/Data/Entry.hs b/FeedMonad/src/Data/Entry.hs index 7ac32a5..8cdcfcd 100644 --- a/FeedMonad/src/Data/Entry.hs +++ b/FeedMonad/src/Data/Entry.hs @@ -8,7 +8,7 @@ import Data.Text (Text) import Control.Lens import Data.SafeCopy import GHC.Generics (Generic) -import Data.URL (URL (URL)) +import Data.URL (URL ) newtype Tag = Tag Text @@ -27,9 +27,6 @@ data Entry = Entry -- * Lenses for accessing relevant parts of entry -_URL :: Iso' URL String -_URL = iso (\(URL u) -> u) URL - content :: Lens' Entry ByteString content = lens entryContent (\ en bs -> en{entryContent=bs}) diff --git a/FeedMonad/src/Data/URL.hs b/FeedMonad/src/Data/URL.hs index 80e57b2..f73b00c 100644 --- a/FeedMonad/src/Data/URL.hs +++ b/FeedMonad/src/Data/URL.hs @@ -3,8 +3,12 @@ module Data.URL where import GHC.Generics (Generic) import Data.SafeCopy (SafeCopy) +import Control.Lens newtype URL = URL String deriving (Show, Eq, Ord, Generic) +_URL :: Iso' URL String +_URL = iso (\(URL u) -> u) URL + instance SafeCopy URL diff --git a/FeedMonad/src/Database.hs b/FeedMonad/src/Database.hs index b91f6b1..5e67f3e 100644 --- a/FeedMonad/src/Database.hs +++ b/FeedMonad/src/Database.hs @@ -9,6 +9,8 @@ module Database -- * Internal State FeedMonadState , emptyFeedMonadState + , FeedId(..) + , EntryId(..) -- * Update functions , SaveEntry(..) -- * Query functions diff --git a/FeedMonad/src/FeedMonad.hs b/FeedMonad/src/FeedMonad.hs index cda1f77..9ce18f4 100644 --- a/FeedMonad/src/FeedMonad.hs +++ b/FeedMonad/src/FeedMonad.hs @@ -8,21 +8,26 @@ import Numeric.Natural (Natural) import Data.Category (Category) import Data.Acid (openLocalState, AcidState (closeAcidState)) import Control.Exception (bracket) -import Database (emptyFeedMonadState) +import Database (emptyFeedMonadState, FeedId (FeedId)) import Network.HTTP.Client.TLS (newTlsManager) import Control.Monad.App (runApp) import Data.Environment import Control.Monad.Trans (liftIO) -import Data.URL (URL) import Data.Foldable (for_) import Control.Monad.HTTP (fetch, execute) import Text.Feed.Import (parseFeedSource) +import Text.Feed.Types +import qualified Text.Atom.Feed as Atom +import Data.Entry +import Control.Lens +import Data.Text.Strict.Lens (utf8, unpacked) +import Data.URL (_URL) newtype Minutes = Minutes Natural data FeedMonad = FeedMonad - { feeds :: [Category URL] + { feeds :: [Category FeedId] -- ^ The forest of urls for the feeds. It's a forest because of the categories , filters :: Middleware -- ^ The middleware. Modifies the scoring, tags and content @@ -42,11 +47,37 @@ defaultConfig = FeedMonad , secretToken = "i am a secret" } +parseAtom :: Atom.Feed -> [Entry] +parseAtom Atom.Feed{Atom.feedEntries=es} = map parseEntry es + where + parseEntry :: Atom.Entry -> Entry + parseEntry atomEntry = Entry + { entryURL = view (unpacked . from _URL) $ Atom.entryId atomEntry + , entryTitle = + case Atom.entryTitle atomEntry of + Atom.TextString txt -> txt + _ -> "Title supported" + , entryContent = + case Atom.entryContent atomEntry of + Just (Atom.TextContent txt) -> view (re utf8 . lazy) txt + Just (Atom.HTMLContent html) -> view (re utf8 . lazy) html + Just _ -> "Content not supported" + Nothing -> "" + , entryScore = 0 + , entryTags = mempty + } + defaultMain :: FeedMonad -> IO () defaultMain f = bracket (openLocalState emptyFeedMonadState) closeAcidState $ \st -> do mgr <- newTlsManager runApp (Environment mgr st) $ - for_ (feeds f) $ \c -> for_ c $ \url -> do - feed <- parseFeedSource <$> liftIO (execute mgr (fetch url)) - liftIO $ print feed + for_ (feeds f) $ \c -> for_ c $ \fid -> do + let FeedId u = fid + feed <- parseFeedSource <$> liftIO (execute mgr (fetch u)) + case feed of + Nothing -> pure () + Just (AtomFeed atom) -> liftIO $ print $ parseAtom atom + Just (RSSFeed _rssFeed) -> liftIO $ putStrLn "rssFeed" + Just (RSS1Feed _rss1Feed) -> liftIO $ putStrLn "rss1Feed" + Just (XMLFeed _xmlFeed) -> liftIO $ putStrLn "xmlFeed"