imm 0.5.0.1 → 0.5.1.0
raw patch · 14 files changed
+538/−420 lines, 14 filesdep +hsloggerdep +resourcetdep ~http-conduitdep ~network
Dependencies added: hslogger, resourcet
Dependency ranges changed: http-conduit, network
Files
- Imm.hs +1/−1
- Imm/Boot.hs +36/−30
- Imm/Config.hs +119/−26
- Imm/Core.hs +34/−98
- Imm/Database.hs +86/−36
- Imm/Dyre.hs +26/−14
- Imm/Error.hs +45/−4
- Imm/Feed.hs +38/−47
- Imm/HTTP.hs +22/−3
- Imm/Mail.hs +21/−13
- Imm/Maildir.hs +0/−2
- Imm/Options.hs +86/−98
- Imm/Util.hs +14/−42
- imm.cabal +10/−6
Imm.hs view
@@ -13,7 +13,7 @@ import Imm.Config import Imm.Feed import Imm.HTTP-import Imm.Mail+import Imm.Mail hiding(formatFrom, formatSubject, formatBody) import Imm.Maildir import Imm.OPML import Imm.Util
Imm/Boot.hs view
@@ -4,64 +4,70 @@ -- {{{ Imports import qualified Imm.Core as Core import Imm.Config+import Imm.Database import Imm.Dyre as Dyre-import Imm.Options (CliOptions)+import Imm.Error+import Imm.Options (Action(..), Configuration(..), OptionsReader(..)) import qualified Imm.Options as Options import Imm.Util -import Control.Conditional-import Control.Lens hiding ((??))+import Control.Lens hiding (Action, (??))+import Control.Monad.Error hiding(when)+import Control.Monad.Reader hiding(when) -import Data.Default-import Data.Either-import Data.Maybe+import Data.Version import Network.URI as N -import System.Directory+import Paths_imm++import System.Log.Logger import System.Exit -- }}} type ConfigFeed = (Config -> Config, String) + -- | Main function to call in the configuration file. imm :: [ConfigFeed] -> IO ()-imm feedsFromConfig = do- options <- Options.get+imm feedsFromConfig = Options.run $ do+ action <- readOptions Options.action+ configuration <- readOptions Options.configuration+ feedsFromOptions <- readOptions Options.feedsList+ dataDir <- readOptions Options.dataDirectory - when (view Options.help options) $ putStrLn Options.usage >> exitSuccess+ when (action == Help) . io $ putStrLn Options.usage >> exitSuccess+ when (action == ShowVersion) . io $ putStrLn (showVersion version) >> exitSuccess+ when (action == Recompile) . io $ Dyre.recompile >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) - Dyre.wrap realMain options (options, feedsFromConfig)+ io $ Dyre.wrap (configuration == Vanilla) realMain (action, dataDir, feedsFromOptions, feedsFromConfig) validateFeeds :: [ConfigFeed] -> [URI] -> ([String], Core.FeedList) validateFeeds feedsFromConfig feedsFromOptions = (errors ++ errors', null feedsFromOptions ? feedsOK ?? feedsOK') where 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+ 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+realMain :: (Action, Maybe FilePath, [URI], [ConfigFeed]) -> IO ()+realMain (action, dataDir, feedsFromOptions, feedsFromConfig) = do+ let (errors, feedsOK) = validateFeeds feedsFromConfig feedsFromOptions+ unless (null errors) . errorM "imm.boot" $ unlines errors - when (null feedsOK) $ putStrLn "Nothing to process. Exiting..." >> exitFailure- -- when (view Options.verbose options) . putStrLn . unlines $ map (show . snd) feedsOK+ when (null feedsOK) $ warningM "imm.boot" "Nothing to process. Exiting..." >> exitFailure+ -- io . debugM "imm.boot" . unlines $ "Feeds to be processed:":(map (show . snd) feedsOK) - home <- getHomeDirectory >/> "feeds"- let config = set maildir home def- dispatch feedsOK config options+ withError . withConfig (maybe id (set (fileDatabase . directory)) dataDir) $ dispatch action feedsOK -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+dispatch :: Action -> Core.FeedList -> ReaderT Config (ErrorT ImmError IO) ()+dispatch CheckFeeds feeds = mapM_ Core.check feeds+dispatch ListFeeds feeds = mapM_ Core.list feeds+dispatch MarkAsRead feeds = mapM_ Core.markAsRead feeds+dispatch MarkAsUnread feeds = mapM_ Core.markAsUnread feeds+dispatch UpdateFeeds feeds = mapM_ Core.update feeds+dispatch ImportFeeds _ = Core.importOPML =<< io getContents+dispatch _ _ = io $ putStrLn Options.usage
Imm/Config.hs view
@@ -1,59 +1,152 @@-{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}-module Imm.Config where+{-# LANGUAGE OverlappingInstances, TemplateHaskell #-}+module Imm.Config (+-- * Types+ FromFormat(FromFormat),+ SubjectFormat(SubjectFormat),+ BodyFormat(BodyFormat),+ Config,+ maildir,+ fileDatabase,+ dateParsers,+ formatFrom,+ formatSubject,+ formatBody,+ decoder,+ ConfigReader(..),+ withConfig,+-- * Misc+ addFeeds,+) where -- {{{ Imports+import Imm.Database+import Imm.Error+import Imm.Feed (FeedParser)+import qualified Imm.Feed as F+import Imm.HTTP (Decoder(..))+import qualified Imm.Mail as Mail import Imm.Util -import Control.Lens-import Control.Monad.Base-import Control.Monad.Reader hiding(forM_)+import Control.Lens hiding((??))+import Control.Monad.Error hiding(forM_, guard)+import Control.Monad.Reader hiding(forM_, guard) -import Data.Char import Data.Foldable hiding(concat) import Data.Text.ICU.Convert-import Data.Time+import qualified Data.Text.Lazy as TL+import Data.Time as T+import Data.Time.RFC2822+import Data.Time.RFC3339 -import Text.Feed.Types as F+import Text.Feed.Query as F+-- import Text.Feed.Types as F++import System.Directory+-- import System.Environment.XDG.BaseDir+import System.Locale -- }}} -- {{{ Types-type Format = (Item, Feed) -> String+newtype FromFormat = FromFormat { unFromFormat :: Mail.Format }+newtype SubjectFormat = SubjectFormat { unSubjectFormat :: Mail.Format }+newtype BodyFormat = BodyFormat { unBodyFormat :: Mail.Format } +instance Default FromFormat where+ def = FromFormat $ \(item, feed) -> fromMaybe (getFeedTitle feed) $ getItemAuthor item++instance Default SubjectFormat where+ def = SubjectFormat $ \(item, _feed) -> fromMaybe "Untitled" $ getItemTitle item++instance Default BodyFormat where+ def = BodyFormat $ \(item, _feed) -> let+ link = fromMaybe "No link found." $ getItemLink item+ content = F.getItemContent item+ description = fromMaybe "No description." $ getItemDescription item+ in "<p>" ++ link ++ "</p><p>" ++ (null content ? description ?? content) ++ "</p>"+++-- | The only exported constructor is through 'Default' class. data Config = Config {- _maildir :: FilePath, -- ^ Where mails will be written+ _maildir :: FilePath, -- ^ Where mails will be written+ _fileDatabase :: FileDatabase, -- ^ Database configuration, used to store resilient information (basically: last update time) _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+ _formatFrom :: FromFormat, -- ^ Called to write the From: header of feed mails+ _formatSubject :: SubjectFormat, -- ^ Called to write the Subject: header of feed mails+ _formatBody :: BodyFormat, -- ^ Called to write the body of feed mails (sic!)+ _decoder :: String -- ^ 'Converter' name used to decode the HTTP response from a feed URI } makeLenses ''Config +instance Default (IO Config) where+ def = do+ theDatabase <- def+ mailDir <- getHomeDirectory >/> "feeds"+ return Config {+ _maildir = mailDir,+ _fileDatabase = theDatabase,+ _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 = def,+ _formatSubject = def,+ _formatBody = def,+ _decoder = "UTF-8"+ } +instance (Monad m) => FeedParser (ReaderT Config m) where+ parseDate date = return . listToMaybe . {-map T.zonedTimeToUTC .-} catMaybes =<< tryParsers strippedDate+ where+ tryParsers string = return . map ($ string) =<< asks (view dateParsers)+ strippedDate = TL.unpack . TL.strip . TL.pack $ date++instance (Applicative m, MonadBase IO m) => Decoder (ReaderT Config m) where+ converter = io . (`open` Nothing) =<< asks (view decoder)++instance (MonadBase IO m) => DatabaseReader (ReaderT Config m) where+ getLastCheck = withReaderT (view fileDatabase) . getLastCheck++instance (MonadBase IO m) => DatabaseWriter (ReaderT Config (ErrorT ImmError m)) where+ storeLastCheck uri = withReaderT (view fileDatabase) . storeLastCheck uri+ forget = withReaderT (view fileDatabase) . forget++instance (Monad m) => Mail.MailFormatter (ReaderT Config m) where+ formatFrom = asks $ unFromFormat . view formatFrom+ formatSubject = asks $ unSubjectFormat . view formatSubject+ formatBody = asks $ unBodyFormat . view formatBody++ -- | 'MonadReader' for 'Config' class ConfigReader m where- readConfig :: Simple Lens Config a -> m a+ readConfig :: Simple Lens Config a -> m a+ localConfig :: (Config -> Config) -> m a -> m a instance (Monad m) => ConfigReader (ReaderT Config m) where readConfig l = return . view l =<< ask+ localConfig = local -instance ConfigReader ((->) Config) where- readConfig l = view l++withConfig :: (MonadBase IO m) => (Config -> Config) -> ReaderT Config m a -> m a+withConfig f g = do+ theConfig <- f <$> io def+ runReaderT g theConfig -- }}} --- | 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+addFeeds :: (MonadBase IO m) => [(String, [String])] -> m ()+addFeeds feeds = forM_ feeds addFeedsGroup++addFeedsGroup :: (MonadBase IO m) => (String, [String]) -> m ()+addFeedsGroup (groupTitle, uris) = io $ do+ -- guard (not $ null uris) putStrLn $ "-- Group " ++ groupTitle putStrLn $ map toLower (concat . words $ groupTitle) ++ " = ["- forM_ uris (\uri -> putStrLn $ " " ++ show uri ++ ",")+ putStrLn . (" " ++) . intercalate ",\n " $ map show uris putStrLn "]" putStrLn ""
Imm/Core.hs view
@@ -1,152 +1,88 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} module Imm.Core where -- {{{ Imports import Imm.Config import Imm.Database import Imm.Error-import Imm.Feed (ImmFeed, FeedID)+import Imm.Feed (ImmFeed, FeedParser(..)) import qualified Imm.Feed as Feed+import qualified Imm.HTTP as HTTP import qualified Imm.Maildir as Maildir+import Imm.Mail (MailFormatter(..)) 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.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 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 System.Log.Logger 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+type FeedConfig = (Config -> Config, FeedID)+type FeedList = [FeedConfig] -- }}} -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+check :: (MonadBase IO m, FeedParser m, ConfigReader m, DatabaseReader m, HTTP.Decoder m, MonadError ImmError m) => FeedConfig -> m ()+check (f, feedID) = localConfig f . localError "imm.core" $ do+ io . noticeM "imm.core" $ "Checking: " ++ show feedID+ Feed.download feedID >>= Feed.check -importOPML :: (MonadBase IO m) => m ()-importOPML = io $ mapM_ addFeeds =<< OPML.read <$> getContents+importOPML :: (MonadBase IO m, MonadPlus m) => String -> m ()+importOPML = mapM_ addFeeds . OPML.read -list :: CliOptions -> FeedList -> IO ()-list options = mapM_ (\(f, feedID) -> runI' options (f def) $ (io . putStrLn =<< Feed.showStatus feedID))+list :: (MonadBase IO m, ConfigReader m, DatabaseReader m, MonadError ImmError m) => FeedConfig -> m ()+list (f, feedID) = localConfig f . localError "imm.core" $ (io . noticeM "imm.core" =<< Feed.showStatus feedID) -markAsRead :: CliOptions -> FeedList -> IO ()-markAsRead options = mapM_ (\(f, feedID) -> runI options (f def) $ checkStateDirectory >> Feed.markAsRead feedID)+markAsRead :: (MonadBase IO m, ConfigReader m, DatabaseState m, MonadError ImmError m) => FeedConfig -> m ()+markAsRead (f, feedID) = localConfig f . localError "imm.core" $ Feed.markAsRead feedID -markAsUnread :: CliOptions -> FeedList -> IO ()-markAsUnread options = mapM_ (\(f, feedID) -> runI options (f def) $ Feed.markAsUnread feedID)+markAsUnread :: (MonadBase IO m, ConfigReader m, DatabaseState m, MonadError ImmError m) => FeedConfig -> m ()+markAsUnread (f, feedID) = localConfig f . localError "imm.core" $ 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+update :: (MonadBase IO m, ConfigReader m, DatabaseState m, MonadError ImmError m, FeedParser m, MailFormatter m, HTTP.Decoder m) => FeedConfig -> m ()+update (f, feedID) = localConfig f . localError "imm.core" $ do+ io . noticeM "imm.core" $ "Updating: " ++ show feedID+ Feed.download feedID >>= updateFeed -- | 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 :: (Applicative m, ConfigReader m, DatabaseState m, FeedParser m, MailFormatter m, MonadBase IO m, MonadError ImmError m) => ImmFeed -> m () updateFeed (uri, feed) = do--- checkStateDirectory Maildir.create =<< readConfig maildir - logV $ Feed.describe feed+ io . debugM "imm.core" $ Feed.describe feed lastCheck <- getLastCheck uri- results <- forM (feedItems feed) $ \item -> do- (Right date) <- Feed.getDate item+ (results :: [Integer]) <- forM (feedItems feed) $ \item -> do+ date <- Feed.getDate item (date > lastCheck) ? (updateItem (item, feed) >> return 1) ?? return 0- log $ "==> " ++ show (sum results) ++ " new item(s)"+ io . noticeM "imm.core" $ "==> " ++ 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 :: (Applicative m, ConfigReader m, FeedParser m, MailFormatter m, MonadBase IO 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+ io . debugM "imm.core" $ "Adding following item to maildir [" ++ dir ++ "]:\n" ++ Feed.describeItem item+ Maildir.add dir =<< Mail.build timeZone (item, feed)
Imm/Database.hs view
@@ -1,11 +1,20 @@-module Imm.Database where+{-# LANGUAGE OverlappingInstances, TemplateHaskell #-}+module Imm.Database (+ FeedID,+ DatabaseReader(..),+ DatabaseWriter(..),+ DatabaseState,+ FileDatabase,+ directory,+ getDataFile,+) where -- {{{ Imports import Imm.Error-import Imm.Options import Imm.Util -import Control.Monad.Base+import Control.Lens+import Control.Monad.Reader import Control.Monad.Error import Data.Time hiding(parseTime)@@ -14,50 +23,91 @@ import Network.URI import System.Directory+import System.Environment.XDG.BaseDir import System.FilePath import System.Locale import System.IO+import System.Log.Logger -- }}} +-- {{{ Types+type FeedID = URI++class DatabaseReader m where+ -- | Read the last check time in the state file.+ getLastCheck :: FeedID -> m UTCTime++instance (Error e, DatabaseReader m) => DatabaseReader (ErrorT e m) where+ getLastCheck = getLastCheck+++class (MonadError ImmError m) => DatabaseWriter m where+ -- | Write the last update time in the data file.+ storeLastCheck :: FeedID -> UTCTime -> m ()+ -- | Remove state file as if no update was ever done.+ forget :: FeedID -> m ()+++type (DatabaseState m) = (DatabaseReader m, DatabaseWriter m)+++data FileDatabase = FileDatabase {+ _directory :: FilePath,+ _getDataFile :: FeedID -> FilePath+}++makeLenses ''FileDatabase+ -- | 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+instance Default (IO FileDatabase) where+ def = do+ dataDir <- getUserConfigDir "imm" >/> "state"+ return FileDatabase {+ _directory = dataDir,+ _getDataFile = \feedUri -> case uriAuthority feedUri of+ Just auth -> toFileName =<< ((++ uriQuery feedUri) . (++ uriPath feedUri) . uriRegName $ auth)+ _ -> show feedUri >>= toFileName+ } --- | Remove forbidden characters in a filename.-toFileName :: Char -> String-toFileName '/' = "."-toFileName '?' = "."-toFileName x = [x]+instance (MonadBase IO m) => DatabaseReader (ReaderT FileDatabase m) where+ getLastCheck feedUri = do+ dataDirectory <- asks (view directory)+ dataFileGetter <- asks (view getDataFile) --- | 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+ let dataFile = dataDirectory </> dataFileGetter feedUri - either (const $ return timeZero) return result- where- fileName = getStateFile feedUri- timeZero = posixSecondsToUTCTime 0+ result <- runErrorT $ do+ content <- try $ readFile dataFile+ parseTime content+ either (const $ io (warningM "imm.database" "Unable to read last update time.") >> return timeZero) return result+ where+ timeZero = posixSecondsToUTCTime 0 +instance (MonadBase IO m, MonadError ImmError m) => DatabaseWriter (ReaderT FileDatabase m) where+ storeLastCheck feedUri date = do+ dataDirectory <- asks (view directory)+ dataFileGetter <- asks (view getDataFile) --- | 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+ let dataFile = dataFileGetter feedUri - (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+ io . debugM "imm.database" $ "Storing last update time [" ++ show date ++ "] at <" ++ dataDirectory </> dataFile ++ ">"+ try . io . createDirectoryIfMissing True $ dataDirectory+ (file, stream) <- try $ openTempFile dataDirectory dataFile+ io $ hPutStrLn stream (formatTime defaultTimeLocale "%c" date)+ io $ hClose stream+ try $ renameFile file (dataDirectory </> dataFile) + forget uri = do+ dataDirectory <- asks (view directory)+ dataFileGetter <- asks (view getDataFile) -forget :: (OptionsReader m, MonadBase IO m, MonadError ImmError m) => URI -> m ()-forget uri = do- directory <- getStateDirectory- try $ removeFile (directory </> getStateFile uri)+ let dataFile = dataDirectory </> dataFileGetter uri+ io . debugM "imm.database" $ "Removing data file <" ++ dataFile ++ ">"+ try $ removeFile dataFile+-- }}}++-- | Remove forbidden characters in a filename.+toFileName :: Char -> String+toFileName '/' = "."+toFileName '?' = "."+toFileName x = [x]
Imm/Dyre.hs view
@@ -1,25 +1,31 @@-module Imm.Dyre where+module Imm.Dyre (+ wrap,+ recompile,+) where -- {{{ Imports-import Imm.Options import Imm.Util import Config.Dyre+import Config.Dyre.Compile import Config.Dyre.Paths -import Control.Lens import Control.Monad-import Control.Monad.Base+import Control.Monad.Trans.Control import System.IO+import System.Log.Logger -- }}} --- | 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 $ [+nullMain :: a -> IO ()+nullMain = const $ return ()++-- Print various paths used for dynamic reconfiguration+showPaths :: MonadBase IO m => m String+showPaths = io $ do+ (a, b, c, d, e) <- getPaths $ parameters nullMain+ return . unlines $ [ "Current binary: " ++ a, "Custom binary: " ++ b, "Config file: " ++ c,@@ -37,9 +43,15 @@ includeCurrentDirectory = False} where main' (Left e) = putStrLn e- main' (Right x) = main x+ main' (Right x) = do+ debugM "imm.dyre" =<< showPaths+ 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+wrap :: (MonadBaseControl IO m) => Bool -> (a -> m ()) -> a -> m ()+wrap vanilla main args = liftBaseWith $ \runInIO -> wrapMain ((parameters (void . runInIO . main)) { configCheck = not vanilla }) $ Right args++-- | Launch a recompilation of the configuration file+recompile :: IO (Maybe String)+recompile = do+ customCompile $ parameters nullMain+ getErrorString $ parameters nullMain
Imm/Error.hs view
@@ -1,21 +1,32 @@ module Imm.Error where -- {{{ Imports+import qualified Control.Exception as E+import Imm.Util+ import Control.Monad.Error -import Data.Maybe+import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T-import Data.Text.Encoding+import Data.Text.Encoding as T import Data.Text.Encoding.Error+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Encoding as TL+import Data.Time as T import Network.HTTP.Conduit hiding(HandshakeFailed) import Network.HTTP.Types.Status import Network.TLS hiding(DecodeError)+import Network.URI as N import System.IO.Error import Text.Feed.Query import Text.Feed.Types++import System.Locale+import System.Log.Logger+import System.Timeout as S -- }}} data ImmError =@@ -32,8 +43,8 @@ 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 (StatusCodeException status _headers _cookieJar)) =+ "/!\\ HTTP error: " ++ show (statusCode status) ++ " " ++ (T.unpack . T.decodeUtf8) (statusMessage status) show (HTTPError e) = "/!\\ HTTP error: " ++ show e show (TLSError (HandshakeFailed e)) = "/!\\ TLS error: " ++ show e show (UnicodeError (DecodeError e _)) = e@@ -52,3 +63,33 @@ instance Error ImmError where strMsg = OtherError+++withError :: (Error e, Show e, MonadBase IO m) => ErrorT e m () -> m ()+withError = runErrorT >=> either (io . print) return++localError :: (MonadBase IO m, MonadError ImmError m) => String -> m () -> m ()+localError category f = f `catchError` (io . errorM category . show)++-- | Monad-agnostic version of 'Control.Exception.try'+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 :: (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))+++-- {{{ 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 . TL.decodeUtf8'++-- | Monad-agnostic version of 'Network.URI.parseURI'+parseURI :: (MonadError ImmError m) => String -> m URI+parseURI uri = maybe (throwError $ ParseUriError uri) return $ N.parseURI uri++-- | 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+-- }}}
Imm/Feed.hs view
@@ -1,26 +1,16 @@ module Imm.Feed where -- {{{ Imports-import Imm.Config import Imm.Database import Imm.Error import qualified Imm.HTTP as HTTP-import Imm.Options hiding(markAsRead)-import Imm.Util+import Imm.Util hiding(when) --- import Control.Applicative-import Control.Conditional hiding(when)-import Control.Monad.Base import Control.Monad.Error -import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.Char-import Data.Either-import Data.Functor-import Data.Maybe+-- import qualified Data.ByteString as B+-- import qualified Data.ByteString.Lazy as BL import qualified Data.Text.Lazy as TL-import Data.Text.ICU.Convert import Data.Time as T hiding(parseTime) import Data.Time.Clock.POSIX @@ -34,20 +24,31 @@ import Text.Feed.Types as F import Text.XML.Light.Proc import Text.XML.Light.Types++import System.Log.Logger -- }}} -type FeedID = URI-type ImmFeed = (FeedID, Feed)+-- {{{ Types+type ImmFeed = (FeedID, Feed) -describeType :: Feed -> String-describeType (AtomFeed _) = "Atom"-describeType (RSSFeed _) = "RSS 2.x"-describeType (RSS1Feed _) = "RSS 1.x"-describeType (XMLFeed _) = "XML"+class FeedParser m where+ parseDate :: String -> m (Maybe UTCTime) +instance (Monad m, Error e, FeedParser m) => FeedParser (ErrorT e m) where+ parseDate = lift . parseDate+-- }}}+++-- | Provide a 'String' representation of the feed type.+showType :: Feed -> String+showType (AtomFeed _) = "Atom"+showType (RSSFeed _) = "RSS 2.x"+showType (RSS1Feed _) = "RSS 1.x"+showType (XMLFeed _) = "XML"+ describe :: Feed -> String describe feed = unlines [- "Type: " ++ describeType feed,+ "Type: " ++ showType feed, "Title: " ++ getFeedTitle feed, "Author: " ++ fromMaybe "No author" (getFeedAuthor feed), "Home: " ++ fromMaybe "No home" (getFeedHome feed)]@@ -66,38 +67,34 @@ -- | 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 :: (HTTP.Decoder m, MonadBase IO m, MonadError ImmError m) => URI -> m ImmFeed download uri = do- logV $ "Downloading " ++ show uri- d <- getDecoder- feed <- parse . TL.unpack . decodeWith d =<< HTTP.getRaw uri+ io . debugM "imm.feed" $ "Downloading " ++ show uri+ feed <- parse . TL.unpack =<< HTTP.get uri return (uri, feed)- where- decodeWith d = TL.fromChunks . (: []) . toUnicode d . B.concat . BL.toChunks -- |-check :: (ConfigReader m, OptionsReader m, MonadBase IO m, MonadError ImmError m) => ImmFeed -> m ()+check :: (FeedParser m, DatabaseReader m, MonadBase IO m, MonadError ImmError m) => ImmFeed -> m () check (uri, feed) = do lastCheck <- getLastCheck uri- (errors, dates) <- partitionEithers <$> forM (feedItems feed) getDate- logE . unlines $ map show errors+ (errors, dates) <- partitionEithers <$> forM (feedItems feed) (\item -> (return . Right =<< getDate item) `catchError` (return . Left))+ unless (null errors) . io . errorM "imm.feed" . unlines $ map show errors let newItems = filter (> lastCheck) dates- io . putStrLn $ "==> " ++ show (length newItems) ++ " new item(s) "+ io . noticeM "imm.feed" $ "==> " ++ show (length newItems) ++ " new item(s) " -- | 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.")+markAsRead :: (MonadBase IO m, MonadError ImmError m, DatabaseState m) => URI -> m ()+markAsRead uri = io getCurrentTime >>= storeLastCheck uri >> (io . debugM "imm.feed" $ "Feed " ++ show uri ++ " marked as read.") -- | Simply remove the state file.-markAsUnread :: forall (m :: * -> *) . (MonadBase IO m, MonadError ImmError m, OptionsReader m) => URI -> m ()+markAsUnread :: (MonadBase IO m, MonadError ImmError m, DatabaseState m) => URI -> m () markAsUnread uri = do forget uri- logV $ "Feed " ++ show uri ++ " marked as unread."-+ io . noticeM "imm.feed" $ "Feed " ++ show uri ++ " marked as unread." -- | Return a 'String' describing the last update for a given feed.-showStatus :: (OptionsReader m, MonadBase IO m) => URI -> m String+showStatus :: (DatabaseReader 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@@ -112,19 +109,13 @@ 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+ theContent = dropWhile isSpace . concatMap concat . map (map cdData . onlyText . elContent) . RSS.rssItemOther $ i theDescription = fromMaybe "No description." $ RSS.rssItemDescription i-getItemContent (RSS1Item i) = concat . catMaybes . map (RSS1.contentValue) . RSS1.itemContent $ i+getItemContent (RSS1Item i) = concat . mapMaybe RSS1.contentValue . RSS1.itemContent $ i getItemContent item = fromMaybe "No content." . 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--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+getDate :: (FeedParser m, Monad m, MonadError ImmError m) => Item -> m UTCTime+getDate item = maybe (throwError $ ParseItemDateError item) return =<< maybe (return Nothing) parseDate =<< return (getItemDate item) -- }}}
Imm/HTTP.hs view
@@ -3,21 +3,35 @@ -- {{{ Imports import Imm.Error-import Imm.Util as U+import Imm.Util import Control.Exception as E-import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_)+import Control.Monad.Trans.Resource +import Data.ByteString as B import Data.ByteString.Lazy as BL import Data.ByteString.Char8 as BC import Data.CaseInsensitive-import Data.Functor+import Data.Text.ICU.Convert+import qualified Data.Text.Lazy as TL import Network.HTTP.Conduit as H import Network.URI -- }}} +-- {{{ Types+class (Applicative m, Functor m, Monad m) => Decoder m where+ converter :: m Converter+ decode :: BL.ByteString -> m TL.Text+ decode string = return . TL.fromChunks . (: []) =<< toUnicode <$> converter <*> return strictString+ where+ strictString = B.concat $ BL.toChunks string++instance (Error e, Decoder m) => Decoder (ErrorT e m) where+ converter = lift converter+-- }}}+ -- | Perform an HTTP GET request and return the response body as raw 'ByteString' getRaw :: (MonadBase IO m, MonadError ImmError m) => URI -> m BL.ByteString getRaw uri = do@@ -25,7 +39,12 @@ res <- withManager' (httpLbs req) return $ responseBody res +-- | Same as 'getRaw' with additional decoding+get :: (Decoder m, MonadBase IO m, MonadError ImmError m) => URI -> m TL.Text+get uri = decode =<< getRaw uri+ -- | Monad-agnostic version of 'withManager'+withManager' :: (MonadError ImmError m, MonadBase IO m) => (Manager -> ResourceT IO b) -> m b 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
Imm/Mail.hs view
@@ -2,20 +2,22 @@ module Imm.Mail where -- {{{ Imports-import Imm.Config-import Imm.Feed+import Imm.Feed as F+import Imm.Util -import Control.Applicative-import Control.Lens hiding(from)+import Control.Lens hiding(from, (??))+import Control.Monad.Error -import Data.Default import Data.Time import Data.Time.RFC2822 +-- import Text.Feed.Query as F import Text.Feed.Types--- }}} +-- import System.Log.Logger+-- }}} +-- {{{ Types data Mail = Mail { _returnPath :: String, _date :: Maybe ZonedTime,@@ -29,7 +31,6 @@ makeLenses ''Mail - instance Default Mail where def = Mail { _charset = "utf-8",@@ -41,7 +42,6 @@ _subject = "Untitled", _returnPath = "<imm@noreply>"} - instance Show Mail where show mail = unlines [ "Return-Path: " ++ view returnPath mail,@@ -54,11 +54,19 @@ view body mail] +type Format = (Item, Feed) -> String++class MailFormatter m where+ formatFrom :: m Format+ formatSubject :: m Format+ formatBody :: m Format+-- }}}+ -- | Build mail from a given feed, using builders functions from 'Settings'.-build :: (Applicative m, ConfigReader m, Monad m) => TimeZone -> (Item, Feed) -> m Mail+build :: (Applicative m, MailFormatter m, FeedParser m, Monad m) => TimeZone -> (Item, Feed) -> m Mail build timeZone (item, feed) = do- 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+ from' <- formatFrom <*> return (item, feed)+ subject' <- formatSubject <*> return (item, feed)+ body' <- formatBody <*> return (item, feed)+ date' <- return . either (const Nothing) (Just . utcToZonedTime timeZone) =<< runErrorT (getDate item) return . set date date' . set from from' . set subject subject' . set body body' $ def
Imm/Maildir.hs view
@@ -5,10 +5,8 @@ import Imm.Mail import Imm.Util -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
Imm/Options.hs view
@@ -1,93 +1,83 @@-{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} -- | Commandline options tools. Designed to be imported as @qualified@.-module Imm.Options where+module Imm.Options (+ CliOptions,+ action,+ configuration,+ feedsList,+ dataDirectory,+ OptionsReader(..),+ Action(..),+ Configuration(..),+ run,+ usage,+) 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 Control.Lens as L hiding(Action, (??))+import Control.Monad.Reader hiding(mapM_, when) -import Data.Default-import Data.Either-import Data.Functor-import Data.List-import Data.Maybe+import Data.Foldable import Network.URI as N -import Prelude hiding(log)+import Prelude hiding(foldl, log, mapM_) import System.Console.GetOpt import System.Environment-import System.Environment.XDG.BaseDir-import System.IO+-- import System.Environment.XDG.BaseDir+import System.Log as Log+import System.Log.Logger -- }}} -- {{{ Types--- | Available commandline options (cf @imm -h@)+-- | Mutually exclusive actions.+-- Default is 'PrintHelp'.+data Action = Help | ShowVersion | Recompile | CheckFeeds | ImportFeeds | ListFeeds | MarkAsRead | MarkAsUnread | UpdateFeeds+ deriving(Eq, Show)++instance Default Action where+ def = Help++-- | How dynamic reconfiguration process should behave.+-- Default is 'Normal', that is: use custom configuration file and recompile if change detected.+data Configuration = Normal | Vanilla | ForceReconfiguration | IgnoreReconfiguration+ deriving(Eq, Show)++instance Default Configuration where+ def = Normal+++-- | Available commandline options 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,+ _action :: Action,+ _configuration :: Configuration,+ _dataDirectory :: Maybe FilePath,+ _feedsList :: [URI],+ _logLevel :: Log.Priority, _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]+ show opts = unwords $ catMaybes [+ return . ("ACTION=" ++) . show $ view action opts,+ return . ("CONFIGURATION=" ++) . show $ view configuration opts,+ null (view feedsList opts) ? Nothing ?? Just ("FEED_URI=[" ++ (unwords . map show $ view feedsList opts) ++ "]"),+ return . ("DATA_DIR=" ++) =<< view dataDirectory opts,+ return . ("LOG_LEVEL=" ++) . show $ view logLevel opts,+ 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,+ _action = def,+ _configuration = def,+ _logLevel = Log.INFO,+ _dataDirectory = Nothing,+ _feedsList = [], _dyreDebug = False} -- | 'MonadReader' for 'CliOptions'@@ -99,28 +89,40 @@ instance OptionsReader ((->) CliOptions) where readOptions l = view l++-- | Parse commandline options, set the corresponding log level.+run :: (MonadBase IO m) => ReaderT CliOptions m a -> m a+run f = do+ opts <- get+ io . updateGlobalLogger rootLoggerName . setLevel $ view logLevel opts+ io . debugM "imm.options" $ "Commandline options: " ++ show opts+ runReaderT f opts -- }}} 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"]+-- Action+ Option "c" ["check"] (NoArg (set action CheckFeeds)) "Check availability and validity of all feed sources currently configured, without writing any mail",+ Option "l" ["list"] (NoArg (set action ListFeeds)) "List all feed sources currently configured, along with their status",+ Option "R" ["mark-read"] (NoArg (set action MarkAsRead)) "Mark every item of processed feeds as read, ie set last update as now without writing any mail",+ Option "U" ["mark-unread"] (NoArg (set action MarkAsUnread)) "Mark every item of processed feeds as unread, ie delete corresponding state files",+ Option "u" ["update"] (NoArg (set action UpdateFeeds)) "Update list of feeds (mostly used option)",+ Option "i" ["import"] (NoArg (set action ImportFeeds)) "Import feeds list from an OPML descriptor (read from stdin)",+ Option "h" ["help"] (NoArg (set action Help)) "Print this help",+ Option "V" ["version"] (NoArg (set action ShowVersion)) "Print version",+ Option "r" ["recompile"] (NoArg (set action Recompile)) "Only recompile configuration",+-- Dynamic configuration+ Option "1" ["vanilla"] (NoArg (set configuration Vanilla)) "Do not read custom configuration file",+ Option [] ["force-reconf"] (NoArg (set configuration ForceReconfiguration)) "Recompile configuration before starting the program",+ Option [] ["deny-reconf"] (NoArg (set configuration IgnoreReconfiguration)) "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",+-- Log level+ Option "q" ["quiet"] (NoArg (set logLevel Log.ERROR)) "Do not print any log",+ Option "v" ["verbose"] (NoArg (set logLevel Log.DEBUG)) "Print detailed logs",+-- Misc+ Option "d" ["database"] (ReqArg (set dataDirectory . Just) "PATH") "Where feeds' state (last update time) will be stored"] --- | Usage text (cf @imm -h@)+-- | Usage text (printed when using 'Help' action) 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 @@ -131,20 +133,6 @@ 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)+ unless (null errors) $ io . putStrLn $ unlines errors+ return $ set feedsList 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/Util.hs view
@@ -1,26 +1,22 @@-module Imm.Util where+module Imm.Util (+ module X,+ (>/>),+ io,+) where -- {{{ Imports-import Imm.Error--import qualified Control.Exception as E-import Control.Monad.Base-import Control.Monad.Error--import qualified Data.ByteString.Lazy as BL-import Data.Functor-import Data.Maybe-import Data.Text.Lazy.Encoding hiding(decodeUtf8)-import qualified Data.Text.Lazy as TL-import Data.Time as T-import Data.Time.RFC2822-import Data.Time.RFC3339+import Control.Applicative as X+import Control.Conditional as X hiding(unless)+import Control.Monad.Base as X -import Network.URI as N+import Data.Char as X+import Data.Default as X+import Data.Either as X+import Data.Functor as X+import Data.List as X hiding(foldl, sum)+import Data.Maybe as X import System.FilePath-import System.Locale-import System.Timeout as S -- }}} @@ -28,30 +24,6 @@ (>/>) :: (MonadBase IO m) => IO FilePath -> FilePath -> m FilePath (>/>) a b = io $ (</> b) <$> a --- {{{ Monadic utilities -- | 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 :: (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 :: (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))--- }}}---- {{{ 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'---- | Monad-agnostic version of 'Network.URI.parseURI'-parseURI :: (MonadError ImmError m) => String -> m URI-parseURI uri = maybe (throwError $ ParseUriError uri) return $ N.parseURI uri---- | 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--- }}}
imm.cabal view
@@ -1,5 +1,5 @@ Name: imm-Version: 0.5.0.1+Version: 0.5.1.0 Synopsis: Retrieve RSS/Atom feeds and write one mail per new item in a maildir. Description: Cf README --Homepage:@@ -16,8 +16,8 @@ Extra-source-files: README Source-repository head- Type: git- Location: git@github.com:k0ral/imm.git+ Type: mercurial+ Location: https://bitbucket.org/k0ral/imm Library Exposed-modules:@@ -26,7 +26,6 @@ Imm.Config, Imm.Core, Imm.Database,- Imm.Dyre, Imm.Error, Imm.Feed, Imm.HTTP,@@ -35,6 +34,9 @@ Imm.OPML, Imm.Options, Imm.Util+ Other-modules:+ Imm.Dyre,+ Paths_imm Build-depends: base == 4.*, bytestring,@@ -45,13 +47,15 @@ dyre, feed, filepath,- http-conduit,+ hslogger,+ http-conduit >= 1.9.0, http-types, lens, mime-mail, monad-control, mtl, network,+ resourcet, old-locale, opml, random,@@ -68,12 +72,12 @@ ConstraintKinds, KindSignatures, FlexibleContexts,+ FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes - -- Other-modules: -- Build-tools: Ghc-options: -Wall