diff --git a/Imm/Boot.hs b/Imm/Boot.hs --- a/Imm/Boot.hs +++ b/Imm/Boot.hs @@ -1,39 +1,42 @@ +-- | Low level functions used at start-up to parse commandline and handle dynamic reconfiguration. module Imm.Boot where -- {{{ Imports -import Imm.Main +import qualified Imm.Main as Main import Imm.Types import qualified Config.Dyre as D import Config.Dyre.Paths -import Control.Monad.Error -import Control.Monad.Reader - import System.Console.CmdArgs +import System.Console.CmdArgs.Explicit import System.IO -- }}} -- {{{ Commandline options --- | Available commandline options -cliOptions :: CliOptions -cliOptions = CliOptions { - mCheck = def &= explicit &= name "c" &= name "check" &= help "Check availability and validity of all feed sources currently configured.", - mList = def &= explicit &= name "l" &= name "list" &= help "List all feed sources currently configured.", - mDenyReconf = def &= explicit &= name "deny-reconf" &= help "Deny recompilation even if the configuration file has changed.", - mMasterBinary = def &= explicit &= name "dyre-master-binary" -} - -getOptions :: IO CliOptions -getOptions = cmdArgs $ cliOptions +-- | Available commandline options. +cliOptions :: Mode (CmdArgs CliOptions) +cliOptions = cmdArgsMode $ baseOptions &= verbosityArgs [explicit, name "verbose", name "v"] [] &= versionArg [ignore] &= help "Convert items from RSS/Atom feeds to maildir entries." &= helpArg [explicit, name "help", name "h"] &= program "imm" + where + baseOptions = CliOptions { + -- mCheck = def &= explicit &= name "c" &= name "check" &= help "Check availability and validity of all feed sources currently configured.", + mFeedURI = def &= explicit &= name "f" &= name "feed" &= help "Only process given feed." &= typ "URI", + mImportOPML = def &= explicit &= name "i" &= name "import" &= help "Import feeds list from an OPML descriptor (read from stdin).", + mList = def &= explicit &= name "l" &= name "list" &= help "List all feed sources currently configured, along with their status.", + mMarkAsRead = def &= explicit &= name "R" &= name "mark-read" &= help "Mark every item of processed feeds as read, ie set last update as now without writing any mail.", + mMarkAsUnread = def &= explicit &= name "U" &= name "mark-unread" &= help "Mark every item of processed feeds as unread, ie delete corresponding state files.", + mUpdate = def &= explicit &= name "u" &= name "update" &= help "Update list of feeds (mostly used option).", + mDenyReconf = def &= explicit &= name "deny-reconf" &= help "Deny recompilation even if the configuration file has changed.", + mMasterBinary = def &= explicit &= name "dyre-master-binary" &= help "Flag used internally for dynamic reconfiguration purposes." &= typ "PATH"} -- }}} -- {{{ Dynamic reconfiguration +-- | Print various paths used for dynamic reconfiguration. printDyrePaths :: IO () printDyrePaths = do (a, b, c, d, e) <- getPaths dyreParameters @@ -44,7 +47,8 @@ "Cache directory: " ++ d, "Lib directory: " ++ e, []] -dyreParameters :: D.Params (Either String (Settings, CliOptions)) +-- | Dynamic configuration settings. +dyreParameters :: D.Params (Either String FeedList) dyreParameters = D.defaultParams { D.projectName = "imm", D.showError = showError, @@ -57,17 +61,27 @@ showError _ = Left -- }}} --- | Main function to call. -imm :: Settings -> IO () -imm settings = do - options <- getOptions - D.wrapMain dyreParameters (Right (settings, options)) +-- | Main function to call in your configuration file. +imm :: FeedList -> IO () +imm = D.wrapMain dyreParameters . Right --- Main dispatcher, depending on commandline options -realMain :: Either String (Settings, CliOptions) -> IO () +-- | Internal dispatcher, decides which function to execute depending on commandline options. +realMain :: Either String FeedList -> IO () realMain (Left e) = putStrLn e -realMain (Right (settings, options)) - | mList options = mapM_ (flip runReaderT settings . printFeedGroupStatus) $ mFeedGroups settings - | mCheck options = mapM_ (flip runReaderT settings . checkFeedGroup) $ mFeedGroups settings - | otherwise = whenLoud printDyrePaths >> runErrorT (runReaderT main settings) >>= either print return +realMain (Right feeds) = do + options <- cmdArgsRun cliOptions + whenLoud printDyrePaths + let feeds' = case (mFeedURI options) of + Just uri -> filter (\(_, u) -> u == uri) feeds + _ -> feeds + realMain' (feeds', options) + where + realMain' (f, options) + | mImportOPML options = Main.importOPML + | mList options = Main.list f + | mMarkAsRead options = Main.markAsRead f + | mMarkAsUnread options = Main.markAsUnread f +-- | mCheck options = Main.check f + | mUpdate options = Main.update f + | otherwise = print $ helpText [] HelpFormatDefault cliOptions -- }}} diff --git a/Imm/Config.hs b/Imm/Config.hs --- a/Imm/Config.hs +++ b/Imm/Config.hs @@ -1,27 +1,38 @@ +-- | Default settings module Imm.Config where -- {{{ Imports import Imm.Feed import Imm.Types +import Imm.Util +import Control.Monad.Trans + +import Data.Char +import Data.Default +import Data.Foldable hiding(concat) import qualified Data.Text.Lazy as T import System.FilePath import Text.Feed.Query -import Text.Feed.Types -- }}} --- | Default configuration. -defaultSettings :: Settings -defaultSettings = Settings { - mStateDirectory = ( "state") . mConfiguration, - mFeedGroups = [], - mFromBuilder = \(item, feed) -> maybe (getFeedTitle feed) id $ getItemAuthor item, - mSubjectBuilder = \(item, _feed) -> T.pack . maybe "Untitled" id $ getItemTitle item, - mBodyBuilder = \(item, _feed) -> contentBuilder item -} -contentBuilder :: Item -> T.Text -contentBuilder item = - T.unlines $ map (flip ($) item) [T.pack . getItemLinkNM, getItemContent] +instance Default Settings where + def = Settings { + mStateDirectory = ( "state") . mConfiguration, + mMaildir = ( "feeds") . mHome, + mFromBuilder = \(item, feed) -> maybe (getFeedTitle feed) id $ getItemAuthor item, + mSubjectBuilder = \(item, _feed) -> T.pack . maybe "Untitled" id $ getItemTitle item, + mBodyBuilder = \(item, _feed) -> T.unlines $ map (flip ($) item) [T.pack . getItemLinkNM, getItemContent]} + + +addFeeds :: MonadIO m => [(String, [String])] -> m () +addFeeds feeds = io . forM_ feeds $ \(groupTitle, uris) -> do + putStrLn $ "-- Group " ++ groupTitle + putStrLn $ map toLower (concat . words $ groupTitle) ++ " = [" + forM_ uris (\uri -> putStrLn $ " " ++ show uri ++ ",") + putStrLn "]" + putStrLn "" + diff --git a/Imm/Executable.hs b/Imm/Executable.hs --- a/Imm/Executable.hs +++ b/Imm/Executable.hs @@ -1,8 +1,7 @@ --module Executable where import Imm.Boot -import Imm.Config --import Imm.Types main :: IO () -main = imm defaultSettings +main = imm [] diff --git a/Imm/Feed.hs b/Imm/Feed.hs --- a/Imm/Feed.hs +++ b/Imm/Feed.hs @@ -1,28 +1,33 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, RankNTypes, KindSignatures #-} module Imm.Feed where -- {{{ Imports +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.Conditional hiding(when) import Control.Monad.Error -import Control.Monad.Reader +import Control.Monad.Reader hiding(when) --import Data.Functor import qualified Data.Text.Lazy as T import Data.Time hiding(parseTime) import Data.Time.Clock.POSIX -import Network.URI +import Network.URI as N import System.Directory import System.FilePath import System.IO import System.Locale -import Text.Atom.Feed hiding(URI) +import qualified Text.Atom.Feed as Atom +import Text.Feed.Import as F import Text.Feed.Query as F -import Text.Feed.Types +import Text.Feed.Types as F import Text.XML.Light.Proc -- }}} @@ -37,7 +42,21 @@ toFileName x = [x] -- }}} +-- | Monad-agnostic version of 'Text.Feed.Import.parseFeedString' +parse :: MonadError ImmError m => String -> m Feed +parse x = maybe (throwError $ ParseFeedError x) return $ parseFeedString x +-- | +printStatus :: (MonadReader Settings m, MonadIO m) => String -> m () +printStatus feedUri = do + prefix <- case N.parseURI feedUri of + Just uri -> do + lastCheck <- getLastCheck uri + return $ (lastCheck == posixSecondsToUTCTime 0) ? "[NEW] " ?? ("[Last update: "++ show lastCheck ++ "]") + _ -> return "[Not an URI]" + io . putStrLn $ prefix ++ " " ++ feedUri + + getLastCheck :: (MonadReader Settings m, MonadIO m) => URI -> m UTCTime getLastCheck feedUri = do directory <- asks mStateDirectory >>= resolve @@ -61,27 +80,78 @@ 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) + +-- | Create mails for each new item +update :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => ImmFeed -> m () +update (uri, feed) = do + logNormal $ "Updating feed " ++ show uri +-- checkStateDirectory + 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 + forM_ (feedItems feed) $ \item -> + do + date <- getDate item + when (date > lastCheck) $ updateItem (item, feed) + `catchError` (io . print) + + markAsRead uri + +updateItem :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => (Item, Feed) -> m () +updateItem (item, feed) = do + date <- getDate item + logVerbose $ unlines [ + " Item author: " ++ (maybe "" id $ getItemAuthor item), + " Item title: " ++ (maybe "" id $ getItemTitle item), + " Item URI: " ++ (maybe "" id $ getItemLink item), + -- " Item Body: " ++ (Imm.Mail.getItemContent 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 >>= resolve + try $ removeFile $ directory (getStateFile uri) + logVerbose $ "Feed " ++ show uri ++ " marked as unread." + + -- {{{ Item utilities 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 . entryContent $ e +getItemContent (AtomItem e) = T.pack . maybe "No content" extractHtml . Atom.entryContent $ e getItemContent item = T.pack . maybe "Empty" id . getItemDescription $ item -getItemDate :: MonadError ImmError m => Item -> m UTCTime -getItemDate x = maybe (throwError $ ParseItemDateError x) return $ parseDate =<< F.getItemDate x +getDate :: MonadError ImmError m => Item -> m UTCTime +getDate x = maybe (throwError $ ParseItemDateError x) return $ parseDate =<< F.getItemDate x -- }}} -extractHtml :: EntryContent -> String -extractHtml (HTMLContent c) = c -extractHtml (XHTMLContent c) = strContent c -extractHtml (TextContent t) = t -extractHtml (MixedContent a b)= show a ++ show b -extractHtml (ExternalContent mediaType uri) = show mediaType ++ show uri +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 diff --git a/Imm/HTTP.hs b/Imm/HTTP.hs new file mode 100644 --- /dev/null +++ b/Imm/HTTP.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, KindSignatures #-} +-- | HTTP client related functions +module Imm.HTTP where + +-- {{{ Imports +import Imm.Types +import Imm.Util as U + +import Control.Exception as E +import Control.Monad.Error hiding(forM_, mapM_) + +import Data.ByteString.Lazy as BL +import Data.ByteString.Char8 as BC +import Data.CaseInsensitive +import Data.Functor + +import Network.HTTP.Conduit as H +import Network.URI + +import Prelude hiding(catch) +-- }}} + + +getRaw :: (MonadIO m, MonadError ImmError m) => URI -> m BL.ByteString +getRaw uri = do + logVerbose $ "Downloading " ++ show uri + req <- request $ show uri + res <- withManager' (httpLbs req) + return $ responseBody res + + +-- | Monad-agnostic version of 'withManager +withManager' f = do + res <- timeout 11000000 $ (Right <$> withManager f) `catch` (return . Left . IOE) `catch` (return . Left . HTTPError) `catch` (return . Left . TLSError) + either throwError return res + +-- | Monad-agnostic version of 'parseUrl' +parseURL :: forall (m :: * -> *) (m' :: * -> *) . (MonadIO m, MonadError ImmError m) => String -> m (Request m') +parseURL uri = do + result <- io $ (Right <$> parseUrl uri) `catch` (return . Left . HTTPError) + either throwError return result + + +-- | Build an HTTP request for given URI. +request :: (MonadError ImmError m, MonadIO m) => String -> m (Request a) +request uri = do + req <- parseURL uri + return $ req { requestHeaders = [ + (mk $ BC.pack "User-Agent", BC.pack "Mozilla/4.0"), + (mk $ BC.pack "Accept", BC.pack "*/*")]} diff --git a/Imm/Mail.hs b/Imm/Mail.hs --- a/Imm/Mail.hs +++ b/Imm/Mail.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +-- | Utilities to manipulate mails. module Imm.Mail where -- {{{ Imports @@ -9,6 +10,7 @@ import Control.Monad import Control.Monad.Reader +import Data.Default import qualified Data.Text.Lazy as T import Data.Time import Data.Time.RFC2822 @@ -18,17 +20,16 @@ -- }}} -bare :: Mail -bare = Mail { - mCharset = "utf-8", - mBody = T.pack "", - mContentDisposition = "inline", - mDate = Nothing, - mFrom = "imm", - mMIME = "text/html", - mSubject = T.pack "Untitled", - mReturnPath = ""} - +instance Default Mail where + def = Mail { + mCharset = "utf-8", + mBody = T.pack "", + mContentDisposition = "inline", + mDate = Nothing, + mFrom = "imm", + mMIME = "text/html", + mSubject = T.pack "Untitled", + mReturnPath = ""} toText :: Mail -> T.Text toText mail = T.unlines [ @@ -47,7 +48,7 @@ from <- buildFrom (item, feed) subject <- buildSubject (item, feed) body <- buildBody (item, feed) - return bare {mDate = date, mFrom = from, mSubject = subject, mBody = body} + return def {mDate = date, mFrom = from, mSubject = subject, mBody = body} where date = maybe Nothing (Just . utcToZonedTime timeZone) . parseDate <=< F.getItemDate $ item diff --git a/Imm/Maildir.hs b/Imm/Maildir.hs --- a/Imm/Maildir.hs +++ b/Imm/Maildir.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +-- | Utilities to manipulate maildirs. module Imm.Maildir where -- {{{ Imports @@ -27,7 +28,6 @@ try $ createDirectoryIfMissing True (dir "cur") try $ createDirectoryIfMissing True (dir "new") try $ createDirectoryIfMissing True (dir "tmp") - logVerbose $ "Maildir correctly created at: " ++ dir add :: (MonadIO m, MonadError ImmError m) => PortableFilePath -> Mail -> m () diff --git a/Imm/Main.hs b/Imm/Main.hs --- a/Imm/Main.hs +++ b/Imm/Main.hs @@ -1,123 +1,49 @@ {-# LANGUAGE FlexibleContexts #-} +-- | Main high level process functions. module Imm.Main where -- {{{ Imports -import Imm.Feed -import qualified Imm.Mail as Mail -import qualified Imm.Maildir as Maildir +import Imm.Config +import Imm.Feed as Feed +import Imm.OPML as OPML import Imm.Types import Imm.Util -import Control.Conditional hiding(when) import Control.Monad hiding(forM_, mapM_) import Control.Monad.Error hiding(forM_, mapM_) import Control.Monad.Reader hiding(forM_, mapM_) -import qualified Data.ByteString.Lazy as B -import qualified Data.Text.Lazy as T -import Data.Either +import Data.Default import Data.Foldable ---import Data.Functor -import Data.Time -import Data.Time.Clock.POSIX - -import Network.Browser hiding(request) -import Network.HTTP -import Network.URI hiding(parseURI) +import Data.Functor import Prelude hiding(mapM_) import System.Directory - ---import Text.Feed.Import -import Text.Feed.Query hiding(getItemDate) -import Text.Feed.Types +import System.IO -- }}} --- {{{ Quick actions performed for specific commandline options -printFeedGroupStatus :: (MonadReader Settings m, MonadIO m) => FeedGroup -> m () -printFeedGroupStatus (settings, feeds) = do - maildir <- resolve $ mMaildir settings - io . putStrLn $ " => Feed group " ++ maildir - mapM_ printFeedStatus feeds -printFeedStatus :: (MonadReader Settings m, MonadIO m) => String -> m () -printFeedStatus feedUri = do - prefix <- case parseURI feedUri of - Right uri -> do - lastCheck <- getLastCheck uri - return $ (lastCheck == posixSecondsToUTCTime 0) ? "[NEW] " ?? ("[Last update: "++ show lastCheck ++ "]") - _ -> return "[Not an URI]" - io . putStrLn $ prefix ++ " " ++ feedUri - - -checkFeedGroup :: (MonadReader Settings m, MonadIO m) => FeedGroup -> m () -checkFeedGroup (settings, feeds) = return () --- }}} - --- | Internal entry point for imm, after boot process -main :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => m () -main = do - checkStateDirectory - asks mFeedGroups >>= mapM_ (\x -> processFeedGroup x `catchError` (io . print)) - -checkStateDirectory :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => m () -checkStateDirectory = asks mStateDirectory >>= resolve >>= try . io . createDirectoryIfMissing True - - -processFeedGroup :: (MonadIO m, MonadReader Settings m, MonadError ImmError m) => FeedGroup -> m () -processFeedGroup _feedGroup@(config, feedURIs) = do - Maildir.init $ mMaildir config - forM_ feedURIs $ \uri -> - (parseURI uri >>= downloadFeed >>= processFeed config) - `catchError` (io . print) - +importOPML :: (MonadIO m) => m () +importOPML = io $ (maybe (return ()) addFeeds) =<< OPML.read <$> hGetContents stdin -processFeed :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => FeedSettings -> ImmFeed -> m () -processFeed feedSettings (uri, feed) = do - logVerbose $ unlines [ - "Processing feed: " ++ show uri, - "Title: " ++ (getFeedTitle feed), - "Author: " ++ (maybe "No author" id $ getFeedAuthor feed), - "Home: " ++ (maybe "No home" id $ getFeedHome feed)] - - lastCheck <- getLastCheck uri - forM_ (feedItems feed) $ \item -> - do - date <- getItemDate item - when (date > lastCheck) $ processItem feedSettings (item, feed) - `catchError` (io . print) +list :: (MonadIO m) => FeedList -> m () +list = io . mapM_ (\(f, u) -> runReaderT (printStatus u) (f def)) - storeLastCheck uri =<< io getCurrentTime - - -processItem :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => FeedSettings -> (Item, Feed) -> m () -processItem feedSettings (item, feed) = do - date <- getItemDate item - logVerbose $ unlines [ - " Item author: " ++ (maybe "" id $ getItemAuthor item), - " Item title: " ++ (maybe "" id $ getItemTitle item), - " Item URI: " ++ (maybe "" id $ getItemLink item), - -- " Item Body: " ++ (Imm.Mail.getItemContent item), - " Item date: " ++ show date] - - timeZone <- io getCurrentTimeZone - Maildir.add dir =<< Mail.build timeZone (item, feed) - where - dir = mMaildir feedSettings +markAsRead :: (MonadIO m) => FeedList -> m () +markAsRead = mapM_ (\(f,u) -> runReaderT (runErrorT $ checkStateDirectory >> parseURI u >>= Feed.markAsRead) (f def)) +markAsUnread :: (MonadIO m) => FeedList -> m () +markAsUnread = mapM_ (\(f,u) -> runReaderT (runErrorT $ parseURI u >>= Feed.markAsUnread) (f def)) -downloadRaw :: (MonadIO m, MonadError ImmError m) => URI -> m B.ByteString -downloadRaw uri = do - logVerbose $ "Downloading " ++ show uri - (_, r) <- io . browse $ do - setAllowRedirects True - request (mkRequest GET uri :: Request B.ByteString) - when (rspCode r == (4,0,4)) $ throwError (HTTPError $ rspReason r) - return . rspBody $ r +update :: (MonadIO m) => FeedList -> m () +update feeds = io . forM_ feeds $ \(f, u) -> do + result <- runErrorT . (`runReaderT` (f def)) $ do + feed <- Feed.download =<< parseURI u + checkStateDirectory + Feed.update feed + either print return result -downloadFeed :: (MonadIO m, MonadError ImmError m) => URI -> m ImmFeed -downloadFeed uri = do - feed <- parseFeedString . T.unpack =<< decodeUtf8 =<< downloadRaw uri - return (uri, feed) +checkStateDirectory :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => m () +checkStateDirectory = asks mStateDirectory >>= resolve >>= try . io . createDirectoryIfMissing True diff --git a/Imm/OPML.hs b/Imm/OPML.hs new file mode 100644 --- /dev/null +++ b/Imm/OPML.hs @@ -0,0 +1,17 @@ +module Imm.OPML where + +-- {{{ Imports +import Text.OPML.Reader +import Text.OPML.Syntax +import Text.XML.Light.Types +-- }}} + +read :: String -> Maybe [(String, [String])] +read rawOPML = do + opml <- parseOPMLString rawOPML + let groups = opmlBody opml + groupNames = map opmlText groups + feeds = \group -> opmlOutlineChildren group + feedURI = \feed -> (concat . map attrVal) . (filter ((== "xmlUrl") . qName . attrKey)) . opmlOutlineAttrs $ feed + + return $ zip groupNames (map (map feedURI) (map feeds groups)) diff --git a/Imm/Types.hs b/Imm/Types.hs --- a/Imm/Types.hs +++ b/Imm/Types.hs @@ -1,19 +1,26 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} module Imm.Types where -- {{{ Imports +--import Control.Exception import Control.Monad.Error +import Data.Text.Encoding import Data.Text.Encoding.Error -import qualified Data.Text.Lazy as T +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.Time +import Network.HTTP.Conduit hiding(HandshakeFailed) +import Network.HTTP.Types.Status import Network.URI -import Network.Stream +--import Network.Stream +import Network.TLS +import Prelude hiding(catch) + import System.Console.CmdArgs -import System.IO.Error +import System.IO.Error hiding(catch) import Text.Feed.Query import Text.Feed.Types @@ -23,31 +30,35 @@ -- | Errors that can be returned by an Imm process data ImmError = OtherError String - | HTTPError String + | HTTPError HttpException + | TLSError HandshakeFailed | UnicodeError UnicodeException | ParseUriError String | ParseTimeError String | ParseItemDateError Item | ParseFeedError String - | CE ConnError | IOE IOError + | TimeOut instance Show ImmError where show (OtherError e) = e - show (HTTPError e) = e + show (HTTPError (StatusCodeException status _headers)) = + "/!\\ HTTP error: " ++ show (statusCode status) ++ " " ++ (T.unpack . decodeUtf8) (statusMessage status) + show (HTTPError e) = "/!\\ HTTP error: " ++ show e + show (TLSError (HandshakeFailed e)) = "/!\\ TLS error: " ++ show e show (UnicodeError (DecodeError e _)) = e show (UnicodeError (EncodeError e _)) = e - show (ParseUriError raw) = "Cannot parse URI: " ++ raw + show (ParseUriError raw) = "/!\\ Cannot parse URI: " ++ raw show (ParseItemDateError item) = unlines [ - "Cannot parse date from item: ", + "/!\\ Cannot parse date from item: ", " title: " ++ (show $ getItemTitle item), " link:" ++ (show $ getItemLink item), " publish date:" ++ (show $ getItemPublishDate item), " date:" ++ (show $ getItemDate item)] - show (ParseTimeError raw) = "Cannot parse time: " ++ raw - show (ParseFeedError raw) = "Cannot parse feed: " ++ raw - show (CE e) = show e - show (IOE e) = ioeGetLocation e ++ " " ++ maybe "" id (ioeGetFileName e) ++ " " ++ ioeGetErrorString e + show (ParseTimeError raw) = "/!\\ Cannot parse time: " ++ raw + show (ParseFeedError raw) = "/!\\ Cannot parse feed: " ++ raw + show (IOE e) = "/!\\ IO error: " ++ ioeGetLocation e ++ ": " ++ maybe "" id (ioeGetFileName e) ++ " " ++ ioeGetErrorString e + show TimeOut = "/!\\ Process has timed out" instance Error ImmError where strMsg x = OtherError x @@ -55,47 +66,54 @@ -- {{{ Settings type data CliOptions = CliOptions { - mCheck :: Bool, +-- mCheck :: Bool, + mFeedURI :: Maybe String, + mImportOPML :: Bool, mList :: Bool, + mMarkAsRead :: Bool, + mMarkAsUnread :: Bool, + mUpdate :: Bool, mDenyReconf :: Bool, -- ^ Do not recompile configuration even if it has changed - mMasterBinary :: Maybe String} - deriving (Data, Typeable, Show, Eq) + mMasterBinary :: Maybe String +} deriving (Data, Typeable, Show, Eq) -- | Set of settings for imm data Settings = Settings { mStateDirectory :: PortableFilePath, - mFeedGroups :: [FeedGroup], + mMaildir :: PortableFilePath, mFromBuilder :: (Item, Feed) -> String, - mSubjectBuilder :: (Item, Feed) -> T.Text, - mBodyBuilder :: (Item, Feed) -> T.Text -- ^ sic! + mSubjectBuilder :: (Item, Feed) -> TL.Text, + mBodyBuilder :: (Item, Feed) -> TL.Text -- ^ sic! } + +-- | +type CustomSettings = Settings -> Settings -- }}} -- {{{ Feed types -type FeedGroup = (FeedSettings, [String]) - -data FeedSettings = FeedSettings { - mMaildir :: PortableFilePath} - -type ImmFeed = (URI, Feed) +type FeedList = [(CustomSettings, String)] +type ImmFeed = (URI, Feed) -- }}} data Mail = Mail { mReturnPath :: String, mDate :: Maybe ZonedTime, mFrom :: String, - mSubject :: T.Text, + mSubject :: TL.Text, mMIME :: String, mCharset :: String, mContentDisposition :: String, - mBody :: T.Text} + mBody :: TL.Text +} +-- {{{ Generic file paths -- | Set of reference directories, typically used to build FilePath-s data RefDirs = RefDirs { mHome :: FilePath, -- ^ Home directory mTemporary :: FilePath, -- ^ Temporary files directory mConfiguration :: FilePath, -- ^ Configuration directory - mData :: FilePath} -- ^ Data directory + mData :: FilePath -- ^ Data directory +} type PortableFilePath = RefDirs -> FilePath - +-- }}} diff --git a/Imm/Util.hs b/Imm/Util.hs --- a/Imm/Util.hs +++ b/Imm/Util.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} +-- | Various utilities module Imm.Util where -- {{{ Imports @@ -10,39 +11,43 @@ import Control.Monad.Error --import Control.Monad.IO.Class -import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import Data.Maybe +import Data.Text.ICU.Convert import Data.Text.Lazy.Encoding hiding(decodeUtf8) -import qualified Data.Text.Lazy as T -import qualified Data.Time as T +import qualified Data.Text.Lazy as TL +import Data.Time as T import Data.Time.RFC2822 import Data.Time.RFC3339 -import Network.Browser as N -import Network.HTTP import Network.URI as N import System.Console.CmdArgs import System.Directory import System.Environment.XDG.BaseDir +import System.IO import System.Locale - -import qualified Text.Feed.Import as F -import Text.Feed.Types +import System.Timeout as S -- }}} -- {{{ Monadic utilities --- | Shortcut to liftIO +-- | Shortcut to 'liftIO' io :: MonadIO m => IO a -> m a io = liftIO --- | Monad-agnostic version of Control.Exception.try +-- | Monad-agnostic version of 'Control.Exception.try' try :: (MonadIO m, MonadError ImmError m) => IO a -> m a try = (io . E.try) >=> either (throwError . IOE) return + +-- | Monad-agnostic version of 'System.timeout' +timeout :: (MonadIO m, MonadError ImmError m) => Int -> IO a -> m a +timeout n f = maybe (throwError TimeOut) (io . return) =<< (io $ S.timeout n (io f)) -- }}} --- | Print logs with arbitrary importance. -logNormal, logVerbose :: MonadIO m => String -> m () +-- | Print logs with arbitrary importance +logError, logNormal, logVerbose :: MonadIO m => String -> m () +logError = io . hPutStr stderr logNormal = io . whenNormal . putStrLn logVerbose = io . whenLoud . putStrLn @@ -56,25 +61,27 @@ return . f $ RefDirs homeDir tmpDir configDir dataDir --- {{{ Monad-agnostic version of various error-prone functions -decodeUtf8 :: MonadError ImmError m => B.ByteString -> m T.Text +-- {{{ Monad-agnostic version of various error-prone functions +-- | Monad-agnostic version of Data.Text.Encoding.decodeUtf8 +decodeUtf8 :: MonadError ImmError m => BL.ByteString -> m TL.Text decodeUtf8 = either (throwError . UnicodeError) return . decodeUtf8' +decode :: (MonadIO m, MonadError ImmError m) => BL.ByteString -> m TL.Text +decode raw = do + catchError (decodeUtf8 raw) $ return $ do + conv <- io $ open "ISO-8859-1" Nothing + return . TL.fromChunks . (\a -> [a]) . toUnicode conv . B.concat . BL.toChunks $ raw -parseDate :: String -> Maybe T.UTCTime -parseDate date = listToMaybe . map T.zonedTimeToUTC . catMaybes . flip map [readRFC2822, readRFC3339, T.parseTime defaultTimeLocale "%a, %d %b %G %T"] $ \f -> f . T.unpack . T.strip . T.pack $ date -parseFeedString :: MonadError ImmError m => String -> m Feed -parseFeedString x = maybe (throwError . ParseFeedError $ show x) return $ F.parseFeedString x - +-- | Monad-agnostic version of Network.URI.parseURI parseURI :: (MonadError ImmError m) => String -> m URI parseURI uri = maybe (throwError $ ParseUriError uri) return $ N.parseURI uri -parseTime :: (MonadError ImmError m) => String -> m T.UTCTime +-- | Monad-agnostic version of Data.Time.Format.parseTime +parseTime :: (MonadError ImmError m) => String -> m UTCTime parseTime string = maybe (throwError $ ParseTimeError string) return $ T.parseTime defaultTimeLocale "%c" string - -request :: Request B.ByteString -> BrowserAction (HandleStream B.ByteString) (URI, Response B.ByteString) -request r = io $ (E.catch :: IO a -> (IOError -> IO a) -> IO a) - (browse $ N.request r) - (\e -> return (rqURI r, Response (4,0,4) ("Unable to connect to " ++ show (rqURI r)) [] B.empty)) -- }}} + + +parseDate :: String -> Maybe UTCTime +parseDate date = listToMaybe . map T.zonedTimeToUTC . catMaybes . flip map [readRFC2822, readRFC3339, T.parseTime defaultTimeLocale "%a, %d %b %G %T", T.parseTime defaultTimeLocale "%Y-%m-%d", T.parseTime defaultTimeLocale "%e %b %Y", T.parseTime defaultTimeLocale "%a, %e %b %Y %k:%M:%S %z", T.parseTime defaultTimeLocale "%a, %e %b %Y %T %Z"] $ \f -> f . TL.unpack . TL.strip . TL.pack $ date diff --git a/imm.cabal b/imm.cabal --- a/imm.cabal +++ b/imm.cabal @@ -1,6 +1,6 @@ Name: imm -Version: 0.3.0.0 -Synopsis: RSS-to-maildir tool +Version: 0.4.0.0 +Synopsis: Retrieve RSS/Atom feeds and write one mail per new item in a maildir. --Description: --Homepage: Category: Web @@ -23,8 +23,10 @@ Exposed-modules: Imm.Boot, Imm.Config, + Imm.HTTP, Imm.Main, Imm.Feed, + Imm.OPML, Imm.Types, Imm.Util, Imm.Mail, @@ -32,21 +34,27 @@ Build-depends: base == 4.*, bytestring, + case-insensitive, cmdargs, cond, + data-default, directory, dyre, feed, filepath, - HTTP, + http-conduit, + http-types, mime-mail, mtl, network, old-locale, + opml, random, text, + text-icu, time, timerep, + tls, utf8-string, xdg-basedir, xml