84 lines
2.8 KiB
Haskell
84 lines
2.8 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DeriveFunctor #-}
|
|
module FeedMonad where
|
|
|
|
import Data.Text (Text)
|
|
import Middleware (Middleware)
|
|
import Numeric.Natural (Natural)
|
|
import Data.Category (Category)
|
|
import Data.Acid (openLocalState, AcidState (closeAcidState))
|
|
import Control.Exception (bracket)
|
|
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.Foldable (for_, traverse_)
|
|
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 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
|
|
, refreshTime :: Minutes
|
|
-- ^ How often to refresh the feeds
|
|
, secretToken :: Text
|
|
-- ^ Used for authenticating the UI. This is a single user app
|
|
-- served over http, so we can get around with hardcoded
|
|
-- authentication token
|
|
}
|
|
|
|
defaultConfig :: FeedMonad
|
|
defaultConfig = FeedMonad
|
|
{ feeds = []
|
|
, filters = id
|
|
, refreshTime = Minutes 30
|
|
, 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 $ \fid -> do
|
|
let FeedId u = fid
|
|
feed <- parseFeedSource <$> liftIO (execute mgr (fetch u))
|
|
case feed of
|
|
Nothing -> pure ()
|
|
Just (AtomFeed atom) -> liftIO (traverse (execute mgr . filters f pure) (parseAtom atom) >>= traverse_ print)
|
|
Just (RSSFeed _rssFeed) -> liftIO $ putStrLn "rssFeed"
|
|
Just (RSS1Feed _rss1Feed) -> liftIO $ putStrLn "rss1Feed"
|
|
Just (XMLFeed _xmlFeed) -> liftIO $ putStrLn "xmlFeed"
|