packages feed

imm 0.6.0.3 → 1.0.0.0

raw patch · 38 files changed

+1777/−1286 lines, 38 filesdep +HaskellNetdep +HaskellNet-SSLdep +aesondep −asyncdep −conddep −data-defaultdep ~directorydep ~networkdep ~time

Dependencies added: HaskellNet, HaskellNet-SSL, aeson, ansi-wl-pprint, atom-conduit, chunked-data, comonad, compdata, conduit, conduit-combinators, conduit-parse, connection, containers, exceptions, fast-logger, free, hashable, http-client, http-client-tls, mono-traversable, monoid-subclasses, opml-conduit, optparse-applicative, rainbow, rainbox, rss-conduit, uri-bytestring, xml-conduit

Dependencies removed: async, cond, data-default, feed, hslogger, http-conduit, lens, monad-control, mtl, network-uri, old-locale, opml, random, resourcet, text-icu, transformers-base, utf8-string, xdg-basedir

Dependency ranges changed: directory, network, time, timerep, tls

Files

− Imm.hs 
@@ -1,19 +0,0 @@-module Imm (-    module Imm.Boot,-    module Imm.Config,-    module Imm.Feed,-    module Imm.HTTP,-    module Imm.Mail,-    module Imm.Maildir,-    module Imm.OPML,-    module Imm.Util-) where--import Imm.Boot-import Imm.Config-import Imm.Feed-import Imm.HTTP-import Imm.Mail hiding(formatFrom, formatSubject, formatBody)-import Imm.Maildir-import Imm.OPML-import Imm.Util
− Imm/Boot.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE TupleSections #-}-module Imm.Boot (imm, ConfigFeed) where---- {{{ Imports-import qualified Imm.Core as Core-import Imm.Config-import Imm.Database-import Imm.Dyre as Dyre-import qualified Imm.Feed as Feed-import Imm.Options (Action(..))-import qualified Imm.Options as Options-import Imm.Util--import Control.Lens hiding (Action, (??))-import Control.Monad.Error hiding(mapM_, when)--- import Control.Monad.Reader hiding(mapM_, when)-import Control.Monad.Trans.Maybe--import Data.Foldable-import Data.Version--import Network.URI as N--import Paths_imm-import Prelude hiding (mapM_)--import System.Log.Logger-import System.Exit--- }}}--type ConfigFeed = (Config -> Config, String)----- | Main function to call in the configuration file.-imm :: [ConfigFeed] -> IO ()-imm feedsFromConfig = void . runMaybeT $ do-    options <- Options.get-    let dataDir          = view Options.dataDirectory options-        dyreMode         = view Options.dyreMode      options-        feedsFromOptions = view Options.feedsList     options-        logLevel         = view Options.logLevel      options--    action <- handleSpecialActions $ view Options.action options--    io . updateGlobalLogger rootLoggerName $ setLevel logLevel-    io . debugM "imm.options" $ "Commandline options: " ++ show options--    io $ Dyre.wrap dyreMode realMain (action, dataDir, feedsFromOptions, feedsFromConfig)---handleSpecialActions :: Options.Action -> MaybeT IO Feed.Action-handleSpecialActions Help         = io (putStrLn Options.usage) >> mzero-handleSpecialActions ShowVersion  = (io . putStrLn $ showVersion version) >> mzero-handleSpecialActions Recompile    = (io $ Dyre.recompile >>= mapM_ putStrLn) >> mzero-handleSpecialActions Import       = io getContents >>= Core.importOPML >> mzero-handleSpecialActions (Run action) = return action---realMain :: (Feed.Action, Maybe FilePath, [URI], [ConfigFeed]) -> IO ()-realMain (action, dataDir, feedsFromOptions, feedsFromConfig) = do-    unless (null errors)  . errorM   "imm.boot" $ unlines errors-    when   (null feedsOK) $ warningM "imm.boot"   "Nothing to process. Exiting..." >> exitFailure-    -- io . debugM "imm.boot" . unlines $ "Feeds to be processed:":(map (show . snd) feedsOK)--    Core.dispatch baseConfig action feedsOK-  where-    (errors, feedsOK) = validateFeeds feedsFromConfig feedsFromOptions-    baseConfig        = maybe id (set (fileDatabase . directory)) dataDir---validateFeeds :: [ConfigFeed] -> [URI] -> ([String], Core.FeedList)-validateFeeds feedsFromConfig feedsFromOptions = (errors ++ errors', null feedsFromOptions ? feedsOK ?? feedsOK')-  where-    validateFromConfig (x, u) = maybe (Left ("Invalid feed URI: " ++ u)) (Right . (x,)) $ N.parseURI u-    validateFromOptions uri   = maybe (Left ("URI from commandline option has no configuration entry: " ++ show uri)) Right . listToMaybe . filter ((== uri) . snd) $ feedsOK-    (errors,  feedsOK)        = partitionEithers $ map validateFromConfig  feedsFromConfig-    (errors', feedsOK')       = partitionEithers $ map validateFromOptions feedsFromOptions
− Imm/Config.hs 
@@ -1,171 +0,0 @@-{-# LANGUAGE OverlappingInstances, TemplateHaskell #-}-module Imm.Config (--- * Types-    FromFormat(FromFormat),-    SubjectFormat(SubjectFormat),-    BodyFormat(BodyFormat),-    Config,-    maildir,-    fileDatabase,-    dateParsers,-    formatFrom,-    formatSubject,-    formatBody,-    decoder,-    withConfig,--- * Misc-    addFeeds,-) where---- {{{ Imports-import Imm.Database-import Imm.Error-import Imm.Feed (FeedParser)-import qualified Imm.Feed as F-import Imm.Maildir (Maildir, MaildirWriter(..))-import Imm.HTTP (Decoder(..))-import qualified Imm.Mail as Mail-import Imm.Util--import Control.Lens hiding((??))-import Control.Monad.Error hiding(forM_, guard)-import Control.Monad.Reader hiding(forM_, guard)--import Data.Foldable hiding(concat)-import Data.Text.ICU.Convert-import qualified Data.Text.Lazy as TL-import Data.Time as T-import Data.Time.RFC2822-import Data.Time.RFC3339--import Prelude hiding(init)--import Text.Feed.Query as F--- import Text.Feed.Types as F--import System.Directory--- import System.Environment.XDG.BaseDir-import System.Locale--- }}}---- {{{ Types-newtype FromFormat    = FromFormat    { unFromFormat    :: Mail.Format }-newtype SubjectFormat = SubjectFormat { unSubjectFormat :: Mail.Format }-newtype BodyFormat    = BodyFormat    { unBodyFormat    :: Mail.Format }--instance Default FromFormat where-    def = FromFormat $ \(item, feed) -> fromMaybe (getFeedTitle feed) $ getItemAuthor item--instance Default SubjectFormat where-    def = SubjectFormat $ \(item, _feed) -> fromMaybe "Untitled" $ getItemTitle item--instance Default BodyFormat where-    def = BodyFormat $ \(item, _feed) -> let-                                           link        = fromMaybe "No link found." $ getItemLink item-                                           content     = F.getItemContent item-                                           description = fromMaybe "No description." $ getItemDescription item-                                         in "<p>" ++ link ++ "</p><p>" ++ (null content ? description ?? content) ++ "</p>"----- | The only exported constructor is through 'Default' class.-data Config = Config {-    _maildir        :: Maildir,                    -- ^ Where mails will be written-    _fileDatabase   :: FileDatabase,               -- ^ Database configuration, used to store resilient information (basically: last update time)-    _dateParsers    :: [String -> Maybe UTCTime],  -- ^ List of date parsing functions, will be tried sequentially until one succeeds-    _formatFrom     :: FromFormat,                 -- ^ Called to write the From: header of feed mails-    _formatSubject  :: SubjectFormat,              -- ^ Called to write the Subject: header of feed mails-    _formatBody     :: BodyFormat,                 -- ^ Called to write the body of feed mails (sic!)-    _decoder        :: String                      -- ^ 'Converter' name used to decode the HTTP response from a feed URI-}--makeLenses ''Config--instance Default (IO Config) where-    def = do-        theDatabase <- def-        mailDir     <- getHomeDirectory >/> "feeds"-        return Config {-            _maildir       = mailDir,-            _fileDatabase  = theDatabase,-            _dateParsers   = [-                return . zonedTimeToUTC <=< readRFC2822,-                return . zonedTimeToUTC <=< 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"],-            _formatFrom    = def,-            _formatSubject = def,-            _formatBody    = def,-            _decoder       = "UTF-8"-        }--instance (Monad m) => FeedParser (ReaderT Config m) where-    parseDate date = return . listToMaybe . {-map T.zonedTimeToUTC .-} catMaybes =<< tryParsers strippedDate-      where-        tryParsers string = return . map ($ string) =<< asks (view dateParsers)-        strippedDate      = TL.unpack . TL.strip . TL.pack $ date--instance (Applicative m, MonadBase IO m) => Decoder (ReaderT Config m) where-    converter = io . (`open` Nothing) =<< asks (view decoder)--instance (MonadBase IO m) => DatabaseReader (ReaderT Config m) where-    getLastCheck = withReaderT (view fileDatabase) . getLastCheck--instance (MonadError ImmError m, MonadBase IO m) => DatabaseWriter (ReaderT Config m) where-    storeLastCheck uri = withReaderT (view fileDatabase) . storeLastCheck uri-    forget             = withReaderT (view fileDatabase) . forget--instance (MonadBase IO m, MonadError ImmError m) => MaildirWriter (ReaderT Config m) where-    init       = do-        theMaildir <- asks $ view maildir-        lift $ runReaderT init theMaildir-    write mail = do-        theMaildir <- asks $ view maildir-        lift $ runReaderT (write mail) theMaildir--instance (Monad m) => Mail.MailFormatter (ReaderT Config m) where-    formatFrom    = asks $ unFromFormat    . view formatFrom-    formatSubject = asks $ unSubjectFormat . view formatSubject-    formatBody    = asks $ unBodyFormat    . view formatBody---withConfig :: (MonadBase IO m) => (Config -> Config) -> ReaderT Config m a -> m a-withConfig f g = do-    theConfig <- f <$> io def-    runReaderT g theConfig--- }}}----- | Return the Haskell code to write in the configuration file to add feeds.-addFeeds :: (MonadBase IO m) => [(String, [String])] -> m ()-addFeeds feeds = do-    io . putStrLn . unlines $-        "import Imm":-        "import Control.Lens":-        "import System.FilePath":-        "":-        "main :: IO ()":-        "main = imm myFeeds":-        "":-        "maildirRoot = \"/home/<user>/feeds\"   -- TODO: fill <user>":-        "":-        ("myFeeds = concat $ " ++ intercalate ":" (map (map toLower . concat . words . fst) feeds) ++ ":[]"):-        []--    forM_ feeds addFeedsGroup--addFeedsGroup :: (MonadBase IO m) => (String, [String]) -> m ()-addFeedsGroup (groupTitle, uris) = io $ do-    -- guard (not $ null uris)-    putStr . unlines $-        ("-- Group " ++ groupTitle):-        (groupID ++ "Config = set maildir (maildirRoot </> \"" ++ groupID ++ "\")"):-        (groupID ++ "       = zip (repeat " ++ groupID ++ "Config) $"):-        []-    putStr . unlines $ map (\u -> "    " ++ show u ++ ":") uris-    putStrLn "    []"-    putStrLn ""-  where-    groupID = map toLower . concat . words $ groupTitle
− Imm/Core.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}-module Imm.Core (--- * Types-    FeedConfig,-    FeedList,--- * Actions-    dispatch,-    importOPML,-    check,-    showStatus,-    markAsRead,-    markAsUnread,-    update,-) where---- {{{ Imports-import Imm.Config-import Imm.Database-import Imm.Error-import Imm.Feed (FeedParser(..))-import qualified Imm.Feed as Feed-import Imm.Maildir (MaildirWriter(..))-import qualified Imm.Maildir as Maildir-import Imm.Mail (MailFormatter(..))-import qualified Imm.Mail as Mail-import Imm.OPML as OPML-import Imm.Util--import Control.Concurrent.Async-import Control.Monad hiding(forM_, mapM_)-import Control.Monad.Error hiding(forM_, mapM_)--- import Control.Monad.Reader hiding(forM_, mapM_)--import Data.Foldable hiding(foldr)-import Data.Time as T--import Prelude hiding(log, mapM_, sum)--import System.Log.Logger--import Text.Feed.Query as F-import Text.Feed.Types as F--- }}}---- {{{ Types-type FeedConfig = (Config -> Config, FeedID)-type FeedList   = [FeedConfig]--- }}}---dispatch :: (Config -> Config) -> Feed.Action -> FeedList -> IO ()-dispatch baseConfig Feed.Check        feeds = void $ mapConcurrently (check baseConfig) feeds-dispatch baseConfig Feed.ShowStatus   feeds = mapM_ (showStatus baseConfig) feeds-dispatch baseConfig Feed.MarkAsRead   feeds = mapM_ (markAsRead baseConfig) feeds-dispatch baseConfig Feed.MarkAsUnread feeds = mapM_ (markAsUnread baseConfig) feeds-dispatch baseConfig Feed.Update       feeds = void $ mapConcurrently (update baseConfig) feeds---importOPML :: (MonadBase IO m, MonadPlus m) => String -> m ()-importOPML = mapM_ addFeeds . OPML.read---check :: (Config -> Config) -> FeedConfig -> IO ()-check baseConfig (f, feedID) = withError "imm.core". withConfig (f . baseConfig) $ Feed.download feedID >>= Feed.check---showStatus :: (Config -> Config) -> FeedConfig -> IO ()-showStatus baseConfig (f, feedID) = withConfig (f . baseConfig) (io . noticeM "imm.core" =<< Feed.showStatus feedID)---markAsRead :: (Config -> Config) -> FeedConfig -> IO ()-markAsRead baseConfig (f, feedID) = withError "imm.core" . withConfig (f . baseConfig) $ Feed.markAsRead feedID---markAsUnread :: (Config -> Config) -> FeedConfig -> IO ()-markAsUnread baseConfig (f, feedID) = withError "imm.core" . withConfig (f . baseConfig) $ Feed.markAsUnread feedID----- | Write mails for each new item, and update the last check time in state file.-update :: (Config -> Config) -> FeedConfig -> IO ()-update baseConfig (f, feedID) = withError "imm.core" . withConfig (f . baseConfig) $ do-    -- io . noticeM "imm.core" $ "Updating: " ++ show feedID-    (uri, feed) <- Feed.download feedID--    Maildir.init--    io . debugM "imm.core" $ Feed.describe feed--    lastCheck <- getLastCheck uri-    (results :: [Integer]) <- forM (feedItems feed) $ \item -> do-        date <- Feed.getDate item-        (date > lastCheck) ? (updateItem (item, feed) >> return 1) ?? return 0-    io . noticeM "imm.core" $ "==> " ++ show (sum results) ++ " new item(s) for <" ++ show feedID ++ ">"-    Feed.markAsRead uri---updateItem :: (Applicative m, FeedParser m, MaildirWriter m, MailFormatter m, MonadBase IO m, MonadError ImmError m) => (Item, Feed) -> m ()-updateItem (item, feed) = do-    timeZone <- io getCurrentTimeZone-    Maildir.write =<< Mail.build timeZone (item, feed)
− Imm/Database.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE OverlappingInstances, TemplateHaskell #-}-module Imm.Database (-    FeedID,-    DatabaseReader(..),-    DatabaseWriter(..),-    DatabaseState,-    FileDatabase,-    directory,-    getDataFile,-) where---- {{{ Imports-import Imm.Error-import Imm.Util--import Control.Lens-import Control.Monad.Reader-import Control.Monad.Error--import Data.Time hiding(parseTime)-import Data.Time.Clock.POSIX--import Network.URI--import System.Directory-import System.Environment.XDG.BaseDir-import System.FilePath-import System.Locale-import System.IO-import System.Log.Logger--- }}}---- {{{ Types-type FeedID  = URI--class DatabaseReader m where-    -- | Read the last check time in the state file.-    getLastCheck :: FeedID -> m UTCTime--instance (Error e, DatabaseReader m) => DatabaseReader (ErrorT e m) where-    getLastCheck = getLastCheck--class DatabaseWriter m where-    -- | Write the last update time in the data file.-    storeLastCheck :: FeedID -> UTCTime -> m ()-    -- | Remove state file as if no update was ever done.-    forget         :: FeedID -> m ()---type (DatabaseState m) = (DatabaseReader m, DatabaseWriter m)---data FileDatabase = FileDatabase {-    _directory   :: FilePath,-    _getDataFile :: FeedID -> FilePath-}--makeLenses ''FileDatabase---- | A state file stores the last check time for a single feed, identified with its 'URI'.-instance Default (IO FileDatabase) where-    def = do-        dataDir         <- getUserConfigDir "imm" >/> "state"-        return FileDatabase {-            _directory = dataDir,-            _getDataFile = \feedUri -> case uriAuthority feedUri of-                Just auth -> toFileName =<< ((++ uriQuery feedUri) . (++ uriPath feedUri) . uriRegName $ auth)-                _         -> show feedUri >>= toFileName-                }--instance (MonadBase IO m) => DatabaseReader (ReaderT FileDatabase m) where-    getLastCheck feedUri = do-        dataDirectory  <- asks (view directory)-        dataFileGetter <- asks (view getDataFile)--        let dataFile = dataDirectory </> dataFileGetter feedUri-        io . debugM "imm.database" $ "Reading last check time from: " ++ dataFile--        result <- runErrorT $ do-            content <- try $ readFile dataFile-            parseTime content-        either (const $ io (debugM "imm.database" "Unable to read last update time.") >> return timeZero) return result-      where-        timeZero = posixSecondsToUTCTime 0--instance (MonadBase IO m, MonadError ImmError m) => DatabaseWriter (ReaderT FileDatabase m) where-    storeLastCheck feedUri date = do-        dataDirectory  <- asks (view directory)-        dataFileGetter <- asks (view getDataFile)--        let dataFile = dataFileGetter feedUri--        io . debugM "imm.database" $ "Storing last update time [" ++ show date ++ "] at <" ++ dataDirectory </> dataFile ++ ">"-        try . io . createDirectoryIfMissing True $ dataDirectory-        (file, stream) <- try $ openTempFile dataDirectory dataFile-        io $ hPutStrLn stream (formatTime defaultTimeLocale "%c" date)-        io $ hClose stream-        try $ renameFile file (dataDirectory </> dataFile)--    forget uri = do-        dataDirectory  <- asks (view directory)-        dataFileGetter <- asks (view getDataFile)--        let dataFile = dataDirectory </> dataFileGetter uri-        io . debugM "imm.database" $ "Removing data file <" ++ dataFile ++ ">"-        try $ removeFile dataFile--- }}}---- | Remove forbidden characters in a filename.-toFileName :: Char -> String-toFileName '/' = "."-toFileName '?' = "."-toFileName x   = [x]
− Imm/Dyre.hs 
@@ -1,66 +0,0 @@-module Imm.Dyre (-    Mode(..),-    wrap,-    recompile,-) where---- {{{ Imports-import Imm.Util--import Config.Dyre-import Config.Dyre.Compile-import Config.Dyre.Paths--import Control.Monad-import Control.Monad.Trans.Control--import System.IO-import System.Log.Logger--- }}}---- | How dynamic reconfiguration process should behave.--- Default is 'Normal', that is: use custom configuration file and recompile if change detected.-data Mode = Normal | Vanilla | ForceReconfiguration | IgnoreReconfiguration-    deriving(Eq, Show)--instance Default Mode where-    def = Normal---nullMain :: a -> IO ()-nullMain = const $ return ()---- Print various paths used for dynamic reconfiguration-showPaths :: MonadBase IO m => m String-showPaths = io $ do-    (a, b, c, d, e) <- getPaths $ parameters nullMain-    return . unlines $-        ("Current binary:  " ++ a):-        ("Custom binary:   " ++ b):-        ("Config file:     " ++ c):-        ("Cache directory: " ++ d):-        ("Lib directory:   " ++ e):[]---- | Dynamic reconfiguration settings-parameters :: (a -> IO ()) -> Params (Either String a)-parameters main = defaultParams {-    projectName             = "imm",-    showError               = const Left,-    realMain                = main',-    ghcOpts                 = ["-threaded"],-    statusOut               = hPutStrLn stderr,-    includeCurrentDirectory = False}-  where-    main' (Left e)  = putStrLn e-    main' (Right x) = do-        debugM "imm.dyre" =<< showPaths-        main x--wrap :: (MonadBaseControl IO m) => Mode -> (a -> m ()) -> a -> m ()-wrap mode main args = liftBaseWith $ \runInIO -> wrapMain ((parameters (void . runInIO . main)) { configCheck = (mode /= Vanilla) }) $ Right args---- | Launch a recompilation of the configuration file-recompile :: IO (Maybe String)-recompile = do-    customCompile  $ parameters nullMain-    getErrorString $ parameters nullMain
− Imm/Error.hs 
@@ -1,97 +0,0 @@-module Imm.Error (--- * Types-    ImmError(..),-    withError,-    localError,--- * Functions redefinition-    try,-    timeout,-    parseURI,-    parseTime,-) where---- {{{ Imports-import qualified Control.Exception as E-import Imm.Util--import Control.Monad.Error--import qualified Data.Text as T-import Data.Text.Encoding as T-import Data.Text.Encoding.Error-import Data.Time (UTCTime)-import qualified Data.Time as T--import Network.HTTP.Conduit hiding(HandshakeFailed)-import Network.HTTP.Types.Status-import Network.TLS hiding(DecodeError)-import Network.URI (URI)-import qualified Network.URI as N--import System.IO.Error--import Text.Feed.Query-import Text.Feed.Types--import System.Locale-import System.Log.Logger-import qualified System.Timeout as S--- }}}--data ImmError =-    OtherError         String-  | HTTPError          HttpException-  | TLSError           TLSException-  | UnicodeError       UnicodeException-  | ParseUriError      String-  | ParseTimeError     String-  | ParseItemDateError Item-  | ParseFeedError     String-  | IOE                IOError-  | TimeOut--instance Show ImmError where-    show (OtherError e)            = e-    show (HTTPError (StatusCodeException status _headers _cookieJar)) =-        "/!\\ HTTP error: " ++ show (statusCode status) ++ " " ++ (T.unpack . T.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 (ParseItemDateError item) = unlines [-        "/!\\ Cannot parse date from item: ",-        "    title: "       ++ (show $ getItemTitle item),-        "    link:"         ++ (show $ getItemLink item),-        "    publish date:" ++ (show (getItemPublishDate item :: Maybe (Maybe UTCTime))),-        "    date:"         ++ (show $ getItemDate item)]-    show (ParseTimeError raw)      = "/!\\ Cannot parse time: " ++ raw-    show (ParseFeedError raw)      = "/!\\ Cannot parse feed: " ++ raw-    show (IOE e)                   = "/!\\ IO error [" ++ ioeGetLocation e ++ "]: " ++ fromMaybe "" (ioeGetFileName e) ++ " " ++ ioeGetErrorString e-    show TimeOut                   = "/!\\ Process has timed out"--instance Error ImmError where-    strMsg = OtherError---withError :: (Error e, Show e, MonadBase IO m) => String -> ErrorT e m () -> m ()-withError category = runErrorT >=> either (io . errorM category . show) return--localError :: (MonadBase IO m, MonadError ImmError m) => String -> m () -> m ()-localError category f = f `catchError` (io . errorM category . show)---- | Monad-agnostic version of 'Control.Exception.try'-try :: (MonadBase IO m, MonadError ImmError m) => IO a -> m a-try = (io . E.try) >=> either (throwError . IOE) return---- | Monad-agnostic version of 'System.timeout'-timeout :: (MonadBase IO m, MonadError ImmError m) => Int -> IO a -> m a-timeout n f = maybe (throwError TimeOut) (io . return) =<< (io $ S.timeout n (io f))---- | Monad-agnostic version of 'Network.URI.parseURI'-parseURI :: (MonadError ImmError m) => String -> m URI-parseURI uri = maybe (throwError $ ParseUriError uri) return $ N.parseURI uri---- | 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
− Imm/Executable.hs 
@@ -1,6 +0,0 @@---module Executable where--import Imm--main :: IO ()-main = imm []
− Imm/Feed.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE TupleSections #-}-module Imm.Feed where---- {{{ Imports-import Imm.Database-import Imm.Error-import qualified Imm.HTTP as HTTP-import Imm.Util hiding(when)--import Control.Monad.Error---- import qualified Data.ByteString as B--- import qualified Data.ByteString.Lazy as BL-import qualified Data.Text.Lazy as TL-import Data.Time as T hiding(parseTime)-import Data.Time.Clock.POSIX--import Network.URI as N--import qualified Text.Atom.Feed as Atom-import qualified Text.RSS1.Syntax as RSS1-import qualified Text.RSS.Syntax as RSS-import Text.Feed.Import as F-import Text.Feed.Query as F-import Text.Feed.Types as F-import Text.XML.Light.Proc-import Text.XML.Light.Types--import System.Log.Logger--- }}}---- {{{ Types-data Action = Check | ShowStatus | MarkAsRead | MarkAsUnread | Update-    deriving(Eq, Show)--type ImmFeed = (FeedID, Feed)--class FeedParser m where-    parseDate :: String -> m (Maybe UTCTime)--instance (Monad m, Error e, FeedParser m) => FeedParser (ErrorT e m) where-    parseDate = lift . parseDate--- }}}----- | Provide a 'String' representation of the feed type.-showType :: Feed -> String-showType (AtomFeed _) = "Atom"-showType (RSSFeed _)  = "RSS 2.x"-showType (RSS1Feed _) = "RSS 1.x"-showType (XMLFeed _)  = "XML"--describe :: Feed -> String-describe feed = unlines [-    "Type:   " ++ showType feed,-    "Title:  " ++ getFeedTitle feed,-    "Author: " ++ fromMaybe "No author" (getFeedAuthor feed),-    "Home:   " ++ fromMaybe "No home"   (getFeedHome feed)]--describeItem :: Item -> String-describeItem item = unlines [-    "   Item author: " ++ fromMaybe "<empty>" (getItemAuthor item),-    "   Item title:  " ++ fromMaybe "<empty>" (getItemTitle item),-    "   Item URI:    " ++ fromMaybe "<empty>" (getItemLink  item),-    -- "   Item Body:   " ++ (Imm.Mail.getItemContent  item),-    "   Item date:   " ++ fromMaybe "<empty>" (getItemDate item)]---- | Monad-agnostic version of 'Text.Feed.Import.parseFeedString'-parse :: MonadError ImmError m => String -> m Feed-parse x = maybe (throwError $ ParseFeedError x) return $ parseFeedString x----- | Retrieve, decode and parse the given resource as a feed.-download :: (HTTP.Decoder m, MonadBase IO m, MonadError ImmError m) => URI -> m ImmFeed-download uri = do-    io . debugM "imm.feed" $ "Downloading " ++ show uri-    fmap (uri,) . parse . TL.unpack =<< HTTP.get uri---- | Count the list of unread items for given feed.-check :: (FeedParser m, DatabaseReader m, MonadBase IO m, MonadError ImmError m) => ImmFeed -> m ()-check (feedID, feed) = do-    lastCheck       <- getLastCheck feedID-    (errors, dates) <- tryGetDates $ feedItems feed-    let newItems     = filter (> lastCheck) dates--    unless (null errors) . io . errorM "imm.feed" . unlines $ map show errors-    io . noticeM "imm.feed" $ show (length newItems) ++ " new item(s) for <" ++ show feedID ++ ">"-  where-    tryGetDates = fmap partitionEithers . mapM (runErrorT . getDate)---- | Simply set the last check time to now.-markAsRead :: (MonadBase IO m, MonadError ImmError m, DatabaseWriter m) => URI -> m ()-markAsRead uri = do-    io getCurrentTime >>= storeLastCheck uri-    io . noticeM "imm.feed" $ "Feed <" ++ show uri ++ "> marked as read."---- | Simply remove the state file.-markAsUnread ::  (MonadBase IO m, MonadError ImmError m, DatabaseWriter m) => URI -> m ()-markAsUnread uri = do-    forget uri-    io . noticeM "imm.feed" $ "Feed <" ++ show uri ++ "> marked as unread."---- | Return a 'String' describing the last update for a given feed.-showStatus :: (DatabaseReader m, MonadBase IO m) => URI -> m String-showStatus uri = let nullTime = posixSecondsToUTCTime 0 in do-    lastCheck <- getLastCheck uri-    return $ ((lastCheck == nullTime) ? "[NEW] " ?? ("[Last update: "++ show lastCheck ++ "]")) ++ " " ++ show uri----- {{{ Item utilities--- | This function is missing from 'Text.Feed.Query', probably because it is difficult to define where the content is located in a generic way for Atom/RSS 1.x/RSS 2.x feeds.-getItemContent :: Item -> String-getItemContent (AtomItem i) = length theContent < length theSummary ? theSummary ?? theContent-  where-    theContent = fromMaybe "" (extractHtml <$> Atom.entryContent i)-    theSummary = fromMaybe "No content" (Atom.txtToString <$> Atom.entrySummary i)-getItemContent (RSSItem  i) = length theContent < length theDescription ? theDescription ?? theContent-  where-    theContent     = dropWhile isSpace . concatMap concat . map (map cdData . onlyText . elContent) . RSS.rssItemOther $ i-    theDescription = fromMaybe "No description." $ RSS.rssItemDescription i-getItemContent (RSS1Item i) = concat . mapMaybe RSS1.contentValue . RSS1.itemContent $ i-getItemContent item         = fromMaybe "No content." . getItemDescription $ item--getDate :: (FeedParser m, Monad m, MonadError ImmError m) => Item -> m UTCTime-getDate item = maybe (throwError $ ParseItemDateError item) return =<< maybe (return Nothing) parseDate =<< return (getItemDate item)--- }}}---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
− Imm/HTTP.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Imm.HTTP where---- {{{ Imports-import Imm.Error-import Imm.Util--import Control.Exception as E-import Control.Monad.Error hiding(forM_, mapM_)-import Control.Monad.Trans.Resource--import Data.ByteString as B-import Data.ByteString.Lazy as BL-import Data.ByteString.Char8 as BC-import Data.CaseInsensitive-import Data.Text.ICU.Convert-import qualified Data.Text.Lazy as TL--import Network.HTTP.Conduit as H-import Network.URI--- }}}---- {{{ Types-class (Applicative m, Functor m, Monad m) => Decoder m where-    converter :: m Converter-    decode    :: BL.ByteString -> m TL.Text-    decode string = return . TL.fromChunks . (: []) =<< toUnicode <$> converter <*> return strictString-      where-        strictString = B.concat $ BL.toChunks string--instance (Error e, Decoder m) => Decoder (ErrorT e m) where-    converter = lift converter--- }}}---- | Perform an HTTP GET request and return the response body as raw 'ByteString'-getRaw :: (MonadBase IO m, MonadError ImmError m) => URI -> m BL.ByteString-getRaw uri = do-    req <- request $ show uri-    res <- withManager' (httpLbs req)-    return $ responseBody res---- | Same as 'getRaw' with additional decoding-get :: (Decoder m, MonadBase IO m, MonadError ImmError m) => URI -> m TL.Text-get uri = getRaw uri >>= decode---- | Monad-agnostic version of 'withManager'-withManager' :: (MonadError ImmError m, MonadBase IO m) => (Manager -> ResourceT IO b) -> m b-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 :: (MonadBase IO m, MonadError ImmError m) => String -> m Request-parseURL uri = do-    result <- io $ (Right <$> parseUrl uri) `catch` (return . Left . HTTPError)-    either throwError return result---- | Build an HTTP request for given URI-request :: (MonadBase IO m, MonadError ImmError m) => String -> m Request-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 "*/*")]}
− Imm/Mail.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Imm.Mail where---- {{{ Imports-import Imm.Feed as F-import Imm.Util--import Control.Lens hiding(from, (??))-import Control.Monad.Error--import Data.Time-import Data.Time.RFC2822---- import Text.Feed.Query as F-import Text.Feed.Types---- import System.Log.Logger--- }}}---- {{{ Types-data Mail = Mail {-    _returnPath         :: String,-    _date               :: Maybe ZonedTime,-    _from               :: String,-    _subject            :: String,-    _mime               :: String,-    _charset            :: String,-    _contentDisposition :: String,-    _body               :: String-}--makeLenses ''Mail--instance Default Mail where-    def = Mail {-        _charset            = "utf-8",-        _body               = empty,-        _contentDisposition = "inline",-        _date               = Nothing,-        _from               = "imm",-        _mime               = "text/html",-        _subject            = "Untitled",-        _returnPath         = "<imm@noreply>"}--instance Show Mail where-    show mail = unlines [-        "Return-Path: " ++ view returnPath mail,-        maybe "" (("Date: " ++) . showRFC2822) $ view date mail,-        "From: " ++ view from mail,-        "Subject: " ++ view subject mail,-        "Content-Type: " ++ view mime mail ++ "; charset=" ++ view charset mail,-        "Content-Disposition: " ++ view contentDisposition mail,-        "",-        view body mail]---type Format = (Item, Feed) -> String--class MailFormatter m where-    formatFrom    :: m Format-    formatSubject :: m Format-    formatBody    :: m Format--- }}}---- | Build mail from a given feed, using builders functions from 'Settings'.-build :: (Applicative m, MailFormatter m, FeedParser m, Monad m) => TimeZone -> (Item, Feed) -> m Mail-build timeZone (item, feed) = do-    from'    <- formatFrom    <*> return (item, feed)-    subject' <- formatSubject <*> return (item, feed)-    body'    <- formatBody    <*> return (item, feed)-    date'    <- runErrorT' (utcToZonedTime timeZone <$> getDate item)-    return . set date date' . set from from' . set subject subject' . set body body' $ def-  where-    runErrorT' = (return . either (const Nothing) Just) <=< runErrorT
− Imm/Maildir.hs 
@@ -1,53 +0,0 @@-module Imm.Maildir where---- {{{ Imports-import Imm.Error-import Imm.Mail-import Imm.Util--import Control.Monad.Error-import Control.Monad.Reader--import qualified Data.Text.Lazy.IO as T-import qualified Data.Text.Lazy as TL-import Data.Time.Clock.POSIX--import Network.BSD--import System.Directory-import System.FilePath-import System.Log.Logger-import System.Random--- }}}--type Maildir = FilePath--class MaildirWriter m where-    -- | Build a maildir with subdirectories cur, new and tmp.-    init :: m ()-    -- | Add a mail to the maildir-    write  :: Mail -> m ()--instance (MonadBase IO m, MonadError ImmError m) => MaildirWriter (ReaderT Maildir m) where-    init = do-        theMaildir <- ask-        io . debugM "imm.maildir" $ "Creating maildir [" ++ theMaildir ++ "]"-        try . mapM_ (createDirectoryIfMissing True) $-            theMaildir:-            (theMaildir </> "cur"):-            (theMaildir </> "new"):-            (theMaildir </> "tmp"):[]-    write mail = do-        fileName   <- io getUniqueName-        theMaildir <- ask-        io . debugM "imm.maildir" $ "Writing new mail in maildir [" ++ theMaildir ++ "]"-        try $ T.writeFile (theMaildir </> "new" </> fileName) (TL.pack $ show mail)---- | Return an allegedly unique filename; useful to add new mail files in a maildir.-getUniqueName :: MonadBase IO m => m String-getUniqueName = io $ do-    time     <- show <$> getPOSIXTime-    hostname <- getHostName-    rand     <- show <$> (getStdRandom $ randomR (1,100000) :: IO Int)--    return . concat $ time:".":rand:".":hostname:[]
− Imm/OPML.hs 
@@ -1,18 +0,0 @@-module Imm.OPML where---- {{{ Imports-import Text.OPML.Reader-import Text.OPML.Syntax-import Text.XML.Light.Types--- }}}---- | Parse an OPML string and return a list of tuples (category title, feed URIs).-read :: String -> Maybe [(String, [String])]-read rawOPML = do-    opml <- parseOPMLString rawOPML-    let groups     = opmlBody opml-        groupNames = map opmlText groups-        feeds      = opmlOutlineChildren-        feedURI    = concatMap attrVal . filter ((== "xmlUrl") . qName . attrKey) . opmlOutlineAttrs-    -    return $ zip groupNames (map (map feedURI . feeds) groups)
− Imm/Options.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Imm.Options (-    CliOptions,-    action,-    dyreMode,-    feedsList,-    dataDirectory,-    logLevel,-    Action(..),-    get,-    usage,-) where---- {{{ Imports-import Imm.Dyre as Dyre-import qualified Imm.Feed as Feed-import Imm.Util--import Control.Lens as L  hiding(Action, (??))-import Control.Monad.Reader hiding(mapM_, when)--import Data.Foldable--import Network.URI as N--import Prelude hiding(foldl, log, mapM_)--import System.Console.GetOpt-import System.Environment--- import System.Environment.XDG.BaseDir-import System.Log as Log--- }}}---- {{{ Types--- | Mutually exclusive actions.--- Default is 'PrintHelp'.-data Action = Help | ShowVersion | Recompile | Import | Run Feed.Action-    deriving(Eq, Show)--instance Default Action where-    def = Help---- | Available commandline options-data CliOptions = CliOptions {-    _action         :: Action,-    _dyreMode       :: Dyre.Mode,-    _dataDirectory  :: Maybe FilePath,-    _feedsList      :: [URI],-    _logLevel       :: Log.Priority}-    deriving(Eq)--makeLenses ''CliOptions--instance Show CliOptions where-    show opts = unwords $ catMaybes [-        return . ("ACTION=" ++) . show $ view action opts,-        return . ("RECONFIGURATION_MODE=" ++) . show $ view dyreMode opts,-        null (view feedsList opts) ? Nothing ?? Just ("FEED_URI=[" ++ (unwords . map show $ view feedsList opts) ++ "]"),-        return . ("DATA_DIR=" ++) =<< view dataDirectory opts,-        return $ "LOG_LEVEL=" ++ show (view logLevel opts)]--instance Default CliOptions where-    def = CliOptions {-        _action        = def,-        _dyreMode      = def,-        _logLevel      = Log.INFO,-        _dataDirectory = Nothing,-        _feedsList     = []}--- }}}--description :: [OptDescr (CliOptions -> CliOptions)]-description = [--- Action-    Option "c"     ["check"]              (NoArg (set action $ Run Feed.Check))             "Check availability and validity of all feed sources currently configured, without writing any mail",-    Option "l"     ["list"]               (NoArg (set action $ Run Feed.ShowStatus))        "List all feed sources currently configured, along with their status",-    Option "R"     ["mark-read"]          (NoArg (set action $ Run Feed.MarkAsRead))        "Mark every item of processed feeds as read, ie set last update as now without writing any mail",-    Option "U"     ["mark-unread"]        (NoArg (set action $ Run Feed.MarkAsUnread))      "Mark every item of processed feeds as unread, ie delete corresponding state files",-    Option "u"     ["update"]             (NoArg (set action $ Run Feed.Update))            "Update list of feeds (mostly used option)",-    Option "i"     ["import"]             (NoArg (set action Import))                       "Import feeds list from an OPML descriptor (read from stdin)",-    Option "h"     ["help"]               (NoArg (set action Help))                         "Print this help",-    Option "V"     ["version"]            (NoArg (set action ShowVersion))                  "Print version",-    Option "r"     ["recompile"]          (NoArg (set action Recompile))                    "Only recompile configuration",--- Dynamic configuration-    Option "1"     ["vanilla"]            (NoArg (set dyreMode Vanilla))                    "Do not read custom configuration file",-    Option []      ["force-reconf"]       (NoArg (set dyreMode ForceReconfiguration))       "Recompile configuration before starting the program",-    Option []      ["deny-reconf"]        (NoArg (set dyreMode IgnoreReconfiguration))      "Do not recompile configuration even if it has changed",-    Option []      ["dyre-debug"]         (NoArg id)                                        "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program",--- Log level-    Option "q"     ["quiet"]              (NoArg (set logLevel Log.ERROR))                  "Do not print any log",-    Option "v"     ["verbose"]            (NoArg (set logLevel Log.DEBUG))                  "Print detailed logs",--- Misc-    Option "d"     ["database"]           (ReqArg (set dataDirectory . Just) "PATH")        "Where feeds' state (last update time) will be stored"]---- | Usage text (printed when using 'Help' action)-usage :: String-usage = flip usageInfo description . unlines $-    "Usage: imm [OPTIONS] [URI]":-    "":-    "Convert items from RSS/Atom feeds to maildir entries.":-    "If one or more URI(s) are given, they will be processed instead of the feeds list from configuration.":[]---- | Get and parse commandline options-get :: (MonadBase IO m) => m CliOptions-get = io $ do-    parsedArgs <- getOpt' Permute description <$> getArgs-    case parsedArgs of-        (opts, input, _, []) -> do-            let (errors, valids) = partitionEithers $ map parseURI' input-            unless (null errors) $ io . putStrLn $ unlines errors-            return $ set feedsList valids  (foldl (flip id) def opts)-        (_, _, _, _)         -> return def-  where-    parseURI' uri = maybe (Left $ "Invalid URI given in commandline: " ++ uri) Right $ N.parseURI uri
− Imm/Util.hs 
@@ -1,29 +0,0 @@-module Imm.Util (-    module X,-    (>/>),-    io,-) where---- {{{ Imports-import Control.Applicative as X-import Control.Conditional as X hiding(unless)-import Control.Monad.Base as X--import Data.Char as X-import Data.Default as X-import Data.Either as X-import Data.Functor as X-import Data.List as X hiding(foldl, init, sum)-import Data.Maybe as X--import System.FilePath--- }}}----- | Like '</>' with first argument in IO to build platform-dependent paths.-(>/>) :: (MonadBase IO m) => IO FilePath -> FilePath -> m FilePath-(>/>) a b = io $ (</> b) <$> a---- | Shortcut to 'liftBase' with 'IO' as base monad-io :: MonadBase IO m => IO a -> m a-io = liftBase
− README 
@@ -1,58 +0,0 @@-=========-About imm-=========--In a nutshell----------------**Technically**, *imm* is a little tool that retrieves a list of RSS/Atom feeds and fills a maildir with new items.--**Functionally**, *imm* makes it possible to use mail readers for feeds, for the sake of *I-want-the-mutt-of-feed-readers* zealots.--*imm* is written and configured in *Haskell*.--Informations about versions, dependencies, source repositories and contacts can be found in hackage_.---Need & purpose-----------------Following numerous RSS/Atom feeds needs organization and aggregation.-Such needs are usually met by feed readers.-Although there are a lot of those, some people still feel unsatisfied with the existing implementations.--The expected features of a feed reader could be defined as follows:--- it retrieves items with the following attributes: an author, a date/time, a (possibly enriched) body;-- items can be sorted, categorized, marked as read/unread, tagged, shared/forwarded;-- items must be available from anywhere on the internet.--Luckily, there's already a widespread solution that provides such features: mail readers.-Considering that, *imm* aims at projecting the RSS/Atom paradigm onto the mail one; this way, all the existing tools that work on mails can be leveraged to work on RSS/Atom feeds as well, no wheel reinventing.---Function-----------*imm* does only one thing and does it well: it downloads an RSS/Atom feeds list, and for each new item it writes a file in a local maildir. How and where to write mail files is setup in *imm*'s configuration file.--No *SMTP* sending, no *IMAP* serving, no aggregating: those should be performed by external tools.---Example usage----------------It is possible to setup a Google Reader-like on a server using the following steps:--- schedule *imm* to check feeds regularly and write new items into a local maildir;-- setup an IMAP server to publish the aforementioned maildir;-- setup a webmail, bound to the IMAP server above, to read feeds from any computer connected to the internet.---Getting started------------------To get started, please fill the configuration file at ``~/.config/imm/imm.hs`` with your feeds list and settings. An example configuration file is provided with the package. Configuring *imm* requires basic knowledge of *Haskell* language.---.. _hackage: http://hackage.haskell.org/package/imm
+ README.md view
@@ -0,0 +1,28 @@+# imm++## In a nutshell++*imm* is a tool that does only one thing: it retrieves a list of RSS/Atom feeds, and executes arbitrary actions for each of them (e.g. sending a mail).++Notably, *imm* makes it possible to use mail readers for feeds, for the sake of *I-want-the-mutt-of-feed-readers* zealots.++*imm* is written and configured in *Haskell*. To get started, please consult documentation of `Imm.Boot` module.++Informations about versions, dependencies, source repositories and contacts can be found in [hackage][1].+++## Rationale++Following numerous RSS/Atom feeds needs organization and aggregation, which is usually accomplished through feed readers.+Although there are a lot of those, some people still feel unsatisfied with the existing implementations.++The expected features of a feed reader could be defined as follows:++- it retrieves a bunch of items that have some attributes: an author, a date/time, a (possibly enriched) body;+- items can be sorted, categorized, marked as read/unread, tagged, shared/forwarded;+- items must be available from anywhere on the internet.++Luckily, there's already a widespread solution that provides such features: mail readers.+Considering that, *imm* can project the RSS/Atom paradigm onto the mail one; this way, all the existing tools that work on mails can be leveraged to work on RSS/Atom feeds as well, no wheel reinventing.++[1]: http://hackage.haskell.org/package/imm
imm.cabal view
@@ -1,97 +1,51 @@-Name:                imm-Version:             0.6.0.3-Synopsis:            Retrieve RSS/Atom feeds and write one mail per new item in a maildir.-Description:         Cf README---Homepage:-Category:            Web--License:             OtherLicense-License-file:        LICENSE--- Copyright:-Author:              kamaradclimber, koral-Maintainer:          koral att mailoo dott org--Cabal-version:       >=1.8-Build-type:          Simple-Extra-source-files:  README--Source-repository head-    Type:     mercurial-    Location: https://bitbucket.org/k0ral/imm--flag network-uri-   description: Get Network.URI from the network-uri package-   default: True+name:                imm+version:             1.0.0.0+synopsis:            Execute arbitrary actions for each unread element of RSS/Atom feeds+--description:+homepage:            https://github.com/k0ral/imm+license:             OtherLicense+license-file:        LICENSE+author:              kamaradclimber, koral+maintainer:          koral <koral@mailoo.org>+category:            Web+build-type:          Simple+cabal-version:       >=1.8+extra-source-files:  README.md -Library-    Exposed-modules:-        Imm,-        Imm.Boot,-        Imm.Config,-        Imm.Core,-        Imm.Database,-        Imm.Error,-        Imm.Feed,-        Imm.HTTP,-        Imm.Mail,-        Imm.Maildir,-        Imm.Util-    Other-modules:-        Imm.Dyre,-        Imm.OPML,-        Imm.Options,-        Paths_imm-    Build-depends:-        async,-        base == 4.*,-        bytestring,-        case-insensitive,-        cond,-        data-default,-        directory,-        dyre,-        feed == 0.3.9.2,-        filepath,-        hslogger,-        http-conduit >= 2.0 && < 2.2,-        http-types,-        lens,-        mime-mail,-        monad-control,-        mtl,-        resourcet,-        old-locale,-        opml,-        random,-        text,-        text-icu,-        transformers-base,-        transformers,-        time,-        timerep >= 1.0.3,-        tls >= 1.2 && < 1.3,-        utf8-string,-        xdg-basedir,-        xml-    if flag(network-uri)-        build-depends: network-uri >= 2.6, network >= 2.6-    else-        build-depends: network-uri < 2.6, network < 2.6-    Extensions:-        ConstraintKinds,-        KindSignatures,-        FlexibleContexts,-        FlexibleInstances,-        FunctionalDependencies,-        GeneralizedNewtypeDeriving,-        MultiParamTypeClasses,-        RankNTypes+source-repository head+  type:     git+  location: git://github.com/k0ral/imm.git -    -- Build-tools:-    Ghc-options: -Wall+library+  exposed-modules:+    Imm+    Imm.Boot+    Imm.Core+    Imm.Database+    Imm.Database.FeedTable+    Imm.Database.JsonFile+    Imm.Feed+    Imm.Hooks+    Imm.Hooks.SendMail+    Imm.HTTP+    Imm.HTTP.Simple+    Imm.Logger+    Imm.Logger.Simple+    Imm.Prelude+  other-modules:+    Imm.Aeson+    Imm.Dyre+    Imm.Error+    Imm.Options+    Imm.Pretty+    Paths_imm+  build-depends: aeson, atom-conduit, base == 4.*, bytestring, case-insensitive, chunked-data, comonad, compdata, conduit, conduit-combinators, conduit-parse, connection, containers, directory, dyre, directory, exceptions, fast-logger, filepath, free, hashable, HaskellNet, HaskellNet-SSL >= 0.3.3.0, http-client, http-client-tls, http-types, mime-mail, monoid-subclasses, mono-traversable, network, opml-conduit, optparse-applicative, rainbow, rainbox, rss-conduit, text, transformers, time, timerep >= 2.0.0.0, tls, uri-bytestring, xml, xml-conduit, ansi-wl-pprint+  -- Build-tools:+  hs-source-dirs: src/lib+  ghc-options: -Wall -fno-warn-unused-do-bind -Executable imm-    Build-depends: imm, base == 4.*-    Main-is: Executable.hs-    Hs-Source-Dirs: Imm-    Ghc-options: -Wall -threaded+executable imm+  build-depends: imm, base == 4.*, free+  main-is: Executable.hs+  hs-source-dirs: src/bin+  ghc-options: -Wall -fno-warn-unused-do-bind -threaded
+ src/bin/Executable.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+--module Executable where++-- {{{ Imports+import           Imm+import           Imm.Database.JsonFile+import           Imm.Feed+import           Imm.Hooks+import           Imm.HTTP.Simple+import           Imm.Logger.Simple+import           Imm.Prelude++import           System.Exit+-- }}}++mkDummyCoHooks :: (MonadIO m, MonadThrow m) => () -> CoHooksF m ()+mkDummyCoHooks _ = CoHooksF coOnNewElement where+  coOnNewElement _ _ = do+    io $ putStrLn "No hook defined."+    throwM $ ExitFailure 1+++main :: IO ()+main = do+  logger <- defaultLogger+  manager <- defaultManager+  database <- defaultDatabase++  imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (mkDummyCoHooks, ())
+ src/lib/Imm.hs view
@@ -0,0 +1,12 @@+-- | Meta-module that reexports many Imm sub-modules.+--+-- To get started, please consult "Imm.Boot".+module Imm (module X) where++import           Imm.Boot     as X+import           Imm.Core     as X+import           Imm.Database as X+import           Imm.Feed     as X+import           Imm.Hooks    as X+import           Imm.HTTP     as X+import           Imm.Logger   as X
+ src/lib/Imm/Aeson.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Imm.Aeson where++-- {{{ Imports+import           Imm.Prelude++import           Data.Aeson++import           URI.ByteString+-- }}}++parseJsonURI :: (MonadPlus m) => Value -> m URI+parseJsonURI (String s) = either (const mzero) return $ parseURI laxURIParserOptions $ encodeUtf8 s+parseJsonURI _          = mzero++toJsonURI :: URI -> Value+toJsonURI = String . decodeUtf8 . serializeURIRef'
+ src/lib/Imm/Boot.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+module Imm.Boot (imm) where++-- {{{ Imports+import qualified Imm.Core as Core+import Imm.Database.FeedTable as Database+import Imm.Database as Database+import Imm.Dyre as Dyre+import Imm.Feed+import Imm.HTTP as HTTP+import Imm.Hooks+import Imm.Logger as Logger+import Imm.Options as Options hiding(logLevel)+import Imm.Prelude++import Control.Comonad.Cofree+import Control.Monad.Trans.Free++import System.IO (hFlush)+-- }}}++-- | Main function, meant to be used in your personal configuration file,+-- by default located at @$XDG_CONFIG_HOME\/imm\/imm.hs@.+--+-- For more information about the dynamic reconfiguration system, please consult "Config.Dyre".+--+-- Here is an example:+--+-- > import           Imm.Boot+-- > import           Imm.Database.JsonFile+-- > import           Imm.Feed+-- > import           Imm.Hooks.SendMail+-- > import           Imm.HTTP.Simple+-- > import           Imm.Logger.Simple+-- >+-- > main :: IO ()+-- > main = do+-- >   logger <- defaultLogger+-- >   manager <- defaultManager+-- >   database <- defaultDatabase+-- >+-- >   imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (mkCoHooks, sendmail)+-- >+-- > sendmail :: SendMailSettings+-- > sendmail = SendMailSettings smtpServer formatMail+-- >+-- > formatMail :: FormatMail+-- > formatMail = FormatMail+-- >   (\a b -> (defaultFormatFrom a b) { addressEmail = "user@host" } )+-- >   defaultFormatSubject+-- >   defaultFormatBody+-- >   (\_ _ -> [Address Nothing "user@host"])+-- >+-- > smtpServer :: Feed -> FeedElement -> SMTPServer+-- > smtpServer _ _ = SMTPServer+-- >   (Just $ Authentication PLAIN "user" "password")+-- >   (StartTls "smtp.host" defaultSettingsSMTPSTARTTLS)+imm :: (a -> CoHttpClientF IO a, a)  -- ^ HTTP client interpreter (cf "Imm.HTTP")+    -> (b -> CoDatabaseF' IO b, b)  -- ^ Database interpreter (cf "Imm.Database")+    -> (c -> CoLoggerF IO c, c)     -- ^ Logger interpreter (cf "Imm.Logger")+    -> (d -> CoHooksF IO d, d)      -- ^ Hooks interpreter (cf "Imm.Hooks")+    -> IO ()+imm coHttpClient coDatabase coLogger coHooks = void $ do+  options <- parseOptions+  Dyre.wrap (optionDyreMode options) realMain (optionCommand options, optionLogLevel options, coiter next start)+  where (next, start) = mkCoImm coHttpClient coDatabase coLogger coHooks++realMain :: (MonadIO m, PairingM (CoImmF m) ImmF m, MonadCatch m)+         => (Command, LogLevel, Cofree (CoImmF m) a) -> m ()+realMain (command, logLevel, interpreter) = void $ interpret (\_ b -> return b) interpreter $ do+  setLogLevel logLevel+  logDebug $ "Executing: " <> show (pretty command)++  handleAll (logError . fromString . displayException) $ case command of+    Check t        -> Core.check            =<< resolveTarget ByPassConfirmation t+    Import         -> Core.importOPML+    Read t         -> mapM_ Database.markAsRead   =<< resolveTarget AskConfirmation t+    Run t          -> Core.run              =<< resolveTarget ByPassConfirmation t+    Show t         -> Core.showFeed         =<< resolveTarget ByPassConfirmation t+    ShowVersion    -> Core.printVersions+    Subscribe u c  -> Core.subscribe u c+    Unread t       -> mapM_ Database.markAsUnread =<< resolveTarget AskConfirmation t+    Unsubscribe t  -> Database.deleteList FeedTable =<< resolveTarget AskConfirmation t+    _              -> return ()++  Database.commit FeedTable++  return ()++-- * DSL/interpreter model++type CoImmF m = CoHttpClientF m :*: CoDatabaseF' m :*: CoLoggerF m :*: CoHooksF m+type ImmF = HttpClientF :+: DatabaseF' :+: LoggerF :+: HooksF++mkCoImm :: (Functor m)+        => (a -> CoHttpClientF m a, a) -> (b -> CoDatabaseF' m b, b) -> (c -> CoLoggerF m c, c) -> (d -> CoHooksF m d, d)+        -> ((a ::: b ::: c ::: d) -> CoImmF m (a ::: b ::: c ::: d), a ::: b ::: c ::: d)+mkCoImm (coHttpClient, a) (coDatabase, b) (coLogger, c) (coHooks, d) =+  (coHttpClient *:* coDatabase *:* coLogger *:* coHooks, a >: b >: c >: d)+++-- * Util++data SafeGuard = AskConfirmation | ByPassConfirmation+  deriving(Eq, Show)++data InterruptedException = InterruptedException deriving(Eq, Show)+instance Exception InterruptedException where+  displayException _ = "Process interrupted"++promptConfirm :: (MonadIO m, MonadThrow m) => Text -> m ()+promptConfirm s = do+  hPut stdout $ s <> " Confirm [Y/n] "+  io $ hFlush stdout+  x <- getLine+  when (x /= ("" :: Text) && x /= ("Y" :: Text)) $ throwM InterruptedException+++resolveTarget :: (MonadIO m, MonadThrow m, Functor f, MonadFree f m, DatabaseF' :<: f, LoggerF :<: f)+              => SafeGuard -> Maybe Core.FeedRef -> m [FeedID]+resolveTarget s Nothing = do+  result <- keys <$> Database.fetchAll FeedTable+  when (s == AskConfirmation) . promptConfirm $ "This will affect " <> show (length result) <> " feeds."+  return result+resolveTarget _ (Just (FeedRef (Left i))) = do+  result <- fst . (!! i) . mapToList <$> Database.fetchAll FeedTable+  -- logInfo $ "Target(s): " <> show (pretty result)+  return $ singleton result+resolveTarget _ (Just (FeedRef (Right uri))) = return [FeedID uri]
+ src/lib/Imm/Core.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude      #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TupleSections          #-}+{-# LANGUAGE PartialTypeSignatures  #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+module Imm.Core (+-- * Types+    FeedRef,+-- * Actions+    printVersions,+    subscribe,+    showFeed,+    check,+    run,+    importOPML,+) where++-- {{{ Imports+import qualified Imm.Database.FeedTable as Database+import Imm.Database.FeedTable hiding(markAsRead, markAsUnread)+import qualified Imm.Database as Database+import Imm.Feed+import Imm.Hooks as Hooks+import Imm.HTTP (HttpClientF)+import qualified Imm.HTTP as HTTP+import Imm.Logger+import Imm.Prelude+import Imm.Pretty++-- import Control.Concurrent.Async.Lifted (Async, async, mapConcurrently, waitAny)+-- import Control.Concurrent.Async.Pool+import Control.Monad.Free++import qualified Data.ByteString              as ByteString+import Data.Conduit+import Data.Conduit.Combinators as Conduit (stdin)+import Data.Conduit.Parser+import qualified Data.Map as Map+import Data.NonNull+import Data.Set (Set)+import Data.Tree+import           Data.Version++import qualified Paths_imm                      as Package++import Rainbow hiding((<>))+import Rainbox++import           System.Info++import Text.Atom.Conduit.Parse+import Text.Atom.Types+import Text.OPML.Conduit.Parse+import Text.OPML.Types as OPML+import Text.RSS.Conduit.Parse+import Text.RSS.Types+import Text.XML as XML ()+import Text.XML.Stream.Parse as XML++import           URI.ByteString+-- }}}+++printVersions :: (MonadIO m) => m ()+printVersions = io $ do+  putStrLn $ "imm-" ++ showVersion Package.version+  putStrLn $ "compiled by " ++ compilerName ++ "-" ++ showVersion compilerVersion++-- | Print database status for given feed(s)+showFeed :: (MonadIO m, LoggerF :<: f, MonadThrow m, Functor f, MonadFree f m, DatabaseF' :<: f)+         => [FeedID] -> m ()+showFeed feedIDs = do+  feeds <- Database.fetchList FeedTable feedIDs+  if onull feeds then logWarning "No subscription" else putBox $ entryTableToBox feeds++-- | Register the given feed URI in database+subscribe :: (MonadIO m, LoggerF :<: f, Functor f, MonadFree f m, DatabaseF' :<: f, MonadCatch m)+          => URI -> Maybe Text -> m ()+subscribe uri category = Database.register (FeedID uri) $ fromMaybe "default" category++-- | Check for unread elements without processing them+check :: (MonadIO m, MonadCatch m, LoggerF :<: f, Functor f, MonadFree f m, DatabaseF' :<: f, HttpClientF :<: f)+      => [FeedID] -> m ()+check feedIDs = do+  results <- forM (zip ([1..] :: [Int]) feedIDs) $ \(i, f) -> do+    logInfo $ "Checking entry " <> show i <> "/" <> show total <> "..."+    try $ checkOne f++  putBox $ statusTableToBox $ mapFromList $ zip feedIDs results+  where total = length feedIDs++checkOne :: (MonadIO m, MonadCatch m, LoggerF :<: f, Functor f, MonadFree f m, DatabaseF' :<: f, HttpClientF :<: f)+         => FeedID -> m Int+checkOne feedID@(FeedID uri) = do+  body <- HTTP.get uri+  feed <- runConduit $ parseLBS def body =$= runConduitParser ((Left <$> atomFeed) <|> (Right <$> rssDocument))++  case feed of+    Left _ -> logDebug $ "Parsed Atom feed: " <> show (pretty feedID)+    Right _ -> logDebug $ "Parsed RSS feed: " <> show (pretty feedID)++  let dates = either+              (map entryUpdated . feedEntries)+              (mapMaybe itemPubDate . channelItems)+              feed++  logDebug . show . vsep $ either (map prettyEntry . feedEntries) (map prettyItem . channelItems) feed+  status <- Database.getStatus feedID++  return . length $ filter (unread status) dates+  where unread (LastUpdate t1) t2 = t2 > t1+        unread _ _                = True+++run :: (MonadIO m, MonadCatch m, HooksF :<: f, LoggerF :<: f, Functor f, MonadFree f m, DatabaseF' :<: f, HttpClientF :<: f)+    => [FeedID] -> m ()+run feedIDs = forM_ feedIDs $ \feedID@(FeedID uri) -> do+  body <- HTTP.get uri+  feed <- runConduit $ parseLBS def body =$= runConduitParser ((Atom <$> atomFeed) <|> (Rss <$> rssDocument))+  unreadElements <- filterM (fmap not . isRead feedID) $ getElements feed++  logInfo $ show (length unreadElements) <> " unread element(s) for " <> show (pretty feedID)++  forM_ unreadElements $ \element -> do+    onNewElement feed element+    mapM_ (Database.addReadHash feedID) $ getHashes element++  Database.markAsRead feedID+++isRead :: (Functor f, MonadCatch m, DatabaseF' :<: f, MonadFree f m) => FeedID -> FeedElement -> m Bool+isRead feedID element = do+  DatabaseEntry _ _ readHashes lastCheck <- Database.fetch FeedTable feedID+  let matchHash = not $ onull $ (setFromList (getHashes element) :: Set Int) `intersection` readHashes+      matchDate = case (lastCheck, getDate element) of+        (Nothing, _) -> False+        (_, Nothing) -> False+        (Just a, Just b) -> a > b+  return $ matchHash || matchDate++-- | 'subscribe' to all feeds described by the OPML document provided in input (stdin)+importOPML :: (MonadIO m, LoggerF :<: f, Functor f, MonadFree f m, DatabaseF' :<: f, MonadCatch m) => m ()+importOPML = do+  opml <- runConduit $ Conduit.stdin =$= XML.parseBytes def =$= runConduitParser parseOpml+  forM_ (opmlOutlines opml) $ importOPML' mempty++importOPML' :: (MonadIO m, LoggerF :<: f, Functor f, MonadFree f m, DatabaseF' :<: f, MonadCatch m)+            => Maybe Text -> Tree OpmlOutline -> m ()+importOPML' _ (Node (OpmlOutlineGeneric b _) sub) = mapM_ (importOPML' (Just . toNullable $ OPML.text b)) sub+importOPML' c (Node (OpmlOutlineSubscription _ s) _) = subscribe (xmlUri s) c+importOPML' _ _ = return ()+++-- * Boxes++putBox :: (Orientation a, MonadIO m) => Box a -> m ()+putBox = void . io . mapM ByteString.putStr . chunksToByteStrings toByteStringsColors256 . otoList . render++cell :: Text -> Cell+cell a = Cell (singleton $ singleton $ chunk a) top left mempty++type EntryTable = Map FeedID DatabaseEntry++entryTableToBox :: EntryTable -> Box Horizontal+entryTableToBox t = tableByColumns $ Rainbox.intersperse sep $ fromList [col1, col2, col3, col4] where+  result = sortBy (comparing entryURI) $ map snd $ mapToList t+  col1 = fromList $ cell "UID" : map (cell . show) [0..(length result - 1)]+  col2 = fromList $ cell "CATEGORY" : map (cell . entryCategory) result+  col3 = fromList $ cell "LAST CHECK" : map (cell . format . entryLastCheck) result+  col4 = fromList $ cell "FEED URI" : map (cell . show . prettyURI . entryURI) result+  format = maybe "<never>" show+  sep = fromList [separator mempty 1]+++type StatusTable = Map FeedID (Either SomeException Int)++statusTableToBox :: StatusTable -> Box Horizontal+statusTableToBox t = tableByColumns $ Rainbox.intersperse sep $ fromList [col1, col2, col3] where+  result = sortBy (comparing fst) $ Map.toList t+  col1 = fromList $ cell "# UNREAD" : map (cell . either (const "?") show . snd) result+  col2 = fromList $ cell "STATUS" : map (cell . either (fromString . displayException) (const "OK") . snd) result+  col3 = fromList $ cell "FEED" : map (cell . show . pretty . fst) result+  sep = fromList [separator mempty 2]
+ src/lib/Imm/Database.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+-- | DSL/interpreter model for a generic key-value database+module Imm.Database where++-- {{{ Imports+import           Imm.Error+import           Imm.Logger+import           Imm.Prelude++import           Control.Monad.Trans.Free+-- }}}++-- * DSL/interpreter++-- | Generic database table+class (Ord (Key t), Show (Key t), Show (Entry t), Typeable t, Show t, Pretty t, Pretty (Key t), Pretty (Entry t))+  => Table t where+  type Key t :: *+  type Entry t :: *++-- | Database DSL+data DatabaseF t next+  = FetchList t [Key t] (Either SomeException (Map (Key t) (Entry t)) -> next)+  | FetchAll t (Either SomeException (Map (Key t) (Entry t)) -> next)+  | Update t (Key t) (Entry t -> Entry t) (Either SomeException () -> next)+  | InsertList t [(Key t, Entry t)] (Either SomeException () -> next)+  | DeleteList t [Key t] (Either SomeException () -> next)+  | Purge t (Either SomeException () -> next)+  | Commit t (Either SomeException () -> next)+  deriving(Functor)++-- | Database interpreter+data CoDatabaseF t m a = CoDatabaseF+  { fetchListH  :: [Key t] -> m (Either SomeException (Map (Key t) (Entry t)), a)+  , fetchAllH   :: m (Either SomeException (Map (Key t) (Entry t)), a)+  , updateH     :: Key t -> (Entry t -> Entry t) -> m (Either SomeException (), a)+  , insertListH :: [(Key t, Entry t)] -> m (Either SomeException (), a)+  , deleteListH :: [Key t] -> m (Either SomeException (), a)+  , purgeH      :: m (Either SomeException (), a)+  , commitH     :: m (Either SomeException (), a)+  } deriving(Functor)++instance Monad m => PairingM (CoDatabaseF t m) (DatabaseF t) m where+  -- pairM :: (a -> b -> m r) -> f a -> g b -> m r+  pairM p (CoDatabaseF fl _ _ _ _ _ _) (FetchList _ key next) = do+    (result, a) <- fl key+    p a $ next result+  pairM p (CoDatabaseF _ fa _ _ _ _ _) (FetchAll _ next) = do+    (result, a) <- fa+    p a $ next result+  pairM p (CoDatabaseF _ _ u _ _ _ _) (Update _ key f next) = do+    (result, a) <- u key f+    p a $ next result+  pairM p (CoDatabaseF _ _ _ i _ _ _) (InsertList _ rows next) = do+    (result, a) <- i rows+    p a $ next result+  pairM p (CoDatabaseF _ _ _ _ d _ _) (DeleteList _ k next) = do+    (result, a) <- d k+    p a $ next result+  pairM p (CoDatabaseF _ _ _ _ _ p' _) (Purge _ next) = do+    (result, a) <- p'+    p a $ next result+  pairM p (CoDatabaseF _ _ _ _ _ _ c) (Commit _ next) = do+    (result, a) <- c+    p a $ next result+++-- * Exception++data DatabaseException t+  = NotCommitted t+  | NotDeleted t [Key t]+  | NotFound t [Key t]+  | NotInserted t [(Key t, Entry t)]+  | NotPurged t+  | NotUpdated t (Key t)+  | UnableFetchAll t++deriving instance (Eq t, Eq (Key t), Eq (Entry t)) => Eq (DatabaseException t)+deriving instance (Show t, Show (Key t), Show (Entry t)) => Show (DatabaseException t)++instance (Table t, Show (Key t), Show (Entry t), Pretty (Key t), Typeable t) => Exception (DatabaseException t) where+  displayException = show . pretty++instance (Pretty t, Pretty (Key t)) => Pretty (DatabaseException t) where+  pretty (NotCommitted _) = text "Unable to commit database changes."+  pretty (NotDeleted _ x) = text "Unable to delete the following entries in database:" <++> indent 2 (vsep $ map pretty x)+  pretty (NotFound _ x) = text "Unable to find the following entries in database:" <++> indent 2 (vsep $ map pretty x)+  pretty (NotInserted _ x) = text "Unable to insert the following entries in database:" <++> indent 2 (vsep $ map (pretty . fst) x)+  pretty (NotPurged t) = text "Unable to purge database" <+> pretty t+  pretty (NotUpdated _ x) = text "Unable to update the following entry in database:" <++> indent 2 (pretty x)+  pretty (UnableFetchAll _) = text "Unable to fetch all entries from database."+++-- * Primitives++fetch :: (Functor f, MonadFree f m, DatabaseF t :<: f, Table t, MonadThrow m)+      => t -> Key t -> m (Entry t)+fetch t k = do+  results <- liftF . inj $ FetchList t [k] id+  result <- lookup k <$> liftE results+  maybe (throwM $ NotFound t [k]) return result++fetchList :: (Functor f, MonadFree f m, DatabaseF t :<: f, Table t, MonadThrow m)+          => t -> [Key t] -> m (Map (Key t) (Entry t))+fetchList t k = do+  result <- liftF . inj $ FetchList t k id+  liftE result++fetchAll :: (MonadThrow m, Functor f, MonadFree f m, DatabaseF t :<: f, Table t) => t -> m (Map (Key t) (Entry t))+fetchAll t = do+  result <- liftF . inj $ FetchAll t id+  liftE result++update :: (Functor f, MonadFree f m, DatabaseF t :<: f, Table t, MonadThrow m)+       => t -> Key t -> (Entry t -> Entry t) -> m ()+update t k f = do+  result <- liftF . inj $ Update t k f id+  liftE result++insert :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f, Table t)+       => t -> Key t -> Entry t -> m ()+insert t k v = insertList t [(k, v)]++insertList :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f, Table t)+           => t -> [(Key t, Entry t)] -> m ()+insertList t i = do+  logInfo $ "Inserting " <> show (length i) <> " entrie(s)..."+  result <- liftF . inj $ InsertList t i id+  liftE result++delete :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f, Table t) => t -> Key t -> m ()+delete t k = deleteList t [k]++deleteList :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f, Table t)+           => t -> [Key t] -> m ()+deleteList t k = do+  logInfo $ "Deleting " <> show (length k) <> " entrie(s)..."+  result <- liftF . inj $ DeleteList t k id+  liftE result++purge :: (MonadThrow m, Functor f, MonadFree f m, DatabaseF t :<: f, LoggerF :<: f, Table t) => t -> m ()+purge t = do+  logInfo "Purging database..."+  result <- liftF . inj $ Purge t id+  liftE result++commit :: (MonadThrow m, Functor f, MonadFree f m, DatabaseF t :<: f, LoggerF :<: f, Table t) => t -> m ()+commit t = do+  logDebug "Committing database transaction..."+  result <- liftF . inj $ Commit t id+  liftE result+  logDebug "Database transaction committed"
+ src/lib/Imm/Database/FeedTable.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies     #-}+{-# LANGUAGE TypeOperators     #-}+-- | Feed table definitions. This is a specialization of "Imm.Database".+module Imm.Database.FeedTable where++-- {{{ Imports+import Imm.Aeson+import Imm.Database+import           Imm.Logger+import Imm.Prelude+import Imm.Pretty++import Control.Monad.Trans.Free++import           Data.Aeson+import           Data.Set (Set)+import           Data.Time           as Time++import URI.ByteString+-- }}}++-- * Types++-- | Unique key in feeds table+newtype FeedID = FeedID URI+  deriving(Eq, Ord, Show)++instance FromJSON FeedID where+  parseJSON = fmap FeedID . parseJsonURI++instance ToJSON FeedID where+  toJSON (FeedID uri) = toJsonURI uri++instance Pretty FeedID where+  pretty (FeedID uri) = prettyURI uri+++data DatabaseEntry = DatabaseEntry+  { entryURI         :: URI+  , entryCategory    :: Text+  , entryReadHashes  :: Set Int+  , entryLastCheck   :: Maybe UTCTime+  } deriving(Eq, Show)++instance Pretty DatabaseEntry where+  pretty r = text "Entry:" <+> prettyURI (entryURI r) <++> indent 2+    ( text "Category:" <+> text (fromText $ entryCategory r)+    <++> text "Last check:" <+> text (maybe "<never>" (formatTime defaultTimeLocale rfc822DateFormat) $ entryLastCheck r)+    <++> text "Read hashes:" <+> text (show $ length $ entryReadHashes r)+    )++instance FromJSON DatabaseEntry where+  parseJSON (Object v) = DatabaseEntry <$> (parseJsonURI =<< v .: "uri") <*> v .: "category" <*> v.: "readHashes" <*> v .: "lastCheck"+  parseJSON _          = mzero++instance ToJSON DatabaseEntry where+  toJSON entry = object+    [ "uri"        .= toJsonURI (entryURI entry)+    , "category"   .= entryCategory entry+    , "readHashes" .= entryReadHashes entry+    , "lastCheck"  .= entryLastCheck entry+    ]++newDatabaseEntry :: FeedID -> Text -> DatabaseEntry+newDatabaseEntry (FeedID uri) category = DatabaseEntry uri category mempty Nothing++-- | Singleton type to represent feeds table+data FeedTable = FeedTable+  deriving(Show)++instance Pretty FeedTable where+  pretty _ = "Feeds table"++instance Table FeedTable where+  type Key FeedTable = FeedID+  type Entry FeedTable = DatabaseEntry+++data FeedStatus = Unknown | New | LastUpdate UTCTime++instance Pretty FeedStatus where+  pretty Unknown        = text "Unknown"+  pretty New            = text "New"+  pretty (LastUpdate x) = text "Last update:" <+> text (formatTime defaultTimeLocale rfc822DateFormat x)+++data Database = Database [DatabaseEntry]+  deriving (Eq, Show)++type DatabaseF' = DatabaseF FeedTable+type CoDatabaseF' = CoDatabaseF FeedTable++-- * Primitives++register :: (MonadThrow m, LoggerF :<: f, DatabaseF' :<: f, Functor f, MonadFree f m)+          => FeedID -> Text -> m ()+register feedID category = do+  logInfo $ "Registering feed " <> show (brackets $ pretty feedID) <> "..."+  insert FeedTable feedID $ newDatabaseEntry feedID category++getStatus :: (DatabaseF' :<: f, Functor f, MonadFree f m, MonadCatch m)+          => FeedID -> m FeedStatus+getStatus feedID = handleAll (\_ -> return Unknown) $ do+  result <- fmap Just (fetch FeedTable feedID) `catchAll` (\_ -> return Nothing)+  return $ maybe New LastUpdate $ entryLastCheck =<< result++addReadHash :: (DatabaseF' :<: f, Functor f, MonadFree f m, MonadThrow m, LoggerF :<: f)+               => FeedID -> Int -> m ()+addReadHash feedID hash = do+  logDebug $ "Adding read hash: " <> show hash <> "..."+  update FeedTable feedID f+  where f a = a { entryReadHashes = insertSet hash $ entryReadHashes a }++-- | Set the last check time to now+markAsRead :: (MonadIO m, DatabaseF' :<: f, Functor f, MonadFree f m, MonadThrow m, LoggerF :<: f)+           => FeedID -> m ()+markAsRead feedID = do+  logInfo $ "Marking feed as read: " <> show (pretty feedID) <> "..."+  currentTime <- io Time.getCurrentTime+  update FeedTable feedID (f currentTime)+  where f time a = a { entryLastCheck = Just time }++-- | Unset feed's last update and remove all read hashes+markAsUnread ::  (DatabaseF' :<: f, Functor f, MonadFree f m, MonadThrow m, LoggerF :<: f)+             => FeedID -> m ()+markAsUnread feedID = do+  logInfo $ "Marking feed as unread: " <> show (pretty feedID) <> "..."+  update FeedTable feedID $ \a -> a { entryReadHashes = mempty, entryLastCheck = Nothing }
+ src/lib/Imm/Database/JsonFile.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedLists       #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}+-- | Database interpreter based on a JSON file+module Imm.Database.JsonFile (module Imm.Database.JsonFile, module Reexport) where++-- {{{ Imports+import           Imm.Database           hiding (commit, delete, fetchAll,+                                         insert, purge, update)+import           Imm.Database.FeedTable as Reexport+import           Imm.Error+import           Imm.Prelude            hiding (catch, delete, keys)++import           Data.Aeson+import qualified Data.Map               as Map+import qualified Data.Set               as Set++import           System.Directory+import           System.FilePath+import           System.IO              (IOMode (..), openFile)+-- }}}++-- * Types++data CacheStatus = Empty | Clean | Dirty+  deriving(Eq, Show)++data JsonFileDatabase t = JsonFileDatabase FilePath (Map (Key t) (Entry t)) CacheStatus++instance Pretty (JsonFileDatabase t) where+  pretty (JsonFileDatabase file _ _) = "JSON database: " <+> text file++mkJsonFileDatabase :: (Table t) => FilePath -> JsonFileDatabase t+mkJsonFileDatabase file = JsonFileDatabase file mempty Empty++-- | Default database is stored in @$XDG_DATA_HOME\/imm\/feeds.json@+defaultDatabase :: Table t => IO (JsonFileDatabase t)+defaultDatabase = mkJsonFileDatabase <$> getXdgDirectory XdgData "imm/feeds.json"+++data JsonException = UnableDecode+  deriving(Eq, Show)++instance Exception JsonException where+  displayException _ = "Unable to parse JSON"+++-- * Interpreter++-- | Interpreter for 'DatabaseF'+mkCoDatabase :: (Table t, FromJSON (Key t), FromJSON (Entry t), ToJSON (Key t), ToJSON (Entry t), MonadIO m, MonadCatch m)+             => JsonFileDatabase t -> CoDatabaseF t m (JsonFileDatabase t)+mkCoDatabase t = CoDatabaseF coFetch coFetchAll coUpdate coInsert coDelete coPurge coCommit where+  coFetch keys = do+    (cache, t') <- coFetchAll+    let result = fmap (Map.filterWithKey (\uri _ -> member uri $ Set.fromList keys)) cache+    return (result, t')+  coFetchAll = handleAll (\e -> return (Left e, t)) $ do+    t'@(JsonFileDatabase _ cache _) <- loadInCache t+    return (Right cache, t')+  coUpdate key f = exec (\a -> update a key f)+  coInsert rows = exec (`insert` rows)+  coDelete keys = exec (`delete` keys)+  coPurge = exec purge+  coCommit = exec commit+  exec f = handleAll (\e -> return (Left e, t)) $ (Right (),) <$> f t+++-- * Low-level implementation++loadInCache :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))+            => JsonFileDatabase t -> m (JsonFileDatabase t)+loadInCache t@(JsonFileDatabase file _ status) = case status of+  Empty -> do+    io $ createDirectoryIfMissing True $ takeDirectory file+    fileContent <- hGetContents =<< io (openFile file ReadWriteMode)+    cache <- (`failWith` UnableDecode) $ fmap Map.fromList $ decode $ fromEmpty "[]" fileContent+    return $ JsonFileDatabase file cache Clean+  _ -> return t+  where fromEmpty x "" = x+        fromEmpty _ y = y+++insert :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))+       => JsonFileDatabase t -> [(Key t, Entry t)] -> m (JsonFileDatabase t)+insert t rows = insertInCache rows <$> loadInCache t++insertInCache :: Table t => [(Key t, Entry t)] -> JsonFileDatabase t -> JsonFileDatabase t+insertInCache rows (JsonFileDatabase file cache _) = JsonFileDatabase file (Map.union cache $ Map.fromList rows) Dirty+++update :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))+       => JsonFileDatabase t -> Key t -> (Entry t -> Entry t) -> m (JsonFileDatabase t)+update t key f = updateInCache key f <$> loadInCache t++updateInCache :: Table t => Key t -> (Entry t -> Entry t) -> JsonFileDatabase t -> JsonFileDatabase t+updateInCache key f (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where+  newCache = Map.update (Just . f) key cache++delete :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))+       => JsonFileDatabase t -> [Key t] -> m (JsonFileDatabase t)+delete t keys = deleteInCache keys <$> loadInCache t++deleteInCache :: Table t => [Key t] -> JsonFileDatabase t -> JsonFileDatabase t+deleteInCache keys (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where+  newCache = foldr Map.delete cache keys++purge :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))+      => JsonFileDatabase t -> m (JsonFileDatabase t)+purge t = purgeInCache <$> loadInCache t++purgeInCache :: Table t => JsonFileDatabase t -> JsonFileDatabase t+purgeInCache (JsonFileDatabase file _ _) = JsonFileDatabase file mempty Dirty++commit :: (Table t, MonadIO m, ToJSON (Key t), ToJSON (Entry t))+       => JsonFileDatabase t -> m (JsonFileDatabase t)+commit t@(JsonFileDatabase file cache status) = case status of+  Dirty -> do+    writeFile file $ encode $ Map.toList cache+    return $ JsonFileDatabase file cache Clean+  _ -> return t
+ src/lib/Imm/Dyre.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TypeFamilies      #-}+module Imm.Dyre+  ( Mode(..)+  , defaultMode+  , wrap+  , recompile+  ) where++-- {{{ Imports+import           Imm.Prelude++import           Config.Dyre+import           Config.Dyre.Compile+import           Config.Dyre.Paths+-- }}}++-- | How dynamic reconfiguration process should behave.+data Mode = Normal | Vanilla | ForceReconfiguration | IgnoreReconfiguration+  deriving(Eq, Show)++-- | Default mode is 'Normal', that is: use custom configuration file and recompile if change detected.+defaultMode :: Mode+defaultMode = Normal+++-- | Describe the paths used for dynamic reconfiguration+describePaths :: (IsString t, MonadIO m) => m t+describePaths = io $ do+  (a, b, c, d, e) <- getPaths baseParameters+  return $ fromString $ unlines+    [ "Current binary:  " <> a+    , "Custom binary:   " <> b+    , "Config file:     " <> c+    , "Cache directory: " <> d+    , "Lib directory:   " <> e+    ]++-- | Dynamic reconfiguration settings+parameters :: Mode -> (a -> IO ()) -> Params (Either Text a)+parameters mode main = baseParameters+    { configCheck = mode /= Vanilla+    , realMain = main'+    }+  where+    main' (Left e)  = hPutStrLn stderr e+    main' (Right x) = main x+        -- logDebugN . ("Dynamic reconfiguration paths:\n" ++) =<< describePaths++baseParameters :: Params (Either Text a)+baseParameters = defaultParams+  { projectName             = "imm"+  , showError               = const (Left . fromString)+  , ghcOpts                 = ["-threaded"]+  , statusOut               = hPutStrLn stderr+  , includeCurrentDirectory = False+  }++wrap :: Mode -> (a -> IO ()) -> a -> IO ()+wrap mode result args = wrapMain (parameters mode result) (Right args)+++-- | Launch a recompilation of the configuration file+recompile :: (MonadIO m) => m (Maybe Text)+recompile = io $ do+  customCompile baseParameters+  fmap fromString <$> getErrorString baseParameters
+ src/lib/Imm/Error.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Imm.Error (module Imm.Error) where++-- {{{ Imports+import           Imm.Prelude+-- }}}++liftE :: (MonadThrow m, Exception e) => Either e a -> m a+liftE (Left e) = throwM e+liftE (Right a) = return a++-- | Wrap a 'Maybe' value in 'MonadError'+failWith, (<!>) :: (MonadThrow m, Exception e) => Maybe a -> e -> m a+failWith x e = maybe (throwM e) return x+(<!>) = failWith
+ src/lib/Imm/Feed.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- | Helpers to manipulate feeds+module Imm.Feed where++-- {{{ Imports+import           Imm.Prelude+import           Imm.Pretty++import           Data.Hashable+import           Data.NonNull+import           Data.Time++import           Text.Atom.Types+import           Text.RSS.Types++import           URI.ByteString+-- }}}++-- * Types++-- | Feed reference: either its URI, or its UID from database+newtype FeedRef = FeedRef (Either Int URI)+  deriving(Eq, Show)++instance Pretty FeedRef where+  pretty (FeedRef (Left n))  = text "feed" <+> text (show n)+  pretty (FeedRef (Right u)) = prettyURI u++data Feed = Rss RssDocument | Atom AtomFeed+  deriving(Eq, Show)++data FeedElement = RssElement RssItem | AtomElement AtomEntry+  deriving(Eq, Show)+++-- * Generic getters++getElements :: Feed -> [FeedElement]+getElements (Rss doc) = map RssElement $ channelItems doc+getElements (Atom feed) = map AtomElement $ feedEntries feed++getDate :: FeedElement -> Maybe UTCTime+getDate (RssElement item) = itemPubDate item+getDate (AtomElement entry) = Just $ entryUpdated entry++getTitle :: FeedElement -> Text+getTitle (RssElement item) = itemTitle item+getTitle (AtomElement entry) = show $ prettyAtomText $ entryTitle entry++getHashes :: FeedElement -> [Int]+getHashes (RssElement item) = map (hash . (show :: Doc -> String) . prettyGuid) (maybeToList $ itemGuid item)+  <> map ((hash :: String -> Int) . show . withRssURI prettyURI) (maybeToList $ itemLink item)+  <> [hash $ itemTitle item]+  <> [hash $ itemDescription item]+getHashes (AtomElement entry) = [hash $ toNullable $ entryId entry, (hash :: String -> Int) $ show $ prettyAtomText $ entryTitle entry]
+ src/lib/Imm/HTTP.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeOperators         #-}+-- | DSL/interpreter model for the HTTP client+module Imm.HTTP where++-- {{{ Imports+import           Imm.Error+import           Imm.Logger+import           Imm.Prelude+import           Imm.Pretty++import           Control.Monad.Trans.Free++import           URI.ByteString+-- }}}++-- * Types++-- | HTTP client DSL+data HttpClientF next+  = Get URI (Either SomeException LByteString -> next)+  deriving(Functor)++-- | HTTP client interpreter+data CoHttpClientF m a = CoHttpClientF+  { getH :: URI -> m (Either SomeException LByteString, a)+  } deriving(Functor)++instance Monad m => PairingM (CoHttpClientF m) HttpClientF m where+  -- pairM :: (a -> b -> m r) -> f a -> g b -> m r+  pairM p (CoHttpClientF g) (Get uri next) = do+    (result, a) <- g uri+    p a $ next result++-- * Primitives++-- | Perform an HTTP GET request+get :: (MonadFree f m, Functor f, HttpClientF :<: f, LoggerF :<: f, MonadThrow m)+    => URI -> m LByteString+get uri = do+  logDebug $ "Fetching " <> show (prettyURI uri)+  result <- liftF . inj $ Get uri id+  liftE result
+ src/lib/Imm/HTTP/Simple.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Simple HTTP client interpreter.+-- For more information, please consult "Network.HTTP.Client".+module Imm.HTTP.Simple (defaultManager, mkCoHttpClient, module Reexport) where++-- {{{ Imports+import           Imm.HTTP+import           Imm.Prelude+import           Imm.Pretty++import           Data.CaseInsensitive++import           Network.Connection      as Reexport+import           Network.HTTP.Client     as Reexport+import           Network.HTTP.Client.TLS as Reexport++import           URI.ByteString+-- }}}++-- | Interpreter for 'HttpClientF'+mkCoHttpClient :: (MonadIO m, MonadCatch m) => Manager -> CoHttpClientF m Manager+mkCoHttpClient manager = CoHttpClientF coGet where+  coGet uri = handleAll (\e -> return (Left e, manager)) $ do+    result <- httpGet manager uri+    return (Right result, manager)++-- | Default manager uses TLS and no proxy+defaultManager :: IO Manager+defaultManager = newManager $ mkManagerSettings (TLSSettingsSimple False False False) Nothing+++-- | Perform an HTTP GET request and return the response body+httpGet :: (MonadIO m, MonadThrow m)+    => Manager -> URI -> m LByteString+httpGet manager uri = do+  request <- makeRequest uri+  responseBody <$> io (httpLbs request manager)+    -- codec'   <- reader $ view (config.codec)+    -- return $ response $=+ decode codec'++parseUrl' :: (MonadThrow m) => URI -> m Request+parseUrl' = parseUrl . show . prettyURI++-- | Build an HTTP request for given URI+makeRequest :: (MonadIO m, MonadThrow m) => URI -> m Request+makeRequest uri = do+  req <- parseUrl' uri+  return $ req { requestHeaders = [+    (mk "User-Agent", "Mozilla/4.0"),+    (mk "Accept", "*/*")]}
+ src/lib/Imm/Hooks.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeOperators         #-}+-- | DSL/interpreter model for hooks, ie various events that can trigger arbitrary actions+module Imm.Hooks where++-- {{{ Imports+import           Imm.Feed+import           Imm.Logger+import           Imm.Prelude++import           Control.Monad.Free.Class+-- }}}++-- * Types++-- | Hooks DSL+data HooksF next+  = OnNewElement Feed FeedElement next+  deriving(Functor)++-- | Hooks interpreter+data CoHooksF m a = CoHooksF+  { onNewElementH :: Feed -> FeedElement -> m a  -- ^ Triggered for each unread feed element+  } deriving(Functor)++instance Monad m => PairingM (CoHooksF m) HooksF m where+  -- pairM :: (a -> b -> m r) -> f a -> g b -> m r+  pairM p (CoHooksF f) (OnNewElement feed element next) = do+    a <- f feed element+    p a next++-- * Primitives++onNewElement :: (Functor f, MonadFree f m, LoggerF :<: f, HooksF :<: f) => Feed -> FeedElement -> m ()+onNewElement feed element = do+  logDebug $ "Unread element: " <> getTitle element+  liftF . inj $ OnNewElement feed element ()
+ src/lib/Imm/Hooks/SendMail.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}+-- | Hooks interpreter that sends a mail via a SMTP server for each unread element+-- You may want to consult "Network.HaskellNet.SMTP", "Network.HaskellNet.SMTP.SSL" and "Network.Mail.Mime" modules for additional information.+--+-- Here is an example configuration:+--+-- > sendmail :: SendMailSettings+-- > sendmail = SendMailSettings smtpServer formatMail+-- >+-- > formatMail :: FormatMail+-- > formatMail = FormatMail+-- >   (\a b -> (defaultFormatFrom a b) { addressEmail = "user@host" } )+-- >   defaultFormatSubject+-- >   defaultFormatBody+-- >   (\_ _ -> [Address Nothing "user@host"])+-- >+-- > smtpServer :: Feed -> FeedElement -> SMTPServer+-- > smtpServer _ _ = SMTPServer+-- >   (Just $ Authentication PLAIN "user" "password")+-- >   (StartTls "smtp.server" defaultSettingsSMTPSTARTTLS)+--+module Imm.Hooks.SendMail (module Imm.Hooks.SendMail, module Reexport) where++-- {{{ Imports+import           Imm.Feed+import           Imm.Hooks+import           Imm.Prelude+import           Imm.Pretty++import           Data.NonNull+import           Data.Time++import           Network.HaskellNet.SMTP     as Reexport+import           Network.HaskellNet.SMTP.SSL as Reexport+import           Network.Mail.Mime           as Reexport hiding (sendmail)+import           Network.Socket++import           Text.Atom.Types+import           Text.RSS.Types+-- }}}++-- * Settings++type Username = String+type Password = String+type ServerName = String++-- | How to connect to the SMTP server+data ConnectionSettings = Plain ServerName PortNumber | Ssl ServerName Settings | StartTls ServerName Settings+  deriving(Eq, Show)++-- | How to authenticate to the SMTP server+data Authentication = Authentication AuthType Username Password+  deriving(Eq, Show)++data SMTPServer = SMTPServer (Maybe Authentication) ConnectionSettings+  deriving (Eq, Show)++-- | How to format outgoing mails from feed elements+data FormatMail = FormatMail+  { formatFrom    :: Feed -> FeedElement -> Address    -- ^ How to write the From: header of feed mails+  , formatSubject :: Feed -> FeedElement -> Text       -- ^ How to write the Subject: header of feed mails+  , formatBody    :: Feed -> FeedElement -> Text       -- ^ How to write the body of feed mails (sic!)+  , formatTo      :: Feed -> FeedElement -> [Address]  -- ^ How to write the To: header of feed mails+  }++data SendMailSettings = SendMailSettings (Feed -> FeedElement -> SMTPServer) FormatMail+++-- * Interpreter++-- | Interpreter for 'HooksF'+mkCoHooks :: (MonadIO m) => SendMailSettings -> CoHooksF m SendMailSettings+mkCoHooks a@(SendMailSettings connectionSettings formatMail) = CoHooksF coOnNewElement where+  coOnNewElement feed element = do+    timezone <- io getCurrentTimeZone+    currentTime <- io getCurrentTime+    let mail = buildMail formatMail currentTime timezone feed element+    io $ withSMTPConnection (connectionSettings feed element) $ sendMimeMail2 mail+    return a++-- | Fill 'addressName' with the feed title and, if available, the authors' names.+--+-- This function leaves 'addressEmail' empty. You are expected to fill it adequately, because many SMTP servers enforce constraints on the From: email.+defaultFormatFrom :: Feed -> FeedElement -> Address+defaultFormatFrom (Rss doc) (RssElement item) = Address (Just $ channelTitle doc <> " (" <> itemAuthor item <> ")") ""+defaultFormatFrom (Atom feed) (AtomElement entry) = Address (Just $ title <> " (" <> authors <> ")") ""+  where title = show . prettyAtomText $ feedTitle feed+        authors = intercalate ", " $ map (toNullable . personName) $ entryAuthors entry <> feedAuthors feed+defaultFormatFrom _ _ = Address (Just "Unknown") ""++-- | Fill mail subject with the element title+defaultFormatSubject :: Feed -> FeedElement -> Text+defaultFormatSubject _ (RssElement item) = itemTitle item+defaultFormatSubject _ (AtomElement entry) = show . prettyAtomText $ entryTitle entry++-- | Fill mail body with:+--+-- - a list of links associated to the element+-- - the element's content or description/summary+defaultFormatBody :: Feed -> FeedElement -> Text+defaultFormatBody _ (RssElement item) = "<p>" <> maybe "<no link>" (withRssURI (show . prettyURI)) (itemLink item) <> "</p><p>" <> itemDescription item <> "</p>"+defaultFormatBody _ (AtomElement entry) = "<p>" <> intercalate "<br/>" links <> "</p><p>" <> fromMaybe "<empty>" (content <|> summary) <> "</p>"+  where links   = map (withAtomURI (show . prettyURI) . linkHref) $ entryLinks entry+        content = show . prettyAtomContent <$> entryContent entry+        summary = show . prettyAtomText <$> entrySummary entry+++-- * Low-level helpers++authenticate_ :: SMTPConnection -> Authentication -> IO Bool+authenticate_ connection (Authentication t u p) = do+  result <- authenticate t u p connection+  unless result $ putStrLn "Authentication failed"+  return result++withSMTPConnection :: SMTPServer -> (SMTPConnection -> IO a) -> IO a+withSMTPConnection (SMTPServer authentication (Plain server port)) f =+  doSMTPPort server port $ \connection -> do+    forM_ authentication (authenticate_ connection)+    f connection+withSMTPConnection (SMTPServer authentication (Ssl server settings)) f =+  doSMTPSSLWithSettings server settings $ \connection -> do+    forM_ authentication (authenticate_ connection)+    f connection+withSMTPConnection (SMTPServer authentication (StartTls server settings)) f =+  doSMTPSTARTTLSWithSettings server settings $ \connection -> do+    forM_ authentication (authenticate_ connection)+    f connection++-- | Build mail from a given feed+buildMail :: FormatMail -> UTCTime -> TimeZone -> Feed -> FeedElement -> Mail+buildMail format currentTime timeZone feed element =+  let date = formatTime defaultTimeLocale "%a, %e %b %Y %T %z" $ utcToZonedTime timeZone $ fromMaybe currentTime $ getDate element+  in Mail+    { mailFrom = formatFrom format feed element+    , mailTo   = formatTo format feed element+    , mailCc   = []+    , mailBcc  = []+    , mailHeaders =+        [ ("Return-Path", "<imm@noreply>")+        , ("Date", fromString date)+        , ("Subject", formatSubject format feed element)+        , ("Content-disposition", "inline")+        ]+    , mailParts = [[htmlPart $ fromStrict $ formatBody format feed element]]+    }
+ src/lib/Imm/Logger.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeOperators         #-}+-- | DSL/interpreter model for the logger+module Imm.Logger where++-- {{{ Imports+import           Imm.Prelude++import           Control.Monad.Trans.Free++-- import           Text.PrettyPrint.ANSI.Leijen+-- }}}++-- * Types++data LogLevel = Debug | Info | Warning | Error+  deriving(Eq, Ord, Read, Show)++instance Pretty LogLevel where+  pretty Debug = text "DEBUG"+  pretty Info = text "INFO"+  pretty Warning = text "WARNING"+  pretty Error = text "ERROR"++-- | Logger DSL+data LoggerF next+  = Log LogLevel Text next+  | GetLevel (LogLevel -> next)+  | SetLevel LogLevel next+  deriving(Functor)++-- | Logger interpreter+data CoLoggerF m a = CoLoggerF+  { logH      :: LogLevel -> Text -> m a+  , getLevelH :: m (LogLevel, a)+  , setLevelH :: LogLevel -> m a+  } deriving(Functor)++instance Monad m => PairingM (CoLoggerF m) LoggerF m where+  -- pairM :: (a -> b -> m r) -> f a -> g b -> m r+  pairM p (CoLoggerF l _ _) (Log level message next) = do+    a <- l level message+    p a next+  pairM p (CoLoggerF _ gl _) (GetLevel next) = do+    (l, a) <- gl+    p a (next l)+  pairM p (CoLoggerF _ _ sl) (SetLevel level next) = do+    a <- sl level+    p a next++-- * Primitives++log :: (Functor f, MonadFree f m, LoggerF :<: f) => LogLevel -> Text -> m ()+log level message = liftF . inj $ Log level message ()++getLogLevel :: (Functor f, MonadFree f m, LoggerF :<: f) => m LogLevel+getLogLevel = liftF . inj $ GetLevel id++setLogLevel :: (Functor f, MonadFree f m, LoggerF :<: f) => LogLevel -> m ()+setLogLevel level = liftF . inj $ SetLevel level ()++-- * Helpers++logDebug, logInfo, logWarning, logError :: (Functor f, MonadFree f m, LoggerF :<: f) => Text -> m ()+logDebug = log Debug+logInfo = log Info+logWarning = log Warning+logError = log Error
+ src/lib/Imm/Logger/Simple.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Simple logger interpreter.+-- For further information, please consult "System.Log.FastLogger".+module Imm.Logger.Simple (module Imm.Logger.Simple, module Reexport) where++-- {{{ Imports+import           Imm.Logger            as Reexport+import           Imm.Prelude++import           System.Log.FastLogger as Reexport+-- }}}++-- * Settings++data LoggerSettings = LoggerSettings+  { loggerSet      :: LoggerSet  -- ^ 'LoggerSet' used for 'Debug', 'Info' and 'Warning' logs+  , errorLoggerSet :: LoggerSet  -- ^ 'LoggerSet' used for 'Error' logs+  , logLevel       :: LogLevel   -- ^ Discard logs that are strictly less serious than this level+  }++-- | Default logger forwards error messages to stderr, and other messages to stdout.+defaultLogger :: IO LoggerSettings+defaultLogger = LoggerSettings+  <$> newStdoutLoggerSet defaultBufSize+  <*> newStderrLoggerSet defaultBufSize+  <*> pure Info++-- * Interpreter++-- | Interpreter for 'LoggerF'+mkCoLogger :: (MonadIO m) => LoggerSettings -> CoLoggerF m LoggerSettings+mkCoLogger settings = CoLoggerF coLog coGetLevel coSetLevel where+  coLog Error t = do+    io $ pushLogStrLn (errorLoggerSet settings) $ toLogStr $ "ERROR: " <> t+    return settings+  coLog l t = do+    when (l >= logLevel settings) $ io $ pushLogStrLn (loggerSet settings) $ toLogStr $ show (pretty l) <> ": " <> t+    return settings+  coGetLevel = return (logLevel settings, settings)+  coSetLevel l = return $ settings { logLevel = l }
+ src/lib/Imm/Options.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE NoImplicitPrelude  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-}+module Imm.Options where++-- {{{ Imports+import           Imm.Dyre                    as Dyre (Mode (..))+import qualified Imm.Dyre                    as Dyre+import           Imm.Feed+import           Imm.Logger                  as Logger+import           Imm.Prelude                 hiding ((<>))+import           Imm.Pretty++import           Options.Applicative.Builder+import           Options.Applicative.Extra+import           Options.Applicative.Types++import           URI.ByteString+-- }}}++-- | Available commands.+data Command = Check (Maybe FeedRef)+             | Import+             | Read (Maybe FeedRef)+             | Rebuild+             | Unread (Maybe FeedRef)+             | Run (Maybe FeedRef)+             | Show (Maybe FeedRef)+             | ShowVersion+             | Subscribe URI (Maybe Text)+             | Unsubscribe (Maybe FeedRef)++deriving instance Eq Command+deriving instance Show Command++instance Pretty Command where+  pretty (Check f) = text "Check feed(s):" <+> pretty f+  pretty Import = text "Import feeds"+  pretty (Read f) = text "Mark feed(s) as read:" <+> pretty f+  pretty Rebuild = text "Rebuild configuration"+  pretty (Unread f) = text "Mark feed(s) as unread:" <+> pretty f+  pretty (Run f) = text "Download new entries from feed(s):" <+> pretty f+  pretty (Show f) = text "Show status for feed(s):" <+> pretty f+  pretty ShowVersion = text "Show program version"+  pretty (Subscribe f _) = text "Subscribe to feed:" <+> prettyURI f+  pretty (Unsubscribe f) = text "Unsubscribe from feed(s):" <+> pretty f++defaultCommand :: Command+defaultCommand = Show Nothing++-- | Available commandline options.+data CliOptions = CliOptions+  { optionCommand  :: Command+  , optionDyreMode :: Dyre.Mode+  , optionLogLevel :: LogLevel+  }++-- deriving instance Eq CliOptions+defaultOptions :: CliOptions+defaultOptions = CliOptions defaultCommand Dyre.defaultMode Info++-- instance Pretty CliOptions where+--     pretty opts = text "ACTION" <> equals <>  $ opts^.command_+--         , ("RECONFIGURATION_MODE=" ++) . show $ opts^.dyreMode_+--         ]+--         ++ catMaybes [("CONFIG=" ++) <$> opts^.configurationLabel_]++parseOptions :: (MonadIO m) => m CliOptions+parseOptions = io $ customExecParser (prefs noBacktrack) (info parser $ progDesc "Convert items from RSS/Atom feeds to mails.")+  where parser = helper <*> optional dyreMasterBinary *> optional dyreDebug *> cliOptions+++cliOptions :: Parser CliOptions+cliOptions = CliOptions+  <$> commands+  <*> (vanillaFlag <|> forceReconfFlag <|> denyReconfFlag <|> pure Dyre.defaultMode)+  <*> (verboseFlag <|> quietFlag <|> logLevel <|> pure Info)+++commands :: Parser Command+commands = subparser $ mconcat+  [ command "check" . info (Check <$> optional feedRefOption) $ progDesc "Check availability and validity of all feed sources currently configured, without writing any mail."+  , command "import" . info (pure Import) $ progDesc "Import feeds list from an OPML descriptor (read from stdin)."+  , command "read" . info (Read <$> optional feedRefOption) $ progDesc "Mark given feed as read."+  , command "rebuild" . info (pure Rebuild) $ progDesc "Rebuild configuration file."+  , command "run" . info (Run <$> optional feedRefOption) $ progDesc "Update list of feeds."+  , command "show" . info (Show <$> optional feedRefOption) $ progDesc "List all feed sources currently configured, along with their status."+  , command "subscribe" . info subscribeOptions $ progDesc "Subscribe to a feed."+  , command "unread" . info (Unread <$> optional feedRefOption) $ progDesc "Mark given feed as unread."+  , command "unsubscribe" . info unsubscribeOptions $ progDesc "Unsubscribe from a feed."+  , command "version" . info (pure ShowVersion) $ progDesc "Print version."+  ]+++-- {{{ Dynamic reconfiguration options+vanillaFlag, forceReconfFlag, denyReconfFlag :: Parser Dyre.Mode+vanillaFlag      = flag' Vanilla $ long "vanilla" <> short '1' <> help "Ignore custom configuration file."+forceReconfFlag  = flag' ForceReconfiguration $ long "force-reconf" <> help "Recompile configuration file before starting the application."+denyReconfFlag   = flag' IgnoreReconfiguration $ long "deny-reconf" <> help "Do not recompile configuration file even if it has changed."++dyreDebug :: Parser Bool+dyreDebug = switch $ long "dyre-debug" <> help "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program."++dyreMasterBinary :: Parser String+dyreMasterBinary = strOption $ long "dyre-master-binary" <> metavar "PATH" <> hidden <> internal <> help "Internal flag used for dynamic reconfiguration."+-- }}}++-- {{{ Log level options+verboseFlag, quietFlag, logLevel :: Parser LogLevel+verboseFlag = flag' Logger.Debug $ long "verbose" <> short 'v' <> help "Set log level to DEBUG."+quietFlag   = flag' Logger.Error $ long "quiet" <> short 'q' <> help "Set log level to ERROR."+logLevel    = option auto $ long "log-level" <> short 'l' <> metavar "LOG-LEVEL" <> value Info <> completeWith ["Debug", "Info", "Warning", "Error"] <> help "Set log level. Available values: Debug, Info, Warning, Error."+-- }}}++-- {{{ Other options+configLabelOption :: Parser Text+configLabelOption = option auto $ long "config" <> short 'C' <> metavar "CONFIG" <> help "Use the given configuration for all operations."++subscribeOptions, unsubscribeOptions :: Parser Command+subscribeOptions    = Subscribe <$> uriArgument "URI to subscribe to." <*> optional configLabelOption+unsubscribeOptions  = Unsubscribe <$> optional feedRefOption+-- }}}++-- {{{ Util+uriReader :: ReadM URI+uriReader = eitherReader $ first show . parseURI laxURIParserOptions . encodeUtf8 . fromString++feedRefOption :: Parser FeedRef+feedRefOption = fmap FeedRef $ (Left <$> argument auto (metavar "ID")) <|> (Right <$> argument uriReader (metavar "URI"))++uriArgument :: String -> Parser URI+uriArgument helpText = argument uriReader $ metavar "URI" <> help helpText+-- }}}
+ src/lib/Imm/Prelude.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TupleSections          #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+module Imm.Prelude (module Imm.Prelude, module X) where++-- {{{ Imports+import           Control.Applicative          as X+import           Control.Comonad+import           Control.Comonad.Cofree+import           Control.Monad                as X hiding (filterM, replicateM)+import           Control.Monad.Catch          as X+import           Control.Monad.IO.Class       as X+import           Control.Monad.Trans.Free     (FreeF (..), FreeT (..))++import           Data.Bifunctor               as X+import qualified Data.ByteString              as B (ByteString ())+import qualified Data.ByteString.Lazy         as LB (ByteString ())+import           Data.Comp.Ops                as X+import           Data.Containers              as X+import           Data.Functor.Identity+import           Data.IOData                  as X+import           Data.Map                     as X (Map)+import           Data.Maybe                   as X hiding (catMaybes)+import           Data.Monoid                  as X+import           Data.Monoid.Textual          as X (TextualMonoid (), fromText)+import           Data.MonoTraversable         as X+import           Data.Ord                     as X+-- import           Data.Semigroup               as X hiding (option)+import           Data.Sequences               as X+import           Data.Sequences.Lazy          as X+import           Data.String                  as X (IsString (..))+import qualified Data.Text                    as T (Text ())+import qualified Data.Text.Lazy               as LT (Text ())+import           Data.Textual.Encoding        as X+import           Data.Typeable                as X++import qualified GHC.Show                     as Show++import           Prelude                      as X hiding (break, drop,+                                                    dropWhile, elem, filter,+                                                    getLine, lines, log, lookup,+                                                    notElem, readFile,+                                                    replicate, reverse, show,+                                                    span, splitAt, take,+                                                    takeWhile, unlines, unwords,+                                                    words, writeFile)++import           System.IO                    as X (stderr, stdout)++import           Text.PrettyPrint.ANSI.Leijen as X (Doc, Pretty (..), angles,+                                                    brackets, equals, hsep,+                                                    indent, space, text, vsep,+                                                    (<+>))++import           Text.PrettyPrint.ANSI.Leijen (line)+-- }}}++-- * Free monad utilities++-- | Right-associative tuple type-constructor+type a ::: b = (a, b)+infixr 0 :::++-- | Right-associative tuple data-constructor+(>:) :: a -> b -> (a,b)+(>:) a b = (a, b)+infixr 0 >:++(*:*) :: (Functor f, Functor g) => (a -> f a) -> (b -> g b) -> (a, b) -> (f :*: g) (a, b)+(*:*) f g (a,b) = ((,b) <$> f a) :*: ((a,) <$> g b)+infixr 0 *:*+++class (Monad m, Functor f, Functor g) => PairingM f g m | f -> g where+  pairM :: (a -> b -> m r) -> f a -> g b -> m r++instance (Monad m) => PairingM Identity Identity m where+  pairM f (Identity a) (Identity b) = f a b++instance (PairingM f f' m, PairingM g g' m) => PairingM (f :+: g) (f' :*: g') m where+  pairM p (Inl x) (a :*: _) = pairM p x a+  pairM p (Inr x) (_ :*: b) = pairM p x b++instance (PairingM f f' m, PairingM g g' m) => PairingM (f :*: g) (f' :+: g') m where+  pairM p (a :*: _) (Inl x) = pairM p a x+  pairM p (_ :*: b) (Inr x) = pairM p b x++interpret :: (PairingM f g m) => (a -> b -> m r) -> Cofree f a -> FreeT g m b -> m r+interpret p eval program = do+  let a = extract eval+  b <- runFreeT program+  case b of+    Pure x -> p a x+    Free gs -> pairM (interpret p) (unwrap eval) gs++-- * Shortcuts++type LByteString = LB.ByteString+type ByteString = B.ByteString+type LText = LT.Text+type Text = T.Text++-- | Generic 'Show.show'+show :: (Show a, IsString b) => a -> b+show = fromString . Show.show++-- | Shortcut to 'liftIO'+io :: MonadIO m => IO a -> m a+io = liftIO++-- | Infix operator for 'line'+(<++>) :: Doc -> Doc -> Doc+x <++> y = x <> line <> y
+ src/lib/Imm/Pretty.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+module Imm.Pretty where++-- {{{ Imports+import           Imm.Prelude++import           Data.NonNull+import           Data.Time+import           Data.Tree++import           Text.Atom.Types              as Atom+-- import           Text.OPML.Types              as OPML hiding (text)+-- import qualified Text.OPML.Types              as OPML+import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))+import           Text.RSS.Types               as RSS++import           URI.ByteString+-- }}}++prettyTree :: (Pretty a) => Tree a -> Doc+prettyTree (Node n s) = pretty n <++> indent 2 (vsep $ prettyTree <$> s)++prettyTime :: UTCTime -> Doc+prettyTime = text . formatTime defaultTimeLocale rfc822DateFormat++-- instance Pretty OpmlHead where+--   pretty h = hsep $ catMaybes+--                [ pretty <$> fromNullable (opmlTitle h)+--                , (text "created at:" <+>) . pretty <$> opmlCreated h+--                , (text "modified at:" <+>) . pretty <$> modified h+--                , (text "by" <+>) . pretty <$> fromNullable (ownerName h)+--                , angles . pretty <$> fromNullable (ownerEmail h)+--                ]++-- instance Pretty OutlineBase where+--   pretty b = pretty $ OPML.text b++-- instance Pretty OutlineSubscription where+--   pretty b = angles $ pretty $ xmlUri b++-- instance Pretty OpmlOutline where+--   pretty (OpmlOutlineGeneric base otype) = hsep+--                                              [ text "type:" <+> pretty otype+--                                              , pretty base+--                                              ]+--   pretty (OpmlOutlineSubscription base s) = text "Subscription:" <+> pretty base <+> pretty s+--   pretty (OpmlOutlineLink base uri) = text "Link:" <+> pretty base <+> pretty uri++-- instance Pretty Opml where+--   pretty o = text "OPML" <+> pretty (opmlVersion o) <++> indent 2 (pretty (opmlHead o) <++> (vsep . map pretty $ opmlOutlines o))++prettyPerson :: AtomPerson -> Doc+prettyPerson p = text (fromText $ toNullable $ personName p) <> email where+  email = if onull $ personEmail p+    then mempty+    else space <> angles (text $ fromText $ personEmail p)++prettyLink :: AtomLink -> Doc+prettyLink l = withAtomURI prettyURI $ linkHref l++prettyAtomText :: AtomText -> Doc+prettyAtomText (AtomPlainText _ t) = text $ fromText t+prettyAtomText (AtomXHTMLText t) = text $ fromText t++prettyEntry :: AtomEntry -> Doc+prettyEntry e = text "Entry:" <+> prettyAtomText (entryTitle e) <++> indent 4+  (          text "By" <+> equals <+> list (prettyPerson <$> entryAuthors e)+  <++> text "Updated" <+> equals <+> prettyTime (entryUpdated e)+  <++> text "Links" <+> equals <+> list (prettyLink <$> entryLinks e)+  -- , "   Item Body:   " ++ (Imm.Mail.getItemContent item),+  )++prettyItem :: RssItem -> Doc+prettyItem i = text "Item:" <+> text (fromText $ itemTitle i) <++> indent 4+  (          text "By" <+> equals <+> text (fromText $ itemAuthor i)+  <++> text "Updated" <+> equals <+> fromMaybe (text "<empty>") (prettyTime <$> itemPubDate i)+  <++> text "Link" <+> equals <+> fromMaybe (text "<empty>") (withRssURI prettyURI <$> itemLink i)+  )++prettyURI :: URIRef a -> Doc+prettyURI uri = text $ fromText $ decodeUtf8 $ serializeURIRef' uri++prettyGuid :: RssGuid -> Doc+prettyGuid (GuidText t) = text $ fromText t+prettyGuid (GuidUri (RssURI u)) = prettyURI u++prettyAtomContent :: AtomContent -> Doc+prettyAtomContent (AtomContentInlineText _ t) = text $ fromText t+prettyAtomContent (AtomContentInlineXHTML t) = text $ fromText t+prettyAtomContent (AtomContentInlineOther _ t) = text $ fromText t+prettyAtomContent (AtomContentOutOfLine _ u) = withAtomURI prettyURI u