"++s++"
" + diff --git a/Imm/Mail.hs b/Imm/Mail.hs --- a/Imm/Mail.hs +++ b/Imm/Mail.hs @@ -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 = ""++s++"
" +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) diff --git a/Imm/Maildir.hs b/Imm/Maildir.hs --- a/Imm/Maildir.hs +++ b/Imm/Maildir.hs @@ -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) diff --git a/Imm/Main.hs b/Imm/Main.hs --- a/Imm/Main.hs +++ b/Imm/Main.hs @@ -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) diff --git a/Imm/Types.hs b/Imm/Types.hs --- a/Imm/Types.hs +++ b/Imm/Types.hs @@ -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 { diff --git a/Imm/Util.hs b/Imm/Util.hs --- a/Imm/Util.hs +++ b/Imm/Util.hs @@ -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)) +-- }}} diff --git a/imm.cabal b/imm.cabal --- a/imm.cabal +++ b/imm.cabal @@ -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