imm 0.4.0.0 → 0.4.1.0

raw patch · 11 files changed

+109/−141 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Imm/Boot.hs +12/−16
• Imm/Config.hs +4/−3
• Imm/Feed.hs +29/−24
• Imm/HTTP.hs +3/−4
• Imm/Mail.hs +7/−24
• Imm/Maildir.hs +12/−14
• Imm/Main.hs +18/−7
• Imm/OPML.hs +1/−0
• Imm/Types.hs +8/−24
• Imm/Util.hs +14/−24
• imm.cabal +1/−1

@@ -1,4 +1,3 @@--- | Low level functions used at start-up to parse commandline and handle dynamic reconfiguration. module Imm.Boot where  -- {{{ Imports@@ -13,7 +12,6 @@ import System.IO -- }}} --- {{{ Commandline options -- | Available commandline options. cliOptions :: Mode (CmdArgs CliOptions) cliOptions = cmdArgsMode $ baseOptions@@ -24,16 +22,13 @@     &= program "imm"   where     baseOptions = CliOptions {-        --    mCheck         = def &= explicit &= name "c" &= name "check" &= help "Check availability and validity of all feed sources currently configured.",+            mCheck         = def &= explicit &= name "c" &= name "check" &= help "Check availability and validity of all feed sources currently configured, without writing any mail.",             mFeedURI       = def &= explicit &= name "f" &= name "feed"   &= help "Only process given feed." &= typ "URI",             mImportOPML    = def &= explicit &= name "i" &= name "import" &= help "Import feeds list from an OPML descriptor (read from stdin).",             mList          = def &= explicit &= name "l" &= name "list"  &= help "List all feed sources currently configured, along with their status.",             mMarkAsRead    = def &= explicit &= name "R" &= name "mark-read" &= help "Mark every item of processed feeds as read, ie set last update as now without writing any mail.",             mMarkAsUnread  = def &= explicit &= name "U" &= name "mark-unread" &= help "Mark every item of processed feeds as unread, ie delete corresponding state files.",-            mUpdate        = def &= explicit &= name "u" &= name "update" &= help "Update list of feeds (mostly used option).",-            mDenyReconf    = def &= explicit &= name "deny-reconf"       &= help "Deny recompilation even if the configuration file has changed.",-            mMasterBinary  = def &= explicit &= name "dyre-master-binary" &= help "Flag used internally for dynamic reconfiguration purposes." &= typ "PATH"}--- }}}+            mUpdate        = def &= explicit &= name "u" &= name "update" &= help "Update list of feeds (mostly used option)."}  -- {{{ Dynamic reconfiguration -- | Print various paths used for dynamic reconfiguration.@@ -47,7 +42,7 @@         "Cache directory: " ++ d,         "Lib directory:   " ++ e, []] --- | Dynamic configuration settings.+-- | Dynamic reconfiguration settings. dyreParameters :: D.Params (Either String FeedList) dyreParameters = D.defaultParams {   D.projectName  = "imm",@@ -61,7 +56,7 @@ showError _ = Left -- }}} --- | Main function to call in your configuration file.+-- | Main function to call in the configuration file. imm :: FeedList -> IO () imm = D.wrapMain dyreParameters . Right @@ -69,19 +64,20 @@ realMain :: Either String FeedList -> IO () realMain (Left e) = putStrLn e realMain (Right feeds) = do-    options <- cmdArgsRun cliOptions     whenLoud printDyrePaths+    options <- cmdArgsRun cliOptions+     let feeds' = case (mFeedURI options) of           Just uri -> filter (\(_, u) -> u == uri) feeds           _        -> feeds+     realMain' (feeds', options)   where     realMain' (f, options)-      | mImportOPML options   = Main.importOPML-      | mList       options   = Main.list f-      | mMarkAsRead options   = Main.markAsRead f+      | mCheck        options = Main.check f+      | mImportOPML   options = Main.importOPML+      | mList         options = Main.list f+      | mMarkAsRead   options = Main.markAsRead f       | mMarkAsUnread options = Main.markAsUnread f---      | mCheck options = Main.check f-      | mUpdate     options   = Main.update f+      | mUpdate       options = Main.update f       | otherwise             = print $ helpText [] HelpFormatDefault cliOptions--- }}}

@@ -13,7 +13,8 @@ import Data.Foldable hiding(concat) import qualified Data.Text.Lazy as T -import System.FilePath+import System.Directory+import System.Environment.XDG.BaseDir  import Text.Feed.Query -- }}}@@ -21,8 +22,8 @@  instance Default Settings where     def = Settings {-        mStateDirectory = (</> "state") . mConfiguration,-        mMaildir        = (</> "feeds") . mHome,+        mStateDirectory = getUserConfigDir "imm" >/> "state",+        mMaildir        = getHomeDirectory >/> "feeds",         mFromBuilder    = \(item, feed) -> maybe (getFeedTitle feed) id $ getItemAuthor item,         mSubjectBuilder = \(item, _feed) -> T.pack . maybe "Untitled" id $ getItemTitle item,         mBodyBuilder    = \(item, _feed) -> T.unlines $ map (flip ($) item) [T.pack . getItemLinkNM, getItemContent]}

@@ -8,11 +8,12 @@ import Imm.Types import Imm.Util +import Control.Applicative import Control.Conditional hiding(when) import Control.Monad.Error import Control.Monad.Reader hiding(when) ---import Data.Functor+import Data.Either import qualified Data.Text.Lazy as T import Data.Time hiding(parseTime) import Data.Time.Clock.POSIX@@ -20,7 +21,7 @@ import Network.URI as N  import System.Directory-import System.FilePath+--import System.FilePath import System.IO import System.Locale @@ -47,21 +48,18 @@ parse x = maybe (throwError $ ParseFeedError x) return $ parseFeedString x  -- | -printStatus :: (MonadReader Settings m, MonadIO m) => String -> m ()-printStatus feedUri = do-    prefix <- case N.parseURI feedUri of-        Just uri -> do-          lastCheck <- getLastCheck uri-          return $ (lastCheck == posixSecondsToUTCTime 0) ? "[NEW] " ?? ("[Last update: "++ show lastCheck ++ "]")-        _ -> return "[Not an URI]"-    io . putStrLn $ prefix ++ " " ++ feedUri+printStatus :: (MonadReader Settings m, MonadIO m) => URI -> m ()+printStatus uri = do+    lastCheck <- getLastCheck uri+    let prefix = (lastCheck == posixSecondsToUTCTime 0) ? "[NEW] " ?? ("[Last update: "++ show lastCheck ++ "]")+    io . putStrLn $ prefix ++ " " ++ show uri   getLastCheck :: (MonadReader Settings m, MonadIO m) => URI -> m UTCTime getLastCheck feedUri = do-    directory <- asks mStateDirectory >>= resolve+    directory <- asks mStateDirectory     result    <- runErrorT $ do-        content <- try $ readFile (directory </> fileName)+        content <- try $ readFile =<< (directory >/> fileName)         parseTime content              either (const $ return timeZero) return result@@ -72,12 +70,12 @@  storeLastCheck :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => URI -> UTCTime -> m () storeLastCheck feedUri date = do-    directory <- asks mStateDirectory >>= resolve+    directory <- asks mStateDirectory     -    (file, stream) <- try $ openTempFile directory fileName+    (file, stream) <- try $ (`openTempFile` fileName) =<< directory     io $ hPutStrLn stream (formatTime defaultTimeLocale "%c" date)     io $ hClose stream-    try $ renameFile file (directory </> fileName)+    try $ renameFile file =<< (directory >/> fileName)   where     fileName = getStateFile feedUri @@ -86,10 +84,17 @@     feed <- parse . T.unpack =<< decode =<< HTTP.getRaw uri     return (uri, feed) +-- | +check :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => ImmFeed -> m ()+check (uri, feed) = do+    lastCheck <- getLastCheck uri+    dates     <- return . rights =<< forM (feedItems feed) (runErrorT . getDate)+    let newItems = filter (> lastCheck) dates+    io . putStrLn $ "==> " ++ show (length newItems) ++ " new item(s) "+ -- | Create mails for each new item-update :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => ImmFeed -> m ()+update :: (Applicative m, MonadReader Settings m, MonadIO m, MonadError ImmError m) => ImmFeed -> m () update (uri, feed) = do-    logNormal $ "Updating feed " ++ show uri --    checkStateDirectory     Maildir.init =<< asks mMaildir @@ -99,15 +104,15 @@         "Home:   " ++ (maybe "No home"   id $ getFeedHome feed)]          lastCheck <- getLastCheck uri-    forM_ (feedItems feed) $ \item -> +    results <- forM (feedItems feed) $ \item ->        do         date <- getDate item-        when (date > lastCheck) $ updateItem (item, feed)-      `catchError` (io . print)-+        (date > lastCheck) ? (updateItem (item, feed) >> return 1) ?? return 0+      `catchError` (\e -> (io . print) e >> return 0 )+    io . putStrLn $ "==> " ++ show (sum results) ++ " new item(s)"     markAsRead uri -updateItem :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => (Item, Feed) -> m ()+updateItem :: (Applicative m, MonadReader Settings m, MonadIO m, MonadError ImmError m) => (Item, Feed) -> m () updateItem (item, feed) = do     date <- getDate item     logVerbose $ unlines [@@ -127,8 +132,8 @@  markAsUnread :: forall (m :: * -> *) . (MonadIO m, MonadError ImmError m, MonadReader Settings m) => URI -> m () markAsUnread uri = do-    directory <- asks mStateDirectory >>= resolve-    try $ removeFile $ directory </> (getStateFile uri)+    directory <- asks mStateDirectory+    try $ removeFile =<< directory >/> (getStateFile uri)     logVerbose $ "Feed " ++ show uri ++ " marked as unread."      

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, KindSignatures #-}--- | HTTP client related functions module Imm.HTTP where  -- {{{ Imports@@ -20,7 +19,7 @@ import Prelude hiding(catch) -- }}} -+-- | Perform an HTTP GET request and return the response body as raw 'ByteString' getRaw :: (MonadIO m, MonadError ImmError m) => URI -> m BL.ByteString getRaw uri = do     logVerbose $ "Downloading " ++ show uri@@ -29,7 +28,7 @@     return $ responseBody res  --- | Monad-agnostic version of 'withManager+-- | Monad-agnostic version of 'withManager' withManager' f = do     res <- timeout 11000000 $ (Right <$> withManager f) `catch` (return . Left . IOE) `catch` (return . Left . HTTPError) `catch` (return . Left . TLSError)     either throwError return res@@ -41,7 +40,7 @@     either throwError return result      --- | Build an HTTP request for given URI.+-- | Build an HTTP request for given URI request :: (MonadError ImmError m, MonadIO m) => String -> m (Request a) request uri = do     req <- parseURL uri

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}--- | Utilities to manipulate mails. module Imm.Mail where  -- {{{ Imports@@ -7,6 +6,7 @@ import Imm.Types import Imm.Util +import Control.Applicative import Control.Monad import Control.Monad.Reader @@ -31,6 +31,7 @@         mSubject            = T.pack "Untitled",         mReturnPath         = "<imm@noreply>"} + toText :: Mail -> T.Text toText mail = T.unlines [     T.pack $ "Return-Path: " ++ mReturnPath mail,@@ -42,30 +43,12 @@     T.pack "",     mBody mail]  --build :: MonadReader Settings m => TimeZone -> (Item, Feed) -> m Mail+-- | Build mail from a given feed, using builders functions from 'Settings'.+build :: (Applicative m, MonadReader Settings m) => TimeZone -> (Item, Feed) -> m Mail build timeZone (item, feed) = do-    from    <- buildFrom    (item, feed)-    subject <- buildSubject (item, feed)-    body    <- buildBody    (item, feed)+    from    <- asks mFromBuilder    <*> return (item, feed)+    subject <- asks mSubjectBuilder <*> return (item, feed)+    body    <- asks mBodyBuilder    <*> return (item, feed)     return def {mDate = date, mFrom = from, mSubject = subject, mBody = body}   where     date = maybe Nothing (Just . utcToZonedTime timeZone) . parseDate <=< F.getItemDate $ item---buildFrom :: MonadReader Settings m => (Item, Feed) -> m String-buildFrom (item, feed) = do-    builder <- asks mFromBuilder-    return $ builder (item, feed)---buildSubject :: MonadReader Settings m => (Item, Feed) -> m T.Text-buildSubject (item, feed) = do-    builder <- asks mSubjectBuilder-    return $ builder (item, feed)---buildBody :: MonadReader Settings m => (Item, Feed) -> m T.Text-buildBody (item, feed) = do-    builder <- asks mBodyBuilder-    return $ builder (item, feed)

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}--- | Utilities to manipulate maildirs. module Imm.Maildir where  -- {{{ Imports@@ -17,26 +16,26 @@ import Network.BSD  import System.Directory-import System.FilePath+--import System.FilePath import System.Random -- }}} -init :: (MonadIO m, MonadError ImmError m) => PortableFilePath -> m ()+-- | Build a maildir with subdirectories cur, new and tmp.+init :: (MonadIO m, MonadError ImmError m) => IO FilePath -> m () init directory = do-    dir <- io $ resolve directory-    try $ createDirectoryIfMissing True dir-    try $ createDirectoryIfMissing True (dir </> "cur")-    try $ createDirectoryIfMissing True (dir </> "new")-    try $ createDirectoryIfMissing True (dir </> "tmp")-+    try $ createDirectoryIfMissing True =<< directory+    try $ createDirectoryIfMissing True =<< (directory >/> "cur")+    try $ createDirectoryIfMissing True =<< (directory >/> "new")+    try $ createDirectoryIfMissing True =<< (directory >/> "tmp") -add :: (MonadIO m, MonadError ImmError m) => PortableFilePath -> Mail -> m ()+-- | Add a mail to the maildir+add :: (MonadIO m, MonadError ImmError m) => IO FilePath -> Mail -> m () add directory mail = do-    dir      <- resolve directory     fileName <- io getUniqueName-    try $ T.writeFile (dir </> "new" </> fileName) (toText mail)-+    dir      <- directory >/> "new" >/> fileName +    try $ T.writeFile dir (toText mail) +-- | Return an allegedly unique filename; useful to add new mail files in a maildir. getUniqueName :: MonadIO m => m String  getUniqueName = io $ do     time     <- show <$> getPOSIXTime@@ -44,4 +43,3 @@     rand     <- show <$> (getStdRandom $ randomR (1,100000) :: IO Int)          return . concat $ [time, ".", rand, ".", hostname]-

@@ -1,10 +1,9 @@ {-# LANGUAGE FlexibleContexts #-}--- | Main high level process functions. module Imm.Main where  -- {{{ Imports import Imm.Config-import Imm.Feed as Feed+import qualified Imm.Feed as Feed import Imm.OPML as OPML import Imm.Types import Imm.Util@@ -24,26 +23,38 @@ -- }}}  +check :: (MonadIO m) => FeedList -> m ()+check feeds = io . forM_ feeds $ \(f, u) -> do    +    result <- runErrorT . (`runReaderT` (f def)) $ do+        logNormal $ "Checking: " ++ u+        Feed.check =<< Feed.download =<< parseURI u+    either print return result++ importOPML :: (MonadIO m) => m ()-importOPML = io $ (maybe (return ()) addFeeds) =<< OPML.read <$> hGetContents stdin+importOPML = io $ mapM_ addFeeds =<< OPML.read <$> hGetContents stdin + list :: (MonadIO m) => FeedList -> m ()-list = io . mapM_ (\(f, u) -> runReaderT (printStatus u) (f def))+list = io . mapM_ (\(f, u) -> runReaderT (runErrorT $ parseURI u >>= Feed.printStatus) (f def)) + markAsRead :: (MonadIO m) => FeedList -> m () markAsRead = mapM_ (\(f,u) -> runReaderT (runErrorT $ checkStateDirectory >> parseURI u >>= Feed.markAsRead) (f def)) + markAsUnread :: (MonadIO m) => FeedList -> m () markAsUnread = mapM_ (\(f,u) -> runReaderT (runErrorT $ parseURI u >>= Feed.markAsUnread) (f def)) + update :: (MonadIO m) => FeedList -> m () update feeds = io . forM_ feeds $ \(f, u) -> do     result <- runErrorT . (`runReaderT` (f def)) $ do-        feed <- Feed.download =<< parseURI u+        logNormal $ "Updating: " ++ u         checkStateDirectory-        Feed.update feed+        Feed.update =<< Feed.download =<< parseURI u     either print return result   checkStateDirectory :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => m ()-checkStateDirectory = asks mStateDirectory >>= resolve >>= try . io . createDirectoryIfMissing True+checkStateDirectory = try . io . (createDirectoryIfMissing True =<<) =<< asks mStateDirectory

@@ -6,6 +6,7 @@ import Text.XML.Light.Types -- }}} +-- | Parse an OPML string and return a list of feed groups read :: String -> Maybe [(String, [String])] read rawOPML = do     opml <- parseOPMLString rawOPML

@@ -27,7 +27,6 @@ -- }}}  -- {{{ Error handling--- | Errors that can be returned by an Imm process data ImmError =      OtherError         String   | HTTPError          HttpException@@ -65,28 +64,25 @@ -- }}}  -- {{{ Settings type+-- | Available commandline options (cf imm -h) data CliOptions = CliOptions {---    mCheck        :: Bool,+    mCheck        :: Bool,     mFeedURI      :: Maybe String,     mImportOPML   :: Bool,     mList         :: Bool,     mMarkAsRead   :: Bool,     mMarkAsUnread :: Bool,-    mUpdate       :: Bool,-    mDenyReconf   :: Bool,         -- ^ Do not recompile configuration even if it has changed-    mMasterBinary :: Maybe String+    mUpdate       :: Bool } deriving (Data, Typeable, Show, Eq) --- | Set of settings for imm data Settings = Settings {-    mStateDirectory :: PortableFilePath,-    mMaildir        :: PortableFilePath,-    mFromBuilder    :: (Item, Feed) -> String,-    mSubjectBuilder :: (Item, Feed) -> TL.Text,-    mBodyBuilder    :: (Item, Feed) -> TL.Text   -- ^ sic!+    mStateDirectory :: IO FilePath,              -- ^ Where feeds' state (last update time) will be stored+    mMaildir        :: IO FilePath,              -- ^ Where mails will be written+    mFromBuilder    :: (Item, Feed) -> String,   -- ^ Called to write the From: header of feed mails+    mSubjectBuilder :: (Item, Feed) -> TL.Text,  -- ^ Called to write the Subject: header of feed mails+    mBodyBuilder    :: (Item, Feed) -> TL.Text   -- ^ Called to write the body of feed mails (sic!) } --- |  type CustomSettings = Settings -> Settings -- }}} @@ -105,15 +101,3 @@     mContentDisposition :: String,     mBody               :: TL.Text }---- {{{ Generic file paths--- | Set of reference directories, typically used to build FilePath-s-data RefDirs = RefDirs {-    mHome          :: FilePath,        -- ^ Home directory-    mTemporary     :: FilePath,        -- ^ Temporary files directory-    mConfiguration :: FilePath,        -- ^ Configuration directory-    mData          :: FilePath         -- ^ Data directory-}--type PortableFilePath = RefDirs -> FilePath--- }}}

@@ -1,7 +1,4 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}--- | Various utilities+{-# LANGUAGE NoMonomorphismRestriction, RankNTypes, FlexibleContexts #-} module Imm.Util where  -- {{{ Imports@@ -13,6 +10,7 @@  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL+import Data.Functor import Data.Maybe import Data.Text.ICU.Convert import Data.Text.Lazy.Encoding hiding(decodeUtf8)@@ -24,13 +22,17 @@ import Network.URI as N  import System.Console.CmdArgs-import System.Directory-import System.Environment.XDG.BaseDir+import System.FilePath import System.IO import System.Locale import System.Timeout as S -- }}} ++-- | Like '(</>)' with first argument in IO to build platform-dependent paths.+(>/>) :: (MonadIO m) => IO FilePath -> FilePath -> m FilePath+(>/>) a b = io $ (</> b) <$> a+ -- {{{ Monadic utilities -- | Shortcut to 'liftIO' io :: MonadIO m => IO a -> m a@@ -51,37 +53,25 @@ logNormal  = io . whenNormal . putStrLn logVerbose = io . whenLoud . putStrLn --- | Evaluate given function while replacing directory variables appropriately for the current system-resolve :: MonadIO m => (RefDirs -> a) -> m a-resolve f = io $ do-    homeDir   <- getHomeDirectory-    tmpDir    <- getTemporaryDirectory-    configDir <- getUserConfigDir "imm"-    dataDir   <- getUserDataDir   "imm"-    -    return . f $ RefDirs homeDir tmpDir configDir dataDir  -- {{{ Monad-agnostic version of various error-prone functions -- | Monad-agnostic version of Data.Text.Encoding.decodeUtf8 decodeUtf8 :: MonadError ImmError m => BL.ByteString -> m TL.Text decodeUtf8 = either (throwError . UnicodeError) return . decodeUtf8' -decode :: (MonadIO m, MonadError ImmError m) => BL.ByteString -> m TL.Text-decode raw = do-    catchError (decodeUtf8 raw) $ return $ do-        conv <- io $ open "ISO-8859-1" Nothing-        return . TL.fromChunks . (\a -> [a]) . toUnicode conv . B.concat . BL.toChunks $ raw----- | Monad-agnostic version of Network.URI.parseURI+-- | 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+-- | 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 -- }}} +decode :: (MonadIO m, MonadError ImmError m) => BL.ByteString -> m TL.Text+decode raw = catchError (decodeUtf8 raw) $ return $ do+    conv <- io $ open "ISO-8859-1" Nothing+    return . TL.fromChunks . (\a -> [a]) . toUnicode conv . B.concat . BL.toChunks $ raw  parseDate :: String -> Maybe UTCTime parseDate date = listToMaybe . map T.zonedTimeToUTC . catMaybes . flip map [readRFC2822, readRFC3339, T.parseTime defaultTimeLocale "%a, %d %b %G %T", T.parseTime defaultTimeLocale "%Y-%m-%d", T.parseTime defaultTimeLocale "%e %b %Y", T.parseTime defaultTimeLocale "%a, %e %b %Y %k:%M:%S %z", T.parseTime defaultTimeLocale "%a, %e %b %Y %T %Z"] $ \f -> f . TL.unpack . TL.strip . TL.pack $ date

@@ -1,5 +1,5 @@ Name:                imm-Version:             0.4.0.0+Version:             0.4.1.0 Synopsis:            Retrieve RSS/Atom feeds and write one mail per new item in a maildir. --Description:          --Homepage: