imm 1.2.1.0 → 1.3.0.0

raw patch · 25 files changed

+721/−897 lines, 25 filesdep +lifted-basedep +monad-timedep +mtldep −ansi-wl-pprintdep −chunked-datadep −comonadPVP ok

version bump matches the API change (PVP)

Dependencies added: lifted-base, monad-time, mtl, prettyprinter, prettyprinter-ansi-terminal, stm, streaming-bytestring, streaming-with, streamly, transformers-base

Dependencies removed: ansi-wl-pprint, chunked-data, comonad, conduit-combinators, free, rainbow, rainbox, tagged

API changes (from Hackage documentation)

Files

• imm.cabal +53/−4
• src/bin/Executable.hs +5/−13
• src/lib/Imm/Aeson.hs +1/−2
• src/lib/Imm/Boot.hs +101/−79
• src/lib/Imm/Core.hs +97/−123
• src/lib/Imm/Database.hs +41/−109
• src/lib/Imm/Database/FeedTable.hs +50/−50
• src/lib/Imm/Database/JsonFile.hs +62/−53
• src/lib/Imm/Dyre.hs +6/−5
• src/lib/Imm/Error.hs +1/−2
• src/lib/Imm/Feed.hs +5/−4
• src/lib/Imm/HTTP.hs +11/−30
• src/lib/Imm/HTTP/Simple.hs +17/−19
• src/lib/Imm/Hooks.hs +12/−28
• src/lib/Imm/Hooks/Dummy.hs +21/−0
• src/lib/Imm/Hooks/SendMail.hs +14/−16
• src/lib/Imm/Hooks/WriteFile.hs +24/−24
• src/lib/Imm/Logger.hs +14/−63
• src/lib/Imm/Logger/Simple.hs +40/−30
• src/lib/Imm/Options.hs +35/−23
• src/lib/Imm/Prelude.hs +13/−109
• src/lib/Imm/Pretty.hs +57/−38
• src/lib/Imm/XML.hs +5/−36
• src/lib/Imm/XML/Conduit.hs +36/−0
• src/lib/Imm/XML/Simple.hs +0/−37

@@ -1,5 +1,5 @@ name:                imm-version:             1.2.1.0+version:             1.3.0.0 synopsis:            Execute arbitrary actions for each unread element of RSS/Atom feeds description:         Cf README file homepage:            https://github.com/k0ral/imm@@ -26,6 +26,7 @@     Imm.Database.JsonFile     Imm.Feed     Imm.Hooks+    Imm.Hooks.Dummy     Imm.Hooks.SendMail     Imm.Hooks.WriteFile     Imm.HTTP@@ -34,7 +35,7 @@     Imm.Logger.Simple     Imm.Prelude     Imm.XML-    Imm.XML.Simple+    Imm.XML.Conduit   other-modules:     Imm.Aeson     Imm.Dyre@@ -42,13 +43,61 @@     Imm.Options     Imm.Pretty     Paths_imm-  build-depends: aeson, ansi-wl-pprint, 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, microlens, mono-traversable >= 1, network, opml-conduit >= 0.6, optparse-applicative, rainbow, rainbox, rss-conduit >= 0.4.1, safe-exceptions, tagged, text, transformers, time, timerep >= 2.0.0.0, tls, uri-bytestring, xml, xml-conduit >= 1.5, xml-types+  build-depends:+    aeson,+    atom-conduit >= 0.4,+    base == 4.*,+    blaze-html,+    blaze-markup,+    bytestring,+    case-insensitive,+    conduit,+    connection,+    containers,+    directory >= 1.2.3.0,+    dyre,+    fast-logger,+    filepath,+    hashable,+    HaskellNet,+    HaskellNet-SSL >= 0.3.3.0,+    http-client >= 0.4.30,+    http-client-tls,+    http-types,+    lifted-base,+    microlens,+    mime-mail,+    monad-time,+    monoid-subclasses,+    mono-traversable >= 1,+    mtl,+    network,+    opml-conduit >= 0.6,+    optparse-applicative,+    prettyprinter,+    prettyprinter-ansi-terminal,+    rss-conduit >= 0.4.1,+    safe-exceptions,+    stm,+    streaming-bytestring,+    streaming-with,+    streamly,+    text,+    transformers,+    transformers-base,+    time,+    timerep >= 2.0.0.0,+    tls,+    uri-bytestring,+    xml,+    xml-conduit >= 1.5,+    xml-types   -- Build-tools:   hs-source-dirs: src/lib   ghc-options: -Wall -fno-warn-unused-do-bind  executable imm-  build-depends: imm, base == 4.*, free+  build-depends: imm, base == 4.*   main-is: Executable.hs   hs-source-dirs: src/bin   ghc-options: -Wall -fno-warn-unused-do-bind -threaded

@@ -1,31 +1,23 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-} --module Executable where  -- {{{ Imports import           Imm import           Imm.Database.JsonFile-import qualified Imm.Hooks.WriteFile   as WriteFile+import           Imm.Hooks.Dummy import           Imm.HTTP.Simple import           Imm.Logger.Simple import           Imm.Prelude-import           Imm.XML.Simple+import           Imm.XML.Conduit -import           System.Exit+import           Control.Concurrent.MVar -- }}} --- mkDummyCoHooks :: (MonadIO m, MonadThrow m) => () -> CoHooksF m ()--- mkDummyCoHooks _ = CoHooksF coOnNewElement where---   coOnNewElement _ _ = do---     io $ putStrLn "No hook defined."---     throwM $ ExitFailure 1 - main :: IO () main = do   logger <- defaultLogger   manager <- defaultManager-  database <- defaultDatabase+  database <- defaultDatabase :: IO (MVar (JsonFileDatabase FeedTable)) -  -- imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (mkDummyCoHooks, ()) (mkCoXmlParser, defaultPreProcess)-  imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (WriteFile.mkCoHooks, WriteFile.defaultSettings "/home/koral/feeds") (mkCoXmlParser, defaultPreProcess)+  imm $ mkModulesM manager database logger DummyHooks defaultXmlParser

@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-} module Imm.Aeson where  -- {{{ Imports@@ -11,7 +10,7 @@ import           URI.ByteString -- }}} -parseJsonURI :: (MonadPlus m) => Value -> m URI+parseJsonURI :: MonadPlus m => Value -> m URI parseJsonURI (String s) = either (const mzero) return $ parseURI laxURIParserOptions $ encodeUtf8 s parseJsonURI _          = mzero 

@@ -1,12 +1,10 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoImplicitPrelude         #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-} -- | -- = Getting started --@@ -18,38 +16,86 @@ -- -- 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).+-- == @ReaderT@ pattern ----- The design is inspired from <http://dlaing.org/cofun/ Cofun with cofree monads>.-module Imm.Boot (imm) where+-- The behavior of this program can be customized through the @ReaderT@ pattern.+module Imm.Boot (imm, Modules(..), ModulesM, mkModulesM) where  -- {{{ Imports-import qualified Imm.Core as Core-import Imm.Database.FeedTable as Database-import Imm.Database as Database-import Imm.Dyre as Dyre-import Imm.Feed-import Imm.HTTP as HTTP-import Imm.Hooks-import Imm.Logger as Logger-import Imm.Options as Options hiding(logLevel)-import Imm.Prelude-import Imm.Pretty-import Imm.XML+import qualified Imm.Core                   as Core+import           Imm.Database               as Database+import           Imm.Database.FeedTable     as Database+import           Imm.Dyre                   as Dyre+import           Imm.Feed+import           Imm.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 Control.Comonad.Cofree-import Control.Monad.Trans.Free+import           Control.Monad.Time+import           Control.Monad.Trans.Reader+import           Data.Conduit.Combinators   (stdin)+import           Streamly                   (MonadAsync)+import           System.IO                  (hFlush)+-- }}} -import Data.Functor.Product-import Data.Functor.Sum+-- | 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")+  } -import System.IO (hFlush)--- }}}+-- | 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.--- Each argument is an interpreter functor along with an initial state. -- -- Here is an example: --@@ -57,7 +103,7 @@ -- > import           Imm.Database.JsonFile -- > import           Imm.Feed -- > import           Imm.Hooks.SendMail--- > import           Imm.HTTP.Simple+-- > import           Imm.HTTP.Conduit -- > import           Imm.Logger.Simple -- > import           Imm.XML.Simple -- >@@ -67,7 +113,7 @@ -- >   manager  <- defaultManager -- >   database <- defaultDatabase -- >--- >   imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (mkCoHooks, sendmail) (mkCoXmlParser, defaultPreProcess)+-- >   imm $ mkModulesM manager database logger sendmail defaultXmlParser -- > -- > sendmail :: SendMailSettings -- > sendmail = SendMailSettings smtpServer formatMail@@ -83,32 +129,27 @@ -- > smtpServer _ _ = SMTPServer -- >   (Just $ Authentication PLAIN "user" "password") -- >   (StartTls "smtp.host" defaultSettingsSMTPSTARTTLS)-imm :: (a -> CoHttpClientF IO a, a)  -- ^ HTTP client interpreter (cf "Imm.HTTP")-    -> (b -> CoDatabaseF' IO b, b)   -- ^ Database interpreter (cf "Imm.Database")-    -> (c -> CoLoggerF IO c, c)      -- ^ Logger interpreter (cf "Imm.Logger")-    -> (d -> CoHooksF IO d, d)       -- ^ Hooks interpreter (cf "Imm.Hooks")-    -> (e -> CoXmlParserF IO e, e)   -- ^ XML parsing interpreter (cf "Imm.XML")-    -> IO ()-imm coHttpClient coDatabase coLogger coHooks coXmlParser = void $ do+imm :: ModulesM IO -> IO ()+imm modules = void $ do   options <- parseOptions-  Dyre.wrap (optionDyreMode options) realMain (optionCommand options, optionLogLevel options, optionColorizeLogs options, coiter next start)-  where (next, start) = mkCoImm coHttpClient coDatabase coLogger coHooks coXmlParser+  Dyre.wrap (optionDyreMode options) realMain (optionCommand options, optionLogLevel options, optionColorizeLogs options, modules) -realMain :: (MonadIO m, PairingM (CoImmF m) ImmF m, MonadCatch m)-         => (Command, LogLevel, Bool, Cofree (CoImmF m) a) -> m ()-realMain (command, logLevel, colorizeLogs, interpreter) = void $ interpret (\_ b -> return b) interpreter $ do-  setColorizeLogs colorizeLogs+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+  logDebug . ("Using database:" <++>) . indent 2 =<< _describeDatabase FeedTable -  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-    Run t          -> Core.run              =<< resolveTarget ByPassConfirmation t-    Show t         -> Core.showFeed         =<< resolveTarget ByPassConfirmation t+  handleAny (logError . pretty . displayException) $ case command of+    Check t        -> Core.check =<< resolveTarget 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     ShowVersion    -> Core.printVersions     Subscribe u c  -> Core.subscribe u c     Unread t       -> mapM_ Database.markAsUnread =<< resolveTarget AskConfirmation t@@ -118,26 +159,7 @@   Database.commit FeedTable   flushLogs --- * DSL/interpreter model -type CoImmF m = Product (CoHttpClientF m)-  (Product (CoDatabaseF' m)-   (Product (CoLoggerF m)-    (Product (CoHooksF m) (CoXmlParserF m)-    )))-type ImmF = Sum HttpClientF (Sum DatabaseF' (Sum LoggerF (Sum HooksF XmlParserF)))--mkCoImm :: (Functor m)-        => (a -> CoHttpClientF m a, a)-        -> (b -> CoDatabaseF' m b, b)-        -> (c -> CoLoggerF m c, c)-        -> (d -> CoHooksF m d, d)-        -> (e -> CoXmlParserF m e, e)-        -> ((a ::: b ::: c ::: d ::: e) -> CoImmF m (a ::: b ::: c ::: d ::: e), a ::: b ::: c ::: d ::: e)-mkCoImm (coHttpClient, a) (coDatabase, b) (coLogger, c) (coHooks, d) (coXmlParser, e) =-  (coHttpClient *: coDatabase *: coLogger *: coHooks *: coXmlParser, a +: b +: c +: d +: e)-- -- * Util  data SafeGuard = AskConfirmation | ByPassConfirmation@@ -147,19 +169,19 @@ instance Exception InterruptedException where   displayException _ = "Process interrupted" -promptConfirm :: (MonadIO m, MonadThrow m) => Text -> m ()+promptConfirm :: Text -> IO () promptConfirm s = do-  hPut stdout $ s <> " Confirm [Y/n] "-  io $ hFlush stdout+  putStr $ s <> " Confirm [Y/n] "+  hFlush stdout   x <- getLine   unless (null x || x == ("Y" :: Text)) $ throwM InterruptedException  -resolveTarget :: (MonadIO m, MonadThrow m, MonadFree f m, DatabaseF' :<: f)+resolveTarget :: (MonadBase IO m, MonadThrow m, MonadDatabase FeedTable m)               => 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."+  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

@@ -1,111 +1,111 @@-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE NoImplicitPrelude      #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TupleSections          #-}-{-# LANGUAGE PartialTypeSignatures  #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeFamilies          #-} module Imm.Core ( -- * Types-    FeedRef,+  FeedRef, -- * Actions-    printVersions,-    subscribe,-    showFeed,-    check,-    run,-    importOPML,+  printVersions,+  subscribe,+  showFeed,+  check,+  run,+  importOPML, ) where  -- {{{ Imports-import qualified Imm.Database.FeedTable as Database-import Imm.Database.FeedTable hiding(markAsRead, markAsUnread)-import qualified Imm.Database as Database-import Imm.Feed-import Imm.Hooks as Hooks-import Imm.HTTP (HttpClientF)-import qualified Imm.HTTP as HTTP-import Imm.Logger-import Imm.Prelude-import Imm.Pretty-import Imm.XML---- import Control.Concurrent.Async.Lifted (Async, async, mapConcurrently, waitAny)--- import Control.Concurrent.Async.Pool-import Control.Monad.Free+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.Prelude+import           Imm.Pretty+import           Imm.XML -import qualified Data.ByteString              as ByteString-import Data.Conduit-import Data.Conduit.Combinators as Conduit (stdin)-import qualified Data.Map as Map-import Data.NonNull-import Data.Set (Set)-import Data.Time.Format-import Data.Tree+import           Control.Concurrent.STM      (STM, atomically)+import           Control.Concurrent.STM.TVar+import           Control.Monad.Time+import           Data.Conduit+import qualified Data.Map                    as Map+import           Data.NonNull+import           Data.Set                    (Set)+import qualified Data.Set                    as Set+import qualified Data.Text                   as Text+import           Data.Tree import           Data.Version--import qualified Paths_imm                      as Package--import Rainbow (chunksToByteStrings, toByteStringsColors256, chunk)-import Rainbox-+import qualified Paths_imm                   as Package+import           Streamly                    hiding ((<>))+import qualified Streamly.Prelude            as Stream import           System.Info--import Text.OPML.Conduit.Parse-import Text.OPML.Types as OPML-import Text.XML as XML ()-import Text.XML.Stream.Parse as XML-+import           Text.OPML.Conduit.Parse+import           Text.OPML.Types             as OPML+import           Text.XML                    as XML ()+import           Text.XML.Stream.Parse       as XML import           URI.ByteString -- }}}  -printVersions :: (MonadIO m) => m ()-printVersions = io $ do-  putStrLn $ "imm-" ++ showVersion Package.version-  putStrLn $ "compiled by " ++ compilerName ++ "-" ++ showVersion compilerVersion+printVersions :: (MonadBase IO m) => m ()+printVersions = liftBase $ do+  putStrLn $ "imm-" <> Text.pack (showVersion Package.version)+  putStrLn $ "compiled by " <> Text.pack compilerName <> "-" <> Text.pack (showVersion compilerVersion)  -- | Print database status for given feed(s)-showFeed :: (MonadIO m, LoggerF :<: f, MonadThrow m, MonadFree f m, DatabaseF' :<: f)+showFeed :: (MonadLog m, MonadThrow m, MonadDatabase FeedTable m)          => [FeedID] -> m () showFeed feedIDs = do-  feeds <- Database.fetchList FeedTable feedIDs+  entries <- Database.fetchList FeedTable feedIDs   flushLogs-  if null feeds then logWarning "No subscription" else putBox $ entryTableToBox feeds+  when (null entries) $ logWarning "No subscription"+  forM_ (zip [1..] $ Map.elems entries) $ \(i, entry) ->+    logInfo $ pretty (i :: Int) <+> prettyDatabaseEntry entry  -- | Register the given feed URI in database-subscribe :: (LoggerF :<: f, MonadFree f m, DatabaseF' :<: f, MonadCatch m)-          => URI -> Maybe Text -> m ()-subscribe uri category = Database.register (FeedID uri) $ fromMaybe "default" category+subscribe :: (MonadLog m, MonadDatabase FeedTable m, MonadCatch m)+          => URI -> Set Text -> m ()+subscribe uri = Database.register (FeedID uri)  -- | Check for unread elements without processing them-check :: (MonadIO m, MonadCatch m, LoggerF :<: f, MonadFree f m, DatabaseF' :<: f, HttpClientF :<: f, XmlParserF :<: f)+check :: (MonadAsync m, MonadCatch m, MonadLog m, MonadDatabase FeedTable m, MonadHttpClient m, MonadXmlParser m)       => [FeedID] -> m () check feedIDs = do-  results <- for (zip ([1..] :: [Int]) feedIDs) $ \(i, feedID) -> do-    logInfo $ brackets (fill width (bold $ cyan $ pretty i) <+> "/" <+> pretty total) <+> "Checking" <+> magenta (pretty feedID) <> "..."-    try $ checkOne feedID+  progress <- liftBase $ newTVarIO 0 -  flushLogs+  results <- Stream.toList $ wAsyncly $ do+    feedID <- Stream.fromFoldable feedIDs+    result <- lift $ tryAny $ checkOne 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+    return result -  putBox $ statusTableToBox $ mapFromList $ zip feedIDs results+  flushLogs    let (failures, successes) = partitionEithers $ zipWith (\a -> bimap (a,) (a,)) feedIDs 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))+  logInfo $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall"    where width = length (show total :: String)         total = length feedIDs -checkOne :: (MonadIO m, MonadCatch m, LoggerF :<: f, MonadFree f m, DatabaseF' :<: f, HttpClientF :<: f, XmlParserF :<: f)+checkOne :: (MonadBase IO m, MonadCatch m, MonadLog m, MonadDatabase FeedTable m, MonadHttpClient m, MonadXmlParser m)          => FeedID -> m Int checkOne feedID = do   feed <- getFeed feedID   case feed of     Atom _ -> logDebug $ "Parsed Atom feed: " <> pretty feedID-    Rss _ -> logDebug $ "Parsed RSS feed: " <> pretty feedID+    Rss _  -> logDebug $ "Parsed RSS feed: " <> pretty feedID    let dates = mapMaybe getDate $ getElements feed @@ -117,12 +117,19 @@         unread _ _                = True  -run :: (MonadIO m, MonadCatch m, HooksF :<: f, LoggerF :<: f, MonadFree f m, DatabaseF' :<: f, HttpClientF :<: f, XmlParserF :<: f)+run :: (MonadTime m, MonadAsync m, MonadCatch m, MonadImm m, MonadLog m, MonadDatabase FeedTable m, MonadHttpClient m, MonadXmlParser m)     => [FeedID] -> m () run feedIDs = do-  results <- for (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+  progress <- liftBase $ newTVarIO 0++  results <- Stream.toList $ wAsyncly $ do+    feedID <- Stream.fromFoldable feedIDs+    result <- lift $ tryAny $ runOne 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     return $ bimap (feedID,) (feedID,) result    flushLogs@@ -130,82 +137,49 @@   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))+  logInfo $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall"    where width = length (show total :: String)         total = length feedIDs -runOne :: (MonadIO m, MonadCatch m, HooksF :<: f, LoggerF :<: f, MonadFree f m, DatabaseF' :<: f, HttpClientF :<: f, XmlParserF :<: f)-    => FeedID -> m ()+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 -  unless (null unreadElements) $ logInfo $ indent 2 $ green (pretty $ length unreadElements) <+> "new element(s)"-   forM_ unreadElements $ \element -> do     onNewElement feed element     mapM_ (Database.addReadHash feedID) $ getHashes element    Database.markAsRead feedID+  return $ length unreadElements  -isRead :: (MonadCatch m, DatabaseF' :<: f, MonadFree f m) => FeedID -> FeedElement -> m Bool+isRead :: (MonadCatch m, MonadDatabase FeedTable m) => FeedID -> FeedElement -> m Bool isRead feedID element = do   DatabaseEntry _ _ readHashes lastCheck <- Database.fetch FeedTable feedID   let matchHash = not $ null $ (setFromList (getHashes element) :: Set Int) `intersection` readHashes       matchDate = case (lastCheck, getDate element) of-        (Nothing, _) -> False-        (_, Nothing) -> False+        (Nothing, _)     -> False+        (_, Nothing)     -> False         (Just a, Just b) -> a > b   return $ matchHash || matchDate --- | 'subscribe' to all feeds described by the OPML document provided in input (stdin)-importOPML :: (MonadIO m, LoggerF :<: f, MonadFree f m, DatabaseF' :<: f, MonadCatch m) => m ()-importOPML = do-  opml <- runConduit $ Conduit.stdin =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml+-- | '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+  opml <- runConduit $ input .| XML.parseBytes def .| force "Invalid OPML" parseOpml   forM_ (opmlOutlines opml) $ importOPML' mempty -importOPML' :: (MonadIO m, LoggerF :<: f, MonadFree f m, DatabaseF' :<: f, MonadCatch m)-            => Maybe Text -> Tree OpmlOutline -> m ()-importOPML' _ (Node (OpmlOutlineGeneric b _) sub) = mapM_ (importOPML' (Just . toNullable $ OPML.text b)) sub+importOPML' :: (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 ()  -getFeed :: (MonadIO m, MonadCatch m, MonadFree f m, HttpClientF :<: f, LoggerF :<: f, XmlParserF :<: f)+getFeed :: (MonadCatch m, MonadHttpClient m, MonadLog m, MonadXmlParser m)         => FeedID -> m Feed getFeed (FeedID uri) = HTTP.get uri >>= parseXml uri----- * Boxes--putBox :: (Orientation a, MonadIO m) => Box a -> m ()-putBox = io . mapM_ ByteString.putStr . chunksToByteStrings toByteStringsColors256 . toList . render--cell :: Text -> Cell-cell a = Cell (singleton $ singleton $ chunk a) top left mempty--type EntryTable = Map FeedID DatabaseEntry--entryTableToBox :: EntryTable -> Box Horizontal-entryTableToBox t = tableByColumns $ Rainbox.intersperse sep $ fromList [col1, col2, col3, col4] where-  result = sortBy (comparing entryURI) $ map snd $ mapToList t-  col1 = fromList $ cell "UID" : map (cell . show) [0..(length result - 1)]-  col2 = fromList $ cell "CATEGORY" : map (cell . entryCategory) result-  col3 = fromList $ cell "LAST CHECK" : map (cell . format . entryLastCheck) result-  col4 = fromList $ cell "FEED URI" : map (cell . show . prettyURI . entryURI) result-  format = maybe "<never>" (fromString . formatTime defaultTimeLocale "%F %R")-  sep = fromList [separator mempty 1]---type StatusTable = Map FeedID (Either SomeException Int)--statusTableToBox :: StatusTable -> Box Horizontal-statusTableToBox t = tableByColumns $ Rainbox.intersperse sep $ fromList [col1, col2, col3] where-  result = sortBy (comparing fst) $ Map.toList t-  col1 = fromList $ cell "# UNREAD" : map (cell . either (const "?") show . snd) result-  col2 = fromList $ cell "STATUS" : map (cell . either (const "ERROR") (const "OK") . snd) result-  col3 = fromList $ cell "FEED" : map (cell . show . pretty . fst) result-  sep = fromList [separator mempty 2]

@@ -1,89 +1,42 @@-{-# LANGUAGE DeriveFunctor         #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}--- | DSL/interpreter model for a generic key-value database+-- | Database module abstracts over a key-value database that supports CRUD operations. module Imm.Database where  -- {{{ Imports-import           Imm.Error import           Imm.Logger import           Imm.Prelude--import           Control.Monad.Trans.Free+import           Imm.Pretty -import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))+import           Data.Map    (Map) -- }}} --- * DSL/interpreter+-- * Types  -- | Generic database table-class (Ord (Key t), Show (Key t), Show (Entry t), Typeable t, Show t, Pretty t, Pretty (Key t), Pretty (Entry t))+class (Ord (Key t), Show (Key t), Show (Entry t), Typeable t, Show t, Pretty t, Pretty (Key t))   => Table t where   type Key t :: *   type Entry t :: * --- | Database DSL-data DatabaseF 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)-  | DeleteList t [Key t] (Either SomeException () -> next)-  | Purge t (Either SomeException () -> next)-  | Commit t (Either SomeException () -> next)-  deriving(Functor)---- | Database interpreter-data CoDatabaseF t m a = CoDatabaseF-  { 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)-  , deleteListH :: [Key t] -> m (Either SomeException (), a)-  , purgeH      :: m (Either SomeException (), a)-  , commitH     :: m (Either SomeException (), a)-  } deriving(Functor)--instance Monad m => PairingM (CoDatabaseF t m) (DatabaseF t) m where-  -- pairM :: (a -> b -> m r) -> f a -> g b -> m r-  pairM p CoDatabaseF{describeH} (Describe _ next) = do-    (result, a) <- describeH-    p a $ next result-  pairM p CoDatabaseF{fetchListH} (FetchList _ key next) = do-    (result, a) <- fetchListH key-    p a $ next result-  pairM p CoDatabaseF{fetchAllH} (FetchAll _ next) = do-    (result, a) <- fetchAllH-    p a $ next result-  pairM p CoDatabaseF{updateH} (Update _ key f next) = do-    (result, a) <- updateH key f-    p a $ next result-  pairM p CoDatabaseF{insertListH} (InsertList _ rows next) = do-    (result, a) <- insertListH rows-    p a $ next result-  pairM p CoDatabaseF{deleteListH} (DeleteList _ k next) = do-    (result, a) <- deleteListH k-    p a $ next result-  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+-- | 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 ()  --- * Exception- data DatabaseException t   = NotCommitted t   | NotDeleted t [Key t]@@ -100,75 +53,54 @@   displayException = show . pretty  instance (Pretty t, Pretty (Key t)) => Pretty (DatabaseException t) where-  pretty (NotCommitted _) = text "Unable to commit database changes."-  pretty (NotDeleted _ x) = text "Unable to delete the following entries in database:" <++> indent 2 (vsep $ map pretty x)-  pretty (NotFound _ x) = text "Unable to find the following entries in database:" <++> indent 2 (vsep $ map pretty x)-  pretty (NotInserted _ x) = text "Unable to insert the following entries in database:" <++> indent 2 (vsep $ map (pretty . fst) x)-  pretty (NotPurged t) = text "Unable to purge database" <+> pretty t-  pretty (NotUpdated _ x) = text "Unable to update the following entry in database:" <++> indent 2 (pretty x)-  pretty (UnableFetchAll _) = text "Unable to fetch all entries from database."+  pretty (NotCommitted _) = "Unable to commit database changes."+  pretty (NotDeleted _ x) = "Unable to delete the following entries in database:" <++> indent 2 (vsep $ map pretty x)+  pretty (NotFound _ x) = "Unable to find the following entries in database:" <++> indent 2 (vsep $ map pretty x)+  pretty (NotInserted _ x) = "Unable to insert the following entries in database:" <++> indent 2 (vsep $ map (pretty . fst) x)+  pretty (NotPurged t) = "Unable to purge database" <+> pretty t+  pretty (NotUpdated _ x) = "Unable to update the following entry in database:" <++> indent 2 (pretty x)+  pretty (UnableFetchAll _) = "Unable to fetch all entries from database."   -- * Primitives -describeDatabase :: (MonadFree f m, DatabaseF t :<: f)-                 => t -> m Doc-describeDatabase t = liftF . inj $ Describe t id--fetch :: (MonadFree f m, DatabaseF t :<: f, Table t, MonadThrow m)-      => t -> Key t -> m (Entry t)+fetch :: (MonadDatabase t m, Table t, MonadThrow m) => t -> Key t -> m (Entry t) fetch t k = do-  results <- liftF . inj $ FetchList t [k] id-  result <- lookup k <$> liftE results-  maybe (throwM $ NotFound t [k]) return result+  results <- _fetchList t [k]+  maybe (throwM $ NotFound t [k]) return $ lookup k results -fetchList :: (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+fetchList :: (MonadDatabase t m, MonadThrow m) => t -> [Key t] -> m (Map (Key t) (Entry t))+fetchList = _fetchList -fetchAll :: (MonadThrow m, MonadFree f m, DatabaseF t :<: f) => t -> m (Map (Key t) (Entry t))-fetchAll t = do-  result <- liftF . inj $ FetchAll t id-  liftE result+fetchAll :: (MonadThrow m, MonadDatabase t m) => t -> m (Map (Key t) (Entry t))+fetchAll = _fetchAll -update :: (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+update :: (MonadDatabase t m, MonadThrow m) => t -> Key t -> (Entry t -> Entry t) -> m ()+update  = _update -insert :: (MonadThrow m, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f)-       => t -> Key t -> Entry t -> m ()+insert :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> Key t -> Entry t -> m () insert t k v = insertList t [(k, v)] -insertList :: (MonadThrow m, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f)-           => t -> [(Key t, Entry t)] -> m ()+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..."-  result <- liftF . inj $ InsertList t i id-  liftE result+  _insertList t i -delete :: (MonadThrow m, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f) => t -> Key t -> m ()+delete :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> Key t -> m () delete t k = deleteList t [k] -deleteList :: (MonadThrow m, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f)-           => t -> [Key t] -> m ()+deleteList :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> [Key t] -> m () deleteList t k = do   logInfo $ "Deleting " <> yellow (pretty $ length k) <> " entries..."-  result <- liftF . inj $ DeleteList t k id-  liftE result+  _deleteList t k -purge :: (MonadThrow m, MonadFree f m, DatabaseF t :<: f, LoggerF :<: f) => t -> m ()+purge :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> m () purge t = do   logInfo "Purging database..."-  result <- liftF . inj $ Purge t id-  liftE result+  _purge t -commit :: (MonadThrow m, MonadFree f m, DatabaseF t :<: f, LoggerF :<: f) => t -> m ()+commit :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> m () commit t = do   logDebug "Committing database transaction..."-  result <- liftF . inj $ Commit t id-  liftE result+  _commit t   logDebug "Database transaction committed"

@@ -1,25 +1,22 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE NoImplicitPrelude     #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies     #-}-{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-} -- | Feed table definitions. This is a specialization of "Imm.Database". module Imm.Database.FeedTable where  -- {{{ Imports-import Imm.Aeson-import Imm.Database+import           Imm.Aeson+import           Imm.Database import           Imm.Logger-import Imm.Prelude-import Imm.Pretty--import Control.Monad.Trans.Free+import           Imm.Prelude+import           Imm.Pretty +import           Control.Monad.Time import           Data.Aeson-import           Data.Set (Set)-import           Data.Time           as Time--import URI.ByteString+import           Data.Set           (Set)+import           Data.Time+import           URI.ByteString -- }}}  -- * Types@@ -28,6 +25,9 @@ newtype FeedID = FeedID URI   deriving(Eq, Ord, Show) +prettyFeedID :: FeedID -> Doc AnsiStyle+prettyFeedID (FeedID uri) = prettyURI uri+ instance FromJSON FeedID where   parseJSON = fmap FeedID . parseJsonURI @@ -39,33 +39,36 @@   data DatabaseEntry = DatabaseEntry-  { entryURI         :: URI-  , entryCategory    :: Text-  , entryReadHashes  :: Set Int-  , entryLastCheck   :: Maybe UTCTime+  { entryURI        :: URI+  , entryTags       :: Set Text+  , entryReadHashes :: Set Int+  , entryLastCheck  :: Maybe UTCTime   } deriving(Eq, Show) -instance Pretty DatabaseEntry where-  pretty r = text "Entry:" <+> prettyURI (entryURI r) <++> indent 2-    ( text "Category:" <+> text (fromText $ entryCategory r)-    <++> text "Last check:" <+> text (maybe "<never>" (formatTime defaultTimeLocale rfc822DateFormat) $ entryLastCheck r)-    <++> text "Read hashes:" <+> text (show $ length $ entryReadHashes r)-    )+prettyDatabaseEntry :: DatabaseEntry -> Doc AnsiStyle+prettyDatabaseEntry entry = magenta feedID+  <++> indent 3 tags+  <++> indent 3 ("Last checked:" <+> lastCheck) +  where feedID = prettyURI $ entryURI entry+        tags = sep $ map ((<>) "#" . pretty) $ toList $ entryTags entry+        lastCheck = format $ entryLastCheck entry+        format = maybe "never" (fromString . formatTime defaultTimeLocale "%F %R")+ instance FromJSON DatabaseEntry where-  parseJSON (Object v) = DatabaseEntry <$> (parseJsonURI =<< v .: "uri") <*> v .: "category" <*> v.: "readHashes" <*> v .: "lastCheck"+  parseJSON (Object v) = DatabaseEntry <$> (parseJsonURI =<< v .: "uri") <*> v .: "tags" <*> v.: "readHashes" <*> v .: "lastCheck"   parseJSON _          = mzero  instance ToJSON DatabaseEntry where   toJSON entry = object     [ "uri"        .= toJsonURI (entryURI entry)-    , "category"   .= entryCategory entry+    , "tags"       .= entryTags entry     , "readHashes" .= entryReadHashes entry     , "lastCheck"  .= entryLastCheck entry     ] -newDatabaseEntry :: FeedID -> Text -> DatabaseEntry-newDatabaseEntry (FeedID uri) category = DatabaseEntry uri category mempty Nothing+newDatabaseEntry :: FeedID -> Set Text -> DatabaseEntry+newDatabaseEntry (FeedID uri) tags = DatabaseEntry uri tags mempty Nothing  -- | Singleton type to represent feeds table data FeedTable = FeedTable@@ -82,50 +85,47 @@ data FeedStatus = Unknown | New | LastUpdate UTCTime  instance Pretty FeedStatus where-  pretty Unknown        = text "Unknown"-  pretty New            = text "New"-  pretty (LastUpdate x) = text "Last update:" <+> text (formatTime defaultTimeLocale rfc822DateFormat x)+  pretty Unknown        = "Unknown"+  pretty New            = "New"+  pretty (LastUpdate x) = "Last update:" <+> pretty (formatTime defaultTimeLocale rfc822DateFormat x)  -data Database = Database [DatabaseEntry]+newtype Database = Database [DatabaseEntry]   deriving (Eq, Show) -type DatabaseF' = DatabaseF FeedTable-type CoDatabaseF' = CoDatabaseF FeedTable- -- * Primitives -register :: (MonadThrow m, LoggerF :<: f, DatabaseF' :<: f, MonadFree f m)-          => FeedID -> Text -> m ()-register feedID category = do-  logInfo $ "Registering feed " <> magenta (pretty feedID) <> "..."-  insert FeedTable feedID $ newDatabaseEntry feedID category+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 -getStatus :: (DatabaseF' :<: f, MonadFree f m, MonadCatch m)+getStatus :: (MonadDatabase FeedTable m, MonadCatch m)           => FeedID -> m FeedStatus getStatus feedID = handleAny (\_ -> return Unknown) $ do   result <- fmap Just (fetch FeedTable feedID) `catchAny` (\_ -> return Nothing)   return $ maybe New LastUpdate $ entryLastCheck =<< result -addReadHash :: (DatabaseF' :<: f, MonadFree f m, MonadThrow m, LoggerF :<: f)+addReadHash :: (MonadDatabase FeedTable m, MonadThrow m, MonadLog m)                => FeedID -> Int -> m () addReadHash feedID hash = do-  logDebug $ "Adding read hash: " <> pretty hash <> "..."+  logDebug $ "Adding read hash:" <+> pretty hash <> "..."   update FeedTable feedID f   where f a = a { entryReadHashes = insertSet hash $ entryReadHashes a }  -- | Set the last check time to now-markAsRead :: (MonadIO m, DatabaseF' :<: f, MonadFree f m, MonadThrow m, LoggerF :<: f)+markAsRead :: (MonadTime m, MonadDatabase FeedTable m, MonadThrow m, MonadLog m)            => FeedID -> m () markAsRead feedID = do-  logDebug $ "Marking feed as read: " <> pretty feedID <> "..."-  currentTime <- io Time.getCurrentTime-  update FeedTable feedID (f currentTime)+  logDebug $ "Marking feed as read:" <+> pretty feedID <> "..."+  utcTime <- currentTime+  update FeedTable feedID (f utcTime)   where f time a = a { entryLastCheck = Just time }  -- | Unset feed's last update and remove all read hashes-markAsUnread ::  (DatabaseF' :<: f, MonadFree f m, MonadThrow m, LoggerF :<: f)+markAsUnread :: (MonadDatabase FeedTable m, MonadThrow m, MonadLog m)              => FeedID -> m () markAsUnread feedID = do-  logInfo $ "Marking feed as unread: " <> show (pretty feedID) <> "..."+  logInfo $ "Marking feed as unread:" <+> prettyFeedID feedID <> "..."   update FeedTable feedID $ \a -> a { entryReadHashes = mempty, entryLastCheck = Nothing }

@@ -4,44 +4,54 @@ {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedLists       #-} {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE UndecidableInstances  #-}--- | Database interpreter based on a JSON file-module Imm.Database.JsonFile (module Imm.Database.JsonFile, module Reexport) where+-- | Implementation of "Imm.Database" based on a JSON file.+module Imm.Database.JsonFile+  ( JsonFileDatabase+  , mkJsonFileDatabase+  , defaultDatabase+  , JsonException(..)+  , module Imm.Database.FeedTable+  ) where  -- {{{ Imports-import           Imm.Database           hiding (commit, delete, fetchAll,-                                         insert, purge, update)-import           Imm.Database.FeedTable as Reexport+import           Imm.Database                   hiding (commit, delete, insert,+                                                 purge, update)+import           Imm.Database.FeedTable import           Imm.Error-import           Imm.Prelude            hiding (catch, delete, keys)+import           Imm.Prelude                    hiding (delete, keys)+import           Imm.Pretty +import           Control.Concurrent.MVar.Lifted+import           Control.Monad.Reader.Class+import           Control.Monad.Trans.Reader     (ReaderT) import           Data.Aeson-import qualified Data.Map               as Map-import qualified Data.Set               as Set-+import           Data.ByteString.Lazy           (hPut)+import           Data.ByteString.Streaming      (hGetContents, toLazy_)+import           Data.Map                       (Map)+import qualified Data.Map                       as Map+import qualified Data.Set                       as Set+import           Streaming.With import           System.Directory import           System.FilePath-import           System.IO              (IOMode (..), openFile) -- }}} --- * Types- data CacheStatus = Empty | Clean | Dirty   deriving(Eq, Show)  data JsonFileDatabase t = JsonFileDatabase FilePath (Map (Key t) (Entry t)) CacheStatus  instance Pretty (JsonFileDatabase t) where-  pretty (JsonFileDatabase file _ _) = "JSON database: " <+> text file+  pretty (JsonFileDatabase file _ _) = "JSON database: " <+> pretty file  mkJsonFileDatabase :: (Table t) => FilePath -> JsonFileDatabase t mkJsonFileDatabase file = JsonFileDatabase file mempty Empty  -- | Default database is stored in @$XDG_CONFIG_HOME\/imm\/feeds.json@-defaultDatabase :: Table t => IO (JsonFileDatabase t)-defaultDatabase = mkJsonFileDatabase <$> getXdgDirectory XdgConfig "imm/feeds.json"+defaultDatabase :: Table t => IO (MVar (JsonFileDatabase t))+defaultDatabase = do+  databaseFile <- getXdgDirectory XdgConfig "imm/feeds.json"+  newMVar $ mkJsonFileDatabase databaseFile   data JsonException = UnableDecode@@ -51,36 +61,35 @@   displayException _ = "Unable to parse JSON"  --- * Interpreter+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 --- | 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 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 = 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)-  coInsert rows = exec (`insert` rows)-  coDelete keys = exec (`delete` keys)-  coPurge = exec purge-  coCommit = exec commit-  exec f = handleAny (\e -> return (Left e, t)) $ (Right (),) <$> f t+exec :: (a -> IO a) -> ReaderT (MVar a) IO ()+exec f = do+  mvar <- ask+  lift $ modifyMVar_ mvar f   -- * Low-level implementation -loadInCache :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))-            => JsonFileDatabase t -> m (JsonFileDatabase t)+loadInCache :: (Table t, FromJSON (Key t), FromJSON (Entry t))+            => JsonFileDatabase t -> IO (JsonFileDatabase t) loadInCache t@(JsonFileDatabase file _ status) = case status of   Empty -> do-    io $ createDirectoryIfMissing True $ takeDirectory file-    fileContent <- hGetContents =<< io (openFile file ReadWriteMode)+    createDirectoryIfMissing True $ takeDirectory file+    fileContent <- withBinaryFile file ReadWriteMode (toLazy_ . hGetContents)     cache <- (`failWith` UnableDecode) $ fmap Map.fromList $ decode $ fromEmpty "[]" fileContent     return $ JsonFileDatabase file cache Clean   _ -> return t@@ -88,41 +97,41 @@         fromEmpty _ y  = y  -insert :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))-       => JsonFileDatabase t -> [(Key t, Entry t)] -> m (JsonFileDatabase t)-insert t rows = insertInCache rows <$> loadInCache t+insert :: (Table t, FromJSON (Key t), FromJSON (Entry t))+       => [(Key t, Entry t)] -> JsonFileDatabase t -> IO (JsonFileDatabase t)+insert rows t = insertInCache rows <$> loadInCache t  insertInCache :: Table t => [(Key t, Entry t)] -> JsonFileDatabase t -> JsonFileDatabase t insertInCache rows (JsonFileDatabase file cache _) = JsonFileDatabase file (Map.union cache $ Map.fromList rows) Dirty  -update :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))-       => JsonFileDatabase t -> Key t -> (Entry t -> Entry t) -> m (JsonFileDatabase t)+update :: (Table t, FromJSON (Key t), FromJSON (Entry t))+       => JsonFileDatabase t -> Key t -> (Entry t -> Entry t) -> IO (JsonFileDatabase t) update t key f = updateInCache key f <$> loadInCache t  updateInCache :: Table t => Key t -> (Entry t -> Entry t) -> JsonFileDatabase t -> JsonFileDatabase t updateInCache key f (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where   newCache = Map.update (Just . f) key cache -delete :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))-       => JsonFileDatabase t -> [Key t] -> m (JsonFileDatabase t)-delete t keys = deleteInCache keys <$> loadInCache t+delete :: (Table t, FromJSON (Key t), FromJSON (Entry t))+       => [Key t] -> JsonFileDatabase t -> IO (JsonFileDatabase t)+delete keys t = deleteInCache keys <$> loadInCache t  deleteInCache :: Table t => [Key t] -> JsonFileDatabase t -> JsonFileDatabase t deleteInCache keys (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where   newCache = foldr Map.delete cache keys -purge :: (Table t, MonadIO m, MonadCatch m, FromJSON (Key t), FromJSON (Entry t))-      => JsonFileDatabase t -> m (JsonFileDatabase t)+purge :: (Table t, FromJSON (Key t), FromJSON (Entry t))+      => JsonFileDatabase t -> IO (JsonFileDatabase t) purge t = purgeInCache <$> loadInCache t  purgeInCache :: Table t => JsonFileDatabase t -> JsonFileDatabase t purgeInCache (JsonFileDatabase file _ _) = JsonFileDatabase file mempty Dirty -commit :: (MonadIO m, ToJSON (Key t), ToJSON (Entry t))-       => JsonFileDatabase t -> m (JsonFileDatabase t)+commit :: (ToJSON (Key t), ToJSON (Entry t))+       => JsonFileDatabase t -> IO (JsonFileDatabase t) commit t@(JsonFileDatabase file cache status) = case status of   Dirty -> do-    writeFile file $ encode $ Map.toList cache+    withFile file WriteMode $ \h -> (hPut h $ encode $ Map.toList cache)     return $ JsonFileDatabase file cache Clean   _ -> return t

@@ -13,12 +13,13 @@  -- {{{ Imports import           Imm.Prelude+import           Imm.Pretty  import           Config.Dyre import           Config.Dyre.Compile import           Config.Dyre.Paths -import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import           System.IO -- }}}  -- | How dynamic reconfiguration process should behave.@@ -31,7 +32,7 @@   -- | Describe the paths used for dynamic reconfiguration-describePaths :: (MonadIO m) => m Doc+describePaths :: (MonadIO m) => m (Doc AnsiStyle) describePaths = io $ do   (a, b, c, d, e) <- getPaths baseParameters   return $ vsep@@ -43,7 +44,7 @@     ]  -- | Dynamic reconfiguration settings-parameters :: Mode -> (a -> IO ()) -> Params (Either Text a)+parameters :: Mode -> (a -> IO ()) -> Params (Either String a) parameters mode main = baseParameters     { configCheck = mode /= Vanilla     , realMain = main'@@ -52,10 +53,10 @@     main' (Left e)  = hPutStrLn stderr e     main' (Right x) = main x -baseParameters :: Params (Either Text a)+baseParameters :: Params (Either String a) baseParameters = defaultParams   { projectName             = "imm"-  , showError               = const (Left . fromString)+  , showError               = const Left   , ghcOpts                 = ["-threaded"]   , statusOut               = hPutStrLn stderr   , includeCurrentDirectory = False

@@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude   #-}-{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} module Imm.Error (module Imm.Error) where @@ -8,7 +7,7 @@ -- }}}  liftE :: (MonadThrow m, Exception e) => Either e a -> m a-liftE (Left e) = throwM e+liftE (Left e)  = throwM e liftE (Right a) = return a  -- | Wrap a 'Maybe' value in 'MonadError'

@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds         #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-} -- | Helpers to manipulate feeds module Imm.Feed where @@ -26,7 +27,7 @@   deriving(Eq, Show)  instance Pretty FeedRef where-  pretty (ByUID n) = text "feed" <+> text (show n)+  pretty (ByUID n) = "feed" <+> pretty n   pretty (ByURI u) = prettyURI u  data Feed = Rss (RssDocument '[ContentModule, DublinCoreModule]) | Atom AtomFeed@@ -47,7 +48,7 @@ getElements (Atom feed) = map AtomElement $ feedEntries feed  getDate :: FeedElement -> Maybe UTCTime-getDate (RssElement item)   = itemPubDate item <|> (elementDate $ itemDcMetaData (item ^. itemExtensionL))+getDate (RssElement item)   = itemPubDate item <|> elementDate (itemDcMetaData $ item ^. itemExtensionL) getDate (AtomElement entry) = Just $ entryUpdated entry  getTitle :: FeedElement -> Text@@ -63,7 +64,7 @@   getHashes :: FeedElement -> [Int]-getHashes (RssElement item) = map (hash . (show :: Doc -> String) . prettyGuid) (maybeToList $ itemGuid item)+getHashes (RssElement item) = map (hash @String . show . prettyGuid) (maybeToList $ itemGuid item)   <> map ((hash :: String -> Int) . show . withRssURI prettyURI) (maybeToList $ itemLink item)   <> [hash $ itemTitle item]   <> [hash $ itemDescription item]@@ -72,6 +73,6 @@  -- * Misc -prettyElement :: FeedElement -> Doc+prettyElement :: FeedElement -> Doc a prettyElement (RssElement item)   = prettyItem item prettyElement (AtomElement entry) = prettyEntry entry

@@ -1,48 +1,29 @@-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude     #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeOperators         #-}--- | DSL/interpreter model for the HTTP client+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- | HTTP module abstracts over HTTP requests to the external world. module Imm.HTTP where  -- {{{ Imports-import           Imm.Error import           Imm.Logger import           Imm.Prelude import           Imm.Pretty -import           Control.Monad.Trans.Free- import           URI.ByteString -- }}}  -- * Types --- | HTTP client DSL-data HttpClientF next-  = Get URI (Either SomeException LByteString -> next)-  deriving(Functor)---- | HTTP client interpreter-newtype CoHttpClientF m a = CoHttpClientF-  { getH :: URI -> m (Either SomeException LByteString, a)-  } deriving(Functor)--instance Monad m => PairingM (CoHttpClientF m) HttpClientF m where-  -- pairM :: (a -> b -> m r) -> f a -> g b -> m r-  pairM p (CoHttpClientF g) (Get uri next) = do-    (result, a) <- g uri-    p a $ next result+-- | Monad capable of performing GET HTTP requests.+class MonadThrow m => MonadHttpClient m where+  httpGet :: URI -> m LByteString  -- * Primitives --- | Perform an HTTP GET request-get :: (MonadFree f m, HttpClientF :<: f, LoggerF :<: f, MonadThrow m)+-- | 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-  result <- liftF . inj $ Get uri id-  liftE result+  httpGet uri

@@ -1,29 +1,28 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}--- | Simple HTTP client interpreter.--- For more information, please consult "Network.HTTP.Client".-module Imm.HTTP.Simple (defaultManager, mkCoHttpClient, module Reexport) where+-- | Implementation of "Imm.HTTP" based on "Network.HTTP.Client".+module Imm.HTTP.Simple (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-import           Network.HTTP.Client.TLS as Reexport-+import           Network.Connection         as Reexport+import           Network.HTTP.Client        as Reexport+import           Network.HTTP.Client.TLS    as Reexport import           URI.ByteString -- }}} --- | Interpreter for 'HttpClientF'-mkCoHttpClient :: (MonadIO m, MonadCatch m) => Manager -> CoHttpClientF m Manager-mkCoHttpClient manager = CoHttpClientF coGet where-  coGet uri = handleAny (\e -> return (Left e, manager)) $ do-    result <- httpGet manager uri-    return (Right result, manager)+-- | Monad capable of performing HTTP GET requests.+instance MonadHttpClient (ReaderT Manager IO) where+  httpGet uri = do+    manager <- ask+    lift $ httpGet' manager uri  -- | Default manager uses TLS and no proxy defaultManager :: IO Manager@@ -31,11 +30,10 @@   -- | Perform an HTTP GET request and return the response body-httpGet :: (MonadIO m, MonadThrow m)-    => Manager -> URI -> m LByteString-httpGet manager uri = do+httpGet' :: Manager -> URI -> IO LByteString+httpGet' manager uri = do   request <- makeRequest uri-  responseBody <$> io (httpLbs request manager)+  responseBody <$> httpLbs request manager     -- codec'   <- reader $ view (config.codec)     -- return $ response $=+ decode codec' @@ -43,7 +41,7 @@ parseRequest' = parseRequest . show . prettyURI  -- | Build an HTTP request for given URI-makeRequest :: (MonadIO m, MonadThrow m) => URI -> m Request+makeRequest :: URI -> IO Request makeRequest uri = do   req <- parseRequest' uri   return $ req { requestHeaders = [

@@ -1,11 +1,8 @@-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude     #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeOperators         #-}--- | DSL/interpreter model for hooks, ie various events that can trigger arbitrary actions+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Hooks module to define the main behavior of the program. module Imm.Hooks where  -- {{{ Imports@@ -13,31 +10,18 @@ import           Imm.Logger import           Imm.Prelude import           Imm.Pretty--import           Control.Monad.Free.Class -- }}}  -- * Types --- | Hooks DSL-data HooksF next-  = OnNewElement Feed FeedElement next-  deriving(Functor)---- | Hooks interpreter-data CoHooksF m a = CoHooksF-  { onNewElementH :: Feed -> FeedElement -> m a  -- ^ Triggered for each unread feed element-  } deriving(Functor)--instance Monad m => PairingM (CoHooksF m) HooksF m where-  -- pairM :: (a -> b -> m r) -> f a -> g b -> m r-  pairM p (CoHooksF f) (OnNewElement feed element next) = do-    a <- f feed element-    p a next+-- | Monad capable of acting on specific events.+class Monad m => MonadImm m where+  -- | Action triggered for each unread feed element+  processNewElement :: Feed -> FeedElement -> m ()  -- * Primitives -onNewElement :: (MonadFree f m, LoggerF :<: f, HooksF :<: f) => Feed -> FeedElement -> m ()+onNewElement :: (MonadImm m, MonadLog m) => Feed -> FeedElement -> m () onNewElement feed element = do-  logDebug $ "Unread element:" <+> textual (getTitle element)-  liftF . inj $ OnNewElement feed element ()+  logDebug $ "Unread element:" <+> pretty (getTitle element)+  processNewElement feed element

@@ -0,0 +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++-- {{{ 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"

@@ -1,8 +1,9 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators     #-}--- | 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.+-- | 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. -- -- Here is an example configuration: --@@ -29,19 +30,18 @@ import           Imm.Prelude import           Imm.Pretty +import           Control.Monad.Trans.Reader import           Data.NonNull import           Data.Time- import           Network.HaskellNet.SMTP     as Reexport import           Network.HaskellNet.SMTP.SSL as Reexport import           Network.Mail.Mime           as Reexport hiding (sendmail) import           Network.Socket- import           Text.Atom.Types import           Text.RSS.Types -- }}} --- * Settings+-- * Types  type Username = String type Password = String@@ -68,18 +68,16 @@  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 --- * Interpreter --- | Interpreter for 'HooksF'-mkCoHooks :: (MonadIO m) => SendMailSettings -> CoHooksF m SendMailSettings-mkCoHooks a@(SendMailSettings connectionSettings formatMail) = CoHooksF coOnNewElement where-  coOnNewElement feed element = do-    timezone <- io getCurrentTimeZone-    currentTime <- io getCurrentTime-    let mail = buildMail formatMail currentTime timezone feed element-    io $ withSMTPConnection (connectionSettings feed element) $ sendMimeMail2 mail-    return a+-- * Default behavior  -- | Fill 'addressName' with the feed title and, if available, the authors' names. --@@ -93,7 +91,7 @@  -- | Fill mail subject with the element title defaultFormatSubject :: Feed -> FeedElement -> Text-defaultFormatSubject _ element = getTitle element+defaultFormatSubject _ = getTitle  -- | Fill mail body with: --

@@ -1,9 +1,8 @@ {-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators     #-}--- | Hooks interpreter that writes a file for each element.+-- | Implementation of "Imm.Hooks" that writes a file for each new RSS/Atom item. module Imm.Hooks.WriteFile where  -- {{{ Imports@@ -13,39 +12,40 @@ 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)-import qualified Data.Text.Lazy                as Text import           Data.Time+import           Streaming.With import           System.Directory              (createDirectoryIfMissing) import           System.FilePath import           Text.Atom.Types-import           Text.Blaze.Html.Renderer.Text+import           Text.Blaze.Html.Renderer.Utf8 import           Text.Blaze.Html5              (Html, docTypeHtml,                                                 preEscapedToHtml, (!))-import qualified Text.Blaze.Html5              as H hiding (map)+import qualified Text.Blaze.Html5              as H import           Text.Blaze.Html5.Attributes   as H (charset, href) import           Text.RSS.Types import           URI.ByteString -- }}} --- * Settings+-- * Types  -- | Where and what to write in a file-data FileInfo = FileInfo FilePath ByteString--data WriteFileSettings = WriteFileSettings (Feed -> FeedElement -> FileInfo)+data FileInfo = FileInfo FilePath Builder --- * Interpreter+newtype WriteFileSettings = WriteFileSettings (Feed -> FeedElement -> FileInfo) --- | Interpreter for 'HooksF'-mkCoHooks :: MonadIO m => WriteFileSettings -> CoHooksF m WriteFileSettings-mkCoHooks a@(WriteFileSettings f) = CoHooksF coOnNewElement where-  coOnNewElement feed element = do+instance MonadImm (ReaderT WriteFileSettings IO) where+  processNewElement feed element = do+    WriteFileSettings f <- ask     let FileInfo path content = f feed element-    io $ createDirectoryIfMissing True $ takeDirectory path-    writeFile path content-    return a+    lift $ createDirectoryIfMissing True $ takeDirectory path+    writeBinaryFile path $ toStreamingByteString content +-- * Default behavior+ -- | Wrapper around 'defaultFilePath' and 'defaultFileContent' defaultSettings :: FilePath            -- ^ Root directory for 'defaultFilePath'                 -> WriteFileSettings@@ -55,18 +55,18 @@  -- | 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+defaultFilePath root feed element = makeValid $ root </> title </> fileName <.> "html" where   date = maybe "" (formatTime defaultTimeLocale "%F-") $ getDate element   fileName = date <> sanitize (convertText $ getTitle element)-  feedTitle = sanitize $ convertText $ getFeedTitle feed+  title = sanitize $ convertText $ getFeedTitle feed   sanitize = replaceIf isPathSeparator '-' >>> replaceAny ".?!#" '_'-  replaceAny :: [Char] -> Char -> String -> String+  replaceAny :: String -> Char -> String -> String   replaceAny list = replaceIf (`elem` list)   replaceIf f b = map (\c -> if f c then b else c)  -- | 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+defaultFileContent :: Feed -> FeedElement -> Builder+defaultFileContent feed element = renderHtmlBuilder $ docTypeHtml $ do   H.head $ do     H.meta ! H.charset "utf-8"     H.title $ convertText $ getFeedTitle feed <> " | " <> getTitle element@@ -120,5 +120,5 @@ convertText :: (IsString t) => Text -> t convertText = fromString . toString (const "?") -convertDoc :: (IsString t) => Doc -> t+convertDoc :: (IsString t) => Doc a -> t convertDoc = show

@@ -1,18 +1,14 @@-{-# LANGUAGE DeriveFunctor         #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeOperators         #-}--- | DSL/interpreter model for the logger+-- | Logger module. module Imm.Logger where  -- {{{ Imports import           Imm.Prelude--import           Control.Monad.Trans.Free+import           Imm.Pretty -- }}}  -- * Types@@ -21,67 +17,22 @@   deriving(Eq, Ord, Read, Show)  instance Pretty LogLevel where-  pretty Debug   = text "DEBUG"-  pretty Info    = text "INFO"-  pretty Warning = text "WARNING"-  pretty Error   = text "ERROR"---- | Logger DSL-data LoggerF next-  = Log LogLevel Doc next-  | GetLevel (LogLevel -> next)-  | SetLevel LogLevel next-  | SetColorize Bool next-  | Flush next-  deriving(Functor)---- | Logger interpreter-data CoLoggerF m a = CoLoggerF-  { 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{logH} (Log level message next) = do-    a <- logH level message-    p a next-  pairM p CoLoggerF{getLevelH} (GetLevel next) = do-    (l, a) <- getLevelH-    p a (next l)-  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 :: (MonadFree f m, LoggerF :<: f) => LogLevel -> Doc -> m ()-log level message = liftF . inj $ Log level message ()--getLogLevel :: (MonadFree f m, LoggerF :<: f) => m LogLevel-getLogLevel = liftF . inj $ GetLevel id--setLogLevel :: (MonadFree f m, LoggerF :<: f) => LogLevel -> m ()-setLogLevel level = liftF . inj $ SetLevel level ()--setColorizeLogs :: (MonadFree f m, LoggerF :<: f) => Bool -> m ()-setColorizeLogs colorize = liftF . inj $ SetColorize colorize ()+  pretty Debug   = "DEBUG"+  pretty Info    = "INFO"+  pretty Warning = "WARNING"+  pretty Error   = "ERROR" -flushLogs :: (MonadFree f m, LoggerF :<: f) => m ()-flushLogs = liftF . inj $ Flush ()+-- | 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 :: (MonadFree f m, LoggerF :<: f) => Doc -> m ()+logDebug, logInfo, logWarning, logError :: MonadLog m => Doc AnsiStyle -> m () logDebug = log Debug logInfo = log Info logWarning = log Warning

@@ -1,50 +1,60 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--- | Simple logger interpreter.+-- | Implementation of "Imm.Logger" based on @fast-logger@. -- For further information, please consult "System.Log.FastLogger". module Imm.Logger.Simple (module Imm.Logger.Simple, module Reexport) where  -- {{{ Imports-import           Imm.Logger            as Reexport+import           Imm.Logger                                as Reexport import           Imm.Prelude import           Imm.Pretty -import           System.Log.FastLogger as Reexport+import           Control.Concurrent.MVar.Lifted+import           Control.Monad.Trans.Reader+import           Data.Text.Prettyprint.Doc.Render.Terminal+import           System.Log.FastLogger                     as Reexport -- }}} --- * Settings- data LoggerSettings = LoggerSettings-  { loggerSet      :: LoggerSet  -- ^ 'LoggerSet' used for 'Debug', 'Info' and 'Warning' logs-  , errorLoggerSet :: LoggerSet  -- ^ 'LoggerSet' used for 'Error' logs-  , logLevel       :: LogLevel   -- ^ Discard logs that are strictly less serious than this level-  , colorizeLogs   :: Bool       -- ^ Enable log colorisation+  { _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 :: MonadIO m => m LoggerSettings-defaultLogger = io $ LoggerSettings+defaultLogger :: IO (MVar LoggerSettings)+defaultLogger = newMVar =<< LoggerSettings   <$> newStdoutLoggerSet defaultBufSize   <*> newStderrLoggerSet defaultBufSize   <*> pure Info   <*> pure True --- * Interpreter+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 --- | Interpreter for 'LoggerF'-mkCoLogger :: (MonadIO m) => LoggerSettings -> CoLoggerF m LoggerSettings-mkCoLogger settings = CoLoggerF coLog coGetLevel coSetLevel coSetColorize coFlush where-  coLog Error t = do-    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 :: 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+  -- 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 })++  -- flushLogs :: m ()+  flushLogs = do+    settings <- readMVar =<< ask+    lift $ flushLogStr $ _loggerSet settings+    lift $ flushLogStr $ _errorLoggerSet settings

@@ -5,17 +5,19 @@ module Imm.Options where  -- {{{ Imports-import           Imm.Dyre                    as Dyre (Mode (..))-import qualified Imm.Dyre                    as Dyre+import           Imm.Dyre                       as Dyre (Mode (..))+import qualified Imm.Dyre                       as Dyre import           Imm.Feed-import           Imm.Logger                  as Logger+import           Imm.Logger                     as Logger import           Imm.Prelude import           Imm.Pretty -import           Options.Applicative.Builder-import           Options.Applicative.Extra-import           Options.Applicative.Types-+import           Data.Set                       (Set)+import qualified Data.Set                       as Set+import qualified Data.Text                      as Text+import           Options.Applicative+import           Options.Applicative.Help.Core  as Help+import           Options.Applicative.Help.Types import           URI.ByteString -- }}} @@ -27,8 +29,9 @@              | Unread (Maybe FeedRef)              | Run (Maybe FeedRef)              | Show (Maybe FeedRef)+             | Help              | ShowVersion-             | Subscribe URI (Maybe Text)+             | Subscribe URI (Set Text)              | Unsubscribe (Maybe FeedRef)  deriving instance Eq Command@@ -42,6 +45,7 @@   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 Help            = "Display help"   pretty ShowVersion     = "Show program version"   pretty (Subscribe f _) = "Subscribe to feed:" <+> prettyURI f   pretty (Unsubscribe f) = "Unsubscribe from feed(s):" <+> pretty f@@ -67,11 +71,16 @@ --         ] --         ++ catMaybes [("CONFIG=" ++) <$> opts^.configurationLabel_] +helpString :: Text+helpString = Text.pack $ renderHelp 100 $ Help.parserHelp defaultPrefs optionsParser+ parseOptions :: (MonadIO m) => m CliOptions-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+parseOptions = io $ customExecParser defaultPrefs (info optionsParser $ progDesc "Fetch elements from RSS/Atom feeds and execute arbitrary actions for each of them.")  +optionsParser :: Parser CliOptions+optionsParser = optional dyreMasterBinary *> optional dyreDebug *> cliOptions+ cliOptions :: Parser CliOptions cliOptions = CliOptions   <$> commands@@ -82,16 +91,19 @@  commands :: Parser Command commands = subparser $ mconcat-  [ command "check" . info (Check <$> optional feedRefOption) $ progDesc "Check availability and validity of all feed sources currently configured, without writing any mail."-  , command "import" . info (pure Import) $ progDesc "Import feeds list from an OPML descriptor (read from stdin)."-  , command "read" . info (Read <$> optional feedRefOption) $ progDesc "Mark given feed as read."-  , command "rebuild" . info (pure Rebuild) $ progDesc "Rebuild configuration file."-  , command "run" . info (Run <$> optional feedRefOption) $ progDesc "Update list of feeds."-  , command "show" . info (Show <$> optional feedRefOption) $ progDesc "List all feed sources currently configured, along with their status."-  , command "subscribe" . info subscribeOptions $ progDesc "Subscribe to a feed."-  , command "unread" . info (Unread <$> optional feedRefOption) $ progDesc "Mark given feed as unread."-  , command "unsubscribe" . info unsubscribeOptions $ progDesc "Unsubscribe from a feed."-  , command "version" . info (pure ShowVersion) $ progDesc "Print version."+  [ command "add" $ info subscribeOptions $ progDesc "Alias for subscribe."+  , command "check" $ info (Check <$> optional feedRefOption) $ progDesc "Check availability and validity of all feed sources currently configured, without writing any mail."+  , command "help" $ info (pure Help) $ progDesc "Display help"+  , command "import" $ info (pure Import) $ progDesc "Import feeds list from an OPML descriptor (read from stdin)."+  , command "read" $ info (Read <$> optional feedRefOption) $ progDesc "Mark given feed as read."+  , command "rebuild" $ info (pure Rebuild) $ progDesc "Rebuild configuration file."+  , command "remove" $ info unsubscribeOptions $ progDesc "Alias for unsubscribe."+  , command "run" $ info (Run <$> optional feedRefOption) $ progDesc "Update list of feeds."+  , command "show" $ info (Show <$> optional feedRefOption) $ progDesc "List all feed sources currently configured, along with their status."+  , command "subscribe" $ info subscribeOptions $ progDesc "Subscribe to a feed."+  , command "unread" $ info (Unread <$> optional feedRefOption) $ progDesc "Mark given feed as unread."+  , command "unsubscribe" $ info unsubscribeOptions $ progDesc "Unsubscribe from a feed."+  , command "version" $ info (pure ShowVersion) $ progDesc "Print version."   ]  @@ -119,11 +131,11 @@ -- }}}  -- {{{ Other options-configLabelOption :: Parser Text-configLabelOption = option auto $ long "config" <> short 'C' <> metavar "CONFIG" <> help "Use the given configuration for all operations."+tagOption :: Parser Text+tagOption = option auto $ long "tag" <> short 't' <> metavar "TAG" <> help "Set the given tag."  subscribeOptions, unsubscribeOptions :: Parser Command-subscribeOptions    = Subscribe <$> uriArgument "URI to subscribe to." <*> optional configLabelOption+subscribeOptions    = Subscribe <$> uriArgument "URI to subscribe to." <*> (Set.fromList <$> many tagOption) unsubscribeOptions  = Unsubscribe <$> optional feedRefOption -- }}} 

@@ -1,50 +1,31 @@-{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE EmptyDataDecls         #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TupleSections          #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE FlexibleContexts #-} module Imm.Prelude (module Imm.Prelude, module X) where  -- {{{ Imports 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.Base              as X import           Control.Monad.IO.Class          as X-import           Control.Monad.Trans.Free        (FreeF (..), FreeT (..))+import           Control.Monad.Trans             as X (lift) import           Data.Bifunctor                  as X import qualified Data.ByteString                 as B (ByteString) import qualified Data.ByteString.Lazy            as LB (ByteString) 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 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           Data.Text.IO                    as X (getLine, putStr,+                                                       putStrLn) import qualified Data.Text.Lazy                  as LT (Text) import           Data.Traversable                as X (for, forM)-import           Data.Typeable                   as X import qualified GHC.Show                        as Show import           Prelude                         as X hiding (all, and, any,                                                        break, concat, concatMap,@@ -53,92 +34,17 @@                                                        getLine, length, lines,                                                        log, lookup, notElem,                                                        null, or, product,+                                                       putStr, putStrLn,                                                        readFile, replicate,                                                        reverse, sequence_, show,                                                        span, splitAt, sum, take,                                                        takeWhile, unlines,                                                        unwords, words,                                                        writeFile)-import           System.IO                       as X (stderr, stdout)-import           Text.PrettyPrint.ANSI.Leijen    as X (Doc, Pretty (..), angles,-                                                       brackets, equals, hsep,-                                                       indent, space, text,-                                                       vsep, (<+>))-import           Text.PrettyPrint.ANSI.Leijen    (line)+import           System.IO                       as X (IOMode (..), stderr,+                                                       stdout) -- }}} --- * Free monad utilities---- | Right-associative tuple type-constructor-type a ::: b = (a, b)-infixr 0 :::---- | Right-associative tuple data-constructor-(+:) :: a -> b -> (a,b)-(+:) a b = (a, b)-infixr 0 +:--(*:) :: (Functor f, Functor g) => (a -> f a) -> (b -> g b) -> (a, b) -> 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))----- | Functors @f@ and @g@ are paired when they can annihilate each other-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 (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 (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-    Free gs -> pairM (interpret p) (unwrap eval) gs- -- * Shortcuts  type LByteString = LB.ByteString@@ -146,14 +52,12 @@ type LText = LT.Text type Text = T.Text --- | Generic 'Show.show'-show :: (Show a, IsString b) => a -> b-show = fromString . Show.show- -- | Shortcut to 'liftIO' io :: MonadIO m => IO a -> m a io = liftIO --- | Infix operator for 'line'-(<++>) :: Doc -> Doc -> Doc-x <++> y = x <> line <> y+-- * Generalisation++-- | Generic 'Show.show'+show :: (Show a, IsString b) => a -> b+show = fromString . Show.show

@@ -1,37 +1,38 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE NoImplicitPrelude     #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} 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 -import           Text.Atom.Types              as Atom+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 as X hiding (sep, width, (<$>),-                                                    (</>), (<>))-import           Text.RSS.Types               as RSS-+import           Data.Text.Prettyprint.Doc                 as X hiding (list,+                                                                 width)+import           Data.Text.Prettyprint.Doc                 (list)+import           Data.Text.Prettyprint.Doc.Render.Terminal as X (AnsiStyle)+import           Data.Text.Prettyprint.Doc.Render.Terminal+import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty+import           Text.RSS.Types                            as RSS import           URI.ByteString -- }}} --- | Generalized 'text'-textual :: TextualMonoid t => t -> Doc-textual = text . toString (const "?")+-- | Infix operator for 'line'+(<++>) :: Doc a -> Doc a -> Doc a+x <++> y = x <> line <> y -prettyTree :: (Pretty a) => Tree a -> Doc+prettyTree :: (Pretty a) => Tree a -> Doc b prettyTree (Node n s) = pretty n <++> indent 2 (vsep $ prettyTree <$> s) -prettyTime :: UTCTime -> Doc-prettyTime = text . formatTime defaultTimeLocale rfc822DateFormat+prettyTime :: UTCTime -> Doc a+prettyTime = pretty . formatTime defaultTimeLocale rfc822DateFormat  -- instance Pretty OpmlHead where --   pretty h = hsep $ catMaybes@@ -59,20 +60,20 @@ -- instance Pretty Opml where --   pretty o = text "OPML" <+> pretty (opmlVersion o) <++> indent 2 (pretty (opmlHead o) <++> (vsep . map pretty $ opmlOutlines o)) -prettyPerson :: AtomPerson -> Doc-prettyPerson p = text (fromText $ toNullable $ personName p) <> email where+prettyPerson :: AtomPerson -> Doc a+prettyPerson p = pretty (toNullable $ personName p) <> email where   email = if null $ personEmail p     then mempty-    else space <> angles (text $ fromText $ personEmail p)+    else space <> angles (pretty $ personEmail p) -prettyLink :: AtomLink -> Doc+prettyLink :: AtomLink -> Doc a prettyLink l = withAtomURI prettyURI $ linkHref l -prettyAtomText :: AtomText -> Doc-prettyAtomText (AtomPlainText _ t) = text $ fromText t-prettyAtomText (AtomXHTMLText t)   = text $ fromText t+prettyAtomText :: AtomText -> Doc a+prettyAtomText (AtomPlainText _ t) = pretty t+prettyAtomText (AtomXHTMLText t)   = pretty t -prettyEntry :: AtomEntry -> Doc+prettyEntry :: AtomEntry -> Doc a prettyEntry e = "Entry:" <+> prettyAtomText (entryTitle e) <++> indent 4   (         "By" <+> equals <+> list (prettyPerson <$> entryAuthors e)   <++> "Updated" <+> equals <+> prettyTime (entryUpdated e)@@ -80,22 +81,40 @@   -- , "   Item Body:   " ++ (Imm.Mail.getItemContent item),   ) -prettyItem :: RssItem e -> Doc-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)+prettyItem :: RssItem e -> Doc a+prettyItem i = "Item:" <+> pretty (itemTitle i) <++> indent 4+  (         "By" <+> equals <+> pretty (itemAuthor i)+  <++> "Updated" <+> equals <+> maybe "<empty>" prettyTime (itemPubDate i)+  <++> "Link"    <+> equals <+> maybe "<empty>" (withRssURI prettyURI) (itemLink i)   ) -prettyURI :: URIRef a -> Doc-prettyURI uri = text $ fromText $ decodeUtf8 $ serializeURIRef' uri+prettyURI :: URIRef a -> Doc b+prettyURI uri = pretty $ decodeUtf8 $ serializeURIRef' uri -prettyGuid :: RssGuid -> Doc-prettyGuid (GuidText t)         = text $ fromText t+prettyGuid :: RssGuid -> Doc a+prettyGuid (GuidText t)         = pretty t prettyGuid (GuidUri (RssURI u)) = prettyURI u -prettyAtomContent :: AtomContent -> Doc-prettyAtomContent (AtomContentInlineText _ t)  = text $ fromText t-prettyAtomContent (AtomContentInlineXHTML t)   = text $ fromText t-prettyAtomContent (AtomContentInlineOther _ t) = text $ fromText t+prettyAtomContent :: AtomContent -> Doc a+prettyAtomContent (AtomContentInlineText _ t)  = pretty t+prettyAtomContent (AtomContentInlineXHTML t)   = pretty t+prettyAtomContent (AtomContentInlineOther _ t) = pretty t prettyAtomContent (AtomContentOutOfLine _ u)   = withAtomURI prettyURI u++magenta :: Doc AnsiStyle -> Doc AnsiStyle+magenta = annotate $ color Magenta++yellow :: Doc AnsiStyle -> Doc AnsiStyle+yellow = annotate $ color Yellow++red :: Doc AnsiStyle -> Doc AnsiStyle+red = annotate $ color Red++green :: Doc AnsiStyle -> Doc AnsiStyle+green = annotate $ color Green++cyan :: Doc AnsiStyle -> Doc AnsiStyle+cyan = annotate $ color Cyan++bold :: Doc AnsiStyle -> Doc AnsiStyle+bold = annotate Pretty.bold

@@ -1,45 +1,14 @@-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude     #-}-{-# LANGUAGE TypeOperators         #-}--- | DSL/interpreter model for parsing XML into a 'Feed'+{-# LANGUAGE NoImplicitPrelude #-}+-- | XML module abstracts over the parsing of RSS/Atom feeds. module Imm.XML where  -- {{{ Imports-import           Imm.Error import           Imm.Feed import           Imm.Prelude -import           Control.Monad.Trans.Free- import           URI.ByteString -- }}} --- * Types---- | XML parsing DSL-data XmlParserF next-  = ParseXml URI LByteString (Either SomeException Feed -> next)-  deriving(Functor)---- | XML parsing interpreter-newtype CoXmlParserF m a = CoXmlParserF-  { parseXmlH :: URI -> LByteString -> m (Either SomeException Feed, a)-  } deriving(Functor)--instance Monad m => PairingM (CoXmlParserF m) XmlParserF m where-  -- pairM :: (a -> b -> m r) -> f a -> g b -> m r-  pairM f (CoXmlParserF p) (ParseXml uri bytestring next) = do-    (result, a) <- p uri bytestring-    f a $ next result---- * Primitives---- | Parse XML into a 'Feed'-parseXml :: (MonadFree f m, XmlParserF :<: f, MonadThrow m)-         => URI -> LByteString -> m Feed-parseXml uri bytestring = do-  result <- liftF . inj $ ParseXml uri bytestring id-  liftE result+-- | Monad capable of parsing XML into a 'Feed' (RSS or Atom).+class MonadThrow m => MonadXmlParser m where+  parseXml :: URI -> LByteString -> m Feed

@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes        #-}+-- | Implementation of "Imm.XML" based on 'Conduit'.+module Imm.XML.Conduit where++-- {{{ Imports+import           Imm.Feed+import           Imm.Prelude+import           Imm.XML++import           Control.Monad+import           Control.Monad.Fix+import           Control.Monad.Trans.Reader+import           Data.Conduit+import           Data.XML.Types+import           Text.Atom.Conduit.Parse+import           Text.RSS.Conduit.Parse+import           Text.RSS1.Conduit.Parse+import           Text.XML.Stream.Parse+import           URI.ByteString+-- }}}++-- | A pre-process 'Conduit' can be set to alter the raw XML before feeding it to the parser,+-- depending on the feed 'URI'+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))++-- | Forward all 'Event's without any pre-process+defaultXmlParser :: XmlParser+defaultXmlParser = XmlParser $ const $ fix $ \loop -> await >>= maybe (return ()) (yield >=> const loop)

@@ -1,37 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--- | Simple interpreter to parse XML into 'Feed', based on 'Conduit'.-module Imm.XML.Simple where---- {{{ Imports-import           Imm.Feed-import           Imm.Prelude-import           Imm.XML--import           Control.Monad-import           Control.Monad.Fix--import           Data.Conduit-import           Data.XML.Types--import           Text.Atom.Conduit.Parse-import           Text.RSS.Conduit.Parse-import           Text.RSS1.Conduit.Parse-import           Text.XML.Stream.Parse--import           URI.ByteString--- }}}---- | A 'Conduit' to alter the raw XML before feeding it to the parser, depending on the feed 'URI'-type PreProcess m = URI -> Conduit Event m Event---- | Interpreter for 'XmlParserF'-mkCoXmlParser :: (MonadIO m, MonadCatch m) => PreProcess m -> CoXmlParserF m (PreProcess m)-mkCoXmlParser preProcess = CoXmlParserF coParse where-  coParse uri bytestring = handleAny (\e -> return (Left e, preProcess)) $ do-    result <- runConduit $ parseLBS def bytestring =$= preProcess uri =$= force "Invalid feed" ((fmap Atom <$> atomFeed) `orE` (fmap Rss <$> rssDocument) `orE` (fmap Rss <$> rss1Document))-    return (Right result, preProcess)---- | Default pre-process always forwards all 'Event's-defaultPreProcess :: Monad m => PreProcess m-defaultPreProcess _ = fix $ \loop -> await >>= maybe (return ()) (yield >=> const loop)