Parse atom (partially)

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 ()

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})
 

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

FeedMonad/src/Database.hs

@@ -9,6 +9,8 @@ module Database
     -- * Internal State
     FeedMonadState
   , emptyFeedMonadState
+  , FeedId(..)
+  , EntryId(..)
     -- * Update functions
   , SaveEntry(..)
     -- * Query functions

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
+      for_ (feeds f) $ \c -> for_ c $ \fid -> do
-        feed <- parseFeedSource <$> liftIO (execute mgr (fetch url))
+        let FeedId u = fid
-        liftIO $ print feed
+        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"