FeedMonad/FeedMonad/src/FeedMonad.hs

{-# 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