imm 1.3.0.0 → 1.4.0.0

raw patch · 20 files changed

+317/−375 lines, 20 filesdep +monad-controldep −transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: monad-control

Dependencies removed: transformers

API changes (from Hackage documentation)

Files

• README.md +2/−2
• imm.cabal +2/−2
• src/bin/Executable.hs +17/−11
• src/lib/Imm.hs +4/−4
• src/lib/Imm/Boot.hs +47/−102
• src/lib/Imm/Core.hs +54/−61
• src/lib/Imm/Database.hs +49/−39
• src/lib/Imm/Database/FeedTable.hs +23/−26
• src/lib/Imm/Database/JsonFile.hs +17/−22
• src/lib/Imm/HTTP.hs +15/−9
• src/lib/Imm/HTTP/Simple.hs +6/−8
• src/lib/Imm/Hooks.hs +14/−12
• src/lib/Imm/Hooks/Dummy.hs +5/−5
• src/lib/Imm/Hooks/SendMail.hs +9/−10
• src/lib/Imm/Hooks/WriteFile.hs +8/−9
• src/lib/Imm/Logger.hs +14/−17
• src/lib/Imm/Logger/Simple.hs +18/−26
• src/lib/Imm/Prelude.hs +1/−1
• src/lib/Imm/XML.hs +7/−3
• src/lib/Imm/XML/Conduit.hs +5/−6

@@ -9,13 +9,13 @@ To get started, please consult documentation of `Imm.Boot` module.  -## Example workflows+## Example use cases  ### Online feed reader  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.+Bonus points if your mail reader is online as you can now access your feeds from any computer connected to the Internet.  Check out `Imm.Hooks.SendMail` module. 

@@ -1,5 +1,5 @@ name:                imm-version:             1.3.0.0+version:             1.4.0.0 synopsis:            Execute arbitrary actions for each unread element of RSS/Atom feeds description:         Cf README file homepage:            https://github.com/k0ral/imm@@ -67,6 +67,7 @@     lifted-base,     microlens,     mime-mail,+    monad-control,     monad-time,     monoid-subclasses,     mono-traversable >= 1,@@ -83,7 +84,6 @@     streaming-with,     streamly,     text,-    transformers,     transformers-base,     time,     timerep >= 2.0.0.0,

@@ -3,21 +3,27 @@  -- {{{ Imports import           Imm-import           Imm.Database.JsonFile-import           Imm.Hooks.Dummy-import           Imm.HTTP.Simple-import           Imm.Logger.Simple+import           Imm.Database.JsonFile as Database+import           Imm.Hooks.Dummy as Hooks+import           Imm.HTTP.Simple as HTTP+import           Imm.Logger.Simple as Logger import           Imm.Prelude-import           Imm.XML.Conduit--import           Control.Concurrent.MVar+import           Imm.XML.Conduit as XML -- }}}   main :: IO () main = do-  logger <- defaultLogger-  manager <- defaultManager-  database <- defaultDatabase :: IO (MVar (JsonFileDatabase FeedTable))+  logger <- Logger.mkHandle <$> defaultLogger+  database <- Database.mkHandle <$> defaultDatabase+  httpClient <- HTTP.mkHandle <$> defaultManager -  imm $ mkModulesM manager database logger DummyHooks defaultXmlParser+  imm logger database httpClient hooks xmlParser++xmlParser :: XML.Handle IO+xmlParser = XML.mkHandle defaultXmlParser++hooks :: Hooks.Handle IO+hooks = Hooks.mkHandle++

@@ -5,8 +5,8 @@  import           Imm.Boot     as X import           Imm.Core     as X-import           Imm.Database as X+import           Imm.Database as X hiding(Handle) import           Imm.Feed     as X-import           Imm.Hooks    as X-import           Imm.HTTP     as X-import           Imm.Logger   as X+import           Imm.Hooks    as X hiding(Handle)+import           Imm.HTTP     as X hiding(Handle)+import           Imm.Logger   as X hiding(Handle)

@@ -16,10 +16,10 @@ -- -- Your personal configuration is located at @$XDG_CONFIG_HOME\/imm\/imm.hs@. ----- == @ReaderT@ pattern+-- == Handle pattern ----- The behavior of this program can be customized through the @ReaderT@ pattern.-module Imm.Boot (imm, Modules(..), ModulesM, mkModulesM) where+-- The behavior of this program can be customized through the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).+module Imm.Boot (imm) where  -- {{{ Imports import qualified Imm.Core                   as Core@@ -27,97 +27,44 @@ import           Imm.Database.FeedTable     as Database import           Imm.Dyre                   as Dyre import           Imm.Feed-import           Imm.Hooks+import           Imm.Hooks as Hooks import           Imm.HTTP                   as HTTP import           Imm.Logger                 as Logger import           Imm.Options                as Options hiding (logLevel) import           Imm.Prelude import           Imm.Pretty-import           Imm.XML+import           Imm.XML as XML -import           Control.Monad.Time-import           Control.Monad.Trans.Reader import           Data.Conduit.Combinators   (stdin)-import           Streamly                   (MonadAsync) import           System.IO                  (hFlush) -- }}} --- | Modules are independent features of the program which behavior can be controlled by the user.-data Modules httpClient databaseClient logger hooks xmlParser = Modules-  { _httpClient     :: httpClient      -- ^ HTTP client interpreter (cf "Imm.HTTP")-  , _databaseClient :: databaseClient  -- ^ Database interpreter (cf "Imm.Database")-  , _logger         :: logger          -- ^ Logging interpreter (cf "Imm.Logger")-  , _hooks          :: hooks           -- ^ Hooks interpreter (cf "Imm.Hooks")-  , _xmlParser      :: xmlParser       -- ^ XML parsing interpreter (cf "Imm.XML")-  }---- | Type-erased version of 'Modules', using existential quantification.-data ModulesM m = forall a b c d e .-  ( MonadHttpClient (ReaderT a m)-  , MonadDatabase FeedTable (ReaderT b m)-  , MonadLog (ReaderT c m)-  , MonadImm (ReaderT d m)-  , MonadXmlParser (ReaderT e m)-  ) => ModulesM (Modules a b c d e)---- | Constructor for 'ModulesM'.-mkModulesM :: (MonadXmlParser (ReaderT e m), MonadImm (ReaderT d m), MonadLog (ReaderT c m), MonadDatabase FeedTable (ReaderT b m), MonadHttpClient (ReaderT a m))-           => a -> b -> c -> d -> e -> ModulesM m-mkModulesM a b c d e = ModulesM $ Modules a b c d e---instance (MonadIO m, MonadLog (ReaderT c m)) => MonadLog (ReaderT (Modules a b c d e) m) where-  log l t = withReaderT _logger $ log l t-  getLogLevel = withReaderT _logger getLogLevel-  setLogLevel l = withReaderT _logger $ setLogLevel l-  setColorizeLogs c = withReaderT _logger $ setColorizeLogs c-  flushLogs = withReaderT _logger flushLogs--instance (Monad m, MonadImm (ReaderT d m)) => MonadImm (ReaderT (Modules a b c d e) m) where-  processNewElement feed element = withReaderT _hooks $ processNewElement feed element--instance (MonadThrow m, MonadHttpClient (ReaderT a m)) => MonadHttpClient (ReaderT (Modules a b c d e) m) where-  httpGet uri = withReaderT _httpClient $ httpGet uri--instance (MonadThrow m, MonadXmlParser (ReaderT e m))-  => MonadXmlParser (ReaderT (Modules a b c d e) m) where-  parseXml uri bytes = withReaderT _xmlParser $ parseXml uri bytes--instance (MonadThrow m, MonadDatabase FeedTable (ReaderT b m))-  => MonadDatabase FeedTable (ReaderT (Modules a b c d e) m) where-  _describeDatabase t = withReaderT _databaseClient $ _describeDatabase t-  _fetchList t k = withReaderT _databaseClient $ _fetchList t k-  _fetchAll t = withReaderT _databaseClient $ _fetchAll t-  _update t key f = withReaderT _databaseClient $ _update t key f-  _insertList t list = withReaderT _databaseClient $ _insertList t list-  _deleteList t k = withReaderT _databaseClient $ _deleteList t k-  _purge t = withReaderT _databaseClient $ _purge t-  _commit t = withReaderT _databaseClient $ _commit t-- -- | Main function, meant to be used in your personal configuration file. -- -- Here is an example: -- -- > import           Imm.Boot--- > import           Imm.Database.JsonFile+-- > import           Imm.Database.JsonFile as Database -- > import           Imm.Feed--- > import           Imm.Hooks.SendMail--- > import           Imm.HTTP.Conduit--- > import           Imm.Logger.Simple--- > import           Imm.XML.Simple+-- > import           Imm.Hooks.SendMail as Hooks+-- > import           Imm.HTTP.Simple as HTTP+-- > import           Imm.Logger.Simple as Logger+-- > import           Imm.XML.Conduit as XML -- > -- > main :: IO () -- > main = do--- >   logger   <- defaultLogger--- >   manager  <- defaultManager--- >   database <- defaultDatabase+-- >   logger     <- Logger.mkHandle <$> defaultLogger+-- >   database   <- Database.mkHandle <$> defaultDatabase+-- >   httpClient <- HTTP.mkHandle <$> defaultManager -- >--- >   imm $ mkModulesM manager database logger sendmail defaultXmlParser+-- >   imm logger database httpClient hooks xmlParser -- >--- > sendmail :: SendMailSettings--- > sendmail = SendMailSettings smtpServer formatMail+-- > xmlParser :: XML.Handle IO+-- > xmlParser = XML.mkHandle defaultXmlParser -- >+-- > hooks :: Hooks.Handle IO+-- > hooks = Hooks.mkHandle $ SendMailSettings smtpServer formatMail+-- > -- > formatMail :: FormatMail -- > formatMail = FormatMail -- >   (\a b -> (defaultFormatFrom a b) { addressEmail = "user@host" } )@@ -129,35 +76,34 @@ -- > smtpServer _ _ = SMTPServer -- >   (Just $ Authentication PLAIN "user" "password") -- >   (StartTls "smtp.host" defaultSettingsSMTPSTARTTLS)-imm :: ModulesM IO -> IO ()-imm modules = void $ do+imm :: Logger.Handle IO -> Database.Handle IO FeedTable -> HTTP.Handle IO -> Hooks.Handle IO -> XML.Handle IO -> IO ()+imm logger database httpClient hooks xmlParser = void $ do   options <- parseOptions-  Dyre.wrap (optionDyreMode options) realMain (optionCommand options, optionLogLevel options, optionColorizeLogs options, modules)+  Dyre.wrap (optionDyreMode options) realMain (optionCommand options, optionLogLevel options, optionColorizeLogs options, logger, database, httpClient, hooks, xmlParser) -realMain :: (MonadAsync m, MonadTime m, MonadCatch m)-         => (Command, LogLevel, Bool, ModulesM m) -> m ()-realMain (command, logLevel, enableColors, ModulesM modules) = void $ flip runReaderT modules $ do-  setColorizeLogs enableColors-  setLogLevel logLevel-  logDebug . ("Dynamic reconfiguration settings:" <++>) . indent 2 =<< Dyre.describePaths-  logDebug $ "Executing: " <> pretty command-  logDebug . ("Using database:" <++>) . indent 2 =<< _describeDatabase FeedTable+realMain :: (Command, LogLevel, Bool, Logger.Handle IO, Database.Handle IO FeedTable, HTTP.Handle IO, Hooks.Handle IO, XML.Handle IO) -> IO ()+realMain (command, logLevel, enableColors, logger, database, httpClient, hooks, xmlParser) = void $ do+  setColorizeLogs logger enableColors+  setLogLevel logger logLevel+  log logger Debug . ("Dynamic reconfiguration settings:" <++>) . indent 2 =<< Dyre.describePaths+  log logger Debug $ "Executing: " <> pretty command+  log logger Debug . ("Using database:" <++>) . indent 2 =<< _describeDatabase database -  handleAny (logError . pretty . displayException) $ case command of-    Check t        -> Core.check =<< resolveTarget ByPassConfirmation t+  handleAny (log logger Error . pretty . displayException) $ case command of+    Check t        -> Core.check logger database httpClient xmlParser =<< resolveTarget database ByPassConfirmation t     Help           -> liftBase $ putStrLn helpString-    Import         -> Core.importOPML stdin-    Read t         -> mapM_ Database.markAsRead =<< resolveTarget AskConfirmation t-    Run t          -> Core.run =<< resolveTarget ByPassConfirmation t-    Show t         -> Core.showFeed =<< resolveTarget ByPassConfirmation t+    Import         -> Core.importOPML logger database stdin+    Read t         -> mapM_ (Database.markAsRead logger database) =<< resolveTarget database AskConfirmation t+    Run t          -> Core.run logger database httpClient hooks xmlParser =<< resolveTarget database ByPassConfirmation t+    Show t         -> Core.showFeed logger database =<< resolveTarget database ByPassConfirmation t     ShowVersion    -> Core.printVersions-    Subscribe u c  -> Core.subscribe u c-    Unread t       -> mapM_ Database.markAsUnread =<< resolveTarget AskConfirmation t-    Unsubscribe t  -> Database.deleteList FeedTable =<< resolveTarget AskConfirmation t+    Subscribe u c  -> Core.subscribe logger database u c+    Unread t       -> mapM_ (Database.markAsUnread logger database) =<< resolveTarget database AskConfirmation t+    Unsubscribe t  -> Database.deleteList logger database =<< resolveTarget database AskConfirmation t     _              -> return () -  Database.commit FeedTable-  flushLogs+  Database.commit logger database+  flushLogs logger   -- * Util@@ -177,14 +123,13 @@   unless (null x || x == ("Y" :: Text)) $ throwM InterruptedException  -resolveTarget :: (MonadBase IO m, MonadThrow m, MonadDatabase FeedTable m)-              => SafeGuard -> Maybe Core.FeedRef -> m [FeedID]-resolveTarget s Nothing = do-  result <- keys <$> Database.fetchAll FeedTable+resolveTarget :: MonadBase IO m => MonadThrow m => Database.Handle m FeedTable -> SafeGuard -> Maybe Core.FeedRef -> m [FeedID]+resolveTarget database s Nothing = do+  result <- keys <$> Database.fetchAll database   when (s == AskConfirmation) $ liftBase $ promptConfirm $ "This will affect " <> show (length result) <> " feeds."   return result-resolveTarget _ (Just (ByUID i)) = do-  result <- fst . (!! i) . mapToList <$> Database.fetchAll FeedTable-  -- logInfo $ "Target(s): " <> show (pretty result)+resolveTarget database _ (Just (ByUID i)) = do+  result <- fst . (!! (i-1)) . mapToList <$> Database.fetchAll database+  -- log logger Info $ "Target(s): " <> show (pretty result)   return $ singleton result-resolveTarget _ (Just (ByURI uri)) = return [FeedID uri]+resolveTarget _ _ (Just (ByURI uri)) = return [FeedID uri]

@@ -18,18 +18,16 @@ ) where  -- {{{ Imports-import           Imm.Database                (MonadDatabase) import qualified Imm.Database                as Database import           Imm.Database.FeedTable import qualified Imm.Database.FeedTable      as Database import           Imm.Feed import           Imm.Hooks                   as Hooks-import           Imm.HTTP                    (MonadHttpClient) import qualified Imm.HTTP                    as HTTP-import           Imm.Logger+import           Imm.Logger as Logger import           Imm.Prelude import           Imm.Pretty-import           Imm.XML+import           Imm.XML as XML  import           Control.Concurrent.STM      (STM, atomically) import           Control.Concurrent.STM.TVar@@ -60,105 +58,103 @@   putStrLn $ "compiled by " <> Text.pack compilerName <> "-" <> Text.pack (showVersion compilerVersion)  -- | Print database status for given feed(s)-showFeed :: (MonadLog m, MonadThrow m, MonadDatabase FeedTable m)-         => [FeedID] -> m ()-showFeed feedIDs = do-  entries <- Database.fetchList FeedTable feedIDs-  flushLogs-  when (null entries) $ logWarning "No subscription"+showFeed :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> [FeedID] -> m ()+showFeed logger database feedIDs = do+  entries <- Database.fetchList database feedIDs+  flushLogs logger+  when (null entries) $ log logger Warning "No subscription"   forM_ (zip [1..] $ Map.elems entries) $ \(i, entry) ->-    logInfo $ pretty (i :: Int) <+> prettyDatabaseEntry entry+    log logger Info $ pretty (i :: Int) <+> prettyDatabaseEntry entry  -- | Register the given feed URI in database-subscribe :: (MonadLog m, MonadDatabase FeedTable m, MonadCatch m)-          => URI -> Set Text -> m ()-subscribe uri = Database.register (FeedID uri)+subscribe :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> URI -> Set Text -> m ()+subscribe logger database uri = Database.register logger database (FeedID uri)  -- | Check for unread elements without processing them-check :: (MonadAsync m, MonadCatch m, MonadLog m, MonadDatabase FeedTable m, MonadHttpClient m, MonadXmlParser m)-      => [FeedID] -> m ()-check feedIDs = do+check :: (MonadAsync m, MonadCatch m)+      => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> XML.Handle m -> [FeedID] -> m ()+check logger database httpClient xmlParser feedIDs = do   progress <- liftBase $ newTVarIO 0    results <- Stream.toList $ wAsyncly $ do     feedID <- Stream.fromFoldable feedIDs-    result <- lift $ tryAny $ checkOne feedID+    result <- lift $ tryAny $ checkOne logger database httpClient xmlParser feedID     let logResult = either (red . pretty . displayException) (\n -> green (pretty n) <+> "new element(s)") result     n <- liftBase $ atomically $ do       modifyTVar (progress :: TVar Int) (+ 1)       readTVar progress-    lift $ logInfo $ brackets (fill width (bold $ cyan $ pretty n) <+> "/" <+> pretty total) <+> "Checked" <+> magenta (pretty feedID) <+> "=>" <+> logResult+    lift $ log logger Info $ brackets (fill width (bold $ cyan $ pretty n) <+> "/" <+> pretty total) <+> "Checked" <+> magenta (pretty feedID) <+> "=>" <+> logResult     return result -  flushLogs+  flushLogs logger    let (failures, successes) = partitionEithers $ zipWith (\a -> bimap (a,) (a,)) feedIDs results-  unless (null failures) $ logError $ bold (pretty $ length failures) <+> "feeds in error"-  logInfo $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall"+  unless (null failures) $ log logger Error $ bold (pretty $ length failures) <+> "feeds in error"+  log logger Info $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall"    where width = length (show total :: String)         total = length feedIDs -checkOne :: (MonadBase IO m, MonadCatch m, MonadLog m, MonadDatabase FeedTable m, MonadHttpClient m, MonadXmlParser m)-         => FeedID -> m Int-checkOne feedID = do-  feed <- getFeed feedID+checkOne :: (MonadBase IO m, MonadCatch m)+         => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> XML.Handle m -> FeedID -> m Int+checkOne logger database httpClient xmlParser feedID = do+  feed <- getFeed logger httpClient xmlParser feedID   case feed of-    Atom _ -> logDebug $ "Parsed Atom feed: " <> pretty feedID-    Rss _  -> logDebug $ "Parsed RSS feed: " <> pretty feedID+    Atom _ -> log logger Debug $ "Parsed Atom feed: " <> pretty feedID+    Rss _  -> log logger Debug $ "Parsed RSS feed: " <> pretty feedID    let dates = mapMaybe getDate $ getElements feed -  logDebug $ vsep $ map prettyElement $ getElements feed-  status <- Database.getStatus feedID+  log logger Debug $ vsep $ map prettyElement $ getElements feed+  status <- Database.getStatus database feedID    return $ length $ filter (unread status) dates   where unread (LastUpdate t1) t2 = t2 > t1         unread _ _                = True  -run :: (MonadTime m, MonadAsync m, MonadCatch m, MonadImm m, MonadLog m, MonadDatabase FeedTable m, MonadHttpClient m, MonadXmlParser m)-    => [FeedID] -> m ()-run feedIDs = do+run :: (MonadTime m, MonadAsync m, MonadCatch m)+    => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> Hooks.Handle m -> XML.Handle m -> [FeedID] -> m ()+run logger database httpClient hooks xmlParser feedIDs = do   progress <- liftBase $ newTVarIO 0    results <- Stream.toList $ wAsyncly $ do     feedID <- Stream.fromFoldable feedIDs-    result <- lift $ tryAny $ runOne feedID+    result <- lift $ tryAny $ runOne logger database httpClient hooks xmlParser feedID     let logResult = either (red . pretty . displayException) (\n -> green (pretty n) <+> "new element(s)") result     n <- liftBase $ atomically $ do       modifyTVar progress (+ 1)       readTVar progress :: STM Int-    lift $ logInfo $ brackets (fill width (bold $ cyan $ pretty n) <+> "/" <+> pretty total) <+> "Processed" <+> magenta (pretty feedID) <+> "=>" <+> logResult+    lift $ log logger Info $ brackets (fill width (bold $ cyan $ pretty n) <+> "/" <+> pretty total) <+> "Processed" <+> magenta (pretty feedID) <+> "=>" <+> logResult     return $ bimap (feedID,) (feedID,) result -  flushLogs+  flushLogs logger    let (failures, successes) = partitionEithers results -  unless (null failures) $ logError $ bold (pretty $ length failures) <+> "feeds in error"-  logInfo $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall"+  unless (null failures) $ log logger Error $ bold (pretty $ length failures) <+> "feeds in error"+  log logger Info $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall"    where width = length (show total :: String)         total = length feedIDs -runOne :: (MonadTime m, MonadCatch m, MonadImm m, MonadLog m, MonadDatabase FeedTable m, MonadHttpClient m, MonadXmlParser m)-       => FeedID -> m Int-runOne feedID = do-  feed <- getFeed feedID-  unreadElements <- filterM (fmap not . isRead feedID) $ getElements feed+runOne :: (MonadTime m, MonadCatch m)+       => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> Hooks.Handle m -> XML.Handle m -> FeedID -> m Int+runOne logger database httpClient hooks xmlParser feedID = do+  feed <- getFeed logger httpClient xmlParser feedID+  unreadElements <- filterM (fmap not . isRead database feedID) $ getElements feed    forM_ unreadElements $ \element -> do-    onNewElement feed element-    mapM_ (Database.addReadHash feedID) $ getHashes element+    onNewElement logger hooks feed element+    mapM_ (Database.addReadHash logger database feedID) $ getHashes element -  Database.markAsRead feedID+  Database.markAsRead logger database feedID   return $ length unreadElements  -isRead :: (MonadCatch m, MonadDatabase FeedTable m) => FeedID -> FeedElement -> m Bool-isRead feedID element = do-  DatabaseEntry _ _ readHashes lastCheck <- Database.fetch FeedTable feedID+isRead :: MonadCatch m => Database.Handle m FeedTable -> FeedID -> FeedElement -> m Bool+isRead database feedID element = do+  DatabaseEntry _ _ readHashes lastCheck <- Database.fetch database feedID   let matchHash = not $ null $ (setFromList (getHashes element) :: Set Int) `intersection` readHashes       matchDate = case (lastCheck, getDate element) of         (Nothing, _)     -> False@@ -167,19 +163,16 @@   return $ matchHash || matchDate  -- | 'subscribe' to all feeds described by the OPML document provided in input-importOPML :: (MonadLog m, MonadDatabase FeedTable m, MonadCatch m)-           => ConduitT () ByteString m () -> m ()-importOPML input = do+importOPML :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> ConduitT () ByteString m () -> m ()+importOPML logger database input = do   opml <- runConduit $ input .| XML.parseBytes def .| force "Invalid OPML" parseOpml-  forM_ (opmlOutlines opml) $ importOPML' mempty+  forM_ (opmlOutlines opml) $ importOPML' logger database mempty -importOPML' :: (MonadLog m, MonadDatabase FeedTable m, MonadCatch m)-            => Set Text -> Tree OpmlOutline -> m ()-importOPML' _ (Node (OpmlOutlineGeneric b _) sub) = mapM_ (importOPML' (Set.singleton . toNullable $ OPML.text b)) sub-importOPML' c (Node (OpmlOutlineSubscription _ s) _) = subscribe (xmlUri s) c-importOPML' _ _ = return ()+importOPML' :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> Set Text -> Tree OpmlOutline -> m ()+importOPML' logger database _ (Node (OpmlOutlineGeneric b _) sub) = mapM_ (importOPML' logger database (Set.singleton . toNullable $ OPML.text b)) sub+importOPML' logger database c (Node (OpmlOutlineSubscription _ s) _) = subscribe logger database (xmlUri s) c+importOPML' _ _ _ _ = return ()  -getFeed :: (MonadCatch m, MonadHttpClient m, MonadLog m, MonadXmlParser m)-        => FeedID -> m Feed-getFeed (FeedID uri) = HTTP.get uri >>= parseXml uri+getFeed :: MonadCatch m => Logger.Handle m -> HTTP.Handle m -> XML.Handle m -> FeedID -> m Feed+getFeed logger httpClient xmlParser (FeedID uri) = HTTP.get logger httpClient uri >>= parseXml xmlParser uri

@@ -3,14 +3,20 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE UndecidableInstances  #-} -- | Database module abstracts over a key-value database that supports CRUD operations.+--+-- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).+--+-- > import qualified Imm.Database as Database module Imm.Database where  -- {{{ Imports-import           Imm.Logger+import qualified Imm.Logger as Logger+import           Imm.Logger hiding(Handle) import           Imm.Prelude import           Imm.Pretty @@ -24,17 +30,18 @@   => Table t where   type Key t :: *   type Entry t :: *+  rep :: t --- | Monad capable of interacting with a key-value store.-class MonadThrow m => MonadDatabase t m where-  _describeDatabase :: t -> m (Doc a)-  _fetchList :: t -> [Key t] -> m (Map (Key t) (Entry t))-  _fetchAll :: t -> m (Map (Key t) (Entry t))-  _update :: t -> Key t -> (Entry t -> Entry t) -> m ()-  _insertList :: t -> [(Key t, Entry t)] -> m ()-  _deleteList :: t -> [Key t] -> m ()-  _purge :: t -> m ()-  _commit :: t -> m ()+data Handle m t = Handle+  { _describeDatabase :: forall a . m (Doc a)+  , _fetchList :: [Key t] -> m (Map (Key t) (Entry t))+  , _fetchAll :: m (Map (Key t) (Entry t))+  , _update :: Key t -> (Entry t -> Entry t) -> m ()+  , _insertList :: [(Key t, Entry t)] -> m ()+  , _deleteList :: [Key t] -> m ()+  , _purge :: m ()+  , _commit :: m ()+  }   data DatabaseException t@@ -64,43 +71,46 @@  -- * Primitives -fetch :: (MonadDatabase t m, Table t, MonadThrow m) => t -> Key t -> m (Entry t)-fetch t k = do-  results <- _fetchList t [k]-  maybe (throwM $ NotFound t [k]) return $ lookup k results+fetch :: Monad m => Table t => MonadThrow m => Handle m t -> Key t -> m (Entry t)+fetch handle k = do+  results <- _fetchList handle [k]+  maybe (throwM $ NotFound (table handle) [k]) return $ lookup k results -fetchList :: (MonadDatabase t m, MonadThrow m) => t -> [Key t] -> m (Map (Key t) (Entry t))+fetchList :: Monad m => Handle m t -> [Key t] -> m (Map (Key t) (Entry t)) fetchList = _fetchList -fetchAll :: (MonadThrow m, MonadDatabase t m) => t -> m (Map (Key t) (Entry t))+fetchAll :: Monad m => Handle m t -> m (Map (Key t) (Entry t)) fetchAll = _fetchAll -update :: (MonadDatabase t m, MonadThrow m) => t -> Key t -> (Entry t -> Entry t) -> m ()+update :: Monad m => Handle m t -> Key t -> (Entry t -> Entry t) -> m () update  = _update -insert :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> Key t -> Entry t -> m ()-insert t k v = insertList t [(k, v)]+insert :: Monad m => Logger.Handle m -> Handle m t -> Key t -> Entry t -> m ()+insert logger handle k v = insertList logger handle [(k, v)] -insertList :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> [(Key t, Entry t)] -> m ()-insertList t i = do-  logInfo $ "Inserting " <> yellow (pretty $ length i) <> " entries..."-  _insertList t i+insertList :: Monad m => Logger.Handle m -> Handle m t -> [(Key t, Entry t)] -> m ()+insertList logger handle i = do+  log logger Info $ "Inserting " <> yellow (pretty $ length i) <> " entries..."+  _insertList handle i -delete :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> Key t -> m ()-delete t k = deleteList t [k]+delete :: Monad m => Logger.Handle m -> Handle m t -> Key t -> m ()+delete logger handle k = deleteList logger handle [k] -deleteList :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> [Key t] -> m ()-deleteList t k = do-  logInfo $ "Deleting " <> yellow (pretty $ length k) <> " entries..."-  _deleteList t k+deleteList :: Monad m => Logger.Handle m -> Handle m t -> [Key t] -> m ()+deleteList logger handle k = do+  log logger Info $ "Deleting " <> yellow (pretty $ length k) <> " entries..."+  _deleteList handle k -purge :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> m ()-purge t = do-  logInfo "Purging database..."-  _purge t+purge :: Monad m => Logger.Handle m -> Handle m t -> m ()+purge logger handle = do+  log logger Info "Purging database..."+  _purge handle -commit :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> m ()-commit t = do-  logDebug "Committing database transaction..."-  _commit t-  logDebug "Database transaction committed"+commit :: Monad m => Logger.Handle m -> Handle m t -> m ()+commit logger handle = do+  log logger Debug "Committing database transaction..."+  _commit handle+  log logger Debug "Database transaction committed"++table :: Table t => Handle m t -> t+table _ = rep

@@ -7,8 +7,8 @@  -- {{{ Imports import           Imm.Aeson-import           Imm.Database-import           Imm.Logger+import           Imm.Database as Database+import           Imm.Logger as Logger import           Imm.Prelude import           Imm.Pretty @@ -80,6 +80,7 @@ instance Table FeedTable where   type Key FeedTable = FeedID   type Entry FeedTable = DatabaseEntry+  rep = FeedTable   data FeedStatus = Unknown | New | LastUpdate UTCTime@@ -95,37 +96,33 @@  -- * Primitives -register :: (MonadThrow m, MonadLog m, MonadDatabase FeedTable m)-          => FeedID -> Set Text -> m ()-register feedID tags = do-  logInfo $ "Registering feed" <+> magenta (pretty feedID) <> "..."-  insert FeedTable feedID $ newDatabaseEntry feedID tags+register :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> Set Text -> m ()+register logger database feedID tags = do+  log logger Info $ "Registering feed" <+> magenta (pretty feedID) <> "..."+  insert logger database feedID $ newDatabaseEntry feedID tags -getStatus :: (MonadDatabase FeedTable m, MonadCatch m)-          => FeedID -> m FeedStatus-getStatus feedID = handleAny (\_ -> return Unknown) $ do-  result <- fmap Just (fetch FeedTable feedID) `catchAny` (\_ -> return Nothing)+getStatus :: MonadCatch m => Database.Handle m FeedTable -> FeedID -> m FeedStatus+getStatus database feedID = handleAny (\_ -> return Unknown) $ do+  result <- fmap Just (fetch database feedID) `catchAny` (\_ -> return Nothing)   return $ maybe New LastUpdate $ entryLastCheck =<< result -addReadHash :: (MonadDatabase FeedTable m, MonadThrow m, MonadLog m)-               => FeedID -> Int -> m ()-addReadHash feedID hash = do-  logDebug $ "Adding read hash:" <+> pretty hash <> "..."-  update FeedTable feedID f+addReadHash :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> Int -> m ()+addReadHash logger database feedID hash = do+  log logger Debug $ "Adding read hash:" <+> pretty hash <> "..."+  update database feedID f   where f a = a { entryReadHashes = insertSet hash $ entryReadHashes a }  -- | Set the last check time to now-markAsRead :: (MonadTime m, MonadDatabase FeedTable m, MonadThrow m, MonadLog m)-           => FeedID -> m ()-markAsRead feedID = do-  logDebug $ "Marking feed as read:" <+> pretty feedID <> "..."+markAsRead :: (MonadTime m, MonadThrow m)+           => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m ()+markAsRead logger database feedID = do+  log logger Debug $ "Marking feed as read:" <+> pretty feedID <> "..."   utcTime <- currentTime-  update FeedTable feedID (f utcTime)+  update database feedID (f utcTime)   where f time a = a { entryLastCheck = Just time }  -- | Unset feed's last update and remove all read hashes-markAsUnread :: (MonadDatabase FeedTable m, MonadThrow m, MonadLog m)-             => FeedID -> m ()-markAsUnread feedID = do-  logInfo $ "Marking feed as unread:" <+> prettyFeedID feedID <> "..."-  update FeedTable feedID $ \a -> a { entryReadHashes = mempty, entryLastCheck = Nothing }+markAsUnread :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m ()+markAsUnread logger database feedID = do+  log logger Info $ "Marking feed as unread:" <+> prettyFeedID feedID <> "..."+  update database feedID $ \a -> a { entryReadHashes = mempty, entryLastCheck = Nothing }

@@ -10,6 +10,7 @@   ( JsonFileDatabase   , mkJsonFileDatabase   , defaultDatabase+  , mkHandle   , JsonException(..)   , module Imm.Database.FeedTable   ) where@@ -23,8 +24,6 @@ import           Imm.Pretty  import           Control.Concurrent.MVar.Lifted-import           Control.Monad.Reader.Class-import           Control.Monad.Trans.Reader     (ReaderT) import           Data.Aeson import           Data.ByteString.Lazy           (hPut) import           Data.ByteString.Streaming      (hGetContents, toLazy_)@@ -61,25 +60,21 @@   displayException _ = "Unable to parse JSON"  -instance (Table t, FromJSON (Key t), FromJSON (Entry t), ToJSON (Key t), ToJSON (Entry t))-  => MonadDatabase t (ReaderT (MVar (JsonFileDatabase t)) IO) where-  _describeDatabase _ = pretty <$> (readMVar =<< ask)-  _fetchList t keys = Map.filterWithKey (\uri _ -> member uri $ Set.fromList keys) <$> fetchAll t-  _fetchAll _ = do-    mvar <- ask-    lift $ modifyMVar mvar $ \database -> do-      a@(JsonFileDatabase _ cache _) <- loadInCache database-      return (a, cache)-  _update _ key f = exec (\a -> update a key f)-  _insertList _ rows = exec $ insert rows-  _deleteList _ keys = exec $ delete keys-  _purge _ = exec purge-  _commit _ = exec commit--exec :: (a -> IO a) -> ReaderT (MVar a) IO ()-exec f = do-  mvar <- ask-  lift $ modifyMVar_ mvar f+mkHandle :: (Table t, FromJSON (Key t), FromJSON (Entry t), ToJSON (Key t), ToJSON (Entry t), MonadBase IO m)+         => MVar (JsonFileDatabase t) -> Handle m t+mkHandle mvar = Handle+  { _describeDatabase = pretty <$> readMVar mvar+  , _fetchList = \keys -> Map.filterWithKey (\uri _ -> member uri $ Set.fromList keys) <$> fetchAll_+  , _fetchAll = fetchAll_+  , _update = \key f -> liftBase $ modifyMVar_ mvar (\a -> update a key f)+  , _insertList = liftBase . modifyMVar_ mvar . insert+  , _deleteList = liftBase . modifyMVar_ mvar . delete+  , _purge = liftBase $ modifyMVar_ mvar purge+  , _commit = liftBase $ modifyMVar_ mvar commit+  }+  where fetchAll_ = liftBase $ modifyMVar mvar $ \database -> do+          a@(JsonFileDatabase _ cache _) <- loadInCache database+          return (a, cache)   -- * Low-level implementation@@ -132,6 +127,6 @@        => JsonFileDatabase t -> IO (JsonFileDatabase t) commit t@(JsonFileDatabase file cache status) = case status of   Dirty -> do-    withFile file WriteMode $ \h -> (hPut h $ encode $ Map.toList cache)+    withFile file WriteMode $ \h -> hPut h $ encode $ Map.toList cache     return $ JsonFileDatabase file cache Clean   _ -> return t

@@ -3,10 +3,15 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | HTTP module abstracts over HTTP requests to the external world.+--+-- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).+--+-- > import qualified Imm.HTTP as HTTP module Imm.HTTP where  -- {{{ Imports-import           Imm.Logger+import qualified Imm.Logger as Logger+import           Imm.Logger hiding(Handle) import           Imm.Prelude import           Imm.Pretty @@ -15,15 +20,16 @@  -- * Types --- | Monad capable of performing GET HTTP requests.-class MonadThrow m => MonadHttpClient m where-  httpGet :: URI -> m LByteString+-- | Handle to perform GET HTTP requests.+newtype Handle m = Handle+  { httpGet :: URI -> m LByteString+  } + -- * Primitives  -- | Simple wrapper around 'httpGet' that also logs the requested URI.-get :: (MonadHttpClient m, MonadLog m, MonadThrow m)-    => URI -> m LByteString-get uri = do-  logDebug $ "Fetching " <> prettyURI uri-  httpGet uri+get :: Monad m => Logger.Handle m -> Handle m -> URI -> m LByteString+get logger handle uri = do+  log logger Debug $ "Fetching " <> prettyURI uri+  httpGet handle uri

@@ -3,14 +3,13 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Implementation of "Imm.HTTP" based on "Network.HTTP.Client".-module Imm.HTTP.Simple (defaultManager, module Reexport) where+module Imm.HTTP.Simple (mkHandle, defaultManager, module Reexport) where  -- {{{ Imports import           Imm.HTTP import           Imm.Prelude import           Imm.Pretty -import           Control.Monad.Trans.Reader import           Data.CaseInsensitive import           Network.Connection         as Reexport import           Network.HTTP.Client        as Reexport@@ -18,11 +17,10 @@ import           URI.ByteString -- }}} --- | Monad capable of performing HTTP GET requests.-instance MonadHttpClient (ReaderT Manager IO) where-  httpGet uri = do-    manager <- ask-    lift $ httpGet' manager uri+mkHandle :: MonadBase IO m => Manager -> Handle m+mkHandle manager = Handle+  { httpGet = liftBase . httpGet' manager+  }  -- | Default manager uses TLS and no proxy defaultManager :: IO Manager@@ -37,7 +35,7 @@     -- codec'   <- reader $ view (config.codec)     -- return $ response $=+ decode codec' -parseRequest' :: (MonadThrow m) => URI -> m Request+parseRequest' :: MonadThrow m => URI -> m Request parseRequest' = parseRequest . show . prettyURI  -- | Build an HTTP request for given URI

@@ -1,27 +1,29 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}--- | Hooks module to define the main behavior of the program.+-- | Hooks module abstracts over the main behavior of the program.+--+-- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).+--+-- > import qualified Imm.Hooks as Hooks module Imm.Hooks where  -- {{{ Imports import           Imm.Feed-import           Imm.Logger+import qualified Imm.Logger as Logger+import           Imm.Logger hiding(Handle) import           Imm.Prelude import           Imm.Pretty -- }}}  -- * Types --- | Monad capable of acting on specific events.-class Monad m => MonadImm m where-  -- | Action triggered for each unread feed element-  processNewElement :: Feed -> FeedElement -> m ()+newtype Handle m = Handle+  { processNewElement :: Feed -> FeedElement -> m ()  -- ^ Action triggered for each unread feed element+  }  -- * Primitives -onNewElement :: (MonadImm m, MonadLog m) => Feed -> FeedElement -> m ()-onNewElement feed element = do-  logDebug $ "Unread element:" <+> pretty (getTitle element)-  processNewElement feed element+onNewElement :: Monad m => Logger.Handle m -> Handle m -> Feed -> FeedElement -> m ()+onNewElement logger handle feed element = do+  log logger Debug $ "Unread element:" <+> pretty (getTitle element)+  processNewElement handle feed element

@@ -1,21 +1,21 @@-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Implementation of "Imm.Hooks" that does nothing, -- except suggesting the user to define proper hooks. -- -- This is the default implementation of the program.-module Imm.Hooks.Dummy where+module Imm.Hooks.Dummy (module Imm.Hooks.Dummy, module Imm.Hooks) where  -- {{{ Imports import           Imm.Hooks import           Imm.Prelude  import           Control.Exception-import           Control.Monad.Trans.Reader -- }}}  data DummyHooks = DummyHooks -instance MonadImm (ReaderT DummyHooks IO) where-  processNewElement _ _ = throwM $ NoMethodError "Please define a valid Imm.Hooks.processNewElement function"+mkHandle :: MonadThrow m => Handle m+mkHandle = Handle+  { processNewElement = \_ _ -> throwM $ NoMethodError "Please define a valid Imm.Hooks.processNewElement function"+  }

@@ -1,7 +1,6 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators     #-} -- | Implementation of "Imm.Hooks" that sends a mail via a SMTP server for each new RSS/Atom element. -- You may want to check out "Network.HaskellNet.SMTP", "Network.HaskellNet.SMTP.SSL" and "Network.Mail.Mime" modules for additional information. --@@ -30,7 +29,6 @@ import           Imm.Prelude import           Imm.Pretty -import           Control.Monad.Trans.Reader import           Data.NonNull import           Data.Time import           Network.HaskellNet.SMTP     as Reexport@@ -68,13 +66,14 @@  data SendMailSettings = SendMailSettings (Feed -> FeedElement -> SMTPServer) FormatMail -instance MonadImm (ReaderT SendMailSettings IO) where-  processNewElement feed element = do-    SendMailSettings connectionSettings formatMail <- ask-    timezone <- lift getCurrentTimeZone-    currentTime <- lift getCurrentTime-    let mail = buildMail formatMail currentTime timezone feed element-    lift $ withSMTPConnection (connectionSettings feed element) $ sendMimeMail2 mail+mkHandle :: MonadBase IO m => SendMailSettings -> Handle m+mkHandle (SendMailSettings connectionSettings formatMail) = Handle+  { processNewElement = \feed element -> do+      timezone <- liftBase getCurrentTimeZone+      currentTime <- liftBase getCurrentTime+      let mail = buildMail formatMail currentTime timezone feed element+      liftBase $ withSMTPConnection (connectionSettings feed element) $ sendMimeMail2 mail+  }   -- * Default behavior

@@ -1,5 +1,4 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Implementation of "Imm.Hooks" that writes a file for each new RSS/Atom item.@@ -12,7 +11,6 @@ import           Imm.Pretty  import           Control.Arrow-import           Control.Monad.Trans.Reader import           Data.ByteString.Builder import           Data.ByteString.Streaming     (toStreamingByteString) import           Data.Monoid.Textual           hiding (elem, map)@@ -37,12 +35,13 @@  newtype WriteFileSettings = WriteFileSettings (Feed -> FeedElement -> FileInfo) -instance MonadImm (ReaderT WriteFileSettings IO) where-  processNewElement feed element = do-    WriteFileSettings f <- ask-    let FileInfo path content = f feed element-    lift $ createDirectoryIfMissing True $ takeDirectory path-    writeBinaryFile path $ toStreamingByteString content+mkHandle :: MonadBase IO m => MonadIO m => MonadMask m => WriteFileSettings -> Handle m+mkHandle (WriteFileSettings f) = Handle+  { processNewElement = \feed element -> do+      let FileInfo path content = f feed element+      liftBase $ createDirectoryIfMissing True $ takeDirectory path+      writeBinaryFile path $ toStreamingByteString content+  }  -- * Default behavior 

@@ -3,7 +3,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-}--- | Logger module.+-- | Logger module abstracts over logging data.+--+-- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).+--+-- > import qualified Imm.Logger as Logger (Handle)+-- > import Imm.Logger hiding (Handle) module Imm.Logger where  -- {{{ Imports@@ -13,6 +18,14 @@  -- * Types +data Handle m = Handle+  { log :: LogLevel -> Doc AnsiStyle -> m ()+  , getLogLevel :: m LogLevel+  , setLogLevel :: LogLevel -> m ()+  , setColorizeLogs :: Bool -> m ()+  , flushLogs :: m ()+  }+ data LogLevel = Debug | Info | Warning | Error   deriving(Eq, Ord, Read, Show) @@ -21,19 +34,3 @@   pretty Info    = "INFO"   pretty Warning = "WARNING"   pretty Error   = "ERROR"---- | Monad capable of logging pretty text.-class Monad m => MonadLog m where-  log :: LogLevel -> Doc AnsiStyle -> m ()-  getLogLevel :: m LogLevel-  setLogLevel :: LogLevel -> m ()-  setColorizeLogs :: Bool -> m ()-  flushLogs :: m ()---- * Helpers--logDebug, logInfo, logWarning, logError :: MonadLog m => Doc AnsiStyle -> m ()-logDebug = log Debug-logInfo = log Info-logWarning = log Warning-logError = log Error

@@ -11,7 +11,7 @@ import           Imm.Pretty  import           Control.Concurrent.MVar.Lifted-import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.Control import           Data.Text.Prettyprint.Doc.Render.Terminal import           System.Log.FastLogger                     as Reexport -- }}}@@ -23,6 +23,7 @@   , _colorizeLogs   :: Bool       -- ^ Enable log colorisation   } + -- | Default logger forwards error messages to stderr, and other messages to stdout. defaultLogger :: IO (MVar LoggerSettings) defaultLogger = newMVar =<< LoggerSettings@@ -31,30 +32,21 @@   <*> pure Info   <*> pure True -instance MonadLog (ReaderT (MVar LoggerSettings) IO) where-  -- log :: LogLevel -> Doc -> m ()-  log l t = do-    settings <- readMVar =<< ask-    let loggerSet = (if l == Error then _errorLoggerSet else _loggerSet) settings-        handleColor = (\c -> if c then id else unAnnotate) $ _colorizeLogs settings-        refLevel = _logLevel settings-    when (l >= refLevel) $ lift $ pushLogStrLn loggerSet $ toLogStr $ renderLazy $ layoutPretty defaultLayoutOptions $ handleColor t -  -- getLogLevel :: m LogLevel-  getLogLevel = _logLevel <$> (readMVar =<< ask)--  -- setLogLevel :: LogLevel -> m ()-  setLogLevel level = do-    mvar <- ask-    modifyMVar_ mvar $ \settings -> return (settings { _logLevel = level })--  -- setColorizeLogs :: Bool -> m ()-  setColorizeLogs value = do-    mvar <- ask-    modifyMVar_ mvar $ \settings -> return (settings { _colorizeLogs = value })+mkHandle :: MonadBaseControl IO m => MVar LoggerSettings -> Handle m+mkHandle settings = Handle+  { log = \l t -> do+      s <- readMVar settings+      let loggerSet = (if l == Error then _errorLoggerSet else _loggerSet) s+          handleColor = (\c -> if c then id else unAnnotate) $ _colorizeLogs s+          refLevel = _logLevel s+      when (l >= refLevel) $ liftBase $ pushLogStrLn loggerSet $ toLogStr $ renderLazy $ layoutPretty defaultLayoutOptions $ handleColor t -  -- flushLogs :: m ()-  flushLogs = do-    settings <- readMVar =<< ask-    lift $ flushLogStr $ _loggerSet settings-    lift $ flushLogStr $ _errorLoggerSet settings+  , getLogLevel = _logLevel <$> readMVar settings+  , setLogLevel = \level -> modifyMVar_ settings $ \s -> return (s { _logLevel = level })+  , setColorizeLogs = \value -> modifyMVar_ settings $ \s -> return (s { _colorizeLogs = value })+  , flushLogs = do+      s <- readMVar settings+      liftBase $ flushLogStr $ _loggerSet s+      liftBase $ flushLogStr $ _errorLoggerSet s+  }

@@ -3,7 +3,7 @@  -- {{{ Imports import           Control.Applicative             as X-import           Control.Exception.Safe          as X+import           Control.Exception.Safe          as X hiding(handle) import           Control.Monad                   as X (MonadPlus (..), unless,                                                        void, when) import           Control.Monad.Base              as X

@@ -1,5 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | XML module abstracts over the parsing of RSS/Atom feeds.+--+-- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).+--+-- > import qualified Imm.XML as XML module Imm.XML where  -- {{{ Imports@@ -9,6 +13,6 @@ import           URI.ByteString -- }}} --- | Monad capable of parsing XML into a 'Feed' (RSS or Atom).-class MonadThrow m => MonadXmlParser m where-  parseXml :: URI -> LByteString -> m Feed+newtype Handle m = Handle+  { parseXml :: URI -> LByteString -> m Feed+  }

@@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes        #-} -- | Implementation of "Imm.XML" based on 'Conduit'.-module Imm.XML.Conduit where+module Imm.XML.Conduit (module Imm.XML.Conduit, module Imm.XML) where  -- {{{ Imports import           Imm.Feed@@ -11,7 +11,6 @@  import           Control.Monad import           Control.Monad.Fix-import           Control.Monad.Trans.Reader import           Data.Conduit import           Data.XML.Types import           Text.Atom.Conduit.Parse@@ -26,10 +25,10 @@ newtype XmlParser = XmlParser (forall m . Monad m => URI -> ConduitT Event Event m ())  -- | 'Conduit' based implementation-instance (MonadIO m, MonadCatch m) => MonadXmlParser (ReaderT XmlParser m) where-  parseXml uri bytestring = do-    XmlParser preProcess <- ask-    lift $ runConduit $ parseLBS def bytestring .| preProcess uri .| force "Invalid feed" ((fmap Atom <$> atomFeed) `orE` (fmap Rss <$> rssDocument) `orE` (fmap Rss <$> rss1Document))+mkHandle :: MonadIO m => MonadCatch m => XmlParser -> Handle m+mkHandle (XmlParser preProcess) = Handle+  { parseXml = \uri bytestring -> liftIO $ runConduit $ parseLBS def bytestring .| preProcess uri .| force "Invalid feed" ((fmap Atom <$> atomFeed) `orE` (fmap Rss <$> rssDocument) `orE` (fmap Rss <$> rss1Document))+  }  -- | Forward all 'Event's without any pre-process defaultXmlParser :: XmlParser