imm 0.4.1.0 → 0.5.0.0
raw patch · 19 files changed
+825/−473 lines, 19 filesdep +lensdep +monad-controldep +transformers-basedep −cmdargsdep ~networkdep ~timerep
Dependencies added: lens, monad-control, transformers-base
Dependencies removed: cmdargs
Dependency ranges changed: network, timerep
Files
- Imm.hs +19/−0
- Imm/Boot.hs +54/−70
- Imm/Config.hs +39/−19
- Imm/Core.hs +152/−0
- Imm/Database.hs +63/−0
- Imm/Dyre.hs +45/−0
- Imm/Error.hs +54/−0
- Imm/Executable.hs +1/−2
- Imm/Feed.hs +82/−110
- Imm/HTTP.hs +6/−10
- Imm/Mail.hs +44/−34
- Imm/Maildir.hs +14/−15
- Imm/Main.hs +0/−60
- Imm/OPML.hs +4/−4
- Imm/Options.hs +150/−0
- Imm/Types.hs +0/−103
- Imm/Util.hs +10/−30
- README +58/−0
- imm.cabal +30/−16
+ Imm.hs view
@@ -0,0 +1,19 @@+module Imm (+ module Imm.Boot,+ module Imm.Config,+ module Imm.Feed,+ module Imm.HTTP,+ module Imm.Mail,+ module Imm.Maildir,+ module Imm.OPML,+ module Imm.Util+) where++import Imm.Boot+import Imm.Config+import Imm.Feed+import Imm.HTTP+import Imm.Mail+import Imm.Maildir+import Imm.OPML+import Imm.Util
Imm/Boot.hs view
@@ -1,83 +1,67 @@-module Imm.Boot where+{-# LANGUAGE TupleSections #-}+module Imm.Boot (imm, ConfigFeed) where -- {{{ Imports-import qualified Imm.Main as Main-import Imm.Types--import qualified Config.Dyre as D-import Config.Dyre.Paths--import System.Console.CmdArgs-import System.Console.CmdArgs.Explicit-import System.IO--- }}}+import qualified Imm.Core as Core+import Imm.Config+import Imm.Dyre as Dyre+import Imm.Options (CliOptions)+import qualified Imm.Options as Options+import Imm.Util --- | 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, without writing any mail.",- 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)."}+import Control.Conditional+import Control.Lens hiding ((??)) --- {{{ Dynamic reconfiguration--- | Print various paths used for dynamic reconfiguration.-printDyrePaths :: IO ()-printDyrePaths = do- (a, b, c, d, e) <- getPaths dyreParameters- putStrLn . unlines $ [- "Current binary: " ++ a,- "Custom binary: " ++ b,- "Config file: " ++ c,- "Cache directory: " ++ d,- "Lib directory: " ++ e, []]+import Data.Default+import Data.Either+import Data.Maybe --- | Dynamic reconfiguration settings.-dyreParameters :: D.Params (Either String FeedList)-dyreParameters = D.defaultParams {- D.projectName = "imm",- D.showError = showError,- D.realMain = realMain,- D.ghcOpts = ["-threaded"],- D.statusOut = hPutStrLn stderr-}+import Network.URI as N -showError :: Either String a -> String -> Either String a-showError _ = Left+import System.Directory+import System.Exit -- }}} +type ConfigFeed = (Config -> Config, String)+ -- | Main function to call in the configuration file.-imm :: FeedList -> IO ()-imm = D.wrapMain dyreParameters . Right+imm :: [ConfigFeed] -> IO ()+imm feedsFromConfig = do+ options <- Options.get --- | Internal dispatcher, decides which function to execute depending on commandline options.-realMain :: Either String FeedList -> IO ()-realMain (Left e) = putStrLn e-realMain (Right feeds) = do- whenLoud printDyrePaths- options <- cmdArgsRun cliOptions+ when (view Options.help options) $ putStrLn Options.usage >> exitSuccess - let feeds' = case (mFeedURI options) of- Just uri -> filter (\(_, u) -> u == uri) feeds- _ -> feeds+ Dyre.wrap realMain options (options, feedsFromConfig) - realMain' (feeds', options)++validateFeeds :: [ConfigFeed] -> [URI] -> ([String], Core.FeedList)+validateFeeds feedsFromConfig feedsFromOptions = (errors ++ errors', null feedsFromOptions ? feedsOK ?? feedsOK') where- realMain' (f, options)- | mCheck options = Main.check f- | mImportOPML options = Main.importOPML- | mList options = Main.list f- | mMarkAsRead options = Main.markAsRead f- | mMarkAsUnread options = Main.markAsUnread f- | mUpdate options = Main.update f- | otherwise = print $ helpText [] HelpFormatDefault cliOptions+ validateFromConfig (x, u) = maybe (Left ("Invalid feed URI: " ++ u)) (Right . (x,)) $ N.parseURI u+ validateFromOptions uri = maybe (Left ("URI from commandline option has no configuration entry: " ++ show uri)) Right . listToMaybe . (filter ((== uri) . snd)) $ feedsOK+ (errors, feedsOK) = partitionEithers $ map validateFromConfig feedsFromConfig+ (errors', feedsOK') = partitionEithers $ map validateFromOptions feedsFromOptions+++realMain :: (CliOptions, [ConfigFeed]) -> IO ()+realMain (options, feedsFromConfig) = do+ let (errors, feedsOK) = validateFeeds feedsFromConfig (view Options.feedList options)+ when (not $ null errors) . putStrLn $ unlines errors++ when (null feedsOK) $ putStrLn "Nothing to process. Exiting..." >> exitFailure+ -- when (view Options.verbose options) . putStrLn . unlines $ map (show . snd) feedsOK++ home <- getHomeDirectory >/> "feeds"+ let config = set maildir home def+ dispatch feedsOK config options+++dispatch :: Core.FeedList -> Config -> CliOptions -> IO ()+dispatch feeds config options+ | options^.Options.check = Core.check options feeds+ | options^.Options.list = Core.list options feeds+ | options^.Options.markAsRead = Core.markAsRead options feeds+ | options^.Options.markAsUnread = Core.markAsUnread options feeds+ | options^.Options.update = Core.update options feeds+ | isJust (options^.Options.importOPML) = Core.importOPML+ | otherwise = putStrLn Options.usage
Imm/Config.hs view
@@ -1,39 +1,59 @@--- | Default settings+{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} module Imm.Config where -- {{{ Imports-import Imm.Feed-import Imm.Types import Imm.Util -import Control.Monad.Trans+import Control.Lens+import Control.Monad.Base+import Control.Monad.Reader hiding(forM_) import Data.Char-import Data.Default import Data.Foldable hiding(concat)-import qualified Data.Text.Lazy as T--import System.Directory-import System.Environment.XDG.BaseDir+import Data.Text.ICU.Convert+import Data.Time -import Text.Feed.Query+import Text.Feed.Types as F -- }}} +-- {{{ Types+type Format = (Item, Feed) -> String -instance Default Settings where- def = Settings {- mStateDirectory = getUserConfigDir "imm" >/> "state",- mMaildir = getHomeDirectory >/> "feeds",- 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]}+data Config = Config {+ _maildir :: FilePath, -- ^ Where mails will be written+ _dateParsers :: [String -> Maybe UTCTime], -- ^ List of date parsing functions, will be tried sequentially until one succeeds+ _formatFrom :: Format, -- ^ Called to write the From: header of feed mails+ _formatSubject :: Format, -- ^ Called to write the Subject: header of feed mails+ _formatBody :: Format, -- ^ Called to write the body of feed mails (sic!)+ _decoder :: String -- ^ 'Converter' name used to decode the HTTP response from a feed URI+ -- _decoder :: BL.ByteString -> Maybe TL.Text -- ^ Called to decode the HTTP response from a feed URI+} +makeLenses ''Config -addFeeds :: MonadIO m => [(String, [String])] -> m ()++-- | 'MonadReader' for 'Config'+class ConfigReader m where+ readConfig :: Simple Lens Config a -> m a++instance (Monad m) => ConfigReader (ReaderT Config m) where+ readConfig l = return . view l =<< ask++instance ConfigReader ((->) Config) where+ readConfig l = view l+-- }}}++-- | Return the decoder corresponding to the converter name set in 'Config'.+getDecoder :: (ConfigReader m, MonadBase IO m) => m Converter+getDecoder = do+ converterName <- readConfig decoder+ io $ open converterName Nothing++-- | Return the Haskell code to write in the configuration file to add a feed.+addFeeds :: MonadBase IO 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 ""-
+ Imm/Core.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE TypeFamilies #-}+module Imm.Core where++-- {{{ Imports+import Imm.Config+import Imm.Database+import Imm.Error+import Imm.Feed (ImmFeed, FeedID)+import qualified Imm.Feed as Feed+import qualified Imm.Maildir as Maildir+import qualified Imm.Mail as Mail+import Imm.OPML as OPML+import Imm.Options (CliOptions(..), OptionsReader(..), log, logV)+import qualified Imm.Options as Options+import Imm.Util++import Control.Applicative+import Control.Conditional+import Control.Lens hiding((??))+import Control.Monad hiding(forM_, mapM_)+import Control.Monad.Base+import Control.Monad.Error hiding(forM_, mapM_)+import Control.Monad.Reader hiding(forM_, mapM_)+import Control.Monad.Trans.Control++import Data.Default+import Data.Foldable+-- import Data.Functor+import Data.Maybe+import Data.Time as T+import Data.Time.RFC2822+import Data.Time.RFC3339++import Prelude hiding(log, mapM_, sum)++import System.Directory+import System.Locale++import Text.Feed.Query as F+import Text.Feed.Types as F+-- }}}++-- {{{ Types+type FeedList = [(Config -> Config, FeedID)]++newtype I a = I { unIT :: ErrorT ImmError (ReaderT CliOptions (ReaderT Config IO)) a}+ deriving (Applicative, Functor, Monad, MonadBase IO, MonadError ImmError)++instance MonadBaseControl IO I where+ newtype StM I a = StI { unStI :: StM (ErrorT ImmError (ReaderT CliOptions (ReaderT Config IO))) a }+ liftBaseWith f = I . liftBaseWith $ \runInBase -> f $ liftM StI . runInBase . unIT+ restoreM = I . restoreM . unStI+++instance ConfigReader I where+ readConfig l = I $ (lift . lift) ask >>= return . view l++instance OptionsReader I where+ readOptions l = I $ lift ask >>= return . view l++runI :: CliOptions -> Config -> I a -> IO (Either ImmError a)+runI options config i = do+ (`runReaderT` config). (`runReaderT` options) . runErrorT $ unIT i++runI' :: CliOptions -> Config -> I () -> IO ()+runI' options config i = do+ result <- runI options config i+ either print return result+-- }}}+++checkStateDirectory :: (OptionsReader m, MonadBase IO m, MonadError ImmError m) => m ()+checkStateDirectory = try . io . (createDirectoryIfMissing True) =<< Options.getStateDirectory+++check :: (MonadBase IO m) => CliOptions -> FeedList -> m ()+check options feeds = io . forM_ feeds $ \(f, feedID) -> runI' options (f def) $ do+ log $ "Checking: " ++ show feedID+ Feed.check =<< Feed.download feedID+++importOPML :: (MonadBase IO m) => m ()+importOPML = io $ mapM_ addFeeds =<< OPML.read <$> getContents+++list :: CliOptions -> FeedList -> IO ()+list options = mapM_ (\(f, feedID) -> runI' options (f def) $ (io . putStrLn =<< Feed.showStatus feedID))+++markAsRead :: CliOptions -> FeedList -> IO ()+markAsRead options = mapM_ (\(f, feedID) -> runI options (f def) $ checkStateDirectory >> Feed.markAsRead feedID)+++markAsUnread :: CliOptions -> FeedList -> IO ()+markAsUnread options = mapM_ (\(f, feedID) -> runI options (f def) $ Feed.markAsUnread feedID)+++update :: (MonadBase IO m) => CliOptions -> FeedList -> m ()+update options feeds = io . forM_ feeds $ \(f, feedID) -> do+ runI' options (f def) $ do+ log $ "Updating: " ++ show feedID+ checkStateDirectory+ updateFeed =<< Feed.download feedID++-- | Write mails for each new item, and update the last check time in state file.+updateFeed :: (Applicative m, ConfigReader m, MonadBase IO m, OptionsReader m, MonadError ImmError m) => ImmFeed -> m ()+updateFeed (uri, feed) = do+-- checkStateDirectory+ Maildir.create =<< readConfig maildir++ logV $ Feed.describe feed++ lastCheck <- getLastCheck uri+ results <- forM (feedItems feed) $ \item -> do+ (Right date) <- Feed.getDate item+ (date > lastCheck) ? (updateItem (item, feed) >> return 1) ?? return 0+ log $ "==> " ++ show (sum results) ++ " new item(s)"+ Feed.markAsRead uri+++updateItem :: (Applicative m, ConfigReader m, MonadBase IO m, OptionsReader m, MonadError ImmError m) => (Item, Feed) -> m ()+updateItem (item, feed) = do+ logV $ Feed.describeItem item++ timeZone <- io getCurrentTimeZone+ dir <- readConfig maildir+ Maildir.add dir =<< Mail.build timeZone (item, feed)+++instance Default Config where+ def = Config {+ _maildir = "feeds",+ _dateParsers = [+ return . zonedTimeToUTC <=< readRFC2822,+ return . zonedTimeToUTC <=< 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"],+ _formatFrom = \(item, feed) -> fromMaybe (getFeedTitle feed) $ getItemAuthor item,+ _formatSubject = \(item, _feed) -> fromMaybe "Untitled" $ getItemTitle item,+ _formatBody = defaultBody,+ _decoder = "UTF-8"+ }++defaultBody :: (Item, Feed) -> String+defaultBody (item, _feed) = "<p>" ++ link ++ "</p><p>" ++ (null content ? description ?? content) ++ "</p>"+ where+ link = fromMaybe "No link found." $ getItemLink item+ content = Feed.getItemContent item+ description = fromMaybe "No description." $ getItemDescription item
+ Imm/Database.hs view
@@ -0,0 +1,63 @@+module Imm.Database where++-- {{{ Imports+import Imm.Error+import Imm.Options+import Imm.Util++import Control.Monad.Base+import Control.Monad.Error++import Data.Time hiding(parseTime)+import Data.Time.Clock.POSIX++import Network.URI++import System.Directory+import System.FilePath+import System.Locale+import System.IO+-- }}}++-- | A state file stores the last check time for a single feed, identified with its 'URI'.+getStateFile :: URI -> FilePath+getStateFile feedUri@URI{ uriAuthority = Just auth } = toFileName =<< ((++ uriQuery feedUri) . (++ uriPath feedUri) . uriRegName $ auth)+getStateFile feedUri = show feedUri >>= toFileName++-- | Remove forbidden characters in a filename.+toFileName :: Char -> String+toFileName '/' = "."+toFileName '?' = "."+toFileName x = [x]++-- | Read the last check time in the state file.+getLastCheck :: (OptionsReader m, MonadBase IO m) => URI -> m UTCTime+getLastCheck feedUri = do+ directory <- getStateDirectory+ result <- runErrorT $ do+ content <- try $ readFile (directory </> fileName)+ parseTime content++ either (const $ return timeZero) return result+ where+ fileName = getStateFile feedUri+ timeZero = posixSecondsToUTCTime 0+++-- | Write the last check time in the state file.+storeLastCheck :: (OptionsReader m, MonadBase IO m, MonadError ImmError m) => URI -> UTCTime -> m ()+storeLastCheck feedUri date = do+ directory <- getStateDirectory++ (file, stream) <- try $ openTempFile directory fileName+ io $ hPutStrLn stream (formatTime defaultTimeLocale "%c" date)+ io $ hClose stream+ try $ renameFile file (directory </> fileName)+ where+ fileName = getStateFile feedUri+++forget :: (OptionsReader m, MonadBase IO m, MonadError ImmError m) => URI -> m ()+forget uri = do+ directory <- getStateDirectory+ try $ removeFile (directory </> getStateFile uri)
+ Imm/Dyre.hs view
@@ -0,0 +1,45 @@+module Imm.Dyre where++-- {{{ Imports+import Imm.Options+import Imm.Util++import Config.Dyre+import Config.Dyre.Paths++import Control.Lens+import Control.Monad+import Control.Monad.Base++import System.IO+-- }}}+++-- | Print various paths used for dynamic reconfiguration+printPaths :: MonadBase IO m => m ()+printPaths = io $ do+ (a, b, c, d, e) <- getPaths (parameters $ const $ return ())+ putStrLn . unlines $ [+ "Current binary: " ++ a,+ "Custom binary: " ++ b,+ "Config file: " ++ c,+ "Cache directory: " ++ d,+ "Lib directory: " ++ e, []]++-- | Dynamic reconfiguration settings+parameters :: (a -> IO ()) -> Params (Either String a)+parameters main = defaultParams {+ projectName = "imm",+ showError = const Left,+ realMain = main',+ ghcOpts = ["-threaded"],+ statusOut = hPutStrLn stderr,+ includeCurrentDirectory = False}+ where+ main' (Left e) = putStrLn e+ main' (Right x) = main x++wrap :: (a -> IO ()) -> CliOptions -> a -> IO ()+wrap main opts args = do+ when (opts^.verbose) printPaths+ wrapMain ((parameters main) { configCheck = not $ opts^.vanilla }) $ Right args
+ Imm/Error.hs view
@@ -0,0 +1,54 @@+module Imm.Error where++-- {{{ Imports+import Control.Monad.Error++import Data.Maybe+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Text.Encoding.Error++import Network.HTTP.Conduit hiding(HandshakeFailed)+import Network.HTTP.Types.Status+import Network.TLS hiding(DecodeError)++import System.IO.Error++import Text.Feed.Query+import Text.Feed.Types+-- }}}++data ImmError =+ OtherError String+ | HTTPError HttpException+ | TLSError HandshakeFailed+ | UnicodeError UnicodeException+ | ParseUriError String+ | ParseTimeError String+ | ParseItemDateError Item+ | ParseFeedError String+ | IOE IOError+ | TimeOut++instance Show ImmError where+ show (OtherError 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 (ParseItemDateError item) = unlines [+ "/!\\ 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 (IOE e) = "/!\\ IO error [" ++ ioeGetLocation e ++ "]: " ++ fromMaybe "" (ioeGetFileName e) ++ " " ++ ioeGetErrorString e+ show TimeOut = "/!\\ Process has timed out"++instance Error ImmError where+ strMsg = OtherError
Imm/Executable.hs view
@@ -1,7 +1,6 @@ --module Executable where -import Imm.Boot---import Imm.Types+import Imm main :: IO () main = imm []
Imm/Feed.hs view
@@ -1,153 +1,130 @@-{-# LANGUAGE FlexibleContexts, RankNTypes, KindSignatures #-} module Imm.Feed where -- {{{ Imports+import Imm.Config+import Imm.Database+import Imm.Error import qualified Imm.HTTP as HTTP-import qualified Imm.Mail as Mail-import qualified Imm.Maildir as Maildir-import Imm.Types+import Imm.Options hiding(markAsRead) import Imm.Util -import Control.Applicative+-- import Control.Applicative import Control.Conditional hiding(when)+import Control.Monad.Base import Control.Monad.Error-import Control.Monad.Reader hiding(when) +import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Char import Data.Either-import qualified Data.Text.Lazy as T-import Data.Time hiding(parseTime)+import Data.Functor+import Data.Maybe+import qualified Data.Text.Lazy as TL+import Data.Text.ICU.Convert+import Data.Time as T hiding(parseTime) import Data.Time.Clock.POSIX import Network.URI as N -import System.Directory---import System.FilePath-import System.IO-import System.Locale- import qualified Text.Atom.Feed as Atom+import qualified Text.RSS1.Syntax as RSS1+import qualified Text.RSS.Syntax as RSS import Text.Feed.Import as F import Text.Feed.Query as F import Text.Feed.Types as F import Text.XML.Light.Proc+import Text.XML.Light.Types -- }}} --- {{{ Util-getStateFile :: URI -> FilePath-getStateFile feedUri@URI{ uriAuthority = Just auth } = toFileName =<< ((++ (uriQuery feedUri)) . (++ (uriPath feedUri)) . uriRegName $ auth)-getStateFile feedUri = show feedUri >>= toFileName+type FeedID = URI+type ImmFeed = (FeedID, Feed) -toFileName :: Char -> String-toFileName '/' = "."-toFileName '?' = "."-toFileName x = [x]--- }}}+describeType :: Feed -> String+describeType (AtomFeed _) = "Atom"+describeType (RSSFeed _) = "RSS 2.x"+describeType (RSS1Feed _) = "RSS 1.x"+describeType (XMLFeed _) = "XML" +describe :: Feed -> String+describe feed = unlines [+ "Type: " ++ describeType feed,+ "Title: " ++ getFeedTitle feed,+ "Author: " ++ fromMaybe "No author" (getFeedAuthor feed),+ "Home: " ++ fromMaybe "No home" (getFeedHome feed)]++describeItem :: Item -> String+describeItem item = unlines [+ " Item author: " ++ fromMaybe "<empty>" (getItemAuthor item),+ " Item title: " ++ fromMaybe "<empty>" (getItemTitle item),+ " Item URI: " ++ fromMaybe "<empty>" (getItemLink item),+ -- " Item Body: " ++ (Imm.Mail.getItemContent item),+ " Item date: " ++ fromMaybe "<empty>" (getItemDate item)]+ -- | 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) => 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+-- | Retrieve, decode and parse the given resource as a feed.+download :: (MonadBase IO m, OptionsReader m, ConfigReader m, MonadError ImmError m) => URI -> m ImmFeed download uri = do- feed <- parse . T.unpack =<< decode =<< HTTP.getRaw uri+ logV $ "Downloading " ++ show uri+ d <- getDecoder+ feed <- parse . TL.unpack . decodeWith d =<< HTTP.getRaw uri return (uri, feed)+ where+ decodeWith d = TL.fromChunks . (: []) . toUnicode d . B.concat . BL.toChunks --- | -check :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => ImmFeed -> m ()+-- |+check :: (ConfigReader m, OptionsReader m, MonadBase IO m, MonadError ImmError m) => ImmFeed -> m () check (uri, feed) = do- lastCheck <- getLastCheck uri- dates <- return . rights =<< forM (feedItems feed) (runErrorT . getDate)+ lastCheck <- getLastCheck uri+ (errors, dates) <- partitionEithers <$> forM (feedItems feed) getDate+ logE . unlines $ map show errors let newItems = filter (> lastCheck) dates io . putStrLn $ "==> " ++ show (length newItems) ++ " new item(s) " --- | Create mails for each new item-update :: (Applicative m, MonadReader Settings m, MonadIO m, MonadError ImmError m) => ImmFeed -> m ()-update (uri, feed) = do--- 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- 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+-- | Simply set the last check time to now.+markAsRead :: forall (m :: * -> *) . (MonadBase IO m, MonadError ImmError m, OptionsReader m) => URI -> m ()+markAsRead uri = io getCurrentTime >>= storeLastCheck uri >> (logV $ "Feed " ++ show uri ++ " marked as read.") -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 Body: " ++ (Imm.Mail.getItemContent item),- " Item date: " ++ show date]- - timeZone <- io getCurrentTimeZone- dir <- asks mMaildir- Maildir.add dir =<< Mail.build timeZone (item, feed)+-- | Simply remove the state file.+markAsUnread :: forall (m :: * -> *) . (MonadBase IO m, MonadError ImmError m, OptionsReader m) => URI -> m ()+markAsUnread uri = do+ forget uri+ logV $ "Feed " ++ show uri ++ " marked as unread." -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.")+-- | Return a 'String' describing the last update for a given feed.+showStatus :: (OptionsReader m, MonadBase IO m) => URI -> m String+showStatus uri = let nullTime = posixSecondsToUTCTime 0 in do+ lastCheck <- getLastCheck uri+ return $ ((lastCheck == nullTime) ? "[NEW] " ?? ("[Last update: "++ show lastCheck ++ "]")) ++ " " ++ show uri -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."- -- {{{ Item utilities-getItemLinkNM :: Item -> String -getItemLinkNM item = maybe "No link found" paragraphy $ getItemLink item+-- | This function is missing from 'Text.Feed.Query', probably because it is difficult to define where the content is located in a generic way for Atom/RSS 1.x/RSS 2.x feeds.+getItemContent :: Item -> String+getItemContent (AtomItem i) = length theContent < length theSummary ? theSummary ?? theContent+ where+ theContent = maybe "" extractHtml $ Atom.entryContent i+ theSummary = maybe "No content" Atom.txtToString $ Atom.entrySummary i+getItemContent (RSSItem i) = length theContent < length theDescription ? theDescription ?? theContent+ where+ theContent = dropWhile isSpace . concat . map concat . map (map cdData . onlyText) . map elContent . RSS.rssItemOther $ i+ theDescription = fromMaybe "No description." $ RSS.rssItemDescription i+getItemContent (RSS1Item i) = concat . catMaybes . map (RSS1.contentValue) . RSS1.itemContent $ i+getItemContent item = fromMaybe "No content." . getItemDescription $ 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 :: (ConfigReader m, Monad m) => Item -> m (Either ImmError UTCTime)+getDate x = do+ parsers <- readConfig dateParsers+ return $ maybe (Left $ ParseItemDateError x) Right $ parseDateWith parsers =<< F.getItemDate x -getDate :: MonadError ImmError m => Item -> m UTCTime-getDate x = maybe (throwError $ ParseItemDateError x) return $ parseDate =<< F.getItemDate x+parseDateWith :: [String -> Maybe UTCTime] -> String -> Maybe UTCTime+parseDateWith parsers date = listToMaybe . {-map T.zonedTimeToUTC .-} catMaybes . flip map parsers $ \f -> f . TL.unpack . TL.strip . TL.pack $ date -- }}} @@ -157,8 +134,3 @@ 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>"-
Imm/HTTP.hs view
@@ -1,11 +1,12 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-} module Imm.HTTP where -- {{{ Imports-import Imm.Types+import Imm.Error import Imm.Util as U import Control.Exception as E+import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_) import Data.ByteString.Lazy as BL@@ -15,33 +16,28 @@ import Network.HTTP.Conduit as H import Network.URI--import Prelude hiding(catch) -- }}} -- | Perform an HTTP GET request and return the response body as raw 'ByteString'-getRaw :: (MonadIO m, MonadError ImmError m) => URI -> m BL.ByteString+getRaw :: (MonadBase IO 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 :: (MonadBase IO 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 :: (MonadBase IO m, MonadError ImmError m) => String -> m (Request a) request uri = do req <- parseURL uri return $ req { requestHeaders = [
Imm/Mail.hs view
@@ -1,54 +1,64 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-} module Imm.Mail where -- {{{ Imports---import Imm.Feed-import Imm.Types-import Imm.Util+import Imm.Config+import Imm.Feed import Control.Applicative-import Control.Monad-import Control.Monad.Reader+import Control.Lens hiding(from) import Data.Default-import qualified Data.Text.Lazy as T import Data.Time import Data.Time.RFC2822 -import Text.Feed.Query as F import Text.Feed.Types -- }}} +data Mail = Mail {+ _returnPath :: String,+ _date :: Maybe ZonedTime,+ _from :: String,+ _subject :: String,+ _mime :: String,+ _charset :: String,+ _contentDisposition :: String,+ _body :: String+}++makeLenses ''Mail++ 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 = "<imm@noreply>"}+ _charset = "utf-8",+ _body = empty,+ _contentDisposition = "inline",+ _date = Nothing,+ _from = "imm",+ _mime = "text/html",+ _subject = "Untitled",+ _returnPath = "<imm@noreply>"} -toText :: Mail -> T.Text-toText mail = T.unlines [- T.pack $ "Return-Path: " ++ mReturnPath mail,- T.pack $ maybe "" (("Date: " ++) . showRFC2822) . mDate $ mail,- T.pack $ "From: " ++ mFrom mail,- T.concat [T.pack "Subject: ", mSubject mail],- T.pack $ "Content-Type: " ++ mMIME mail ++ "; charset=" ++ mCharset mail,- T.pack $ "Content-Disposition: " ++ mContentDisposition mail,- T.pack "",- mBody mail]- +instance Show Mail where+ show mail = unlines [+ "Return-Path: " ++ view returnPath mail,+ maybe "" (("Date: " ++) . showRFC2822) . view date $ mail,+ "From: " ++ view from mail,+ "Subject: " ++ view subject mail,+ "Content-Type: " ++ view mime mail ++ "; charset=" ++ view charset mail,+ "Content-Disposition: " ++ view contentDisposition mail,+ "",+ view body mail]++ -- | Build mail from a given feed, using builders functions from 'Settings'.-build :: (Applicative m, MonadReader Settings m) => TimeZone -> (Item, Feed) -> m Mail+build :: (Applicative m, ConfigReader m, Monad m) => TimeZone -> (Item, Feed) -> m Mail build timeZone (item, feed) = do- from <- asks mFromBuilder <*> return (item, feed)- subject <- asks mSubjectBuilder <*> return (item, feed)- body <- asks mBodyBuilder <*> return (item, feed)- return def {mDate = date, mFrom = from, mSubject = subject, mBody = body}- where- date = maybe Nothing (Just . utcToZonedTime timeZone) . parseDate <=< F.getItemDate $ item+ from' <- readConfig formatFrom <*> return (item, feed)+ subject' <- readConfig formatSubject <*> return (item, feed)+ body' <- readConfig formatBody <*> return (item, feed)+ date' <- either (const Nothing) (Just . utcToZonedTime timeZone) <$> getDate item+ return . set date date' . set from from' . set subject subject' . set body body' $ def
Imm/Maildir.hs view
@@ -1,45 +1,44 @@-{-# LANGUAGE FlexibleContexts #-} module Imm.Maildir where -- {{{ Imports+import Imm.Error import Imm.Mail-import Imm.Types import Imm.Util ---import Control.Monad.IO.Class+import Control.Monad.Base import Control.Monad.Error import Data.Functor import qualified Data.Text.Lazy.IO as T+import qualified Data.Text.Lazy as TL import Data.Time.Clock.POSIX import Network.BSD import System.Directory---import System.FilePath+import System.FilePath import System.Random -- }}} -- | Build a maildir with subdirectories cur, new and tmp.-init :: (MonadIO m, MonadError ImmError m) => IO FilePath -> m ()-init directory = do- try $ createDirectoryIfMissing True =<< directory- try $ createDirectoryIfMissing True =<< (directory >/> "cur")- try $ createDirectoryIfMissing True =<< (directory >/> "new")- try $ createDirectoryIfMissing True =<< (directory >/> "tmp")+create :: (MonadBase IO m, MonadError ImmError m) => FilePath -> m ()+create directory = do+ try $ createDirectoryIfMissing True directory+ try $ createDirectoryIfMissing True (directory </> "cur")+ try $ createDirectoryIfMissing True (directory </> "new")+ try $ createDirectoryIfMissing True (directory </> "tmp") -- | Add a mail to the maildir-add :: (MonadIO m, MonadError ImmError m) => IO FilePath -> Mail -> m ()+add :: (MonadBase IO m, MonadError ImmError m) => FilePath -> Mail -> m () add directory mail = do fileName <- io getUniqueName- dir <- directory >/> "new" >/> fileName - try $ T.writeFile dir (toText mail)+ try $ T.writeFile (directory </> "new" </> fileName) (TL.pack $ show mail) -- | Return an allegedly unique filename; useful to add new mail files in a maildir.-getUniqueName :: MonadIO m => m String +getUniqueName :: MonadBase IO m => m String getUniqueName = io $ do time <- show <$> getPOSIXTime hostname <- getHostName rand <- show <$> (getStdRandom $ randomR (1,100000) :: IO Int)- + return . concat $ [time, ".", rand, ".", hostname]
− Imm/Main.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Imm.Main where---- {{{ Imports-import Imm.Config-import qualified Imm.Feed as Feed-import Imm.OPML as OPML-import Imm.Types-import Imm.Util--import Control.Monad hiding(forM_, mapM_)-import Control.Monad.Error hiding(forM_, mapM_)-import Control.Monad.Reader hiding(forM_, mapM_)--import Data.Default-import Data.Foldable-import Data.Functor--import Prelude hiding(mapM_)--import System.Directory-import System.IO--- }}}---check :: (MonadIO m) => FeedList -> m ()-check feeds = io . forM_ feeds $ \(f, u) -> do - result <- runErrorT . (`runReaderT` (f def)) $ do- logNormal $ "Checking: " ++ u- Feed.check =<< Feed.download =<< parseURI u- either print return result---importOPML :: (MonadIO m) => m ()-importOPML = io $ mapM_ addFeeds =<< OPML.read <$> hGetContents stdin---list :: (MonadIO m) => FeedList -> m ()-list = io . mapM_ (\(f, u) -> runReaderT (runErrorT $ parseURI u >>= Feed.printStatus) (f def))---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))---update :: (MonadIO m) => FeedList -> m ()-update feeds = io . forM_ feeds $ \(f, u) -> do- result <- runErrorT . (`runReaderT` (f def)) $ do- logNormal $ "Updating: " ++ u- checkStateDirectory- Feed.update =<< Feed.download =<< parseURI u- either print return result---checkStateDirectory :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => m ()-checkStateDirectory = try . io . (createDirectoryIfMissing True =<<) =<< asks mStateDirectory
Imm/OPML.hs view
@@ -6,13 +6,13 @@ import Text.XML.Light.Types -- }}} --- | Parse an OPML string and return a list of feed groups+-- | Parse an OPML string and return a list of tuples (category title, feed URIs). 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+ feeds = opmlOutlineChildren+ feedURI = concatMap attrVal . filter ((== "xmlUrl") . qName . attrKey) . opmlOutlineAttrs - return $ zip groupNames (map (map feedURI) (map feeds groups))+ return $ zip groupNames (map (map feedURI . feeds) groups)
+ Imm/Options.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}+-- | Commandline options tools. Designed to be imported as @qualified@.+module Imm.Options where++-- {{{ Imports+import Imm.Util++import Control.Conditional+import Control.Lens as L hiding((??))+import Control.Monad.Base+import Control.Monad.Reader hiding(when)++import Data.Default+import Data.Either+import Data.Functor+import Data.List+import Data.Maybe++import Network.URI as N++import Prelude hiding(log)++import System.Console.GetOpt+import System.Environment+import System.Environment.XDG.BaseDir+import System.IO+-- }}}++-- {{{ Types+-- | Available commandline options (cf @imm -h@)+data CliOptions = CliOptions {+ _stateDirectory :: Maybe FilePath,+ _check :: Bool,+ _feedList :: [URI],+ _importOPML :: Maybe FilePath,+ _list :: Bool,+ _markAsRead :: Bool,+ _markAsUnread :: Bool,+ _update :: Bool,+ _help :: Bool,+ _quiet :: Bool,+ _verbose :: Bool,+ _version :: Bool,+ _vanilla :: Bool,+ _recompile :: Bool,+ _denyReconf :: Bool,+ _forceReconf :: Bool,+ _dyreDebug :: Bool}+ deriving(Eq)++makeLenses ''CliOptions++instance Show CliOptions where+ show opts = intercalate " " $ catMaybes [+ null (view feedList opts) ? Nothing ?? Just ("FEED_URI=[" ++ (intercalate " " . map show $ view feedList opts) ++ "]"),+ return . ("IMPORT_OPML=" ++) =<< view importOPML opts,+ return . ("STATE_DIR=" ++) =<< view stateDirectory opts,+ view check opts ? Just "CHECK" ?? Nothing,+ view list opts ? Just "LIST" ?? Nothing,+ view markAsRead opts ? Just "MARK_READ" ?? Nothing,+ view markAsUnread opts ? Just "MARK_UNREAD" ?? Nothing,+ view update opts ? Just "UPDATE" ?? Nothing,+ view help opts ? Just "HELP" ?? Nothing,+ view quiet opts ? Just "QUIET" ?? Nothing,+ view verbose opts ? Just "VERBOSE" ?? Nothing,+ view version opts ? Just "VERSION" ?? Nothing,+ view vanilla opts ? Just "VANILLA" ?? Nothing,+ view recompile opts ? Just "RECOMPILE" ?? Nothing,+ view denyReconf opts ? Just "DENY_RECONFIGURATION" ?? Nothing,+ view forceReconf opts ? Just "FORCE_RECONFIGURATION" ?? Nothing,+ view dyreDebug opts ? Just "DYRE_DEBUG" ?? Nothing]++instance Default CliOptions where+ def = CliOptions {+ _stateDirectory = Nothing,+ _check = False,+ _feedList = [],+ _importOPML = Nothing,+ _list = False,+ _markAsRead = False,+ _markAsUnread = False,+ _update = False,+ _help = False,+ _quiet = False,+ _verbose = False,+ _version = False,+ _vanilla = False,+ _recompile = False,+ _denyReconf = False,+ _forceReconf = False,+ _dyreDebug = False}++-- | 'MonadReader' for 'CliOptions'+class OptionsReader m where+ readOptions :: Simple Lens CliOptions a -> m a++instance (Monad m) => OptionsReader (ReaderT CliOptions m) where+ readOptions l = return . view l =<< ask++instance OptionsReader ((->) CliOptions) where+ readOptions l = view l+-- }}}++description :: [OptDescr (CliOptions -> CliOptions)]+description = [+ Option ['s'] ["state"] (ReqArg (\v -> set stateDirectory (Just v)) "PATH") "Where feeds' state (last update time) will be stored",+ Option ['c'] ["check"] (NoArg (set check True)) "Check availability and validity of all feed sources currently configured, without writing any mail",+ Option ['l'] ["list"] (NoArg (set list True)) "List all feed sources currently configured, along with their status",+ Option ['R'] ["mark-read"] (NoArg (set markAsRead True)) "Mark every item of processed feeds as read, ie set last update as now without writing any mail",+ Option ['U'] ["mark-unread"] (NoArg (set markAsUnread True)) "Mark every item of processed feeds as unread, ie delete corresponding state files",+ Option ['u'] ["update"] (NoArg (set update True)) "Update list of feeds (mostly used option)",+ Option ['i'] ["import"] (ReqArg (\v -> set importOPML (Just v)) "PATH") "Import feeds list from an OPML descriptor (read from stdin)",+ Option ['h'] ["help"] (NoArg (set help True)) "Print this help",+ Option ['q'] ["quiet"] (NoArg (set quiet True)) "Do not print any log",+ Option ['v'] ["verbose"] (NoArg (set verbose True)) "Print detailed logs",+ Option ['V'] ["version"] (NoArg (set version True)) "Print version",+ Option ['1'] ["vanilla"] (NoArg (set vanilla True)) "Do not read custom configuration file",+ Option ['r'] ["recompile"] (NoArg (set recompile True)) "Only recompile configuration",+ Option [] ["force-reconf"] (NoArg id) "Recompile configuration before starting the program",+ Option [] ["deny-reconf"] (NoArg id) "Do not recompile configuration even if it has changed",+ Option [] ["dyre-debug"] (NoArg id) "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program"]++-- | Usage text (cf @hbro -h@)+usage :: String+usage = usageInfo "Usage: imm [OPTIONS] [URI]\n\nConvert items from RSS/Atom feeds to maildir entries. If one or more URI(s) are given, they will be processed instead of the feeds list from configuration\n" description++-- | Get and parse commandline options+get :: (MonadBase IO m) => m CliOptions+get = io $ do+ options <- getOpt' Permute description <$> getArgs+ case options of+ (opts, input, _, []) -> do+ let (errors, valids) = partitionEithers $ map (\uri -> maybe (Left $ "Invalid URI given in commandline: " ++ uri) Right $ N.parseURI uri) input+ when (not $ null errors) $ io . putStrLn $ unlines errors+ return $ set feedList valids (foldl (flip id) def opts)+ (_, _, _, _) -> return def++-- | Print logs with arbitrary importance+log, logE, logV :: (MonadBase IO m, OptionsReader m) => String -> m ()+log = whenM (not <$> readOptions quiet) . io . putStrLn+logE = whenM (not <$> readOptions quiet) . io . hPutStr stderr+logV = whenM (readOptions verbose) . io . putStrLn+++getStateDirectory :: (OptionsReader m, MonadBase IO m) => m FilePath+getStateDirectory = do+ stateFromOptions <- readOptions stateDirectory+ case stateFromOptions of+ Just x -> return x+ _ -> getUserConfigDir "imm" >/> "state"
− Imm/Types.hs
@@ -1,103 +0,0 @@-{-# 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 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.TLS--import Prelude hiding(catch)--import System.Console.CmdArgs-import System.IO.Error hiding(catch)--import Text.Feed.Query-import Text.Feed.Types--- }}}---- {{{ Error handling-data ImmError = - OtherError String- | HTTPError HttpException- | TLSError HandshakeFailed- | UnicodeError UnicodeException- | ParseUriError String- | ParseTimeError String- | ParseItemDateError Item- | ParseFeedError String- | IOE IOError- | TimeOut--instance Show ImmError where- show (OtherError 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 (ParseItemDateError item) = unlines [- "/!\\ 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 (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--- }}}---- {{{ Settings type--- | Available commandline options (cf imm -h)-data CliOptions = CliOptions {- mCheck :: Bool,- mFeedURI :: Maybe String,- mImportOPML :: Bool,- mList :: Bool,- mMarkAsRead :: Bool,- mMarkAsUnread :: Bool,- mUpdate :: Bool-} deriving (Data, Typeable, Show, Eq)--data Settings = Settings {- mStateDirectory :: IO FilePath, -- ^ Where feeds' state (last update time) will be stored- mMaildir :: IO FilePath, -- ^ Where mails will be written- mFromBuilder :: (Item, Feed) -> String, -- ^ Called to write the From: header of feed mails- mSubjectBuilder :: (Item, Feed) -> TL.Text, -- ^ Called to write the Subject: header of feed mails- mBodyBuilder :: (Item, Feed) -> TL.Text -- ^ Called to write the body of feed mails (sic!)-}--type CustomSettings = Settings -> Settings--- }}}---- {{{ Feed types-type FeedList = [(CustomSettings, String)]-type ImmFeed = (URI, Feed)--- }}}--data Mail = Mail {- mReturnPath :: String,- mDate :: Maybe ZonedTime,- mFrom :: String,- mSubject :: TL.Text,- mMIME :: String,- mCharset :: String,- mContentDisposition :: String,- mBody :: TL.Text-}
Imm/Util.hs view
@@ -1,18 +1,15 @@-{-# LANGUAGE NoMonomorphismRestriction, RankNTypes, FlexibleContexts #-} module Imm.Util where -- {{{ Imports-import Imm.Types+import Imm.Error import qualified Control.Exception as E+import Control.Monad.Base import Control.Monad.Error---import Control.Monad.IO.Class -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Functor import Data.Maybe-import Data.Text.ICU.Convert import Data.Text.Lazy.Encoding hiding(decodeUtf8) import qualified Data.Text.Lazy as TL import Data.Time as T@@ -21,39 +18,30 @@ import Network.URI as N -import System.Console.CmdArgs import System.FilePath-import System.IO import System.Locale import System.Timeout as S -- }}} --- | Like '(</>)' with first argument in IO to build platform-dependent paths.-(>/>) :: (MonadIO m) => IO FilePath -> FilePath -> m FilePath+-- | Like '</>' with first argument in IO to build platform-dependent paths.+(>/>) :: (MonadBase IO m) => IO FilePath -> FilePath -> m FilePath (>/>) a b = io $ (</> b) <$> a -- {{{ Monadic utilities--- | Shortcut to 'liftIO'-io :: MonadIO m => IO a -> m a-io = liftIO+-- | Shortcut to 'liftBase' with 'IO' as base monad+io :: MonadBase IO m => IO a -> m a+io = liftBase -- | 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 +try :: (MonadBase IO 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 :: (MonadBase IO 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-logError, logNormal, logVerbose :: MonadIO m => String -> m ()-logError = io . hPutStr stderr-logNormal = io . whenNormal . putStrLn-logVerbose = io . whenLoud . putStrLn-- -- {{{ 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@@ -67,11 +55,3 @@ parseTime :: (MonadError ImmError m) => String -> m UTCTime parseTime string = maybe (throwError $ ParseTimeError string) return $ T.parseTime defaultTimeLocale "%c" string -- }}}--decode :: (MonadIO m, MonadError ImmError m) => BL.ByteString -> m TL.Text-decode raw = 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 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
+ README view
@@ -0,0 +1,58 @@+=========+About imm+=========++In a nutshell+-------------++**Technically**, *imm* is a little tool that retrieves a list of RSS/Atom feeds and fills a maildir with new items.++**Functionally**, *imm* makes it possible to use mail readers for feeds, for the sake of *I-want-the-mutt-of-feed-readers* zealots.++*imm* is written and configured in *Haskell*.++Informations about versions, dependencies, source repositories and contacts can be found in hackage_.+++Need & purpose+--------------++Following numerous RSS/Atom feeds needs organization and aggregation.+Such needs are usually met by feed readers.+Although there are a lot of those, some people still feel unsatisfied with the existing implementations.++The expected features of a feed reader could be defined as follows:++- it retrieves items with the following attributes: an author, a date/time, a (possibly enriched) body;+- items can be sorted, categorized, marked as read/unread, tagged, shared/forwarded;+- items must be available from anywhere on the internet.++Luckily, there's already a widespread solution that provides such features: mail readers.+Considering that, *imm* aims at projecting the RSS/Atom paradigm onto the mail one; this way, all the existing tools that work on mails can be leveraged to work on RSS/Atom feeds as well, no wheel reinventing.+++Function+--------++*imm* does only one thing and does it well: it downloads an RSS/Atom feeds list, and for each new item it writes a file in a local maildir. How and where to write mail files is setup in *imm*'s configuration file.++No *SMTP* sending, no *IMAP* serving, no aggregating: those should be performed by external tools.+++Example usage+-------------++It is possible to setup a Google Reader-like on a server using the following steps:++- schedule *imm* to check feeds regularly and write new items into a local maildir;+- setup an IMAP server to publish the aforementioned maildir;+- setup a webmail, bound to the IMAP server above, to read feeds from any computer connected to the internet.+++Getting started+---------------++To get started, please fill the configuration file at ``~/.config/imm/imm.hs`` with your feeds list and settings. An example configuration file is provided with the package. Configuring *imm* requires basic knowledge of *Haskell* language.+++.. _hackage: http://hackage.haskell.org/package/imm
imm.cabal view
@@ -1,41 +1,44 @@ Name: imm-Version: 0.4.1.0+Version: 0.5.0.0 Synopsis: Retrieve RSS/Atom feeds and write one mail per new item in a maildir.---Description: +Description: Cf README --Homepage: Category: Web License: OtherLicense License-file: LICENSE--- Copyright: +-- Copyright: Author: kamaradclimber, koral Maintainer: koral att mailoo dott org Cabal-version: >=1.8 Build-type: Simple--- Extra-source-files: +Extra-source-files: README Source-repository head Type: git- Location: git@github:k0ral/imm.git+ Location: git@github.com:k0ral/imm.git Library Exposed-modules:+ Imm, Imm.Boot, Imm.Config,- Imm.HTTP,- Imm.Main,+ Imm.Core,+ Imm.Database,+ Imm.Dyre,+ Imm.Error, Imm.Feed,- Imm.OPML,- Imm.Types,- Imm.Util,+ Imm.HTTP, Imm.Mail,- Imm.Maildir+ Imm.Maildir,+ Imm.OPML,+ Imm.Options,+ Imm.Util Build-depends: base == 4.*, bytestring, case-insensitive,- cmdargs, cond, data-default, directory,@@ -44,7 +47,9 @@ filepath, http-conduit, http-types,+ lens, mime-mail,+ monad-control, mtl, network, old-locale,@@ -52,15 +57,24 @@ random, text, text-icu,+ transformers-base, time,- timerep,+ timerep >= 1.0.3, tls, utf8-string, xdg-basedir, xml- - -- Other-modules: - -- Build-tools: + Extensions:+ ConstraintKinds,+ KindSignatures,+ FlexibleContexts,+ FunctionalDependencies,+ GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ RankNTypes++ -- Other-modules:+ -- Build-tools: Ghc-options: -Wall Executable imm