diff --git a/Imm/Boot.hs b/Imm/Boot.hs --- a/Imm/Boot.hs +++ b/Imm/Boot.hs @@ -7,7 +7,8 @@ import Imm.Database import Imm.Dyre as Dyre import Imm.Error -import Imm.Options (Action(..), Configuration(..), OptionsReader(..)) +import qualified Imm.Feed as Feed +import Imm.Options (Action(..), OptionsReader(..)) import qualified Imm.Options as Options import Imm.Util @@ -30,19 +31,30 @@ -- | Main function to call in the configuration file. imm :: [ConfigFeed] -> IO () -imm feedsFromConfig = Options.run $ do - action <- readOptions Options.action - configuration <- readOptions Options.configuration +imm feedsFromConfig = Options.run $ readOptions Options.action >>= dispatch1 feedsFromConfig + + +dispatch1 :: [ConfigFeed] -> Options.Action -> ReaderT Options.CliOptions IO () +dispatch1 _ Help = io $ putStrLn Options.usage >> exitSuccess +dispatch1 _ ShowVersion = io $ putStrLn (showVersion version) >> exitSuccess +dispatch1 _ Recompile = io $ Dyre.recompile >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) +dispatch1 _ Import = io getContents >>= Core.importOPML >> io exitSuccess +dispatch1 feedsFromConfig (Run action) = do + dyreMode <- readOptions Options.dyreMode feedsFromOptions <- readOptions Options.feedsList dataDir <- readOptions Options.dataDirectory - 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) + io $ Dyre.wrap dyreMode realMain (action, dataDir, feedsFromOptions, feedsFromConfig) - io $ Dyre.wrap (configuration == Vanilla) realMain (action, dataDir, feedsFromOptions, feedsFromConfig) +dispatch2 :: Feed.Action -> Core.FeedList -> ReaderT Config (ErrorT ImmError IO) () +dispatch2 Feed.Check feeds = Core.check feeds +dispatch2 Feed.ShowStatus feeds = mapM_ Core.showStatus feeds +dispatch2 Feed.MarkAsRead feeds = mapM_ Core.markAsRead feeds +dispatch2 Feed.MarkAsUnread feeds = mapM_ Core.markAsUnread feeds +dispatch2 Feed.Update feeds = Core.update feeds + validateFeeds :: [ConfigFeed] -> [URI] -> ([String], Core.FeedList) validateFeeds feedsFromConfig feedsFromOptions = (errors ++ errors', null feedsFromOptions ? feedsOK ?? feedsOK') where @@ -52,22 +64,11 @@ (errors', feedsOK') = partitionEithers $ map validateFromOptions feedsFromOptions -realMain :: (Action, Maybe FilePath, [URI], [ConfigFeed]) -> IO () +realMain :: (Feed.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) $ warningM "imm.boot" "Nothing to process. Exiting..." >> exitFailure + unless (null errors) . errorM "imm.boot" $ unlines errors + when (null feedsOK) $ warningM "imm.boot" "Nothing to process. Exiting..." >> exitFailure -- io . debugM "imm.boot" . unlines $ "Feeds to be processed:":(map (show . snd) feedsOK) - withError . withConfig (maybe id (set (fileDatabase . directory)) dataDir) $ dispatch action feedsOK - - -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 + withError . withConfig (maybe id (set (fileDatabase . directory)) dataDir) $ dispatch2 action feedsOK diff --git a/Imm/Core.hs b/Imm/Core.hs --- a/Imm/Core.hs +++ b/Imm/Core.hs @@ -1,11 +1,22 @@ -{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} -module Imm.Core where +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, TypeFamilies #-} +module Imm.Core ( +-- * Types + FeedConfig, + FeedList, +-- * Actions + importOPML, + check, + showStatus, + markAsRead, + markAsUnread, + update, +) where -- {{{ Imports import Imm.Config import Imm.Database import Imm.Error -import Imm.Feed (ImmFeed, FeedParser(..)) +import Imm.Feed (FeedParser(..)) import qualified Imm.Feed as Feed import qualified Imm.HTTP as HTTP import qualified Imm.Maildir as Maildir @@ -14,13 +25,13 @@ import Imm.OPML as OPML import Imm.Util --- import Control.Lens hiding((??)) +import Control.Concurrent.Async import Control.Monad hiding(forM_, mapM_) import Control.Monad.Error hiding(forM_, mapM_) -- import Control.Monad.Reader hiding(forM_, mapM_) --- import Control.Monad.Trans.Control +import Control.Monad.Trans.Control -import Data.Foldable +import Data.Foldable hiding(foldr) import Data.Time as T import Prelude hiding(log, mapM_, sum) @@ -37,20 +48,21 @@ -- }}} -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, MonadPlus m) => String -> m () importOPML = mapM_ addFeeds . OPML.read -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) +check :: (MonadBaseControl IO m, FeedParser m, ConfigReader m, DatabaseReader m, HTTP.Decoder m, MonadError ImmError m) => FeedList -> m () +check feeds = void . liftBaseWith $ \runInIO -> mapConcurrently (runInIO . checkFeed) feeds +checkFeed :: (MonadBase IO m, FeedParser m, ConfigReader m, DatabaseReader m, HTTP.Decoder m, MonadError ImmError m) => FeedConfig -> m () +checkFeed (f, feedID) = localConfig f . localError "imm.core" $ Feed.download feedID >>= Feed.check + +showStatus :: (MonadBase IO m, ConfigReader m, DatabaseReader m, MonadError ImmError m) => FeedConfig -> m () +showStatus (f, feedID) = localConfig f . localError "imm.core" $ (io . noticeM "imm.core" =<< 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 @@ -59,14 +71,16 @@ markAsUnread (f, feedID) = localConfig f . localError "imm.core" $ Feed.markAsUnread 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 +update :: (MonadBaseControl IO m, ConfigReader m, DatabaseState m, MonadError ImmError m, FeedParser m, MailFormatter m, HTTP.Decoder m) => FeedList -> m () +update feeds = void . liftBaseWith $ \runInIO -> mapConcurrently (runInIO . updateFeed) feeds + -- | Write mails for each new item, and update the last check time in state file. -updateFeed :: (Applicative m, ConfigReader m, DatabaseState m, FeedParser m, MailFormatter m, MonadBase IO m, MonadError ImmError m) => ImmFeed -> m () -updateFeed (uri, feed) = do +updateFeed :: (Applicative m, ConfigReader m, DatabaseState m, FeedParser m, MailFormatter m, MonadBase IO m, HTTP.Decoder m, MonadError ImmError m) => FeedConfig -> m () +updateFeed (f, feedID) = localConfig f . localError "imm.core" $ do + -- io . noticeM "imm.core" $ "Updating: " ++ show feedID + (uri, feed) <- Feed.download feedID + Maildir.create =<< readConfig maildir io . debugM "imm.core" $ Feed.describe feed @@ -75,7 +89,7 @@ (results :: [Integer]) <- forM (feedItems feed) $ \item -> do date <- Feed.getDate item (date > lastCheck) ? (updateItem (item, feed) >> return 1) ?? return 0 - io . noticeM "imm.core" $ "==> " ++ show (sum results) ++ " new item(s)" + io . noticeM "imm.core" $ "==> " ++ show (sum results) ++ " new item(s) for <" ++ show feedID ++ ">" Feed.markAsRead uri diff --git a/Imm/Database.hs b/Imm/Database.hs --- a/Imm/Database.hs +++ b/Imm/Database.hs @@ -75,11 +75,12 @@ dataFileGetter <- asks (view getDataFile) let dataFile = dataDirectory dataFileGetter feedUri + io . debugM "imm.database" $ "Reading last check time from: " ++ dataFile 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 + either (const $ io (debugM "imm.database" "Unable to read last update time.") >> return timeZero) return result where timeZero = posixSecondsToUTCTime 0 diff --git a/Imm/Dyre.hs b/Imm/Dyre.hs --- a/Imm/Dyre.hs +++ b/Imm/Dyre.hs @@ -1,4 +1,5 @@ module Imm.Dyre ( + Mode(..), wrap, recompile, ) where @@ -17,7 +18,15 @@ import System.Log.Logger -- }}} +-- | How dynamic reconfiguration process should behave. +-- Default is 'Normal', that is: use custom configuration file and recompile if change detected. +data Mode = Normal | Vanilla | ForceReconfiguration | IgnoreReconfiguration + deriving(Eq, Show) +instance Default Mode where + def = Normal + + nullMain :: a -> IO () nullMain = const $ return () @@ -47,8 +56,8 @@ debugM "imm.dyre" =<< showPaths main x -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 +wrap :: (MonadBaseControl IO m) => Mode -> (a -> m ()) -> a -> m () +wrap mode main args = liftBaseWith $ \runInIO -> wrapMain ((parameters (void . runInIO . main)) { configCheck = (mode /= Vanilla) }) $ Right args -- | Launch a recompilation of the configuration file recompile :: IO (Maybe String) diff --git a/Imm/Feed.hs b/Imm/Feed.hs --- a/Imm/Feed.hs +++ b/Imm/Feed.hs @@ -29,6 +29,9 @@ -- }}} -- {{{ Types +data Action = Check | ShowStatus | MarkAsRead | MarkAsUnread | Update + deriving(Eq, Show) + type ImmFeed = (FeedID, Feed) class FeedParser m where @@ -75,12 +78,12 @@ -- | check :: (FeedParser m, DatabaseReader m, MonadBase IO m, MonadError ImmError m) => ImmFeed -> m () -check (uri, feed) = do - lastCheck <- getLastCheck uri +check (feedID, feed) = do + lastCheck <- getLastCheck feedID (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 . noticeM "imm.feed" $ "==> " ++ show (length newItems) ++ " new item(s) " + io . noticeM "imm.feed" $ show (length newItems) ++ " new item(s) for <" ++ show feedID ++ ">" -- | Simply set the last check time to now. diff --git a/Imm/HTTP.hs b/Imm/HTTP.hs --- a/Imm/HTTP.hs +++ b/Imm/HTTP.hs @@ -30,7 +30,33 @@ instance (Error e, Decoder m) => Decoder (ErrorT e m) where converter = lift converter + +-- | HTTP client +-- data Client = Client { + -- _manager :: Manager, + -- _state :: BrowserState} + +-- makeLenses ''Client + +-- run :: (MonadBase IO m) => ReaderT (IORef Client) m a -> m a +-- run f = do + -- theInput <- newEmptyMVar + -- threadID <- fork worker + -- manager' <- io $ newManager def + -- ref <- io . newIORef $ Client manager' (defaultState manager') + -- result <- runReaderT f ref + -- io $ closeManager manager' + -- return result + +-- worker = do + -- (theOrder, theResultMVar) <- takeMVar order + -- putMVar theResultMVar result + -- result <- work theOrder + -- }}} + +-- getRaw = do + -- putMVar -- | Perform an HTTP GET request and return the response body as raw 'ByteString' getRaw :: (MonadBase IO m, MonadError ImmError m) => URI -> m BL.ByteString diff --git a/Imm/Options.hs b/Imm/Options.hs --- a/Imm/Options.hs +++ b/Imm/Options.hs @@ -3,17 +3,18 @@ module Imm.Options ( CliOptions, action, - configuration, + dyreMode, feedsList, dataDirectory, OptionsReader(..), Action(..), - Configuration(..), run, usage, ) where -- {{{ Imports +import Imm.Dyre as Dyre +import qualified Imm.Feed as Feed import Imm.Util import Control.Lens as L hiding(Action, (??)) @@ -35,26 +36,17 @@ -- {{{ Types -- | Mutually exclusive actions. -- Default is 'PrintHelp'. -data Action = Help | ShowVersion | Recompile | CheckFeeds | ImportFeeds | ListFeeds | MarkAsRead | MarkAsUnread | UpdateFeeds +data Action = Help | ShowVersion | Recompile | Import | Run Feed.Action 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 { _action :: Action, - _configuration :: Configuration, - _dataDirectory :: Maybe FilePath, + _dyreMode :: Dyre.Mode, + _dataDirectory :: Maybe FilePath, _feedsList :: [URI], _logLevel :: Log.Priority, _dyreDebug :: Bool} @@ -65,7 +57,7 @@ instance Show CliOptions where show opts = unwords $ catMaybes [ return . ("ACTION=" ++) . show $ view action opts, - return . ("CONFIGURATION=" ++) . show $ view configuration opts, + return . ("RECONFIGURATION_MODE=" ++) . show $ view dyreMode 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, @@ -73,12 +65,12 @@ instance Default CliOptions where def = CliOptions { - _action = def, - _configuration = def, - _logLevel = Log.INFO, + _action = def, + _dyreMode = def, + _logLevel = Log.INFO, _dataDirectory = Nothing, - _feedsList = [], - _dyreDebug = False} + _feedsList = [], + _dyreDebug = False} -- | 'MonadReader' for 'CliOptions' class OptionsReader m where @@ -102,20 +94,20 @@ description :: [OptDescr (CliOptions -> CliOptions)] description = [ -- 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 "c" ["check"] (NoArg (set action $ Run Feed.Check)) "Check availability and validity of all feed sources currently configured, without writing any mail", + Option "l" ["list"] (NoArg (set action $ Run Feed.ShowStatus)) "List all feed sources currently configured, along with their status", + Option "R" ["mark-read"] (NoArg (set action $ Run Feed.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 $ Run Feed.MarkAsUnread)) "Mark every item of processed feeds as unread, ie delete corresponding state files", + Option "u" ["update"] (NoArg (set action $ Run Feed.Update)) "Update list of feeds (mostly used option)", + Option "i" ["import"] (NoArg (set action Import)) "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", + Option "1" ["vanilla"] (NoArg (set dyreMode Vanilla)) "Do not read custom configuration file", + Option [] ["force-reconf"] (NoArg (set dyreMode ForceReconfiguration)) "Recompile configuration before starting the program", + Option [] ["deny-reconf"] (NoArg (set dyreMode 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", diff --git a/imm.cabal b/imm.cabal --- a/imm.cabal +++ b/imm.cabal @@ -1,5 +1,5 @@ Name: imm -Version: 0.5.1.0 +Version: 0.6.0.0 Synopsis: Retrieve RSS/Atom feeds and write one mail per new item in a maildir. Description: Cf README --Homepage: @@ -38,6 +38,7 @@ Imm.Dyre, Paths_imm Build-depends: + async, base == 4.*, bytestring, case-insensitive,