imm 1.0.1.0 → 1.1.0.0

raw patch · 20 files changed

+473/−188 lines, 20 filesdep +blaze-htmldep +blaze-markupdep +safe-exceptionsdep −compdatadep −conduit-parsedep −exceptionsdep ~atom-conduitdep ~http-clientdep ~opml-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-html, blaze-markup, safe-exceptions, tagged

Dependencies removed: compdata, conduit-parse, exceptions

Dependency ranges changed: atom-conduit, http-client, opml-conduit, rss-conduit

API changes (from Hackage documentation)

Files

• README.md +47/−14
• imm.cabal +3/−2
• src/bin/Executable.hs +7/−6
• src/lib/Imm/Boot.hs +41/−21
• src/lib/Imm/Core.hs +38/−17
• src/lib/Imm/Database.hs +39/−27
• src/lib/Imm/Database/FeedTable.hs +5/−5
• src/lib/Imm/Database/JsonFile.hs +6/−5
• src/lib/Imm/Dyre.hs +10/−8
• src/lib/Imm/Feed.hs +11/−7
• src/lib/Imm/HTTP.hs +1/−1
• src/lib/Imm/HTTP/Simple.hs +4/−4
• src/lib/Imm/Hooks.hs +2/−1
• src/lib/Imm/Hooks/SendMail.hs +2/−3
• src/lib/Imm/Hooks/WriteFile.hs +119/−0
• src/lib/Imm/Logger.hs +32/−17
• src/lib/Imm/Logger/Simple.hs +14/−5
• src/lib/Imm/Options.hs +23/−18
• src/lib/Imm/Prelude.hs +49/−12
• src/lib/Imm/Pretty.hs +20/−15

@@ -1,28 +1,61 @@ # imm -## In a nutshell+*imm* is a tool to execute arbitrary actions for each new element from RSS/Atom feeds (e.g. sending a mail, or writing a file). -*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).+*imm* is written and configured in *Haskell*. -Notably, *imm* makes it possible to use mail readers for feeds, for the sake of *I-want-the-mutt-of-feed-readers* zealots.+Technical documentation is available at [hackage][1]. -*imm* is written and configured in *Haskell*. To get started, please consult documentation of `Imm.Boot` module.+To get started, please consult documentation of `Imm.Boot` module. -Informations about versions, dependencies, source repositories and contacts can be found in [hackage][1]. +## Example workflows -## Rationale+### Online feed reader -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.+For the sake of *I-want-the-mutt-of-feed-readers* zealots, it is possible to turn any mail reader into a feed reader, by having *imm* send an e-mail with unread elements to an arbitrary address.+You can then browse your feeds through your favourite mail reader, and leverage any mail-related tool on your feeds.+Bonus points if your mail reader is online as you can now access your feeds from anywhere in the internet. -The expected features of a feed reader could be defined as follows:+Check out `Imm.Hooks.SendMail` module. -- 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.+### Offline read-it-later -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.+*imm* is able to store a local copy of unread elements, to read them later while offline for example. External links won't work offline though. +Check out `Imm.Hooks.WriteFile` module.+++## Example usage++- Subscribe to a feed:++  ```+  imm subscribe http://your.feed.org+  ```+- Import feeds from an OPML file:++  ```+  cat feeds.opml | imm import+  ```+- List subscribed feeds:++  ```+  imm show+  ```+- Unsubscribe from a feed:++  ```+  imm unsubscribe http://your.feed.org+  ```+- Check for new elements without executing any action:++  ```+  imm check+  ```+- Execute configured actions for each new element from subscribed feeds:++  ```+  imm run+  ``` [1]: http://hackage.haskell.org/package/imm

@@ -1,5 +1,5 @@ name:                imm-version:             1.0.1.0+version:             1.1.0.0 synopsis:            Execute arbitrary actions for each unread element of RSS/Atom feeds description:         Cf README file homepage:            https://github.com/k0ral/imm@@ -27,6 +27,7 @@     Imm.Feed     Imm.Hooks     Imm.Hooks.SendMail+    Imm.Hooks.WriteFile     Imm.HTTP     Imm.HTTP.Simple     Imm.Logger@@ -39,7 +40,7 @@     Imm.Options     Imm.Pretty     Paths_imm-  build-depends: aeson, atom-conduit, base == 4.*, bytestring, case-insensitive, chunked-data >= 0.3.0, comonad, compdata, conduit, conduit-combinators, conduit-parse, connection, containers, directory >= 1.2.3.0, dyre, 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 >= 1.0.0, 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-depends: aeson, atom-conduit >= 0.4, base == 4.*, blaze-html, blaze-markup, bytestring, case-insensitive, chunked-data >= 0.3.0, comonad, conduit, conduit-combinators, connection, containers, directory >= 1.2.3.0, dyre, fast-logger, filepath, free, hashable, HaskellNet, HaskellNet-SSL >= 0.3.3.0, http-client >= 0.4.30, http-client-tls, http-types, mime-mail, monoid-subclasses, mono-traversable >= 1.0.0, network, opml-conduit >= 0.6, optparse-applicative, rainbow, rainbox, rss-conduit >= 0.3, safe-exceptions, tagged, 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

@@ -5,6 +5,7 @@ -- {{{ Imports import           Imm import           Imm.Database.JsonFile+import qualified Imm.Hooks.WriteFile   as WriteFile import           Imm.HTTP.Simple import           Imm.Logger.Simple import           Imm.Prelude@@ -12,11 +13,11 @@ import           System.Exit -- }}} -mkDummyCoHooks :: (MonadIO m, MonadThrow m) => () -> CoHooksF m ()-mkDummyCoHooks _ = CoHooksF coOnNewElement where-  coOnNewElement _ _ = do-    io $ putStrLn "No hook defined."-    throwM $ ExitFailure 1+-- mkDummyCoHooks :: (MonadIO m, MonadThrow m) => () -> CoHooksF m ()+-- mkDummyCoHooks _ = CoHooksF coOnNewElement where+--   coOnNewElement _ _ = do+--     io $ putStrLn "No hook defined."+--     throwM $ ExitFailure 1   main :: IO ()@@ -25,4 +26,4 @@   manager <- defaultManager   database <- defaultDatabase -  imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (mkDummyCoHooks, ())+  imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (WriteFile.mkCoHooks, WriteFile.defaultSettings "/home/koral/feeds")

@@ -7,6 +7,22 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-}+-- |+-- = Getting started+--+-- == Dynamic reconfiguration+--+-- This program is dynamically configured using the <https://hackage.haskell.org/package/dyre dyre> library.+--+-- You may want to check out <https://hackage.haskell.org/package/dyre/docs/Config-Dyre.html this documentation> to know how to get started.+--+-- Your personal configuration is located at @$XDG_CONFIG_HOME\/imm\/imm.hs@.+--+-- == Interpreter pattern+--+-- The behavior of this program can be customized through the interpreter pattern, implemented using free monads (for the DSL part) and cofree comonads (for the interpreter part).+--+-- The design is inspired from <http://dlaing.org/cofun/ Cofun with cofree monads>. module Imm.Boot (imm) where  -- {{{ Imports@@ -20,17 +36,19 @@ import Imm.Logger as Logger import Imm.Options as Options hiding(logLevel) import Imm.Prelude+import Imm.Pretty  import Control.Comonad.Cofree import Control.Monad.Trans.Free +import Data.Functor.Product+import Data.Functor.Sum+ 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".+-- | Main function, meant to be used in your personal configuration file.+-- Each argument is an interpreter functor along with an initial state. -- -- Here is an example: --@@ -43,8 +61,8 @@ -- > -- > main :: IO () -- > main = do--- >   logger <- defaultLogger--- >   manager <- defaultManager+-- >   logger   <- defaultLogger+-- >   manager  <- defaultManager -- >   database <- defaultDatabase -- > -- >   imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (mkCoHooks, sendmail)@@ -70,16 +88,19 @@     -> IO () imm coHttpClient coDatabase coLogger coHooks = void $ do   options <- parseOptions-  Dyre.wrap (optionDyreMode options) realMain (optionCommand options, optionLogLevel options, coiter next start)+  Dyre.wrap (optionDyreMode options) realMain (optionCommand options, optionLogLevel options, optionColorizeLogs 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+         => (Command, LogLevel, Bool, Cofree (CoImmF m) a) -> m ()+realMain (command, logLevel, colorizeLogs, interpreter) = void $ interpret (\_ b -> return b) interpreter $ do+  setColorizeLogs colorizeLogs   setLogLevel logLevel-  logDebug $ "Executing: " <> show (pretty command)+  logDebug . ("Dynamic reconfiguration settings:" <++>) . indent 2 =<< Dyre.describePaths+  logDebug $ "Executing: " <> pretty command+  logDebug . ("Using database:" <++>) . indent 2 =<< describeDatabase FeedTable -  handleAll (logError . fromString . displayException) $ case command of+  handleAny (logError . textual . displayException) $ case command of     Check t        -> Core.check            =<< resolveTarget ByPassConfirmation t     Import         -> Core.importOPML     Read t         -> mapM_ Database.markAsRead   =<< resolveTarget AskConfirmation t@@ -92,13 +113,12 @@     _              -> return ()    Database.commit FeedTable--  return ()+  flushLogs  -- * DSL/interpreter model -type CoImmF m = CoHttpClientF m :*: CoDatabaseF' m :*: CoLoggerF m :*: CoHooksF m-type ImmF = HttpClientF :+: DatabaseF' :+: LoggerF :+: HooksF+type CoImmF m = Product (CoHttpClientF m) (Product (CoDatabaseF' m) (Product (CoLoggerF m) (CoHooksF m)))+type ImmF = Sum HttpClientF (Sum DatabaseF' (Sum 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)@@ -110,9 +130,9 @@ -- * Util  data SafeGuard = AskConfirmation | ByPassConfirmation-  deriving(Eq, Show)+  deriving(Eq, Read, Show) -data InterruptedException = InterruptedException deriving(Eq, Show)+data InterruptedException = InterruptedException deriving(Eq, Read, Show) instance Exception InterruptedException where   displayException _ = "Process interrupted" @@ -121,17 +141,17 @@   hPut stdout $ s <> " Confirm [Y/n] "   io $ hFlush stdout   x <- getLine-  when (x /= ("" :: Text) && x /= ("Y" :: Text)) $ throwM InterruptedException+  unless (null x || x == ("Y" :: Text)) $ throwM InterruptedException  -resolveTarget :: (MonadIO m, MonadThrow m, Functor f, MonadFree f m, DatabaseF' :<: f, LoggerF :<: f)+resolveTarget :: (MonadIO m, MonadThrow m, Functor f, MonadFree f m, DatabaseF' :<: 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+resolveTarget _ (Just (ByUID 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]+resolveTarget _ (Just (ByURI uri)) = return [FeedID uri]

@@ -37,16 +37,16 @@ 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.Time.Format import Data.Tree import           Data.Version  import qualified Paths_imm                      as Package -import Rainbow hiding((<>))+import Rainbow (chunksToByteStrings, toByteStringsColors256, chunk) import Rainbox  import           System.Info@@ -74,10 +74,11 @@          => [FeedID] -> m () showFeed feedIDs = do   feeds <- Database.fetchList FeedTable feedIDs+  flushLogs   if null 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)+subscribe :: (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 @@ -85,44 +86,64 @@ 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+  results <- forM (zip ([1..] :: [Int]) feedIDs) $ \(i, feedID) -> do+    logInfo $ brackets (fill width (bold $ cyan $ pretty i) <+> "/" <+> pretty total) <+> "Checking" <+> magenta (pretty feedID) <> "..."+    try $ checkOne feedID    putBox $ statusTableToBox $ mapFromList $ zip feedIDs results-  where total = length feedIDs+  where width = length (show total :: String)+        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))+  feed <- runConduit $ parseLBS def body =$= force "Invalid feed" ((fmap Left <$> atomFeed) `orE` (fmap Right <$> rssDocument))    case feed of-    Left _ -> logDebug $ "Parsed Atom feed: " <> show (pretty feedID)-    Right _ -> logDebug $ "Parsed RSS feed: " <> show (pretty feedID)+    Left _ -> logDebug $ "Parsed Atom feed: " <> pretty feedID+    Right _ -> logDebug $ "Parsed RSS feed: " <> pretty feedID    let dates = either               (map entryUpdated . feedEntries)               (mapMaybe itemPubDate . channelItems)               feed -  logDebug . show . vsep $ either (map prettyEntry . feedEntries) (map prettyItem . channelItems) feed+  logDebug $ vsep $ either (map prettyEntry . feedEntries) (map prettyItem . channelItems) feed   status <- Database.getStatus feedID -  return . length $ filter (unread status) dates+  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+run feedIDs = do+  results <- forM (zip ([1..] :: [Int]) feedIDs) $ \(i, feedID) -> do+    logInfo $ brackets (fill width (bold $ cyan $ pretty i) <+> "/" <+> pretty total) <+> "Processing" <+> magenta (pretty feedID) <> "..."+    result <- tryAny $ runOne feedID+    return $ bimap (feedID,) (feedID,) result++  flushLogs++  let (failures, successes) = partitionEithers results++  unless (null failures) $ logError $ bold (pretty $ length failures) <+> "feeds in error"+  forM_ failures $ \(feedID, e) ->+    logError $ indent 2 (pretty feedID <++> indent 2 (pretty $ displayException e))++  where width = length (show total :: String)+        total = length feedIDs++runOne :: (MonadIO m, MonadCatch m, HooksF :<: f, LoggerF :<: f, Functor f, MonadFree f m, DatabaseF' :<: f, HttpClientF :<: f)+    => FeedID -> m ()+runOne feedID@(FeedID uri) = do   body <- HTTP.get uri-  feed <- runConduit $ parseLBS def body =$= runConduitParser ((Atom <$> atomFeed) <|> (Rss <$> rssDocument))+  feed <- runConduit $ parseLBS def body =$= force "Invalid feed" ((fmap Atom <$> atomFeed) `orE` (fmap Rss <$> rssDocument))   unreadElements <- filterM (fmap not . isRead feedID) $ getElements feed -  logInfo $ show (length unreadElements) <> " unread element(s) for " <> show (pretty feedID)+  unless (null unreadElements) $ logInfo $ indent 2 $ green (pretty $ length unreadElements) <+> "unread element(s)"    forM_ unreadElements $ \element -> do     onNewElement feed element@@ -144,7 +165,7 @@ -- | '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+  opml <- runConduit $ Conduit.stdin =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml   forM_ (opmlOutlines opml) $ importOPML' mempty  importOPML' :: (MonadIO m, LoggerF :<: f, Functor f, MonadFree f m, DatabaseF' :<: f, MonadCatch m)@@ -171,7 +192,7 @@   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+  format = maybe "<never>" (fromString . formatTime defaultTimeLocale "%F %R")   sep = fromList [separator mempty 1]  

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE StandaloneDeriving    #-}@@ -17,6 +18,8 @@ import           Imm.Prelude  import           Control.Monad.Trans.Free++import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) -- }}}  -- * DSL/interpreter@@ -29,7 +32,8 @@  -- | Database DSL data DatabaseF t next-  = FetchList t [Key t] (Either SomeException (Map (Key t) (Entry t)) -> next)+  = Describe t (Doc -> 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)@@ -40,7 +44,8 @@  -- | Database interpreter data CoDatabaseF t m a = CoDatabaseF-  { fetchListH  :: [Key t] -> m (Either SomeException (Map (Key t) (Entry t)), a)+  { describeH   :: m (Doc, a)+  , 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)@@ -51,27 +56,30 @@  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+  pairM p CoDatabaseF{describeH} (Describe _ next) = do+    (result, a) <- describeH     p a $ next result-  pairM p (CoDatabaseF _ fa _ _ _ _ _) (FetchAll _ next) = do-    (result, a) <- fa+  pairM p CoDatabaseF{fetchListH} (FetchList _ key next) = do+    (result, a) <- fetchListH key     p a $ next result-  pairM p (CoDatabaseF _ _ u _ _ _ _) (Update _ key f next) = do-    (result, a) <- u key f+  pairM p CoDatabaseF{fetchAllH} (FetchAll _ next) = do+    (result, a) <- fetchAllH     p a $ next result-  pairM p (CoDatabaseF _ _ _ i _ _ _) (InsertList _ rows next) = do-    (result, a) <- i rows+  pairM p CoDatabaseF{updateH} (Update _ key f next) = do+    (result, a) <- updateH key f     p a $ next result-  pairM p (CoDatabaseF _ _ _ _ d _ _) (DeleteList _ k next) = do-    (result, a) <- d k+  pairM p CoDatabaseF{insertListH} (InsertList _ rows next) = do+    (result, a) <- insertListH rows     p a $ next result-  pairM p (CoDatabaseF _ _ _ _ _ p' _) (Purge _ next) = do-    (result, a) <- p'+  pairM p CoDatabaseF{deleteListH} (DeleteList _ k next) = do+    (result, a) <- deleteListH k     p a $ next result-  pairM p (CoDatabaseF _ _ _ _ _ _ c) (Commit _ next) = do-    (result, a) <- c+  pairM p CoDatabaseF{purgeH} (Purge _ next) = do+    (result, a) <- purgeH     p a $ next result+  pairM p CoDatabaseF{commitH} (Commit _ next) = do+    (result, a) <- commitH+    p a $ next result   -- * Exception@@ -103,6 +111,10 @@  -- * Primitives +describeDatabase :: (Functor f, MonadFree f m, DatabaseF t :<: f)+                 => t -> m Doc+describeDatabase t = liftF . inj $ Describe t id+ fetch :: (Functor f, MonadFree f m, DatabaseF t :<: f, Table t, MonadThrow m)       => t -> Key t -> m (Entry t) fetch t k = do@@ -110,51 +122,51 @@   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)+fetchList :: (Functor f, MonadFree f m, DatabaseF t :<: f, 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 :: (MonadThrow m, Functor f, MonadFree f m, DatabaseF t :<: f) => 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)+update :: (Functor f, MonadFree f m, DatabaseF t :<: f, 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)+insert :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f)        => 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)+insertList :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f)            => t -> [(Key t, Entry t)] -> m () insertList t i = do-  logInfo $ "Inserting " <> show (length i) <> " entrie(s)..."+  logInfo $ "Inserting " <> yellow (pretty $ length i) <> " entries..."   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 :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f) => 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)+deleteList :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f)            => t -> [Key t] -> m () deleteList t k = do-  logInfo $ "Deleting " <> show (length k) <> " entrie(s)..."+  logInfo $ "Deleting " <> yellow (pretty $ length k) <> " entries..."   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 :: (MonadThrow m, Functor f, MonadFree f m, DatabaseF t :<: f, LoggerF :<: f) => 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 :: (MonadThrow m, Functor f, MonadFree f m, DatabaseF t :<: f, LoggerF :<: f) => t -> m () commit t = do   logDebug "Committing database transaction..."   result <- liftF . inj $ Commit t id

@@ -98,19 +98,19 @@ 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) <> "..."+  logInfo $ "Registering feed " <> magenta (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)+getStatus feedID = handleAny (\_ -> return Unknown) $ do+  result <- fmap Just (fetch FeedTable feedID) `catchAny` (\_ -> 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 <> "..."+  logDebug $ "Adding read hash: " <> pretty hash <> "..."   update FeedTable feedID f   where f a = a { entryReadHashes = insertSet hash $ entryReadHashes a } @@ -118,7 +118,7 @@ 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) <> "..."+  logDebug $ "Marking feed as read: " <> pretty feedID <> "..."   currentTime <- io Time.getCurrentTime   update FeedTable feedID (f currentTime)   where f time a = a { entryLastCheck = Just time }

@@ -56,12 +56,13 @@ -- | 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+mkCoDatabase t = CoDatabaseF coDescribe coFetch coFetchAll coUpdate coInsert coDelete coPurge coCommit where+  coDescribe = return (pretty t, t)   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+  coFetchAll = handleAny (\e -> return (Left e, t)) $ do     t'@(JsonFileDatabase _ cache _) <- loadInCache t     return (Right cache, t')   coUpdate key f = exec (\a -> update a key f)@@ -69,7 +70,7 @@   coDelete keys = exec (`delete` keys)   coPurge = exec purge   coCommit = exec commit-  exec f = handleAll (\e -> return (Left e, t)) $ (Right (),) <$> f t+  exec f = handleAny (\e -> return (Left e, t)) $ (Right (),) <$> f t   -- * Low-level implementation@@ -84,7 +85,7 @@     return $ JsonFileDatabase file cache Clean   _ -> return t   where fromEmpty x "" = x-        fromEmpty _ y = y+        fromEmpty _ y  = y   insert :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))@@ -118,7 +119,7 @@ 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))+commit :: (MonadIO m, ToJSON (Key t), ToJSON (Entry t))        => JsonFileDatabase t -> m (JsonFileDatabase t) commit t@(JsonFileDatabase file cache status) = case status of   Dirty -> do

@@ -6,6 +6,7 @@ module Imm.Dyre   ( Mode(..)   , defaultMode+  , describePaths   , wrap   , recompile   ) where@@ -16,6 +17,8 @@ import           Config.Dyre import           Config.Dyre.Compile import           Config.Dyre.Paths++import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) -- }}}  -- | How dynamic reconfiguration process should behave.@@ -28,15 +31,15 @@   -- | Describe the paths used for dynamic reconfiguration-describePaths :: (IsString t, MonadIO m) => m t+describePaths :: (MonadIO m) => m Doc 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+  return $ vsep+    [ "Current binary" <+> equals <+> magenta (fromString a)+    , "Custom binary" <+> equals <+> magenta (fromString b)+    , "Config file" <+> equals <+> magenta (fromString c)+    , "Cache directory" <+> equals <+> magenta (fromString d)+    , "Lib directory" <+> equals <+> magenta (fromString e)     ]  -- | Dynamic reconfiguration settings@@ -48,7 +51,6 @@   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

@@ -19,12 +19,12 @@ -- * Types  -- | Feed reference: either its URI, or its UID from database-newtype FeedRef = FeedRef (Either Int URI)+data FeedRef = ByUID Int | ByURI URI   deriving(Eq, Show)  instance Pretty FeedRef where-  pretty (FeedRef (Left n))  = text "feed" <+> text (show n)-  pretty (FeedRef (Right u)) = prettyURI u+  pretty (ByUID n) = text "feed" <+> text (show n)+  pretty (ByURI u) = prettyURI u  data Feed = Rss RssDocument | Atom AtomFeed   deriving(Eq, Show)@@ -35,16 +35,20 @@  -- * Generic getters +getFeedTitle :: Feed -> Text+getFeedTitle (Rss doc)   = channelTitle doc+getFeedTitle (Atom feed) = show $ prettyAtomText $ feedTitle feed+ getElements :: Feed -> [FeedElement]-getElements (Rss doc) = map RssElement $ channelItems doc+getElements (Rss doc)   = map RssElement $ channelItems doc getElements (Atom feed) = map AtomElement $ feedEntries feed  getDate :: FeedElement -> Maybe UTCTime-getDate (RssElement item) = itemPubDate item+getDate (RssElement item)   = itemPubDate item getDate (AtomElement entry) = Just $ entryUpdated entry  getTitle :: FeedElement -> Text-getTitle (RssElement item) = itemTitle item+getTitle (RssElement item)   = itemTitle item getTitle (AtomElement entry) = show $ prettyAtomText $ entryTitle entry  getHashes :: FeedElement -> [Int]@@ -52,4 +56,4 @@   <> 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]+getHashes (AtomElement entry) = [hash $ entryId entry, (hash :: String -> Int) $ show $ prettyAtomText $ entryTitle entry]

@@ -43,6 +43,6 @@ get :: (MonadFree f m, Functor f, HttpClientF :<: f, LoggerF :<: f, MonadThrow m)     => URI -> m LByteString get uri = do-  logDebug $ "Fetching " <> show (prettyURI uri)+  logDebug $ "Fetching " <> prettyURI uri   result <- liftF . inj $ Get uri id   liftE result

@@ -21,7 +21,7 @@ -- | 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+  coGet uri = handleAny (\e -> return (Left e, manager)) $ do     result <- httpGet manager uri     return (Right result, manager) @@ -39,13 +39,13 @@     -- codec'   <- reader $ view (config.codec)     -- return $ response $=+ decode codec' -parseUrl' :: (MonadThrow m) => URI -> m Request-parseUrl' = parseUrl . show . prettyURI+parseRequest' :: (MonadThrow m) => URI -> m Request+parseRequest' = parseRequest . show . prettyURI  -- | Build an HTTP request for given URI makeRequest :: (MonadIO m, MonadThrow m) => URI -> m Request makeRequest uri = do-  req <- parseUrl' uri+  req <- parseRequest' uri   return $ req { requestHeaders = [     (mk "User-Agent", "Mozilla/4.0"),     (mk "Accept", "*/*")]}

@@ -12,6 +12,7 @@ import           Imm.Feed import           Imm.Logger import           Imm.Prelude+import           Imm.Pretty  import           Control.Monad.Free.Class -- }}}@@ -38,5 +39,5 @@  onNewElement :: (Functor f, MonadFree f m, LoggerF :<: f, HooksF :<: f) => Feed -> FeedElement -> m () onNewElement feed element = do-  logDebug $ "Unread element: " <> getTitle element+  logDebug $ "Unread element:" <+> textual (getTitle element)   liftF . inj $ OnNewElement feed element ()

@@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators     #-}--- | Hooks interpreter that sends a mail via a SMTP server for each unread element+-- | Hooks interpreter that sends a mail via a SMTP server for each 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:@@ -93,8 +93,7 @@  -- | Fill mail subject with the element title defaultFormatSubject :: Feed -> FeedElement -> Text-defaultFormatSubject _ (RssElement item) = itemTitle item-defaultFormatSubject _ (AtomElement entry) = show . prettyAtomText $ entryTitle entry+defaultFormatSubject _ element = getTitle element  -- | Fill mail body with: --

@@ -0,0 +1,119 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}+-- | Hooks interpreter that writes a file for each element.+module Imm.Hooks.WriteFile where++-- {{{ Imports+import           Imm.Feed+import           Imm.Hooks+import           Imm.Prelude+import           Imm.Pretty++import           Data.Monoid.Textual           hiding (map)+import qualified Data.Text.Lazy                as Text+import           Data.Time++import           System.Directory              (createDirectoryIfMissing)+import           System.FilePath++import           Text.Atom.Types+import qualified Text.Blaze                    as Blaze+import           Text.Blaze.Html.Renderer.Text+import           Text.Blaze.Html5              as H hiding (map)+import           Text.Blaze.Html5.Attributes   as H (charset, href)+import           Text.RSS.Types++import           URI.ByteString+-- }}}++-- * Settings++-- | Where and what to write in a file+data FileInfo = FileInfo FilePath ByteString++data WriteFileSettings = WriteFileSettings (Feed -> FeedElement -> FileInfo)++-- * Interpreter++-- | Interpreter for 'HooksF'+mkCoHooks :: (MonadIO m) => WriteFileSettings -> CoHooksF m WriteFileSettings+mkCoHooks a@(WriteFileSettings f) = CoHooksF coOnNewElement where+  coOnNewElement feed element = do+    let FileInfo path content = f feed element+    io $ createDirectoryIfMissing True $ takeDirectory path+    writeFile path content+    return a++-- | Wrapper around 'defaultFilePath' and 'defaultFileContent'+defaultSettings :: FilePath            -- ^ Root directory for 'defaultFilePath'+                -> WriteFileSettings+defaultSettings root = WriteFileSettings $ \feed element -> FileInfo+  (defaultFilePath root feed element)+  (defaultFileContent feed element)++-- | Generate a path @<root>/<feed title>/<element date>-<element title>.html@, where @<root>@ is the first argument+defaultFilePath :: FilePath -> Feed -> FeedElement -> FilePath+defaultFilePath root feed element = makeValid $ root </> feedTitle </> fileName <.> "html" where+  date = maybe "" (formatTime defaultTimeLocale "%F-") $ getDate element+  fileName = date <> convertText (sanitizePath $ getTitle element)+  feedTitle = convertText $ sanitizePath $ getFeedTitle feed+  sanitizePath = intercalate "-" . split isPathSeparator++-- | Generate an HTML page, with a title, a header and an article that contains the feed element+defaultFileContent :: Feed -> FeedElement -> ByteString+defaultFileContent feed element = encodeUtf8 $ Text.toStrict $ renderHtml $ docTypeHtml $ do+  H.head $ do+    H.meta ! H.charset "utf-8"+    H.title $ convertText $ getFeedTitle feed <> " | " <> getTitle element+  body $ do+    H.h1 $ convertText $ getFeedTitle feed+    article $ do+      defaultHeader feed element+      defaultBody feed element+++-- * Low-level helpers++-- | Generate an HTML @<header>@ for a given feed element+defaultHeader :: Feed -> FeedElement -> Html+defaultHeader _ element@(RssElement item) = header $ do+  H.h2 $ maybe id (\uri -> H.a ! H.href uri) link $ convertText $ getTitle element+  unless (null author) $ address $ "Published by " >> convertText author+  forM_ (itemPubDate item) $ \date -> p $ " on " >> time (convertDoc $ prettyTime date)+  where link = withRssURI (convertDoc . prettyURI) <$> itemLink item+        author = itemAuthor item+defaultHeader _ element@(AtomElement entry) = header $ do+  H.h2 $ convertText $ getTitle element+  address $ do+    "Published by "+    forM_ (entryAuthors entry) $ \author -> do+      convertDoc $ prettyPerson author+      ", "+  p $ "on " >> time (convertDoc $ prettyTime $ entryUpdated entry)++-- | Generate the HTML content for a given feed element+defaultBody :: Feed -> FeedElement -> Html+defaultBody _ (RssElement item) = p $ preEscapedToHtml $ itemDescription item+defaultBody _ (AtomElement entry) = do+  unless (null links) $ p $ do+    "Related links:"+    H.ul $ forM_ links $ \uri -> H.li (H.a ! H.href (convertAtomURI uri) $ convertAtomURI uri)+  p $ preEscapedToHtml $ fromMaybe "<empty>" $ content <|> summary+  where links   = map linkHref $ entryLinks entry+        content = show . prettyAtomContent <$> entryContent entry :: Maybe Text+        summary = show . prettyAtomText <$> entrySummary entry :: Maybe Text+++convertAtomURI :: (IsString t) => AtomURI -> t+convertAtomURI = withAtomURI convertURI++convertURI :: (IsString t) => URIRef a -> t+convertURI = convertText . decodeUtf8 . serializeURIRef'++convertText :: (IsString t) => Text -> t+convertText = fromString . toString (const "?")++convertDoc :: (IsString t) => Doc -> t+convertDoc = show

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE TypeOperators         #-}@@ -12,8 +13,6 @@ import           Imm.Prelude  import           Control.Monad.Trans.Free---- import           Text.PrettyPrint.ANSI.Leijen -- }}}  -- * Types@@ -22,40 +21,50 @@   deriving(Eq, Ord, Read, Show)  instance Pretty LogLevel where-  pretty Debug = text "DEBUG"-  pretty Info = text "INFO"+  pretty Debug   = text "DEBUG"+  pretty Info    = text "INFO"   pretty Warning = text "WARNING"-  pretty Error = text "ERROR"+  pretty Error   = text "ERROR"  -- | Logger DSL data LoggerF next-  = Log LogLevel Text next+  = Log LogLevel Doc next   | GetLevel (LogLevel -> next)   | SetLevel LogLevel next+  | SetColorize Bool next+  | Flush next   deriving(Functor)  -- | Logger interpreter data CoLoggerF m a = CoLoggerF-  { logH      :: LogLevel -> Text -> m a-  , getLevelH :: m (LogLevel, a)-  , setLevelH :: LogLevel -> m a+  { logH         :: LogLevel -> Doc -> m a+  , getLevelH    :: m (LogLevel, a)+  , setLevelH    :: LogLevel -> m a+  , setColorizeH :: Bool -> m a+  , flushH       :: 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+  pairM p CoLoggerF{logH} (Log level message next) = do+    a <- logH level message     p a next-  pairM p (CoLoggerF _ gl _) (GetLevel next) = do-    (l, a) <- gl+  pairM p CoLoggerF{getLevelH} (GetLevel next) = do+    (l, a) <- getLevelH     p a (next l)-  pairM p (CoLoggerF _ _ sl) (SetLevel level next) = do-    a <- sl level+  pairM p CoLoggerF{setLevelH} (SetLevel level next) = do+    a <- setLevelH level     p a next+  pairM p CoLoggerF{setColorizeH} (SetColorize colorize next) = do+    a <- setColorizeH colorize+    p a next+  pairM p CoLoggerF{flushH} (Flush next) = do+    a <- flushH+    p a next  -- * Primitives -log :: (Functor f, MonadFree f m, LoggerF :<: f) => LogLevel -> Text -> m ()+log :: (Functor f, MonadFree f m, LoggerF :<: f) => LogLevel -> Doc -> m () log level message = liftF . inj $ Log level message ()  getLogLevel :: (Functor f, MonadFree f m, LoggerF :<: f) => m LogLevel@@ -64,9 +73,15 @@ setLogLevel :: (Functor f, MonadFree f m, LoggerF :<: f) => LogLevel -> m () setLogLevel level = liftF . inj $ SetLevel level () +setColorizeLogs :: (Functor f, MonadFree f m, LoggerF :<: f) => Bool -> m ()+setColorizeLogs colorize = liftF . inj $ SetColorize colorize ()++flushLogs :: (Functor f, MonadFree f m, LoggerF :<: f) => m ()+flushLogs = liftF . inj $ Flush ()+ -- * Helpers -logDebug, logInfo, logWarning, logError :: (Functor f, MonadFree f m, LoggerF :<: f) => Text -> m ()+logDebug, logInfo, logWarning, logError :: (Functor f, MonadFree f m, LoggerF :<: f) => Doc -> m () logDebug = log Debug logInfo = log Info logWarning = log Warning

@@ -7,6 +7,7 @@ -- {{{ Imports import           Imm.Logger            as Reexport import           Imm.Prelude+import           Imm.Pretty  import           System.Log.FastLogger as Reexport -- }}}@@ -17,25 +18,33 @@   { 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+  , colorizeLogs   :: Bool       -- ^ Enable log colorisation   }  -- | Default logger forwards error messages to stderr, and other messages to stdout.-defaultLogger :: IO LoggerSettings-defaultLogger = LoggerSettings+defaultLogger :: MonadIO m => m LoggerSettings+defaultLogger = io $ LoggerSettings   <$> newStdoutLoggerSet defaultBufSize   <*> newStderrLoggerSet defaultBufSize   <*> pure Info+  <*> pure True  -- * Interpreter  -- | Interpreter for 'LoggerF' mkCoLogger :: (MonadIO m) => LoggerSettings -> CoLoggerF m LoggerSettings-mkCoLogger settings = CoLoggerF coLog coGetLevel coSetLevel where+mkCoLogger settings = CoLoggerF coLog coGetLevel coSetLevel coSetColorize coFlush where   coLog Error t = do-    io $ pushLogStrLn (errorLoggerSet settings) $ toLogStr $ "ERROR: " <> t+    io $ pushLogStrLn (errorLoggerSet settings) $ toLogStr $ (show :: Doc -> String) $ handleColor $ red t     return settings   coLog l t = do-    when (l >= logLevel settings) $ io $ pushLogStrLn (loggerSet settings) $ toLogStr $ show (pretty l) <> ": " <> t+    when (l >= logLevel settings) $ io $ pushLogStrLn (loggerSet settings) $ toLogStr $ (show :: Doc -> String) $ handleColor t     return settings   coGetLevel = return (logLevel settings, settings)   coSetLevel l = return $ settings { logLevel = l }+  coSetColorize c = return $ settings { colorizeLogs = c }+  coFlush = do+    io $ flushLogStr $ loggerSet settings+    io $ flushLogStr $ errorLoggerSet settings+    return settings+  handleColor = if colorizeLogs settings then id else plain

@@ -9,7 +9,7 @@ import qualified Imm.Dyre                    as Dyre import           Imm.Feed import           Imm.Logger                  as Logger-import           Imm.Prelude                 hiding ((<>))+import           Imm.Prelude import           Imm.Pretty  import           Options.Applicative.Builder@@ -35,30 +35,31 @@ 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+  pretty (Check f)       = "Check feed(s):" <+> pretty f+  pretty Import          = "Import feeds"+  pretty (Read f)        = "Mark feed(s) as read:" <+> pretty f+  pretty Rebuild         = "Rebuild configuration"+  pretty (Unread f)      = "Mark feed(s) as unread:" <+> pretty f+  pretty (Run f)         = "Download new entries from feed(s):" <+> pretty f+  pretty (Show f)        = "Show status for feed(s):" <+> pretty f+  pretty ShowVersion     = "Show program version"+  pretty (Subscribe f _) = "Subscribe to feed:" <+> prettyURI f+  pretty (Unsubscribe f) = "Unsubscribe from feed(s):" <+> pretty f  defaultCommand :: Command defaultCommand = Show Nothing  -- | Available commandline options. data CliOptions = CliOptions-  { optionCommand  :: Command-  , optionDyreMode :: Dyre.Mode-  , optionLogLevel :: LogLevel+  { optionCommand      :: Command+  , optionDyreMode     :: Dyre.Mode+  , optionLogLevel     :: LogLevel+  , optionColorizeLogs :: Bool   }  -- deriving instance Eq CliOptions defaultOptions :: CliOptions-defaultOptions = CliOptions defaultCommand Dyre.defaultMode Info+defaultOptions = CliOptions defaultCommand Dyre.defaultMode Info True  -- instance Pretty CliOptions where --     pretty opts = text "ACTION" <> equals <>  $ opts^.command_@@ -67,7 +68,7 @@ --         ++ 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.")+parseOptions = io $ customExecParser (defaultPrefs {- noBacktrack -} ) (info parser $ progDesc "Fetch elements from RSS/Atom feeds and execute arbitrary actions for each of them.")   where parser = helper <*> optional dyreMasterBinary *> optional dyreDebug *> cliOptions  @@ -76,6 +77,7 @@   <$> commands   <*> (vanillaFlag <|> forceReconfFlag <|> denyReconfFlag <|> pure Dyre.defaultMode)   <*> (verboseFlag <|> quietFlag <|> logLevel <|> pure Info)+  <*> (colorizeLogs <|> pure True)   commands :: Parser Command@@ -106,11 +108,14 @@ dyreMasterBinary = strOption $ long "dyre-master-binary" <> metavar "PATH" <> hidden <> internal <> help "Internal flag used for dynamic reconfiguration." -- }}} --- {{{ Log level options+-- {{{ Log 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."++colorizeLogs :: Parser Bool+colorizeLogs = flag' False $ long "nocolor" <> help "Disable log colorisation." -- }}}  -- {{{ Other options@@ -127,7 +132,7 @@ uriReader = eitherReader $ first show . parseURI laxURIParserOptions . encodeUtf8 . fromString  feedRefOption :: Parser FeedRef-feedRefOption = fmap FeedRef $ (Left <$> argument auto (metavar "ID")) <|> (Right <$> argument uriReader (metavar "URI"))+feedRefOption = argument ((ByUID <$> auto) <|> (ByURI <$> uriReader)) $ metavar "TARGET"  uriArgument :: String -> Parser URI uriArgument helpText = argument uriReader $ metavar "URI" <> help helpText

@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE EmptyDataDecls         #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-}@@ -16,29 +17,32 @@ import           Control.Applicative             as X import           Control.Comonad import           Control.Comonad.Cofree+import           Control.Exception.Safe          as X import           Control.Monad                   as X (MonadPlus (..), unless,                                                        void, when)-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.Either                     as X import           Data.Foldable                   as X (forM_) import           Data.Functor.Identity+import           Data.Functor.Product+import           Data.Functor.Sum 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                     as X hiding (Product, Sum) import           Data.Monoid.Textual             as X (TextualMonoid (),                                                        fromText) import           Data.MonoTraversable.Unprefixed as X hiding (forM_, mapM_) import           Data.Ord                        as X import           Data.Sequences                  as X import           Data.String                     as X (IsString (..))+import           Data.Tagged import qualified Data.Text                       as T (Text ()) import qualified Data.Text.Lazy                  as LT (Text ()) import           Data.Traversable                as X (forM)@@ -81,31 +85,64 @@ (>:) 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)+(*:*) :: (Functor f, Functor g) => (a -> f a) -> (b -> g b) -> (a, b) -> Product f g (a, b)+(*:*) f g (a,b) = Pair ((,b) <$> f a) ((a,) <$> g b) infixr 0 *:*  +data HLeft+data HRight+data HId+data HNo++type family Contains a b where+  Contains a a         = HId+  Contains a (Sum a b) = HLeft+  Contains a (Sum b c) = (HRight, Contains a c)+  Contains a b         = HNo++class Sub i sub sup where+  inj' :: Tagged i (sub a -> sup a)++instance Sub HId a a where+  inj' = Tagged id++instance Sub HLeft a (Sum a b) where+  inj' = Tagged InL++instance (Sub x f g) => Sub (HRight, x) f (Sum h g) where+  inj' = Tagged $ InR . proxy inj' (Proxy :: Proxy x)+++-- | A constraint @f :<: g@ expresses that @f@ is subsumed by @g@,+-- i.e. @f@ can be used to construct elements in @g@.+class (Functor sub, Functor sup) => sub :<: sup where+  inj :: sub a -> sup a++instance (Functor f, Functor g, Sub (Contains f g) f g) => f :<: g where+  inj = proxy inj' (Proxy :: Proxy (Contains f g))++ 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 (Sum f g) (Product f' g') m where+  pairM p (InL x) (Pair a _) = pairM p x a+  pairM p (InR x) (Pair _ 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+instance (PairingM f f' m, PairingM g g' m) => PairingM (Product f g) (Sum f' g') m where+  pairM p (Pair a _) (InL x) = pairM p a x+  pairM p (Pair _ 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+    Pure x  -> p a x     Free gs -> pairM (interpret p) (unwrap eval) gs  -- * Shortcuts

@@ -3,11 +3,12 @@ {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE PartialTypeSignatures #-}-module Imm.Pretty where+module Imm.Pretty (module Imm.Pretty, module X) where  -- {{{ Imports import           Imm.Prelude +import           Data.Monoid.Textual import           Data.NonNull import           Data.Time import           Data.Tree@@ -15,12 +16,16 @@ 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.PrettyPrint.ANSI.Leijen as X hiding ((<$>), (</>), (<>)) import           Text.RSS.Types               as RSS  import           URI.ByteString -- }}} +-- | Generalized 'text'+textual :: TextualMonoid t => t -> Doc+textual = text . toString (const "?")+ prettyTree :: (Pretty a) => Tree a -> Doc prettyTree (Node n s) = pretty n <++> indent 2 (vsep $ prettyTree <$> s) @@ -64,32 +69,32 @@  prettyAtomText :: AtomText -> Doc prettyAtomText (AtomPlainText _ t) = text $ fromText t-prettyAtomText (AtomXHTMLText 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)+prettyEntry e = "Entry:" <+> prettyAtomText (entryTitle e) <++> indent 4+  (         "By" <+> equals <+> list (prettyPerson <$> entryAuthors e)+  <++> "Updated" <+> equals <+> prettyTime (entryUpdated e)+  <++> "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)+prettyItem i = "Item:" <+> text (fromText $ itemTitle i) <++> indent 4+  (         "By" <+> equals <+> text (fromText $ itemAuthor i)+  <++> "Updated" <+> equals <+> fromMaybe "<empty>" (prettyTime <$> itemPubDate i)+  <++> "Link"    <+> equals <+> fromMaybe "<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 (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 (AtomContentInlineText _ t)  = text $ fromText t+prettyAtomContent (AtomContentInlineXHTML t)   = text $ fromText t prettyAtomContent (AtomContentInlineOther _ t) = text $ fromText t-prettyAtomContent (AtomContentOutOfLine _ u) = withAtomURI prettyURI u+prettyAtomContent (AtomContentOutOfLine _ u)   = withAtomURI prettyURI u