imm 0.2.0.0 → 0.3.0.0

raw patch · 11 files changed

+387/−235 lines, 11 filesdep +conddep −errorsdep −transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: cond

Dependencies removed: errors, transformers

API changes (from Hackage documentation)

Files

• Imm/Boot.hs +35/−24
• Imm/Config.hs +16/−1
• Imm/Core.hs +0/−99
• Imm/Executable.hs +8/−0
• Imm/Feed.hs +66/−23
• Imm/Mail.hs +28/−34
• Imm/Maildir.hs +14/−15
• Imm/Main.hs +121/−6
• Imm/Types.hs +46/−8
• Imm/Util.hs +49/−20
• imm.cabal +4/−5

@@ -1,13 +1,14 @@ module Imm.Boot where  -- {{{ Imports-import Imm.Core+import Imm.Main import Imm.Types  import qualified Config.Dyre as D import Config.Dyre.Paths -import Data.Foldable+import Control.Monad.Error+import Control.Monad.Reader  import System.Console.CmdArgs import System.IO@@ -17,46 +18,56 @@ -- | Available commandline options cliOptions :: CliOptions cliOptions = CliOptions {-    mParameter     = def &= help "option description" &= explicit &= name "p" &= name "parameter" &= typ "type of the argument",-    mMasterBinary  = def &= name "dyre-master-binary" &= explicit+    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-    &= verbosityArgs [explicit, name "Verbose", name "v"] []+    &= verbosityArgs [explicit, name "verbose", name "v"] []     &= versionArg [ignore]-    &= help "Fetch and send items from RSS/Atom feeds to a custom mail address."+    &= help "Convert items from RSS/Atom feeds to maildir entries."     &= helpArg [explicit, name "help", name "h"]     &= program "imm" -- }}}  -- {{{ Dynamic reconfiguration printDyrePaths :: IO ()-printDyrePaths = getPaths (dyreParameters []) >>= \(a, b, c, d, e) -> (putStrLn . unlines) [-    "Current binary:  " ++ a,-    "Custom binary:   " ++ b,-    "Config file:     " ++ c,-    "Cache directory: " ++ d,-    "Lib directory:   " ++ e, []]+printDyrePaths = do+    (a, b, c, d, e) <- getPaths dyreParameters+    putStrLn . unlines $ [+        "Current binary:  " ++ a,+        "Custom binary:   " ++ b,+        "Config file:     " ++ c,+        "Cache directory: " ++ d,+        "Lib directory:   " ++ e, []] -dyreParameters :: [FeedGroup] -> D.Params (Settings, CliOptions)-dyreParameters feedGroups = D.defaultParams {+dyreParameters :: D.Params (Either String (Settings, CliOptions))+dyreParameters = D.defaultParams {   D.projectName  = "imm",   D.showError    = showError,-  D.realMain     = realMain feedGroups,+  D.realMain     = realMain,   D.ghcOpts      = ["-threaded"],   D.statusOut    = hPutStrLn stderr } -showError :: (Settings, a) -> String -> (Settings, a)-showError (settings, x) message = (settings { mError = Just message }, x)+showError :: Either String a -> String -> Either String a+showError _ = Left -- }}} --- | -imm :: [FeedGroup] -> Settings -> IO ()-imm feedGroups settings = do-    forM_ (mError settings) putStrLn-    whenLoud printDyrePaths-    +-- | Main function to call.+imm :: Settings -> IO ()+imm settings = do     options <- getOptions-    D.wrapMain (dyreParameters feedGroups) (settings, options)+    D.wrapMain dyreParameters (Right (settings, options))++-- Main dispatcher, depending on commandline options+realMain :: Either String (Settings, CliOptions) -> 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+-- }}}

@@ -1,12 +1,27 @@ module Imm.Config where +-- {{{ Imports+import Imm.Feed import Imm.Types +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,-    mError          = Nothing+    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]

@@ -1,99 +0,0 @@-module Imm.Core where---- {{{ Imports-import Imm.Feed-import Imm.Mail-import qualified Imm.Maildir as Maildir-import Imm.Types-import Imm.Util--import Control.Error-import Control.Monad hiding(forM_, mapM_)--import qualified Data.ByteString.Lazy as B---import qualified Data.ByteString.UTF8 as B-import qualified Data.Text.Lazy as T-import Data.Text.Lazy.Encoding-import Data.Foldable---import Data.Functor-import Data.Time--import Network.HTTP hiding(Response)-import Network.Stream-import Network.URI--import Prelude hiding(mapM_)--import Text.Feed.Import-import Text.Feed.Query-import Text.Feed.Types--- }}}---- Entry point-realMain :: [FeedGroup] -> (Settings, CliOptions) -> IO ()-realMain feedGroups (settings, _options) = do-    result <- forM feedGroups $ runEitherT . processFeedGroup settings-    forM_ (lefts result) print--   -processFeedGroup :: Settings -> FeedGroup -> EitherT ImmError IO ()-processFeedGroup globalSettings _feedGroup@(feedSettings, feedURIs) = do-    fmapLT OtherError $ Maildir.init $ mMailDirectory feedSettings-    forM_ feedURIs $ \uri -> do-        uri' <- EitherT . return $ parseURI' uri-        feed <- downloadFeed uri'-        processFeed globalSettings feedSettings feed-  where-    parseURI' uri = note (ParseUriError uri) . parseURI $ uri---processFeed :: Settings -> FeedSettings -> ImmFeed -> EitherT ImmError IO ()-processFeed globalSettings feedSettings (uri, feed) = do-    io . logVerbose $ unlines [-        "Processing feed: " ++ show uri,-        ("Title:  " ++) . getFeedTitle $ feed,-        ("Author: " ++) . maybe "No author" id . getFeedAuthor $ feed,-        ("Home:   " ++) . maybe "No home"   id . getFeedHome $ feed]-    -    lastCheck <- io $ getLastCheck globalSettings (uri, feed)-    forM_ (feedItems feed) $ \item -> do-      date <- EitherT . return $ getItemDate' item-      when (date > lastCheck) $ fmapLT OtherError $ processItem globalSettings feedSettings item-      return ()-    -    currentTime <- io getCurrentTime-    storeLastCheck globalSettings (uri, feed) currentTime-  where-    getItemDate' x = note (ParseItemDateError x) . (parseDate <=< getItemDate) $ x-      -      -processItem :: Settings -> FeedSettings -> Item -> Script ()-processItem _globalSettings feedSettings item = do-    io . logVerbose $ unlines ["",-            "   Item author: " ++ (maybe "" id $ getItemAuthor item),-            "   Item title:  " ++ (maybe "" id $ getItemTitle item),-            "   Item URI:    " ++ (maybe "" id $ getItemLink  item),-            --"   Item Content:    " ++ (Imm.Mail.getItemContent  item),-            "   Item date:   " ++ (maybe "" id $ time)]-    -    timeZone <- io getCurrentTimeZone-    void $ Maildir.add dir . itemToMail timeZone $ item -  where-    time = getItemDate item-    dir  = mMailDirectory feedSettings---downloadRaw :: URI -> EitherT ConnError IO T.Text-downloadRaw uri = do-    io . logVerbose $ "Downloading " ++ show uri-    response <- EitherT $ simpleHTTP (mkRequest GET uri :: Request B.ByteString)-    return . decodeUtf8 . rspBody $ response---downloadFeed :: URI -> EitherT ImmError IO ImmFeed-downloadFeed uri = do-    rawData <- fmapLT CE $ downloadRaw uri-    feed    <- EitherT . return $ parseFeedString' (T.unpack rawData)-    return (uri, feed)-  where-    parseFeedString' x = note (ParseFeedError $ show x) $ parseFeedString x

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

@@ -1,46 +1,89 @@+{-# LANGUAGE FlexibleContexts #-} module Imm.Feed where  -- {{{ Imports import Imm.Types import Imm.Util -import Control.Error---import Control.Exception+import Control.Monad.Error+import Control.Monad.Reader -import Data.Time+--import Data.Functor+import qualified Data.Text.Lazy as T+import Data.Time hiding(parseTime) import Data.Time.Clock.POSIX +import Network.URI+ import System.Directory import System.FilePath import System.IO import System.Locale++import Text.Atom.Feed hiding(URI)+import Text.Feed.Query as F+import Text.Feed.Types+import Text.XML.Light.Proc -- }}} +-- {{{ Util+getStateFile :: URI -> FilePath+getStateFile feedUri@URI{ uriAuthority = Just auth } = toFileName =<< ((++ (uriQuery feedUri)) . (++ (uriPath feedUri)) . uriRegName $ auth)+getStateFile feedUri = show feedUri >>= toFileName -getLastCheck :: Settings -> ImmFeed -> IO UTCTime-getLastCheck settings (uri, _feed) = do-    directory <- resolve $ mStateDirectory settings-    -    result <- runEitherT $ do-        content <- fmapLT OtherError . tryIO $ readFile (directory </> fileName)-        EitherT . return $ parseTime' content+toFileName :: Char -> String+toFileName '/' = "."+toFileName '?' = "."+toFileName x = [x]+-- }}} -    either -        (\e -> print e >> return timeZero)-        return-        result++getLastCheck :: (MonadReader Settings m, MonadIO m) => URI -> m UTCTime+getLastCheck feedUri = do+    directory <- asks mStateDirectory >>= resolve+    result    <- runErrorT $ do+        content <- try $ readFile (directory </> fileName)+        parseTime content+        +    either (const $ return timeZero) return result   where-    fileName = show uri >>= escapeFileName-    timeZero = posixSecondsToUTCTime $ 0 -    parseTime' string = note (ParseTimeError string) $ parseTime defaultTimeLocale "%c" string+    fileName = getStateFile feedUri+    timeZero = posixSecondsToUTCTime 0   -storeLastCheck :: Settings -> ImmFeed -> UTCTime -> EitherT ImmError IO ()-storeLastCheck settings (uri, _) date = do-    directory <- io . resolve $ mStateDirectory settings-    let fileName = show uri >>= escapeFileName+storeLastCheck :: (MonadReader Settings m, MonadIO m, MonadError ImmError m) => URI -> UTCTime -> m ()+storeLastCheck feedUri date = do+    directory <- asks mStateDirectory >>= resolve     -    (file, stream) <- fmapLT OtherError . tryIO $ openTempFile directory fileName+    (file, stream) <- try $ openTempFile directory fileName     io $ hPutStrLn stream (formatTime defaultTimeLocale "%c" date)     io $ hClose stream-    fmapLT OtherError . tryIO $ renameFile file (directory </> fileName)+    try $ renameFile file (directory </> fileName)+  where+    fileName = getStateFile feedUri+    +-- {{{ 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 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+-- }}}+++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+++paragraphy :: String -> String+paragraphy s = "<p>"++s++"</p>"+

@@ -1,26 +1,27 @@+{-# LANGUAGE FlexibleContexts #-} module Imm.Mail where  -- {{{ Imports+--import Imm.Feed import Imm.Types import Imm.Util  import Control.Monad+import Control.Monad.Reader  import qualified Data.Text.Lazy as T import Data.Time import Data.Time.RFC2822 -import Text.Feed.Query+import Text.Feed.Query as F import Text.Feed.Types-import Text.Atom.Feed   as Atom-import Text.XML.Light.Proc -- }}}  -defaultMail :: Mail-defaultMail = Mail {+bare :: Mail+bare = Mail {     mCharset            = "utf-8",-    mContent            = T.pack "",+    mBody               = T.pack "",     mContentDisposition = "inline",     mDate               = Nothing,     mFrom               = "imm",@@ -38,39 +39,32 @@     T.pack $ "Content-Type: " ++ mMIME mail ++ "; charset=" ++ mCharset mail,     T.pack $ "Content-Disposition: " ++ mContentDisposition mail,     T.pack "",-    mContent mail]+    mBody mail]   -itemToMail :: TimeZone -> Item -> Mail-itemToMail timeZone item = defaultMail {-    mDate       = maybe Nothing (Just . utcToZonedTime timeZone) . parseDate <=< getItemDate $ item,-    mFrom       = maybe "Anonymous" id $ getItemAuthor item,-    mSubject    = T.pack $ maybe "Untitled" id $ getItemTitle item,-    mContent    = buildMailBody item}+build :: 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)+    return bare {mDate = date, mFrom = from, mSubject = subject, mBody = body}+  where+    date = maybe Nothing (Just . utcToZonedTime timeZone) . parseDate <=< F.getItemDate $ item -buildMailBody :: Item -> T.Text-buildMailBody item = -    T.unlines $ map ((><) item) [T.pack . getItemLinkNM, getItemContent] -getItemLinkNM :: Item -> String -getItemLinkNM item = maybe "No link found" paragraphy  $ getItemLink item---- ce "magic operator" semble pas défini dans les libs haskell -> WTF ?-(><) :: a -> (a -> b) -> b-(><) a b = b a--paragraphy :: String -> String-paragraphy s = "<p>"++s++"</p>"+buildFrom :: MonadReader Settings m => (Item, Feed) -> m String+buildFrom (item, feed) = do+    builder <- asks mFromBuilder+    return $ builder (item, feed)  -getItemContent :: Item -> T.Text-getItemContent (AtomItem e) = T.pack . maybe "No content" extractHtml . Atom.entryContent $ e-getItemContent item = T.pack . maybe "Empty" id . getItemDescription $ item+buildSubject :: MonadReader Settings m => (Item, Feed) -> m T.Text+buildSubject (item, feed) = do+    builder <- asks mSubjectBuilder+    return $ builder (item, feed)  -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+buildBody :: MonadReader Settings m => (Item, Feed) -> m T.Text+buildBody (item, feed) = do+    builder <- asks mBodyBuilder+    return $ builder (item, feed)

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} module Imm.Maildir where  -- {{{ Imports@@ -5,8 +6,8 @@ import Imm.Types import Imm.Util -import Control.Error---import Control.Exception+--import Control.Monad.IO.Class+import Control.Monad.Error  import Data.Functor import qualified Data.Text.Lazy.IO as T@@ -16,30 +17,28 @@  import System.Directory import System.FilePath---import System.IO.Error (ioeGetErrorString) import System.Random -- }}} -init :: PortableFilePath -> EitherT String IO ()+init :: (MonadIO m, MonadError ImmError m) => PortableFilePath -> m () init directory = do     dir <- io $ resolve directory-    tryIO $ createDirectoryIfMissing True dir-    tryIO $ createDirectoryIfMissing True (dir </> "cur")-    tryIO $ createDirectoryIfMissing True (dir </> "new")-    tryIO $ createDirectoryIfMissing True (dir </> "tmp")-    -    io . logVerbose $ "Maildir correctly created at: " ++ dir+    try $ createDirectoryIfMissing True dir+    try $ createDirectoryIfMissing True (dir </> "cur")+    try $ createDirectoryIfMissing True (dir </> "new")+    try $ createDirectoryIfMissing True (dir </> "tmp")+    logVerbose $ "Maildir correctly created at: " ++ dir  -add :: PortableFilePath -> Mail -> Script ()+add :: (MonadIO m, MonadError ImmError m) => PortableFilePath -> Mail -> m () add directory mail = do-    dir      <- io $ resolve directory+    dir      <- resolve directory     fileName <- io getUniqueName-    tryIO $ T.writeFile (dir </> "new" </> fileName) (toText mail)+    try $ T.writeFile (dir </> "new" </> fileName) (toText mail)  -getUniqueName :: IO String -getUniqueName = do+getUniqueName :: MonadIO m => m String +getUniqueName = io $ do     time     <- show <$> getPOSIXTime     hostname <- getHostName     rand     <- show <$> (getStdRandom $ randomR (1,100000) :: IO Int)

@@ -1,8 +1,123 @@-module Main where+{-# LANGUAGE FlexibleContexts #-}+module Imm.Main where -import Imm.Boot-import Imm.Config---import Imm.Types+-- {{{ Imports+import Imm.Feed+import qualified Imm.Mail as Mail+import qualified Imm.Maildir as Maildir+import Imm.Types+import Imm.Util -main :: IO ()-main = imm [] defaultSettings+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.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 Prelude hiding(mapM_)++import System.Directory++--import Text.Feed.Import+import Text.Feed.Query hiding(getItemDate)+import Text.Feed.Types+-- }}}++-- {{{ 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)+++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)++    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+++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+++downloadFeed :: (MonadIO m, MonadError ImmError m) => URI -> m ImmFeed+downloadFeed uri = do+    feed <- parseFeedString . T.unpack =<< decodeUtf8 =<< downloadRaw uri+    return (uri, feed)

@@ -1,7 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Imm.Types where  -- {{{ Imports+import Control.Monad.Error++import Data.Text.Encoding.Error import qualified Data.Text.Lazy as T import Data.Time @@ -9,38 +13,72 @@ import Network.Stream  import System.Console.CmdArgs+import System.IO.Error +import Text.Feed.Query import Text.Feed.Types -- }}}  -- {{{ Error handling-data ImmError = OtherError String | ParseUriError String | ParseTimeError String | ParseItemDateError Item | ParseFeedError String | CE ConnError+-- | Errors that can be returned by an Imm process+data ImmError = +    OtherError         String+  | HTTPError          String+  | UnicodeError       UnicodeException+  | ParseUriError      String+  | ParseTimeError     String+  | ParseItemDateError Item+  | ParseFeedError     String+  | CE                 ConnError+  | IOE                IOError  instance Show ImmError where-    show (OtherError e)            = show e+    show (OtherError e)            = e+    show (HTTPError e)             = e+    show (UnicodeError (DecodeError e _)) = e+    show (UnicodeError (EncodeError e _)) = e     show (ParseUriError raw)       = "Cannot parse URI: " ++ raw-    show (ParseItemDateError item) = "Cannot parse date from item: " ++ show item+    show (ParseItemDateError item) = unlines [+        "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++instance Error ImmError where+    strMsg x = OtherError x -- }}} +-- {{{ Settings type data CliOptions = CliOptions {-    mParameter    :: Maybe String,+    mCheck        :: Bool,+    mList         :: Bool,+    mDenyReconf   :: Bool,         -- ^ Do not recompile configuration even if it has changed     mMasterBinary :: Maybe String}    deriving (Data, Typeable, Show, Eq) --- | +-- | Set of settings for imm data Settings = Settings {     mStateDirectory :: PortableFilePath,-    mError          :: Maybe String}+    mFeedGroups     :: [FeedGroup],+    mFromBuilder    :: (Item, Feed) -> String,+    mSubjectBuilder :: (Item, Feed) -> T.Text,+    mBodyBuilder    :: (Item, Feed) -> T.Text   -- ^ sic!+}+-- }}} +-- {{{ Feed types type FeedGroup = (FeedSettings, [String])   data FeedSettings = FeedSettings {-    mMailDirectory  :: PortableFilePath}+    mMaildir  :: PortableFilePath}  type ImmFeed = (URI, Feed)+-- }}}  data Mail = Mail {     mReturnPath         :: String,@@ -50,7 +88,7 @@     mMIME               :: String,     mCharset            :: String,     mContentDisposition :: String,-    mContent            :: T.Text}+    mBody               :: T.Text}  -- | Set of reference directories, typically used to build FilePath-s data RefDirs = RefDirs {

@@ -1,36 +1,54 @@ {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-} module Imm.Util where  -- {{{ Imports import Imm.Types -import Codec.Binary.UTF8.String----import Control.Exception+import qualified Control.Exception as E import Control.Monad.Error --import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy as B import Data.Maybe-import Data.Time+import Data.Text.Lazy.Encoding hiding(decodeUtf8)+import qualified Data.Text.Lazy as T+import qualified Data.Time as T import Data.Time.RFC2822 import Data.Time.RFC3339 ---import Network.URI+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.Locale++import qualified Text.Feed.Import as F+import Text.Feed.Types -- }}} +-- {{{ Monadic utilities+-- | Shortcut to liftIO io :: MonadIO m => IO a -> m a io = liftIO -logNormal, logVerbose :: String -> IO ()-logNormal  = whenNormal . putStrLn-logVerbose = whenLoud . putStrLn+-- | 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 +-- }}} -resolve :: (RefDirs -> a) -> IO a-resolve f = do+-- | Print logs with arbitrary importance.+logNormal, logVerbose :: MonadIO m => String -> m ()+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"@@ -38,14 +56,25 @@          return . f $ RefDirs homeDir tmpDir configDir dataDir -escapeFileName :: Char -> String-escapeFileName '/' = "|"-escapeFileName x   = x:[]-    -parseDate :: String -> Maybe UTCTime-parseDate date = listToMaybe . map zonedTimeToUTC . catMaybes . map ((flip ($)) date) $ [readRFC2822, readRFC3339]+-- {{{ Monad-agnostic version of various error-prone functions    +decodeUtf8 :: MonadError ImmError m => B.ByteString -> m T.Text+decodeUtf8 = either (throwError . UnicodeError) return . decodeUtf8' -decodeIfNeeded :: String -> String-decodeIfNeeded text = case isUTF8Encoded text of-    False -> text-    _     -> decodeString text++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++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+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))    +-- }}}

@@ -1,5 +1,5 @@ Name:                imm-Version:             0.2.0.0+Version:             0.3.0.0 Synopsis:            RSS-to-maildir tool --Description:          --Homepage:@@ -23,7 +23,7 @@     Exposed-modules:         Imm.Boot,         Imm.Config,-        Imm.Core,+        Imm.Main,         Imm.Feed,         Imm.Types,         Imm.Util,@@ -33,9 +33,9 @@         base == 4.*,         bytestring,         cmdargs,+        cond,         directory,         dyre,-        errors,         feed,         filepath,         HTTP,@@ -47,7 +47,6 @@         text,         time,         timerep,-        transformers,         utf8-string,         xdg-basedir,         xml@@ -58,6 +57,6 @@  Executable imm     Build-depends: imm, base == 4.*-    Main-is: Main.hs+    Main-is: Executable.hs     Hs-Source-Dirs: Imm     Ghc-options: -Wall -threaded