imm 0.1.1.0 → 0.2.0.0

raw patch · 10 files changed

+303/−210 lines, 10 filesdep +errorsdep +mtldep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: errors, mtl, transformers

API changes (from Hackage documentation)

Files

• Imm/Boot.hs +62/−0
• Imm/Config.hs +5/−8
• Imm/Core.hs +62/−133
• Imm/Feed.hs +46/−0
• Imm/Mail.hs +47/−4
• Imm/Maildir.hs +23/−24
• Imm/Main.hs +2/−2
• Imm/Types.hs +35/−36
• Imm/Util.hs +15/−2
• imm.cabal +6/−1

@@ -0,0 +1,62 @@+module Imm.Boot where++-- {{{ Imports+import Imm.Core+import Imm.Types++import qualified Config.Dyre as D+import Config.Dyre.Paths++import Data.Foldable++import System.Console.CmdArgs+import System.IO+-- }}}++-- {{{ Commandline options+-- | 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+}++getOptions :: IO CliOptions+getOptions = cmdArgs $ cliOptions+    &= verbosityArgs [explicit, name "Verbose", name "v"] []+    &= versionArg [ignore]+    &= help "Fetch and send items from RSS/Atom feeds to a custom mail address."+    &= 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, []]++dyreParameters :: [FeedGroup] -> D.Params (Settings, CliOptions)+dyreParameters feedGroups = D.defaultParams {+  D.projectName  = "imm",+  D.showError    = showError,+  D.realMain     = realMain feedGroups,+  D.ghcOpts      = ["-threaded"],+  D.statusOut    = hPutStrLn stderr+}++showError :: (Settings, a) -> String -> (Settings, a)+showError (settings, x) message = (settings { mError = Just message }, x)+-- }}}++-- | +imm :: [FeedGroup] -> Settings -> IO ()+imm feedGroups settings = do+    forM_ (mError settings) putStrLn+    whenLoud printDyrePaths+    +    options <- getOptions+    D.wrapMain (dyreParameters feedGroups) (settings, options)

@@ -2,14 +2,11 @@  import Imm.Types +import System.FilePath+ -- | Default configuration.-defaultParameters :: Parameters-defaultParameters = Parameters {-    mCacheDirectory = Nothing,-    mFeedURIs       = [],-    mMailDirectory  = defaultMailDirectory,+defaultSettings :: Settings+defaultSettings = Settings {+    mStateDirectory = (</> "state") . mConfiguration,     mError          = Nothing }--defaultMailDirectory :: PortableFilePath-defaultMailDirectory = const "feeds"

@@ -1,170 +1,99 @@ module Imm.Core where  -- {{{ Imports-import Imm.Config+import Imm.Feed import Imm.Mail import qualified Imm.Maildir as Maildir import Imm.Types import Imm.Util -import qualified Config.Dyre as D-import Config.Dyre.Paths----import Control.Arrow-import Control.Monad hiding(forM_)+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.Maybe import Data.Time-import Data.Time.Clock.POSIX  import Network.HTTP hiding(Response)+import Network.Stream import Network.URI -import System.Console.CmdArgs-import System.Directory-import System.FilePath-import System.IO-import System.IO.Error-import System.Locale+import Prelude hiding(mapM_) -import qualified Text.Feed.Import as F+import Text.Feed.Import import Text.Feed.Query import Text.Feed.Types -- }}} --- {{{ Commandline options                                                                             --- | Available commandline options-cliOptions :: CliOptions-cliOptions = CliOptions {-    mParameter = def &= help "option description" &= explicit &= name "p" &= name "parameter" &= typ "type of the argument"-}--getOptions :: IO CliOptions-getOptions = cmdArgs $ cliOptions-    &= verbosityArgs [explicit, name "Verbose", name "v"] []-    &= versionArg [ignore]-    &= help "Fetch and send items from RSS/Atom feeds to a custom mail address."-    &= helpArg [explicit, name "help", name "h"]-    &= program "imm"--- }}}---- {{{ Configuration-dyreParameters :: D.Params Parameters-dyreParameters = D.defaultParams {-  D.projectName  = "imm",-  D.showError    = showError,-  D.realMain     = realMain,-  D.ghcOpts      = ["-threaded"],-  D.statusOut    = hPutStrLn stderr-}--showError :: Parameters -> String -> Parameters-showError parameters message = parameters { mError = Just message }--- }}}---- | -imm :: Parameters -> IO ()-imm = D.wrapMain dyreParameters- -- Entry point-realMain :: Parameters -> IO ()-realMain parameters@Parameters{ mMailDirectory = directory } = do--- Print configuration error, if any-    forM_ (mError parameters) putStrLn-    --- Parse commandline arguments-    options <- getOptions+realMain :: [FeedGroup] -> (Settings, CliOptions) -> IO ()+realMain feedGroups (settings, _options) = do+    result <- forM feedGroups $ runEitherT . processFeedGroup settings+    forM_ (lefts result) print --- Print in-use paths-    (a, b, c, d, e) <- getPaths dyreParameters -    whenLoud . putStrLn . unlines $ [-        "Current binary:  " ++ a,-        "Custom binary:   " ++ b,-        "Config file:     " ++ c,-        "Cache directory: " ++ d,-        "Lib directory:   " ++ e]-        --- Initialize mailbox-    result <- Maildir.init directory-    when result $ realMain' parameters    --- At this point, a maildir has been setup.-realMain' :: Parameters -> IO ()-realMain' parameters@Parameters{ mFeedURIs = feedURIs } = do    -    let uris   = map parseURI' feedURIs -    rawFeeds  <- mapM (either (return . Left) downloadRaw) uris -    let feeds  = zip feedURIs . map (parseFeedString =<<) $ rawFeeds-    -    void . mapM (processFeed parameters) $ feeds -    return ()+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 -parseURI' :: String -> Either String URI-parseURI' uri = maybe (Left . ("Ill-formatted URI: " ++) $ uri) (Right) . parseURI $ uri -processFeed :: Parameters -> (String, Either String Feed) -> IO ()-processFeed _ (_, Left e) = putStrLn e-processFeed parameters (uri, Right feed) = do-    whenLoud . putStr . unlines $ [-        "Processing feed: " ++ 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]     -    (_, _, _, d, _) <- getPaths dyreParameters-    let directory = maybe d id . mCacheDirectory $ parameters  -    let fileName  = uri >>= escapeFileName-    --- -    oldTime <- try $ readFile (directory </> fileName)-    let timeZero = posixSecondsToUTCTime $ 0 -    let threshold = either-          (const timeZero)-          (maybe timeZero id . parseTime defaultTimeLocale "%F %T %Z")-          oldTime-    -    lastTime <- foldlM (\acc item -> processItem parameters threshold item >>= (return . (max acc))) threshold (feedItems 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 ()     --- -    (file, handle) <- openTempFile directory fileName-    hPutStrLn handle (show lastTime)-    hClose handle-    renameFile file (directory </> fileName)+    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)]     -    return ()+    timeZone <- io getCurrentTimeZone+    void $ Maildir.add dir . itemToMail timeZone $ item +  where+    time = getItemDate item+    dir  = mMailDirectory feedSettings -processItem :: Parameters -> UTCTime -> Item -> IO UTCTime-processItem parameters@Parameters{ mMailDirectory = directory } threshold item = do-    currentTime <- getCurrentTime :: IO UTCTime-    timeZone    <- getCurrentTimeZone-    let time = getItemDate item-  -    whenLoud . putStr . unlines $ ["",-        "   Item author: " ++ (maybe "" id $ getItemAuthor item),-        "   Item title:  " ++ (maybe "" id $ getItemTitle item),-        "   Item URI:    " ++ (maybe "" id $ getItemLink  item),-        "   Item date:   " ++ (maybe "" id $ time)]-    -    case time >>= parseDate of-        Just y -> do-            when (threshold < y) $ do-                whenLoud . putStrLn $ "==> New entry added to maildir."-                Maildir.add directory . itemToMail timeZone $ item -            return y-        _      -> do-            Maildir.add directory . itemToMail timeZone $ item -            return threshold -downloadRaw :: URI -> IO (Either String String)+downloadRaw :: URI -> EitherT ConnError IO T.Text downloadRaw uri = do-    result <- simpleHTTP . getRequest $ show uri-    return . either (Left . show) (Right . decodeIfNeeded . rspBody) $ result+    io . logVerbose $ "Downloading " ++ show uri+    response <- EitherT $ simpleHTTP (mkRequest GET uri :: Request B.ByteString)+    return . decodeUtf8 . rspBody $ response --- | Same as Text.Feed.Import.ParseFeedString, but with Either monad.-parseFeedString :: String -> Either String Feed-parseFeedString = maybe-    (Left "Unable to parse XML from raw page.") -    Right -    . F.parseFeedString +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,46 @@+module Imm.Feed where++-- {{{ Imports+import Imm.Types+import Imm.Util++import Control.Error+--import Control.Exception++import Data.Time+import Data.Time.Clock.POSIX++import System.Directory+import System.FilePath+import System.IO+import System.Locale+-- }}}+++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++    either +        (\e -> print e >> return timeZero)+        return+        result+  where+    fileName = show uri >>= escapeFileName+    timeZero = posixSecondsToUTCTime $ 0 +    parseTime' string = note (ParseTimeError string) $ parseTime defaultTimeLocale "%c" string+++storeLastCheck :: Settings -> ImmFeed -> UTCTime -> EitherT ImmError IO ()+storeLastCheck settings (uri, _) date = do+    directory <- io . resolve $ mStateDirectory settings+    let fileName = show uri >>= escapeFileName+    +    (file, stream) <- fmapLT OtherError . tryIO $ openTempFile directory fileName+    io $ hPutStrLn stream (formatTime defaultTimeLocale "%c" date)+    io $ hClose stream+    fmapLT OtherError . tryIO $ renameFile file (directory </> fileName)

@@ -6,28 +6,71 @@  import Control.Monad +import qualified Data.Text.Lazy as T import Data.Time+import Data.Time.RFC2822  import Text.Feed.Query import Text.Feed.Types+import Text.Atom.Feed   as Atom+import Text.XML.Light.Proc -- }}}   defaultMail :: Mail defaultMail = Mail {     mCharset            = "utf-8",-    mContent            = "",+    mContent            = T.pack "",     mContentDisposition = "inline",     mDate               = Nothing,     mFrom               = "imm",     mMIME               = "text/html",-    mSubject            = "Untitled",+    mSubject            = T.pack "Untitled",     mReturnPath         = "<imm@noreply>"} ++toText :: Mail -> T.Text+toText mail = T.unlines [+    T.pack $ "Return-Path: " ++ mReturnPath mail,+    T.pack $ maybe "" (("Date: " ++) . showRFC2822) . mDate $ mail,+    T.pack $ "From: " ++ mFrom mail,+    T.concat [T.pack "Subject: ", mSubject mail],+    T.pack $ "Content-Type: " ++ mMIME mail ++ "; charset=" ++ mCharset mail,+    T.pack $ "Content-Disposition: " ++ mContentDisposition mail,+    T.pack "",+    mContent 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    = maybe "Untitled" id $ getItemTitle item,-    mContent    = maybe "Empty" id $ getItemDescription item}+    mSubject    = T.pack $ maybe "Untitled" id $ getItemTitle item,+    mContent    = buildMailBody 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>"+++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+++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

@@ -1,49 +1,48 @@ module Imm.Maildir where  -- {{{ Imports-import Imm.Mail()+import Imm.Mail import Imm.Types import Imm.Util +import Control.Error+--import Control.Exception++import Data.Functor+import qualified Data.Text.Lazy.IO as T import Data.Time.Clock.POSIX  import Network.BSD -import System.Console.CmdArgs import System.Directory import System.FilePath-import System.IO.Error+--import System.IO.Error (ioeGetErrorString) import System.Random -- }}} -init :: PortableFilePath -> IO Bool+init :: PortableFilePath -> EitherT String IO () init directory = do-    dir  <- resolve directory-    root <- try $ createDirectoryIfMissing True dir-    cur  <- try . createDirectoryIfMissing True . (dir </>) $ "cur"-    new  <- try . createDirectoryIfMissing True . (dir </>) $ "new"-    tmp  <- try . createDirectoryIfMissing True . (dir </>) $ "tmp"+    dir <- io $ resolve directory+    tryIO $ createDirectoryIfMissing True dir+    tryIO $ createDirectoryIfMissing True (dir </> "cur")+    tryIO $ createDirectoryIfMissing True (dir </> "new")+    tryIO $ createDirectoryIfMissing True (dir </> "tmp")     -    case (root, cur, new, tmp) of-        (Right _, Right _, Right _, Right _) -> do-            whenLoud . putStrLn . ("Maildir correctly created at: " ++) $ dir-            return True-        _                                    -> do-            whenNormal . putStrLn . ("Unable to initialize maildir at: " ++) $ dir-            return False+    io . logVerbose $ "Maildir correctly created at: " ++ dir -add :: PortableFilePath -> Mail -> IO ()++add :: PortableFilePath -> Mail -> Script () add directory mail = do-    dir      <- resolve directory-    fileName <- getUniqueName-    writeFile (dir </> "new" </> fileName) (show mail)+    dir      <- io $ resolve directory+    fileName <- io getUniqueName+    tryIO $ T.writeFile (dir </> "new" </> fileName) (toText mail)  -getUniqueName :: IO String    +getUniqueName :: IO String  getUniqueName = do-    time     <- getPOSIXTime >>= (return . show)+    time     <- show <$> getPOSIXTime     hostname <- getHostName-    rand     <- (getStdRandom $ randomR (1,100000) :: IO Int) >>= (return . show)+    rand     <- show <$> (getStdRandom $ randomR (1,100000) :: IO Int)     -    return $ time ++ "." ++ rand ++ "." ++ hostname+    return . concat $ [time, ".", rand, ".", hostname] 

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

@@ -2,63 +2,62 @@ module Imm.Types where  -- {{{ Imports-import Network.URI-+import qualified Data.Text.Lazy as T import Data.Time-import Data.Time.RFC2822 +import Network.URI+import Network.Stream+ import System.Console.CmdArgs  import Text.Feed.Types -- }}} +-- {{{ Error handling+data ImmError = OtherError String | ParseUriError String | ParseTimeError String | ParseItemDateError Item | ParseFeedError String | CE ConnError +instance Show ImmError where+    show (OtherError e)            = show e+    show (ParseUriError raw)       = "Cannot parse URI: " ++ raw+    show (ParseItemDateError item) = "Cannot parse date from item: " ++ show item+    show (ParseTimeError raw)      = "Cannot parse time: " ++ raw+    show (ParseFeedError raw)      = "Cannot parse feed: " ++ raw+    show (CE e)                    = show e+-- }}}+ data CliOptions = CliOptions {-    mParameter :: Maybe String-} deriving (Data, Typeable, Show, Eq)+    mParameter    :: Maybe String,+    mMasterBinary :: Maybe String} +  deriving (Data, Typeable, Show, Eq)  -- | -data Parameters = Parameters {-    mCacheDirectory :: Maybe String,-    mFeedURIs       :: [String],             -- ^ Feeds list-    mMailDirectory  :: PortableFilePath,-    mError          :: Maybe String          -- ^ Error                                                                                                                           -}+data Settings = Settings {+    mStateDirectory :: PortableFilePath,+    mError          :: Maybe String} -data ImmFeed = ImmFeed {-    mURI  :: URI,-    mFeed :: Feed-}+type FeedGroup = (FeedSettings, [String])  +data FeedSettings = FeedSettings {+    mMailDirectory  :: PortableFilePath}++type ImmFeed = (URI, Feed)+ data Mail = Mail {-    mReturnPath  :: String,-    mDate        :: Maybe ZonedTime,-    mFrom        :: String,-    mSubject     :: String,-    mMIME        :: String,-    mCharset     :: String,+    mReturnPath         :: String,+    mDate               :: Maybe ZonedTime,+    mFrom               :: String,+    mSubject            :: T.Text,+    mMIME               :: String,+    mCharset            :: String,     mContentDisposition :: String,-    mContent     :: String-}--instance Show Mail where -    show mail = unlines [-        "Return-Path: " ++ mReturnPath mail,-        maybe "" (("Date: " ++) . showRFC2822) . mDate $ mail,-        "From: " ++ mFrom mail,-        "Subject: " ++ mSubject mail,-        "Content-Type: " ++ mMIME mail ++ "; charset=" ++ mCharset mail,-        "Content-Disposition: " ++ mContentDisposition mail,-        "",-        mContent mail]+    mContent            :: T.Text}  -- | 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,3 +1,4 @@+{-# LANGUAGE NoMonomorphismRestriction #-} module Imm.Util where  -- {{{ Imports@@ -5,6 +6,10 @@  import Codec.Binary.UTF8.String +--import Control.Exception+import Control.Monad.Error+--import Control.Monad.IO.Class+ import Data.Maybe import Data.Time import Data.Time.RFC2822@@ -12,16 +17,24 @@  --import Network.URI +import System.Console.CmdArgs import System.Directory import System.Environment.XDG.BaseDir -- }}} +io :: MonadIO m => IO a -> m a+io = liftIO++logNormal, logVerbose :: String -> IO ()+logNormal  = whenNormal . putStrLn+logVerbose = whenLoud . putStrLn+ resolve :: (RefDirs -> a) -> IO a resolve f = do     homeDir   <- getHomeDirectory     tmpDir    <- getTemporaryDirectory-    configDir <- getUserConfigDir "hbro"-    dataDir   <- getUserDataDir   "hbro"+    configDir <- getUserConfigDir "imm"+    dataDir   <- getUserDataDir   "imm"          return . f $ RefDirs homeDir tmpDir configDir dataDir 

@@ -1,5 +1,5 @@ Name:                imm-Version:             0.1.1.0+Version:             0.2.0.0 Synopsis:            RSS-to-maildir tool --Description:          --Homepage:@@ -21,8 +21,10 @@  Library     Exposed-modules:+        Imm.Boot,         Imm.Config,         Imm.Core,+        Imm.Feed,         Imm.Types,         Imm.Util,         Imm.Mail,@@ -33,16 +35,19 @@         cmdargs,         directory,         dyre,+        errors,         feed,         filepath,         HTTP,         mime-mail,+        mtl,         network,         old-locale,         random,         text,         time,         timerep,+        transformers,         utf8-string,         xdg-basedir,         xml