{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
module Imm.Core (
-- * Types
  FeedRef,
-- * Actions
  printVersions,
  subscribe,
  showFeed,
  check,
  run,
  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.Hooks               as Hooks
import qualified Imm.HTTP                as HTTP
import           Imm.Logger              as Logger
import           Imm.Pretty
import           Imm.XML                 as XML

import           Control.Exception.Safe
import           Control.Monad.Time
import           Data.Conduit
import qualified Data.Map                as Map
import           Data.Set                (Set)
import qualified Data.Set                as Set
import           Data.Tree
import           Data.Version
import qualified Paths_imm               as Package
import           Refined
import           Streamly                hiding ((<>))
import qualified Streamly.Prelude        as Stream
import           System.Info
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
-- }}}


printVersions :: (MonadBase IO m) => m ()
printVersions = liftBase $ do
  putStrLn $ "imm-" <> showVersion Package.version
  putStrLn $ "compiled by " <> compilerName <> "-" <> showVersion compilerVersion

-- | Print database status for given feed(s)
showFeed :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> [FeedID] -> m ()
showFeed logger database feedIDs = do
  entries <- Database.fetchList database feedIDs
  flushLogs logger
  when (null entries) $ log logger Warning "No subscription"
  forM_ (zip [1..] $ Map.elems entries) $ \(i, entry) ->
    log logger Info $ pretty (i :: Int) <+> 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)

-- | Check for unread elements without processing them
check :: (MonadAsync m, MonadCatch m)
      => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> XML.Handle m -> [FeedID] -> m ()
check logger database httpClient xmlParser feedIDs = do
  progress <- liftBase $ newTVarIO 0

  results <- Stream.toList $ wAsyncly $ do
    feedID <- Stream.fromFoldable feedIDs
    result <- lift $ tryAny $ checkOne logger database httpClient xmlParser feedID
    let logResult = either (red . pretty . displayException) (\n -> green (pretty n) <+> "new element(s)") result
    n <- liftBase $ atomically $ do
      modifyTVar' (progress :: TVar Int) (+ 1)
      readTVar progress
    lift $ log logger Info $ brackets (fill width (bold $ cyan $ pretty n) <+> "/" <+> pretty total) <+> "Checked" <+> magenta (pretty feedID) <+> "=>" <+> logResult
    return result

  flushLogs logger

  let (failures, successes) = partitionEithers $ zipWith (\a -> bimap (a,) (a,)) feedIDs results
  unless (null failures) $ log logger Error $ bold (pretty $ length failures) <+> "feeds in error"
  log logger Info $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall"

  where width = length (show total :: String)
        total = length feedIDs

checkOne :: (MonadBase IO m, MonadCatch m)
         => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> XML.Handle m -> FeedID -> m Int
checkOne logger database httpClient xmlParser feedID = do
  feed <- getFeed logger httpClient xmlParser feedID
  case feed of
    Atom _ -> log logger Debug $ "Parsed Atom feed: " <> pretty feedID
    Rss _  -> log logger Debug $ "Parsed RSS feed: " <> pretty feedID

  let dates = mapMaybe getDate $ getElements feed

  log logger Debug $ vsep $ map prettyElement $ getElements feed
  status <- Database.getStatus database feedID

  return $ length $ filter (unread status) dates
  where unread (LastUpdate t1) t2 = t2 > t1
        unread _ _                = True


run :: (MonadTime m, MonadAsync m, MonadCatch m)
    => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> Hooks.Handle m -> XML.Handle m -> [FeedID] -> m ()
run logger database httpClient hooks xmlParser feedIDs = do
  progress <- liftBase $ newTVarIO 0

  results <- Stream.toList $ wAsyncly $ do
    feedID <- Stream.fromFoldable feedIDs
    result <- lift $ tryAny $ runOne logger database httpClient hooks xmlParser feedID
    let logResult = either (red . pretty . displayException) (\n -> green (pretty n) <+> "new element(s)") result
    n <- liftBase $ atomically $ do
      modifyTVar' progress (+ 1)
      readTVar progress :: STM Int
    lift $ log logger Info $ brackets (fill width (bold $ cyan $ pretty n) <+> "/" <+> pretty total) <+> "Processed" <+> magenta (pretty feedID) <+> "=>" <+> logResult
    return $ bimap (feedID,) (feedID,) result

  flushLogs logger

  let (failures, successes) = partitionEithers results

  unless (null failures) $ log logger Error $ bold (pretty $ length failures) <+> "feeds in error"
  log logger Info $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall"

  where width = length (show total :: String)
        total = length feedIDs

runOne :: (MonadTime m, MonadCatch m)
       => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> Hooks.Handle m -> XML.Handle m -> FeedID -> m Int
runOne logger database httpClient hooks xmlParser feedID = do
  feed <- getFeed logger httpClient xmlParser feedID
  unreadElements <- filterM (fmap not . isRead database feedID) $ getElements feed

  forM_ unreadElements $ \element -> do
    onNewElement logger hooks feed element
    mapM_ (Database.addReadHash logger database feedID) $ getHashes element

  Database.markAsRead logger database feedID
  return $ length unreadElements


isRead :: MonadCatch m => Database.Handle m FeedTable -> FeedID -> FeedElement -> m Bool
isRead database feedID element = do
  DatabaseEntry _ _ readHashes lastCheck <- Database.fetch database feedID
  let matchHash = not $ Set.null $ Set.fromList (getHashes element) `Set.intersection` readHashes
      matchDate = case (lastCheck, getDate element) of
        (Nothing, _)     -> False
        (_, Nothing)     -> False
        (Just a, Just b) -> a > b
  return $ matchHash || matchDate

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


getFeed :: MonadCatch m => Logger.Handle m -> HTTP.Handle m -> XML.Handle m -> FeedID -> m Feed
getFeed logger httpClient xmlParser (FeedID uri) = HTTP.get logger httpClient uri >>= parseXml xmlParser uri