119 lines
4.1 KiB
Haskell
119 lines
4.1 KiB
Haskell
{-# LANGUAGE DeriveFunctor #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
module FeedMonad where
|
|
|
|
import Control.Exception (bracket)
|
|
import Control.Monad.App (App, runApp)
|
|
import Control.Monad.HTTP (execute, fetch)
|
|
import Control.Monad.Reader (asks)
|
|
import Control.Monad.Trans (liftIO, MonadIO)
|
|
import Data.Acid (AcidState(closeAcidState), openLocalState, query, update)
|
|
import Data.Category (Category)
|
|
import Data.Environment
|
|
import Data.Foldable (for_, toList, traverse_)
|
|
import Data.Text (Text)
|
|
import Database
|
|
( CountEntries(CountEntries)
|
|
, FeedId(FeedId)
|
|
, SaveEntries(SaveEntries)
|
|
, emptyFeedMonadState, UnseenEntries (UnseenEntries), EntryId (EntryId)
|
|
)
|
|
import Feed.Parser (parseEntries)
|
|
import Middleware (Middleware)
|
|
import Network.HTTP.Client.TLS (newTlsManager)
|
|
import Numeric.Natural (Natural)
|
|
import Text.Feed.Import (parseFeedSource)
|
|
import Data.Entry (Entry(entryURL))
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.Text.IO as TI
|
|
import Trace
|
|
import qualified Data.Text as T
|
|
import Data.Functor.Contravariant ((>$<))
|
|
import Text.Printf (printf)
|
|
import Data.Either (partitionEithers)
|
|
|
|
|
|
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"
|
|
}
|
|
|
|
data TraceMsg
|
|
= UpdateFeed FeedId UpdateMsg
|
|
| UpdateFeeds
|
|
|
|
data UpdateMsg
|
|
= Start
|
|
| NewEntries Int
|
|
| Failures [Text]
|
|
|
|
formatTraceMsg :: TraceMsg -> Maybe Text
|
|
formatTraceMsg (UpdateFeed fi Start) = Just $ T.pack $ printf "Updating feed %s" (show fi)
|
|
formatTraceMsg (UpdateFeed fi (NewEntries n)) = Just $ T.pack $ printf "Feed (%s) has %d new entries" (show fi) n
|
|
formatTraceMsg (UpdateFeed _ (Failures [])) = Nothing
|
|
formatTraceMsg (UpdateFeed fi (Failures failures)) = Just $ T.pack $ printf "Feed (%s) has %d failures: %s" (show fi) (length failures) (show failures)
|
|
formatTraceMsg UpdateFeeds = Just $ T.pack $ printf "Updating feeds"
|
|
|
|
logTrace :: MonadIO m => Trace m (Maybe Text)
|
|
logTrace = Trace $ \case
|
|
Nothing -> pure ()
|
|
Just msg -> liftIO . TI.putStrLn $ msg
|
|
|
|
updateFeeds :: Trace App TraceMsg -> FeedMonad -> App ()
|
|
updateFeeds trace f = do
|
|
runTrace trace UpdateFeeds
|
|
for_ (feeds f) $
|
|
traverse_ (\fid -> updateFeed (UpdateFeed fid >$< trace) fid)
|
|
where
|
|
updateFeed :: Trace App UpdateMsg -> FeedId -> App ()
|
|
updateFeed t fid = do
|
|
let FeedId u = fid
|
|
mgr <- asks environmentManager
|
|
st <- asks environmentAcidState
|
|
runTrace t Start
|
|
(failures, entries) <- liftIO (partitionEithers . maybe [] parseEntries . parseFeedSource <$> liftIO (execute mgr (fetch u)))
|
|
runTrace t (Failures failures)
|
|
finalEntries <- liftIO (foldMap (\e -> M.singleton (EntryId $ entryURL e) e) <$> traverse (execute mgr . filters f pure) entries)
|
|
newEntries <- liftIO (query st (UnseenEntries fid (M.keysSet finalEntries)))
|
|
runTrace t (NewEntries (length newEntries))
|
|
liftIO (update st (SaveEntries fid (foldMap (\eid -> toList $ M.lookup eid finalEntries) newEntries)))
|
|
|
|
queryCategory :: FeedMonad -> App [Category (FeedId, Int)]
|
|
queryCategory = traverse (traverse q) . feeds
|
|
where
|
|
q :: FeedId -> App (FeedId, Int)
|
|
q fid = do
|
|
st <- asks environmentAcidState
|
|
(fid, ) <$> liftIO (query st (CountEntries fid))
|
|
|
|
defaultMain :: FeedMonad -> IO ()
|
|
defaultMain f = do
|
|
let trace = formatTraceMsg >$< logTrace
|
|
bracket (openLocalState emptyFeedMonadState) closeAcidState $ \st -> do
|
|
mgr <- newTlsManager
|
|
runApp (Environment mgr st) $ do
|
|
updateFeeds trace f
|
|
cat <- queryCategory f
|
|
liftIO $ print cat
|