module Imm.Feed where
import qualified Imm.HTTP as HTTP
import qualified Imm.Mail as Mail
import qualified Imm.Maildir as Maildir
import Imm.Types
import Imm.Util
import Control.Applicative
import Control.Conditional hiding(when)
import Control.Monad.Error
import Control.Monad.Reader hiding(when)
import Data.Either
import qualified Data.Text.Lazy as T
import Data.Time hiding(parseTime)
import Data.Time.Clock.POSIX
import Network.URI as N
import System.Directory
import System.IO
import System.Locale
import qualified Text.Atom.Feed as Atom
import Text.Feed.Import as F
import Text.Feed.Query as F
import Text.Feed.Types as F
import Text.XML.Light.Proc
getStateFile :: URI -> FilePath
getStateFile feedUri@URI{ uriAuthority = Just auth } = toFileName =<< ((++ (uriQuery feedUri)) . (++ (uriPath feedUri)) . uriRegName $ auth)
getStateFile feedUri = show feedUri >>= toFileName
toFileName :: Char -> String
toFileName '/' = "."
toFileName '?' = "."
toFileName x = [x]
parse :: MonadError ImmError m => String -> m Feed
parse x = maybe (throwError $ ParseFeedError x) return $ parseFeedString x
printStatus :: (MonadReader Settings m, MonadIO m) => URI -> m ()
printStatus uri = do
lastCheck <- getLastCheck uri
let prefix = (lastCheck == posixSecondsToUTCTime 0) ? "[NEW] " ?? ("[Last update: "++ show lastCheck ++ "]")
io . putStrLn $ prefix ++ " " ++ show uri
getLastCheck :: (MonadReader Settings m, MonadIO m) => URI -> m UTCTime
getLastCheck feedUri = do
directory <- asks mStateDirectory
result <- runErrorT $ do
content <- try $ readFile =<< (directory >/> fileName)
parseTime content
either (const $ return timeZero) return result
where
fileName = getStateFile feedUri
timeZero = posixSecondsToUTCTime 0
storeLastCheck :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => URI -> UTCTime -> m ()
storeLastCheck feedUri date = do
directory <- asks mStateDirectory
(file, stream) <- try $ (`openTempFile` fileName) =<< directory
io $ hPutStrLn stream (formatTime defaultTimeLocale "%c" date)
io $ hClose stream
try $ renameFile file =<< (directory >/> fileName)
where
fileName = getStateFile feedUri
download :: (MonadIO m, MonadError ImmError m) => URI -> m ImmFeed
download uri = do
feed <- parse . T.unpack =<< decode =<< HTTP.getRaw uri
return (uri, feed)
check :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => ImmFeed -> m ()
check (uri, feed) = do
lastCheck <- getLastCheck uri
dates <- return . rights =<< forM (feedItems feed) (runErrorT . getDate)
let newItems = filter (> lastCheck) dates
io . putStrLn $ "==> " ++ show (length newItems) ++ " new item(s) "
update :: (Applicative m, MonadReader Settings m, MonadIO m, MonadError ImmError m) => ImmFeed -> m ()
update (uri, feed) = do
Maildir.init =<< asks mMaildir
logVerbose $ unlines [
"Title: " ++ (getFeedTitle feed),
"Author: " ++ (maybe "No author" id $ getFeedAuthor feed),
"Home: " ++ (maybe "No home" id $ getFeedHome feed)]
lastCheck <- getLastCheck uri
results <- forM (feedItems feed) $ \item ->
do
date <- getDate item
(date > lastCheck) ? (updateItem (item, feed) >> return 1) ?? return 0
`catchError` (\e -> (io . print) e >> return 0 )
io . putStrLn $ "==> " ++ show (sum results) ++ " new item(s)"
markAsRead uri
updateItem :: (Applicative m, MonadReader Settings m, MonadIO m, MonadError ImmError m) => (Item, Feed) -> m ()
updateItem (item, feed) = do
date <- getDate item
logVerbose $ unlines [
" Item author: " ++ (maybe "<empty>" id $ getItemAuthor item),
" Item title: " ++ (maybe "<empty>" id $ getItemTitle item),
" Item URI: " ++ (maybe "<empty>" id $ getItemLink item),
" Item date: " ++ show date]
timeZone <- io getCurrentTimeZone
dir <- asks mMaildir
Maildir.add dir =<< Mail.build timeZone (item, feed)
markAsRead :: forall (m :: * -> *) . (MonadIO m, MonadError ImmError m, MonadReader Settings m) => URI -> m ()
markAsRead uri = io getCurrentTime >>= storeLastCheck uri >> (logVerbose $ "Feed " ++ show uri ++ " marked as read.")
markAsUnread :: forall (m :: * -> *) . (MonadIO m, MonadError ImmError m, MonadReader Settings m) => URI -> m ()
markAsUnread uri = do
directory <- asks mStateDirectory
try $ removeFile =<< directory >/> (getStateFile uri)
logVerbose $ "Feed " ++ show uri ++ " marked as unread."
getItemLinkNM :: Item -> String
getItemLinkNM item = maybe "No link found" paragraphy $ getItemLink item
getItemContent :: Item -> T.Text
getItemContent (AtomItem e) = T.pack . maybe "No content" extractHtml . Atom.entryContent $ e
getItemContent item = T.pack . maybe "Empty" id . getItemDescription $ item
getDate :: MonadError ImmError m => Item -> m UTCTime
getDate x = maybe (throwError $ ParseItemDateError x) return $ parseDate =<< F.getItemDate x
extractHtml :: Atom.EntryContent -> String
extractHtml (Atom.HTMLContent c) = c
extractHtml (Atom.XHTMLContent c) = strContent c
extractHtml (Atom.TextContent t) = t
extractHtml (Atom.MixedContent a b) = show a ++ show b
extractHtml (Atom.ExternalContent mediaType uri) = show mediaType ++ show uri
paragraphy :: String -> String
paragraphy s = "<p>"++s++"</p>"