Commits

koral  committed d785e72

Significant redesign with few fonctional changes.

  • Participants
  • Parent commits e8d840e

Comments (0)

Files changed (14)

 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
 -- {{{ 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

File Imm/Config.hs

-{-# 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 ""
-{-# 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, 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
 
 
-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, MonadPlus m) => String -> m ()
+importOPML = mapM_ addFeeds . OPML.read
 
 
-importOPML :: (MonadBase IO m) => m ()
-importOPML = io $ mapM_ addFeeds =<< OPML.read <$> getContents
+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)
 
 
-list :: CliOptions -> FeedList -> IO ()
-list options = mapM_ (\(f, feedID) -> runI' options (f def) $ (io . putStrLn =<< Feed.showStatus 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
 
 
-markAsRead :: CliOptions -> FeedList -> IO ()
-markAsRead options = mapM_ (\(f, feedID) -> runI options (f def) $ checkStateDirectory >> Feed.markAsRead 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
 
 
-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
+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
+
+    io . debugM "imm.core" $ "Adding following item to maildir [" ++ dir ++ "]:\n" ++ Feed.describeItem item
     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

File Imm/Database.hs

-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)
 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
+                }
+
+instance (MonadBase IO m) => DatabaseReader (ReaderT FileDatabase m) where
+    getLastCheck feedUri = do
+        dataDirectory  <- asks (view directory)
+        dataFileGetter <- asks (view getDataFile)
+
+        let dataFile = dataDirectory </> dataFileGetter feedUri
+
+        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)
+
+        let dataFile = dataFileGetter 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)
+
+        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]
-
--- | 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)
+toFileName x   = [x]
-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,
     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

File Imm/Error.hs

 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 =
 instance Show ImmError where
     show (OtherError e)            = e
     show (HTTPError (StatusCodeException status _headers _cookieJar)) =
-        "/!\\ HTTP error: " ++ show (statusCode status) ++ " " ++ (T.unpack . decodeUtf8) (statusMessage status)
+        "/!\\ 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
 
 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
+-- }}}
 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
 
 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)]
 
 
 -- | 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
     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)
 -- }}}
 
 
 
 -- {{{ 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
     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
 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,
 
 makeLenses ''Mail
 
-
 instance Default Mail where
     def = Mail {
         _charset            = "utf-8",
         _subject            = "Untitled",
         _returnPath         = "<imm@noreply>"}
 
-
 instance Show Mail where
     show mail = unlines [
         "Return-Path: " ++ view returnPath mail,
         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

File Imm/Maildir.hs

 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

File Imm/Options.hs

-{-# 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'
 
 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
 
     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"
-module Imm.Util where
+module Imm.Util (
+    module X,
+    (>/>),
+    io,
+) where
 
 -- {{{ Imports
-import Imm.Error
+import Control.Applicative as X
+import Control.Conditional as X hiding(unless)
+import Control.Monad.Base as X
 
-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 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
 -- }}}
 
 
 (>/>) :: (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
--- }}}
 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:
 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:
         Imm.Config,
         Imm.Core,
         Imm.Database,
-        Imm.Dyre,
         Imm.Error,
         Imm.Feed,
         Imm.HTTP,
         Imm.OPML,
         Imm.Options,
         Imm.Util
+    Other-modules:
+        Imm.Dyre,
+        Paths_imm
     Build-depends:
         base == 4.*,
         bytestring,
         dyre,
         feed,
         filepath,
+        hslogger,
         http-conduit >= 1.9.0,
         http-types,
         lens,
         monad-control,
         mtl,
         network,
+        resourcet,
         old-locale,
         opml,
         random,
         ConstraintKinds,
         KindSignatures,
         FlexibleContexts,
+        FlexibleInstances,
         FunctionalDependencies,
         GeneralizedNewtypeDeriving,
         MultiParamTypeClasses,
         RankNTypes
 
-    -- Other-modules:
     -- Build-tools:
     Ghc-options: -Wall