" (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 }
diff --git a/src/lib/Imm/Database/JsonFile.hs b/src/lib/Imm/Database/JsonFile.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Database/JsonFile.hs
@@ -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
diff --git a/src/lib/Imm/Dyre.hs b/src/lib/Imm/Dyre.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Dyre.hs
@@ -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
diff --git a/src/lib/Imm/Error.hs b/src/lib/Imm/Error.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Error.hs
@@ -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
diff --git a/src/lib/Imm/Feed.hs b/src/lib/Imm/Feed.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Feed.hs
@@ -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]
diff --git a/src/lib/Imm/HTTP.hs b/src/lib/Imm/HTTP.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/HTTP.hs
@@ -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
diff --git a/src/lib/Imm/HTTP/Simple.hs b/src/lib/Imm/HTTP/Simple.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/HTTP/Simple.hs
@@ -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", "*/*")]}
diff --git a/src/lib/Imm/Hooks.hs b/src/lib/Imm/Hooks.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Hooks.hs
@@ -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 ()
diff --git a/src/lib/Imm/Hooks/SendMail.hs b/src/lib/Imm/Hooks/SendMail.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Hooks/SendMail.hs
@@ -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) = "" <> maybe "" (withRssURI (show . prettyURI)) (itemLink item) <> "
" <> itemDescription item <> "
"
+defaultFormatBody _ (AtomElement entry) = "" <> intercalate "
" links <> "
" <> fromMaybe "" (content <|> summary) <> "
"
+ 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", "")
+ , ("Date", fromString date)
+ , ("Subject", formatSubject format feed element)
+ , ("Content-disposition", "inline")
+ ]
+ , mailParts = [[htmlPart $ fromStrict $ formatBody format feed element]]
+ }
diff --git a/src/lib/Imm/Logger.hs b/src/lib/Imm/Logger.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Logger.hs
@@ -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
diff --git a/src/lib/Imm/Logger/Simple.hs b/src/lib/Imm/Logger/Simple.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Logger/Simple.hs
@@ -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 }
diff --git a/src/lib/Imm/Options.hs b/src/lib/Imm/Options.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Options.hs
@@ -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
+-- }}}
diff --git a/src/lib/Imm/Prelude.hs b/src/lib/Imm/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Prelude.hs
@@ -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
diff --git a/src/lib/Imm/Pretty.hs b/src/lib/Imm/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Imm/Pretty.hs
@@ -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 "") (prettyTime <$> itemPubDate i)
+ <++> text "Link" <+> equals <+> fromMaybe (text "") (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