Core.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeFamilies          #-}
module Core (
-- * Types
  FeedRef,
-- * Actions
  subscribe,
  listFeeds,
  showFeed,
  importOPML,
) where

-- {{{ Imports
import qualified Imm.Database            as Database
import           Imm.Database.FeedTable
import qualified Imm.Database.FeedTable  as Database
import           Imm.Feed
import           Imm.Logger              as Logger
import           Imm.Pretty

import           Control.Exception.Safe
import           Data.Conduit
import qualified Data.Map                as Map
import           Data.Set                (Set)
import qualified Data.Set                as Set
import           Data.Tree
import           Refined
import           Text.OPML.Conduit.Parse
import           Text.OPML.Types         as OPML
import           Text.XML                as XML ()
import           Text.XML.Stream.Parse   as XML
import           URI.ByteString
-- }}}



-- | Print database status for given feed(s)
showFeed :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m ()
showFeed logger database feedID = do
  entry <- Database.fetch database feedID
  flushLogs logger
  log logger Info $ prettyDatabaseEntry entry

-- | Register the given feed URI in database
subscribe :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> URI -> Set Text -> m ()
subscribe logger database uri = Database.register logger database (FeedID uri)

-- | List all subscribed feeds and their status
listFeeds :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> m ()
listFeeds logger database = do
  entries <- Database.fetchAll database
  flushLogs logger
  when (null entries) $ log logger Warning "No subscription"
  forM_ (zip [1..] $ Map.elems entries) $ \(i, entry) ->
    log logger Info $ pretty (i :: Int) <+> prettyShortDatabaseEntry entry


-- | 'subscribe' to all feeds described by the OPML document provided in input
importOPML :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> ConduitT () ByteString m () -> m ()
importOPML logger database input = do
  opml <- runConduit $ input .| XML.parseBytes def .| force "Invalid OPML" parseOpml
  forM_ (opmlOutlines opml) $ importOPML' logger database mempty

importOPML' :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> Set Text -> Tree OpmlOutline -> m ()
importOPML' logger database _ (Node (OpmlOutlineGeneric b _) sub) = mapM_ (importOPML' logger database (Set.singleton . unrefine $ OPML.text b)) sub
importOPML' logger database c (Node (OpmlOutlineSubscription _ s) _) = subscribe logger database (xmlUri s) c
importOPML' _ _ _ _ = return ()