diff --git a/Imm/Boot.hs b/Imm/Boot.hs new file mode 100644 --- /dev/null +++ b/Imm/Boot.hs @@ -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) diff --git a/Imm/Config.hs b/Imm/Config.hs --- a/Imm/Config.hs +++ b/Imm/Config.hs @@ -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" diff --git a/Imm/Core.hs b/Imm/Core.hs --- a/Imm/Core.hs +++ b/Imm/Core.hs @@ -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 diff --git a/Imm/Feed.hs b/Imm/Feed.hs new file mode 100644 --- /dev/null +++ b/Imm/Feed.hs @@ -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) diff --git a/Imm/Mail.hs b/Imm/Mail.hs --- a/Imm/Mail.hs +++ b/Imm/Mail.hs @@ -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 = ""} + +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 = "

"++s++"

" + + +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 diff --git a/Imm/Maildir.hs b/Imm/Maildir.hs --- a/Imm/Maildir.hs +++ b/Imm/Maildir.hs @@ -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] diff --git a/Imm/Main.hs b/Imm/Main.hs --- a/Imm/Main.hs +++ b/Imm/Main.hs @@ -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 diff --git a/Imm/Types.hs b/Imm/Types.hs --- a/Imm/Types.hs +++ b/Imm/Types.hs @@ -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 diff --git a/Imm/Util.hs b/Imm/Util.hs --- a/Imm/Util.hs +++ b/Imm/Util.hs @@ -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 diff --git a/imm.cabal b/imm.cabal --- a/imm.cabal +++ b/imm.cabal @@ -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