imm 0.3.0.0 → 0.4.0.0

raw patch · 12 files changed

+346/−225 lines, 12 filesdep +case-insensitivedep +data-defaultdep +http-conduitdep −HTTPPVP ok

version bump matches the API change (PVP)

Dependencies added: case-insensitive, data-default, http-conduit, http-types, opml, text-icu, tls

Dependencies removed: HTTP

API changes (from Hackage documentation)

Files

• Imm/Boot.hs +41/−27
• Imm/Config.hs +24/−13
• Imm/Executable.hs +1/−2
• Imm/Feed.hs +84/−14
• Imm/HTTP.hs +50/−0
• Imm/Mail.hs +13/−12
• Imm/Maildir.hs +1/−1
• Imm/Main.hs +24/−98
• Imm/OPML.hs +17/−0
• Imm/Types.hs +48/−30
• Imm/Util.hs +32/−25
• imm.cabal +11/−3

@@ -1,39 +1,42 @@+-- | Low level functions used at start-up to parse commandline and handle dynamic reconfiguration. module Imm.Boot where  -- {{{ Imports-import Imm.Main+import qualified Imm.Main as Main import Imm.Types  import qualified Config.Dyre as D import Config.Dyre.Paths -import Control.Monad.Error-import Control.Monad.Reader- import System.Console.CmdArgs+import System.Console.CmdArgs.Explicit import System.IO -- }}}  -- {{{ Commandline options--- | Available commandline options-cliOptions :: CliOptions-cliOptions = CliOptions {-    mCheck         = def &= explicit &= name "c" &= name "check" &= help "Check availability and validity of all feed sources currently configured.",-    mList          = def &= explicit &= name "l" &= name "list"  &= help "List all feed sources currently configured.",-    mDenyReconf    = def &= explicit &= name "deny-reconf"       &= help "Deny recompilation even if the configuration file has changed.",-    mMasterBinary  = def &= explicit &= name "dyre-master-binary"-}--getOptions :: IO CliOptions-getOptions = cmdArgs $ cliOptions+-- | Available commandline options.+cliOptions :: Mode (CmdArgs CliOptions)+cliOptions = cmdArgsMode $ baseOptions     &= verbosityArgs [explicit, name "verbose", name "v"] []     &= versionArg [ignore]     &= help "Convert items from RSS/Atom feeds to maildir entries."     &= helpArg [explicit, name "help", name "h"]     &= program "imm"+  where+    baseOptions = CliOptions {+        --    mCheck         = def &= explicit &= name "c" &= name "check" &= help "Check availability and validity of all feed sources currently configured.",+            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"} -- }}}  -- {{{ Dynamic reconfiguration+-- | Print various paths used for dynamic reconfiguration. printDyrePaths :: IO () printDyrePaths = do     (a, b, c, d, e) <- getPaths dyreParameters@@ -44,7 +47,8 @@         "Cache directory: " ++ d,         "Lib directory:   " ++ e, []] -dyreParameters :: D.Params (Either String (Settings, CliOptions))+-- | Dynamic configuration settings.+dyreParameters :: D.Params (Either String FeedList) dyreParameters = D.defaultParams {   D.projectName  = "imm",   D.showError    = showError,@@ -57,17 +61,27 @@ showError _ = Left -- }}} --- | Main function to call.-imm :: Settings -> IO ()-imm settings = do-    options <- getOptions-    D.wrapMain dyreParameters (Right (settings, options))+-- | Main function to call in your configuration file.+imm :: FeedList -> IO ()+imm = D.wrapMain dyreParameters . Right --- Main dispatcher, depending on commandline options-realMain :: Either String (Settings, CliOptions) -> IO ()+-- | Internal dispatcher, decides which function to execute depending on commandline options.+realMain :: Either String FeedList -> IO () realMain (Left e) = putStrLn e-realMain (Right (settings, options))-  | mList  options = mapM_ (flip runReaderT settings . printFeedGroupStatus) $ mFeedGroups settings-  | mCheck options = mapM_ (flip runReaderT settings . checkFeedGroup) $ mFeedGroups settings-  | otherwise      = whenLoud printDyrePaths >> runErrorT (runReaderT main settings) >>= either print return+realMain (Right feeds) = do+    options <- cmdArgsRun cliOptions+    whenLoud printDyrePaths+    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+      | mMarkAsUnread options = Main.markAsUnread f+--      | mCheck options = Main.check f+      | mUpdate     options   = Main.update f+      | otherwise             = print $ helpText [] HelpFormatDefault cliOptions -- }}}

@@ -1,27 +1,38 @@+-- | Default settings module Imm.Config where  -- {{{ Imports import Imm.Feed import Imm.Types+import Imm.Util +import Control.Monad.Trans++import Data.Char+import Data.Default+import Data.Foldable hiding(concat) import qualified Data.Text.Lazy as T  import System.FilePath  import Text.Feed.Query-import Text.Feed.Types -- }}} --- | Default configuration.-defaultSettings :: Settings-defaultSettings = Settings {-    mStateDirectory = (</> "state") . mConfiguration,-    mFeedGroups     = [],-    mFromBuilder    = \(item, feed) -> maybe (getFeedTitle feed) id $ getItemAuthor item,-    mSubjectBuilder = \(item, _feed) -> T.pack . maybe "Untitled" id $ getItemTitle item,-    mBodyBuilder    = \(item, _feed) -> contentBuilder item-} -contentBuilder :: Item -> T.Text-contentBuilder item = -    T.unlines $ map (flip ($) item) [T.pack . getItemLinkNM, getItemContent]+instance Default Settings where+    def = Settings {+        mStateDirectory = (</> "state") . mConfiguration,+        mMaildir        = (</> "feeds") . mHome,+        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]}+++addFeeds :: MonadIO m => [(String, [String])] -> m ()+addFeeds feeds = io . forM_ feeds $ \(groupTitle, uris) -> do+    putStrLn $ "-- Group " ++ groupTitle+    putStrLn $ map toLower (concat . words $ groupTitle) ++ " = ["+    forM_ uris (\uri -> putStrLn $ "    " ++ show uri ++ ",")+    putStrLn "]"+    putStrLn ""+    

@@ -1,8 +1,7 @@ --module Executable where  import Imm.Boot-import Imm.Config --import Imm.Types  main :: IO ()-main = imm defaultSettings+main = imm []

@@ -1,28 +1,33 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, RankNTypes, KindSignatures #-} module Imm.Feed where  -- {{{ Imports+import qualified Imm.HTTP as HTTP+import qualified Imm.Mail as Mail+import qualified Imm.Maildir as Maildir import Imm.Types import Imm.Util +import Control.Conditional hiding(when) import Control.Monad.Error-import Control.Monad.Reader+import Control.Monad.Reader hiding(when)  --import Data.Functor import qualified Data.Text.Lazy as T import Data.Time hiding(parseTime) import Data.Time.Clock.POSIX -import Network.URI+import Network.URI as N  import System.Directory import System.FilePath import System.IO import System.Locale -import Text.Atom.Feed hiding(URI)+import qualified Text.Atom.Feed as Atom+import Text.Feed.Import as F import Text.Feed.Query as F-import Text.Feed.Types+import Text.Feed.Types as F import Text.XML.Light.Proc -- }}} @@ -37,7 +42,21 @@ toFileName x = [x] -- }}} +-- | Monad-agnostic version of 'Text.Feed.Import.parseFeedString'+parse :: MonadError ImmError m => String -> m Feed+parse x = maybe (throwError $ ParseFeedError x) return $ parseFeedString x +-- | +printStatus :: (MonadReader Settings m, MonadIO m) => 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++ getLastCheck :: (MonadReader Settings m, MonadIO m) => URI -> m UTCTime getLastCheck feedUri = do     directory <- asks mStateDirectory >>= resolve@@ -61,27 +80,78 @@     try $ renameFile file (directory </> fileName)   where     fileName = getStateFile feedUri++download :: (MonadIO m, MonadError ImmError m) => URI -> m ImmFeed+download uri = do+    feed <- parse . T.unpack =<< decode =<< HTTP.getRaw uri+    return (uri, feed)++-- | Create mails for each new item+update :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => ImmFeed -> m ()+update (uri, feed) = do+    logNormal $ "Updating feed " ++ show uri+--    checkStateDirectory+    Maildir.init =<< asks mMaildir++    logVerbose $ unlines [+        "Title:  " ++ (getFeedTitle feed),+        "Author: " ++ (maybe "No author" id $ getFeedAuthor feed),+        "Home:   " ++ (maybe "No home"   id $ getFeedHome feed)]     +    lastCheck <- getLastCheck uri+    forM_ (feedItems feed) $ \item -> +      do+        date <- getDate item+        when (date > lastCheck) $ updateItem (item, feed)+      `catchError` (io . print)++    markAsRead uri++updateItem :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => (Item, Feed) -> m ()+updateItem (item, feed) = do+    date <- getDate item+    logVerbose $ unlines [+            "   Item author: " ++ (maybe "<empty>" id $ getItemAuthor item),+            "   Item title:  " ++ (maybe "<empty>" id $ getItemTitle item),+            "   Item URI:    " ++ (maybe "<empty>" id $ getItemLink  item),+            -- "   Item Body:   " ++ (Imm.Mail.getItemContent  item),+            "   Item date:   " ++ show date]+    +    timeZone <- io getCurrentTimeZone+    dir      <- asks mMaildir+    Maildir.add dir =<< Mail.build timeZone (item, feed)+++markAsRead :: forall (m :: * -> *) . (MonadIO m, MonadError ImmError m, MonadReader Settings m) => URI -> m ()+markAsRead uri = io getCurrentTime >>= storeLastCheck uri >> (logVerbose $ "Feed " ++ show uri ++ " marked as read.")++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)+    logVerbose $ "Feed " ++ show uri ++ " marked as unread."+    + -- {{{ Item utilities getItemLinkNM :: Item -> String  getItemLinkNM item = maybe "No link found" paragraphy  $ getItemLink item   getItemContent :: Item -> T.Text-getItemContent (AtomItem e) = T.pack . maybe "No content" extractHtml . entryContent $ e+getItemContent (AtomItem e) = T.pack . maybe "No content" extractHtml . Atom.entryContent $ e getItemContent item = T.pack . maybe "Empty" id . getItemDescription $ item -getItemDate :: MonadError ImmError m => Item -> m UTCTime-getItemDate x = maybe (throwError $ ParseItemDateError x) return $ parseDate =<< F.getItemDate x+getDate :: MonadError ImmError m => Item -> m UTCTime+getDate x = maybe (throwError $ ParseItemDateError x) return $ parseDate =<< F.getItemDate x -- }}}  -extractHtml :: EntryContent -> String-extractHtml (HTMLContent c) = c-extractHtml (XHTMLContent c) = strContent c-extractHtml (TextContent t) = t-extractHtml (MixedContent a b)= show a ++ show b-extractHtml (ExternalContent mediaType uri) = show mediaType ++ show uri+extractHtml :: Atom.EntryContent -> String+extractHtml (Atom.HTMLContent c) = c+extractHtml (Atom.XHTMLContent c) = strContent c+extractHtml (Atom.TextContent t) = t+extractHtml (Atom.MixedContent a b) = show a ++ show b+extractHtml (Atom.ExternalContent mediaType uri) = show mediaType ++ show uri   paragraphy :: String -> String

@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, KindSignatures #-}+-- | HTTP client related functions+module Imm.HTTP where++-- {{{ Imports+import Imm.Types+import Imm.Util as U++import Control.Exception as E+import Control.Monad.Error hiding(forM_, mapM_)++import Data.ByteString.Lazy as BL+import Data.ByteString.Char8 as BC+import Data.CaseInsensitive+import Data.Functor++import Network.HTTP.Conduit as H+import Network.URI++import Prelude hiding(catch)+-- }}}+++getRaw :: (MonadIO m, MonadError ImmError m) => URI -> m BL.ByteString+getRaw uri = do+    logVerbose $ "Downloading " ++ show uri+    req <- request $ show uri+    res <- withManager' (httpLbs req)+    return $ responseBody res+++-- | Monad-agnostic version of 'withManager+withManager' f = do+    res <- timeout 11000000 $ (Right <$> withManager f) `catch` (return . Left . IOE) `catch` (return . Left . HTTPError) `catch` (return . Left . TLSError)+    either throwError return res++-- | Monad-agnostic version of 'parseUrl'+parseURL :: forall (m :: * -> *) (m' :: * -> *) . (MonadIO m, MonadError ImmError m) => String -> m (Request m')+parseURL uri = do+    result <- io $ (Right <$> parseUrl uri) `catch` (return . Left . HTTPError)+    either throwError return result+    ++-- | Build an HTTP request for given URI.+request :: (MonadError ImmError m, MonadIO m) => String -> m (Request a)+request uri = do+    req <- parseURL uri+    return $ req { requestHeaders = [+        (mk $ BC.pack "User-Agent", BC.pack "Mozilla/4.0"),+        (mk $ BC.pack "Accept", BC.pack "*/*")]}

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+-- | Utilities to manipulate mails. module Imm.Mail where  -- {{{ Imports@@ -9,6 +10,7 @@ import Control.Monad import Control.Monad.Reader +import Data.Default import qualified Data.Text.Lazy as T import Data.Time import Data.Time.RFC2822@@ -18,17 +20,16 @@ -- }}}  -bare :: Mail-bare = Mail {-    mCharset            = "utf-8",-    mBody               = T.pack "",-    mContentDisposition = "inline",-    mDate               = Nothing,-    mFrom               = "imm",-    mMIME               = "text/html",-    mSubject            = T.pack "Untitled",-    mReturnPath         = "<imm@noreply>"}-+instance Default Mail where+    def = Mail {+        mCharset            = "utf-8",+        mBody               = T.pack "",+        mContentDisposition = "inline",+        mDate               = Nothing,+        mFrom               = "imm",+        mMIME               = "text/html",+        mSubject            = T.pack "Untitled",+        mReturnPath         = "<imm@noreply>"}  toText :: Mail -> T.Text toText mail = T.unlines [@@ -47,7 +48,7 @@     from    <- buildFrom    (item, feed)     subject <- buildSubject (item, feed)     body    <- buildBody    (item, feed)-    return bare {mDate = date, mFrom = from, mSubject = subject, mBody = body}+    return def {mDate = date, mFrom = from, mSubject = subject, mBody = body}   where     date = maybe Nothing (Just . utcToZonedTime timeZone) . parseDate <=< F.getItemDate $ item 

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+-- | Utilities to manipulate maildirs. module Imm.Maildir where  -- {{{ Imports@@ -27,7 +28,6 @@     try $ createDirectoryIfMissing True (dir </> "cur")     try $ createDirectoryIfMissing True (dir </> "new")     try $ createDirectoryIfMissing True (dir </> "tmp")-    logVerbose $ "Maildir correctly created at: " ++ dir   add :: (MonadIO m, MonadError ImmError m) => PortableFilePath -> Mail -> m ()

@@ -1,123 +1,49 @@ {-# LANGUAGE FlexibleContexts #-}+-- | Main high level process functions. module Imm.Main where  -- {{{ Imports-import Imm.Feed-import qualified Imm.Mail as Mail-import qualified Imm.Maildir as Maildir+import Imm.Config+import Imm.Feed as Feed+import Imm.OPML as OPML import Imm.Types import Imm.Util -import Control.Conditional hiding(when) import Control.Monad hiding(forM_, mapM_) import Control.Monad.Error hiding(forM_, mapM_) import Control.Monad.Reader hiding(forM_, mapM_) -import qualified Data.ByteString.Lazy as B-import qualified Data.Text.Lazy as T-import Data.Either+import Data.Default import Data.Foldable---import Data.Functor-import Data.Time-import Data.Time.Clock.POSIX--import Network.Browser hiding(request)-import Network.HTTP-import Network.URI hiding(parseURI)+import Data.Functor  import Prelude hiding(mapM_)  import System.Directory----import Text.Feed.Import-import Text.Feed.Query hiding(getItemDate)-import Text.Feed.Types+import System.IO -- }}} --- {{{ Quick actions performed for specific commandline options-printFeedGroupStatus :: (MonadReader Settings m, MonadIO m) => FeedGroup -> m ()-printFeedGroupStatus (settings, feeds) = do-    maildir <- resolve $ mMaildir settings-    io . putStrLn $ " => Feed group " ++ maildir-    mapM_ printFeedStatus feeds -printFeedStatus :: (MonadReader Settings m, MonadIO m) => String -> m ()-printFeedStatus feedUri = do-    prefix <- case parseURI feedUri of-        Right uri -> do-          lastCheck <- getLastCheck uri-          return $ (lastCheck == posixSecondsToUTCTime 0) ? "[NEW] " ?? ("[Last update: "++ show lastCheck ++ "]")-        _ -> return "[Not an URI]"-    io . putStrLn $ prefix ++ " " ++ feedUri--   -checkFeedGroup :: (MonadReader Settings m, MonadIO m) => FeedGroup -> m ()-checkFeedGroup (settings, feeds) = return ()--- }}}---- | Internal entry point for imm, after boot process-main :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => m ()-main = do-    checkStateDirectory    -    asks mFeedGroups >>= mapM_ (\x -> processFeedGroup x `catchError` (io . print))--checkStateDirectory :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => m ()-checkStateDirectory = asks mStateDirectory >>= resolve >>= try . io . createDirectoryIfMissing True---processFeedGroup :: (MonadIO m, MonadReader Settings m, MonadError ImmError m) => FeedGroup -> m ()-processFeedGroup _feedGroup@(config, feedURIs) = do-    Maildir.init $ mMaildir config-    forM_ feedURIs $ \uri ->-        (parseURI uri >>= downloadFeed >>= processFeed config)-        `catchError` (io . print)-+importOPML :: (MonadIO m) => m ()+importOPML = io $ (maybe (return ()) addFeeds) =<< OPML.read <$> hGetContents stdin -processFeed :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => FeedSettings -> ImmFeed -> m ()-processFeed feedSettings (uri, feed) = do-    logVerbose $ unlines [-        "Processing feed: " ++ show uri,-        "Title:  " ++ (getFeedTitle feed),-        "Author: " ++ (maybe "No author" id $ getFeedAuthor feed),-        "Home:   " ++ (maybe "No home"   id $ getFeedHome feed)]-    -    lastCheck <- getLastCheck uri-    forM_ (feedItems feed) $ \item -> -      do-        date <- getItemDate item-        when (date > lastCheck) $ processItem feedSettings (item, feed)-      `catchError` (io . print)+list :: (MonadIO m) => FeedList -> m ()+list = io . mapM_ (\(f, u) -> runReaderT (printStatus u) (f def)) -    storeLastCheck uri =<< io getCurrentTime-    -      -processItem :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => FeedSettings -> (Item, Feed) -> m ()-processItem feedSettings (item, feed) = do-    date <- getItemDate item-    logVerbose $ unlines [-            "   Item author: " ++ (maybe "" id $ getItemAuthor item),-            "   Item title:  " ++ (maybe "" id $ getItemTitle item),-            "   Item URI:    " ++ (maybe "" id $ getItemLink  item),-            -- "   Item Body:   " ++ (Imm.Mail.getItemContent  item),-            "   Item date:   " ++ show date]-    -    timeZone <- io getCurrentTimeZone-    Maildir.add dir =<< Mail.build timeZone (item, feed)-  where-    dir = mMaildir feedSettings+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)) -downloadRaw :: (MonadIO m, MonadError ImmError m) => URI -> m B.ByteString-downloadRaw uri = do-    logVerbose $ "Downloading " ++ show uri-    (_, r) <- io . browse $ do-        setAllowRedirects True-        request (mkRequest GET uri :: Request B.ByteString)-    when (rspCode r == (4,0,4)) $ throwError (HTTPError $ rspReason r)-    return . rspBody $ r+update :: (MonadIO m) => FeedList -> m ()+update feeds = io . forM_ feeds $ \(f, u) -> do+    result <- runErrorT . (`runReaderT` (f def)) $ do+        feed <- Feed.download =<< parseURI u+        checkStateDirectory+        Feed.update feed+    either print return result  -downloadFeed :: (MonadIO m, MonadError ImmError m) => URI -> m ImmFeed-downloadFeed uri = do-    feed <- parseFeedString . T.unpack =<< decodeUtf8 =<< downloadRaw uri-    return (uri, feed)+checkStateDirectory :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => m ()+checkStateDirectory = asks mStateDirectory >>= resolve >>= try . io . createDirectoryIfMissing True

@@ -0,0 +1,17 @@+module Imm.OPML where++-- {{{ Imports+import Text.OPML.Reader+import Text.OPML.Syntax+import Text.XML.Light.Types+-- }}}++read :: String -> Maybe [(String, [String])]+read rawOPML = do+    opml <- parseOPMLString rawOPML+    let groups     = opmlBody opml+        groupNames = map opmlText groups+        feeds      = \group -> opmlOutlineChildren group+        feedURI    = \feed -> (concat . map attrVal) . (filter ((== "xmlUrl") . qName . attrKey)) . opmlOutlineAttrs $ feed+    +    return $ zip groupNames (map (map feedURI) (map feeds groups))

@@ -1,19 +1,26 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} module Imm.Types where  -- {{{ Imports+--import Control.Exception import Control.Monad.Error +import Data.Text.Encoding import Data.Text.Encoding.Error-import qualified Data.Text.Lazy as T+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL import Data.Time +import Network.HTTP.Conduit hiding(HandshakeFailed)+import Network.HTTP.Types.Status import Network.URI-import Network.Stream+--import Network.Stream+import Network.TLS +import Prelude hiding(catch)+ import System.Console.CmdArgs-import System.IO.Error+import System.IO.Error hiding(catch)  import Text.Feed.Query import Text.Feed.Types@@ -23,31 +30,35 @@ -- | Errors that can be returned by an Imm process data ImmError =      OtherError         String-  | HTTPError          String+  | HTTPError          HttpException+  | TLSError           HandshakeFailed   | UnicodeError       UnicodeException   | ParseUriError      String   | ParseTimeError     String   | ParseItemDateError Item   | ParseFeedError     String-  | CE                 ConnError   | IOE                IOError+  | TimeOut  instance Show ImmError where     show (OtherError e)            = e-    show (HTTPError e)             = e+    show (HTTPError (StatusCodeException status _headers)) = +        "/!\\ HTTP error: " ++ show (statusCode status) ++ " " ++ (T.unpack . decodeUtf8) (statusMessage status)+    show (HTTPError e)             = "/!\\ HTTP error: " ++ show e+    show (TLSError (HandshakeFailed e)) = "/!\\ TLS error: " ++ show e     show (UnicodeError (DecodeError e _)) = e     show (UnicodeError (EncodeError e _)) = e-    show (ParseUriError raw)       = "Cannot parse URI: " ++ raw+    show (ParseUriError raw)       = "/!\\ Cannot parse URI: " ++ raw     show (ParseItemDateError item) = unlines [-        "Cannot parse date from item: ",+        "/!\\ Cannot parse date from item: ",         "    title: "       ++ (show $ getItemTitle item),         "    link:"         ++ (show $ getItemLink item),         "    publish date:" ++ (show $ getItemPublishDate item),         "    date:"         ++ (show $ getItemDate item)]-    show (ParseTimeError raw)      = "Cannot parse time: " ++ raw-    show (ParseFeedError raw)      = "Cannot parse feed: " ++ raw-    show (CE e)                    = show e-    show (IOE e)                   = ioeGetLocation e ++ " " ++ maybe "" id (ioeGetFileName e) ++ " " ++ ioeGetErrorString e+    show (ParseTimeError raw)      = "/!\\ Cannot parse time: " ++ raw+    show (ParseFeedError raw)      = "/!\\ Cannot parse feed: " ++ raw+    show (IOE e)                   = "/!\\ IO error: " ++ ioeGetLocation e ++ ": " ++ maybe "" id (ioeGetFileName e) ++ " " ++ ioeGetErrorString e+    show TimeOut                   = "/!\\ Process has timed out"  instance Error ImmError where     strMsg x = OtherError x@@ -55,47 +66,54 @@  -- {{{ Settings type 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} -  deriving (Data, Typeable, Show, Eq)+    mMasterBinary :: Maybe String+} deriving (Data, Typeable, Show, Eq)  -- | Set of settings for imm data Settings = Settings {     mStateDirectory :: PortableFilePath,-    mFeedGroups     :: [FeedGroup],+    mMaildir        :: PortableFilePath,     mFromBuilder    :: (Item, Feed) -> String,-    mSubjectBuilder :: (Item, Feed) -> T.Text,-    mBodyBuilder    :: (Item, Feed) -> T.Text   -- ^ sic!+    mSubjectBuilder :: (Item, Feed) -> TL.Text,+    mBodyBuilder    :: (Item, Feed) -> TL.Text   -- ^ sic! }++-- | +type CustomSettings = Settings -> Settings -- }}}  -- {{{ Feed types-type FeedGroup = (FeedSettings, [String]) --data FeedSettings = FeedSettings {-    mMaildir  :: PortableFilePath}--type ImmFeed = (URI, Feed)+type FeedList  = [(CustomSettings, String)]+type ImmFeed   = (URI, Feed) -- }}}  data Mail = Mail {     mReturnPath         :: String,     mDate               :: Maybe ZonedTime,     mFrom               :: String,-    mSubject            :: T.Text,+    mSubject            :: TL.Text,     mMIME               :: String,     mCharset            :: String,     mContentDisposition :: String,-    mBody               :: T.Text}+    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+    mData          :: FilePath         -- ^ Data directory+}  type PortableFilePath = RefDirs -> FilePath-+-- }}}

@@ -1,6 +1,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-}+-- | Various utilities module Imm.Util where  -- {{{ Imports@@ -10,39 +11,43 @@ import Control.Monad.Error --import Control.Monad.IO.Class -import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.Maybe+import Data.Text.ICU.Convert import Data.Text.Lazy.Encoding hiding(decodeUtf8)-import qualified Data.Text.Lazy as T-import qualified Data.Time as T+import qualified Data.Text.Lazy as TL+import Data.Time as T import Data.Time.RFC2822 import Data.Time.RFC3339 -import Network.Browser as N-import Network.HTTP import Network.URI as N  import System.Console.CmdArgs import System.Directory import System.Environment.XDG.BaseDir+import System.IO import System.Locale--import qualified Text.Feed.Import as F-import Text.Feed.Types+import System.Timeout as S -- }}}  -- {{{ Monadic utilities--- | Shortcut to liftIO+-- | Shortcut to 'liftIO' io :: MonadIO m => IO a -> m a io = liftIO --- | Monad-agnostic version of Control.Exception.try+-- | Monad-agnostic version of 'Control.Exception.try' try :: (MonadIO m, MonadError ImmError m) => IO a -> m a try = (io . E.try) >=> either (throwError . IOE) return ++-- | Monad-agnostic version of 'System.timeout'+timeout :: (MonadIO m, MonadError ImmError m) => Int -> IO a -> m a+timeout n f = maybe (throwError TimeOut) (io . return) =<< (io $ S.timeout n (io f)) -- }}} --- | Print logs with arbitrary importance.-logNormal, logVerbose :: MonadIO m => String -> m ()+-- | Print logs with arbitrary importance+logError, logNormal, logVerbose :: MonadIO m => String -> m ()+logError   = io . hPutStr stderr logNormal  = io . whenNormal . putStrLn logVerbose = io . whenLoud . putStrLn @@ -56,25 +61,27 @@          return . f $ RefDirs homeDir tmpDir configDir dataDir --- {{{ Monad-agnostic version of various error-prone functions    -decodeUtf8 :: MonadError ImmError m => B.ByteString -> m T.Text+-- {{{ 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 -parseDate :: String -> Maybe T.UTCTime-parseDate date = listToMaybe . map T.zonedTimeToUTC . catMaybes . flip map [readRFC2822, readRFC3339, T.parseTime defaultTimeLocale "%a, %d %b %G %T"] $ \f -> f . T.unpack . T.strip . T.pack $ date -parseFeedString :: MonadError ImmError m => String -> m Feed-parseFeedString x = maybe (throwError . ParseFeedError $ show x) return $ F.parseFeedString x-+-- | Monad-agnostic version of Network.URI.parseURI parseURI :: (MonadError ImmError m) => String -> m URI parseURI uri = maybe (throwError $ ParseUriError uri) return $ N.parseURI uri -parseTime :: (MonadError ImmError m) => String -> m T.UTCTime+-- | 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--request :: Request B.ByteString -> BrowserAction (HandleStream B.ByteString) (URI, Response B.ByteString)-request r = io $ (E.catch :: IO a -> (IOError -> IO a) -> IO a)-    (browse $ N.request r)-    (\e -> return (rqURI r, Response (4,0,4) ("Unable to connect to " ++ show (rqURI r)) [] B.empty))     -- }}}+++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,6 +1,6 @@ Name:                imm-Version:             0.3.0.0-Synopsis:            RSS-to-maildir tool+Version:             0.4.0.0+Synopsis:            Retrieve RSS/Atom feeds and write one mail per new item in a maildir. --Description:          --Homepage: Category:            Web@@ -23,8 +23,10 @@     Exposed-modules:         Imm.Boot,         Imm.Config,+        Imm.HTTP,         Imm.Main,         Imm.Feed,+        Imm.OPML,         Imm.Types,         Imm.Util,         Imm.Mail,@@ -32,21 +34,27 @@     Build-depends:         base == 4.*,         bytestring,+        case-insensitive,         cmdargs,         cond,+        data-default,         directory,         dyre,         feed,         filepath,-        HTTP,+        http-conduit,+        http-types,         mime-mail,         mtl,         network,         old-locale,+        opml,         random,         text,+        text-icu,         time,         timerep,+        tls,         utf8-string,         xdg-basedir,         xml