imm 1.5.0.0 → 1.6.0.0

raw patch · 37 files changed

+1473/−1298 lines, 37 filesdep +asyncdep +binarydep +dhalldep −basedep −dyredep −monoid-subclassesdep ~HaskellNetdep ~atom-conduitdep ~base-nopreludenew-component:exe:imm-sendmailnew-component:exe:imm-writefilePVP ok

version bump matches the API change (PVP)

Dependencies added: async, binary, dhall, stm-chans, typed-process

Dependencies removed: base, dyre, monoid-subclasses, mtl, streamly, transformers-base, xml

Dependency ranges changed: HaskellNet, atom-conduit, base-noprelude, directory, network, refined, rss-conduit

API changes (from Hackage documentation)

Files

• README.md +67/−19
• data/callbacks.dhall +23/−0
• imm.cabal +41/−54
• src/bin/Executable.hs +0/−27
• src/lib/Imm.hs +2/−5
• src/lib/Imm/Aeson.hs +0/−15
• src/lib/Imm/Boot.hs +0/−138
• src/lib/Imm/Callback.hs +39/−0
• src/lib/Imm/Core.hs +0/−174
• src/lib/Imm/Database.hs +14/−1
• src/lib/Imm/Database/FeedTable.hs +127/−44
• src/lib/Imm/Database/JsonFile.hs +0/−122
• src/lib/Imm/Dyre.hs +0/−71
• src/lib/Imm/Error.hs +0/−15
• src/lib/Imm/Feed.hs +92/−14
• src/lib/Imm/HTTP/Simple.hs +0/−46
• src/lib/Imm/Hooks.hs +0/−27
• src/lib/Imm/Hooks/Dummy.hs +0/−20
• src/lib/Imm/Hooks/SendMail.hs +0/−144
• src/lib/Imm/Hooks/WriteFile.hs +0/−123
• src/lib/Imm/Logger/Simple.hs +0/−46
• src/lib/Imm/Options.hs +0/−150
• src/lib/Imm/Pretty.hs +28/−9
• src/lib/Imm/XML/Conduit.hs +0/−32
• src/lib/Prelude.hs +1/−2
• src/main/Core.hs +70/−0
• src/main/Database.hs +127/−0
• src/main/HTTP.hs +46/−0
• src/main/Logger.hs +52/−0
• src/main/Main.hs +228/−0
• src/main/Options.hs +144/−0
• src/main/Prelude.hs +7/−0
• src/main/XML.hs +32/−0
• src/send-mail/Main.hs +185/−0
• src/send-mail/Prelude.hs +7/−0
• src/write-file/Main.hs +134/−0
• src/write-file/Prelude.hs +7/−0

@@ -1,14 +1,29 @@ # imm -*imm* is a tool to execute arbitrary actions for each new element from RSS/Atom feeds (e.g. sending a mail, or writing a file).+*imm* is a program that executes arbitrary callbacks (e.g. sending a mail, or writing a file) for each element of RSS/Atom feeds. -*imm* is written and configured in *Haskell*.+*imm* is written in [Haskell][2], configured in [Dhall][3]. The project includes: -Technical documentation is available at [hackage][1].+- a main executable `imm` that users directly run+- additional executables (`imm-writefile` and `imm-sendmail`) that `imm` can be configured to use as callbacks+- a [*Haskell*][2] library, that exports functions useful to both the main executable and callbacks; the API is documented [in Hackage][1]. -To get started, please consult documentation of `Imm.Boot` module.+## Callbacks +Callbacks are configured through the `$XDG_CONFIG_HOME/imm/callbacks.dhall` file. A commented template file is bundled with the project. +`imm` will call each callback once per feed element, and will fill its standard input (`stdin`) with a JSON object structured as follows:++```json+{+  "feed": "RSS document or Atom feed (XML)",+  "element": "RSS item or Atom entry (XML)"+}+```++`imm` expects callbacks to return `0` in case of success, or any other exit code in case of failure, in which case the standard error output (`stderr`) will be displayed.++ ## Example use cases  ### Online feed reader@@ -17,45 +32,78 @@ You can then browse your feeds through your favourite mail reader, and leverage any mail-related tool on your feeds. Bonus points if your mail reader is online as you can now access your feeds from any computer connected to the Internet. -Check out `Imm.Hooks.SendMail` module.+Here is an example configuration:+```dhall+let Callback : Type =+  { _executable : Text+  , _arguments : List Text+  } +let sendMail =+  { _executable = "imm-sendmail"+  , _arguments = ["--login", "-u", "user@domain.com", "-P", "password", "-s", "smtp.domain.com", "-p", "587", "--to", "foo.bar@domain.com"]+  }++let config : List Callback = [ sendMail ]+in config+```+ ### Offline read-it-later  *imm* is able to store a local copy of unread elements, to read them later while offline for example. External links won't work offline though. -Check out `Imm.Hooks.WriteFile` module.+```+let Callback : Type =+  { _executable : Text+  , _arguments : List Text+  } +let writeFile =+  { _executable = "imm-writefile"+  , _arguments = [ "-d", "/path/to/folder" ]+  } +let config : List Callback = [ writeFile ]+in config+```+ ## Example usage  - Subscribe to a feed:--  ```+  ```bash   imm subscribe http://your.feed.org   ```-- Import feeds from an OPML file: -  ```+- Import feeds from an OPML file:+  ```bash   cat feeds.opml | imm import   ```-- List subscribed feeds: -  ```-  imm show+- List subscribed feeds:+  ```bash+  imm list   ```-- Unsubscribe from a feed: +- Show details about a feed:+  ```bash+  imm show http://your.feed.org   ```++- Unsubscribe from a feed:+  ```bash   imm unsubscribe http://your.feed.org   ```-- Check for new elements without executing any action: -  ```-  imm check+- Check for new elements without executing any action:+  ```bash+  imm run --no-callbacks --read-only   ```-- Execute configured actions for each new element from subscribed feeds: -  ```+- Execute configured callbacks for each new element from subscribed feeds:+  ```bash   imm run   ```+ [1]: http://hackage.haskell.org/package/imm+[2]: https://www.haskell.org+[3]: https://dhall-lang.org/

@@ -0,0 +1,23 @@+-- This file must produce a `List Callback` expression,+-- where `Callback` is defined as follows:+let Callback : Type =+  { _executable : Text+  , _arguments : List Text+  }++-- Below are 2 basic callbacks bundled with imm.+--+-- Check out `imm-writefile --help`+let writeFile =+  { _executable = "imm-writefile"+  , _arguments = [ "-d", "/path/to/folder" ]+  }++-- Check out `imm-sendmail --help`+let sendMail =+  { _executable = "imm-sendmail"+  , _arguments = ["--login", "-u", "user@domain.com", "-P", "password", "-s", "smtp.domain.com", "-p", "587", "--to", "foo.bar@domain.com"]+  }++let config : List Callback = [ writeFile ]+in config

@@ -1,102 +1,89 @@+cabal-version:       2.2 name:                imm-version:             1.5.0.0-synopsis:            Execute arbitrary actions for each unread element of RSS/Atom feeds+version:             1.6.0.0+synopsis:            Execute arbitrary callbacks for each element of RSS/Atom feeds description:         Cf README file homepage:            https://github.com/k0ral/imm-license:             PublicDomain+license:             CC0-1.0 license-file:        LICENSE author:              kamaradclimber, koral-maintainer:          koral <koral@mailoo.org>+maintainer:          chahine.moreau@gmail.com category:            Web build-type:          Simple-cabal-version:       >=1.8+data-files:          data/*.dhall extra-source-files:  README.md+tested-with:         GHC <8.8 && >=8.4  source-repository head   type:     git   location: git://github.com/k0ral/imm.git +common common+  build-depends: base-noprelude >=4.7 && <5, relude+  default-language: Haskell2010+  other-modules:+    Prelude+ library+  import: common   exposed-modules:     Imm-    Imm.Boot-    Imm.Core+    Imm.Callback     Imm.Database     Imm.Database.FeedTable-    Imm.Database.JsonFile     Imm.Feed-    Imm.Hooks-    Imm.Hooks.Dummy-    Imm.Hooks.SendMail-    Imm.Hooks.WriteFile     Imm.HTTP-    Imm.HTTP.Simple     Imm.Logger-    Imm.Logger.Simple-    Imm.XML-    Imm.XML.Conduit-  other-modules:-    Imm.Aeson-    Imm.Dyre-    Imm.Error-    Imm.Options     Imm.Pretty-    Paths_imm-    Prelude+    Imm.XML   build-depends:     aeson,-    atom-conduit >= 0.6,-    base-noprelude == 4.*,-    blaze-html,-    blaze-markup,-    bytestring,-    case-insensitive,+    async,+    atom-conduit >= 0.7,+    binary,     conduit,-    connection,     containers,+    dhall,     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,     microlens,-    mime-mail,     monad-time,-    monoid-subclasses,-    mtl,-    network,-    opml-conduit >= 0.7,-    optparse-applicative,     prettyprinter,     prettyprinter-ansi-terminal,-    refined,-    relude,+    refined >=0.4.1,     rss-conduit >= 0.4.1,     safe-exceptions,-    stm,-    streaming-bytestring,-    streaming-with,-    streamly,     text,-    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.*-  main-is: Executable.hs-  hs-source-dirs: src/bin+  import: common+  build-depends: imm, aeson, async, atom-conduit >=0.7, bytestring, case-insensitive, conduit, connection, containers, dhall, directory, fast-logger, filepath, http-client >=0.4.30, http-client-tls, opml-conduit >=0.7, optparse-applicative, prettyprinter-ansi-terminal, refined >=0.4.1, rss-conduit >=0.4.1, safe-exceptions, stm, stm-chans, streaming-bytestring, streaming-with, text, typed-process, uri-bytestring, xml-conduit >=1.5, xml-types+  main-is: Main.hs+  other-modules: Core, Database, HTTP, Logger, Options, Paths_imm, XML+  autogen-modules: Paths_imm+  hs-source-dirs: src/main+  ghc-options: -Wall -fno-warn-unused-do-bind -threaded++executable imm-writefile+  import: common+  build-depends: imm, aeson, atom-conduit, blaze-html, blaze-markup, bytestring, directory, filepath, optparse-applicative, prettyprinter, rss-conduit, streaming-bytestring, streaming-with, text, time, uri-bytestring+  main-is: Main.hs+  hs-source-dirs: src/write-file+  ghc-options: -Wall -fno-warn-unused-do-bind -threaded++executable imm-sendmail+  import: common+  build-depends: imm, aeson, atom-conduit, blaze-html, blaze-markup, bytestring, directory, filepath, HaskellNet >=0.5, HaskellNet-SSL >= 0.3.3.0, mime-mail, network <3, optparse-applicative, prettyprinter, refined, rss-conduit, text, time, uri-bytestring+  main-is: Main.hs+  hs-source-dirs: src/send-mail   ghc-options: -Wall -fno-warn-unused-do-bind -threaded

@@ -1,27 +0,0 @@--- module Executable where---- {{{ Imports-import           Imm-import           Imm.Database.JsonFile as Database-import           Imm.Hooks.Dummy as Hooks-import           Imm.HTTP.Simple as HTTP-import           Imm.Logger.Simple as Logger-import           Imm.XML.Conduit as XML--- }}}---main :: IO ()-main = do-  logger <- Logger.mkHandle <$> defaultLogger-  database <- Database.mkHandle <$> defaultDatabase-  httpClient <- HTTP.mkHandle <$> defaultManager--  imm logger database httpClient hooks xmlParser--xmlParser :: XML.Handle IO-xmlParser = XML.mkHandle defaultXmlParser--hooks :: Hooks.Handle IO-hooks = Hooks.mkHandle--

@@ -1,12 +1,9 @@ -- | Meta-module that reexports many Imm sub-modules.------ To get started, please consult "Imm.Boot". module Imm (module X) where -import           Imm.Boot     as X-import           Imm.Core     as X+import           Imm.Callback as X import           Imm.Database as X hiding(Handle) import           Imm.Feed     as X-import           Imm.Hooks    as X hiding(Handle) import           Imm.HTTP     as X hiding(Handle) import           Imm.Logger   as X hiding(Handle)+import           Imm.XML      as X hiding(Handle)

@@ -1,15 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-module Imm.Aeson where---- {{{ Imports-import           Data.Aeson--import           URI.ByteString--- }}}--parseJsonURI :: MonadPlus m => Value -> m URI-parseJsonURI (String s) = either (const mzero) return $ parseURI laxURIParserOptions $ encodeUtf8 s-parseJsonURI _          = mzero--toJsonURI :: URI -> Value-toJsonURI = String . decodeUtf8 . serializeURIRef'

@@ -1,138 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE RankNTypes                #-}--- |--- = Getting started------ == Dynamic reconfiguration------ This program is dynamically configured using the <https://hackage.haskell.org/package/dyre dyre> library.------ You may want to check out <https://hackage.haskell.org/package/dyre/docs/Config-Dyre.html this documentation> to know how to get started.------ Your personal configuration is located at @$XDG_CONFIG_HOME\/imm\/imm.hs@.------ == Handle pattern------ The behavior of this program can be customized through the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).-module Imm.Boot (imm) where---- {{{ Imports-import qualified Imm.Core                 as Core-import           Imm.Database             as Database-import           Imm.Database.FeedTable   as Database-import           Imm.Dyre                 as Dyre-import           Imm.Feed-import           Imm.Hooks                as Hooks-import           Imm.HTTP                 as HTTP-import           Imm.Logger               as Logger-import           Imm.Options              as Options hiding (logLevel)-import           Imm.Pretty-import           Imm.XML                  as XML--import           Control.Exception.Safe-import           Data.Conduit.Combinators as Conduit (stdin)-import qualified Data.Map                 as Map-import           Data.Text                as Text hiding (length)-import           Data.Text.IO             as Text-import           Relude.Unsafe            (at)-import           System.IO                (hFlush)--- }}}---- | Main function, meant to be used in your personal configuration file.------ Here is an example:------ > import           Imm.Boot--- > import           Imm.Database.JsonFile as Database--- > import           Imm.Feed--- > import           Imm.Hooks.SendMail as Hooks--- > import           Imm.HTTP.Simple as HTTP--- > import           Imm.Logger.Simple as Logger--- > import           Imm.XML.Conduit as XML--- >--- > main :: IO ()--- > main = do--- >   logger     <- Logger.mkHandle <$> defaultLogger--- >   database   <- Database.mkHandle <$> defaultDatabase--- >   httpClient <- HTTP.mkHandle <$> defaultManager--- >--- >   imm logger database httpClient hooks xmlParser--- >--- > xmlParser :: XML.Handle IO--- > xmlParser = XML.mkHandle defaultXmlParser--- >--- > hooks :: Hooks.Handle IO--- > hooks = Hooks.mkHandle $ SendMailSettings smtpServer formatMail--- >--- > formatMail :: FormatMail--- > formatMail = FormatMail--- >   (\a b -> (defaultFormatFrom a b) { addressEmail = "user@host" } )--- >   defaultFormatSubject--- >   defaultFormatBody--- >   (\_ _ -> [Address Nothing "user@host"])--- >--- > smtpServer :: Feed -> FeedElement -> SMTPServer--- > smtpServer _ _ = SMTPServer--- >   (Just $ Authentication PLAIN "user" "password")--- >   (StartTls "smtp.host" defaultSettingsSMTPSTARTTLS)-imm :: Logger.Handle IO -> Database.Handle IO FeedTable -> HTTP.Handle IO -> Hooks.Handle IO -> XML.Handle IO -> IO ()-imm logger database httpClient hooks xmlParser = void $ do-  options <- parseOptions-  Dyre.wrap (optionDyreMode options) realMain (optionCommand options, optionLogLevel options, optionColorizeLogs options, logger, database, httpClient, hooks, xmlParser)--realMain :: (Command, LogLevel, Bool, Logger.Handle IO, Database.Handle IO FeedTable, HTTP.Handle IO, Hooks.Handle IO, XML.Handle IO) -> IO ()-realMain (command, logLevel, enableColors, logger, database, httpClient, hooks, xmlParser) = void $ do-  setColorizeLogs logger enableColors-  setLogLevel logger logLevel-  log logger Debug . ("Dynamic reconfiguration settings:" <++>) . indent 2 =<< Dyre.describePaths-  log logger Debug $ "Executing: " <> pretty command-  log logger Debug . ("Using database:" <++>) . indent 2 =<< _describeDatabase database--  handleAny (log logger Error . pretty . displayException) $ case command of-    Check t        -> Core.check logger database httpClient xmlParser =<< resolveTarget database ByPassConfirmation t-    Help           -> Text.putStrLn helpString-    Import         -> Core.importOPML logger database Conduit.stdin-    Read t         -> mapM_ (Database.markAsRead logger database) =<< resolveTarget database AskConfirmation t-    Run t          -> Core.run logger database httpClient hooks xmlParser =<< resolveTarget database ByPassConfirmation t-    Show t         -> Core.showFeed logger database =<< resolveTarget database ByPassConfirmation t-    ShowVersion    -> Core.printVersions-    Subscribe u c  -> Core.subscribe logger database u c-    Unread t       -> mapM_ (Database.markAsUnread logger database) =<< resolveTarget database AskConfirmation t-    Unsubscribe t  -> Database.deleteList logger database =<< resolveTarget database AskConfirmation t-    _              -> return ()--  Database.commit logger database-  flushLogs logger----- * Util--data SafeGuard = AskConfirmation | ByPassConfirmation-  deriving(Eq, Read, Show)--data InterruptedException = InterruptedException deriving(Eq, Read, Show)-instance Exception InterruptedException where-  displayException _ = "Process interrupted"--promptConfirm :: Text -> IO ()-promptConfirm s = do-  Text.putStr $ s <> " Confirm [Y/n] "-  hFlush stdout-  x <- Text.getLine-  unless (Text.null x || x == "Y") $ throwM InterruptedException---resolveTarget :: MonadIO m => MonadThrow m => Database.Handle m FeedTable -> SafeGuard -> Maybe Core.FeedRef -> m [FeedID]-resolveTarget database s Nothing = do-  result <- Map.keys <$> Database.fetchAll database-  when (s == AskConfirmation) $ liftIO $ promptConfirm $ "This will affect " <> show (length result) <> " feeds."-  return result-resolveTarget database _ (Just (ByUID i)) = do-  result <- fst . at (i-1) . Map.toList <$> Database.fetchAll database-  -- log logger Info $ "Target(s): " <> show (pretty result)-  return [result]-resolveTarget _ _ (Just (ByURI uri)) = return [FeedID uri]

@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+module Imm.Callback where++-- {{{ Imports+import           Imm.Feed++import           Data.Aeson+import           Data.Aeson.Types+import           Data.Text.Prettyprint.Doc+import           Dhall+-- }}}++-- | External program run for each feed element.+--+-- A `Message` is passed to this program through stdin, serialized in JSON.+data Callback = Callback+  { _executable :: FilePath+  , _arguments  :: [Text]+  } deriving (Eq, Generic, Ord, Read, Show)++instance Interpret Callback++instance Pretty Callback where+  pretty (Callback executable arguments) = pretty executable <+> sep (pretty <$> arguments)+++-- | All information passed to external programs about a new feed item, are stored in this structure.+data Message = Message Feed FeedElement deriving(Eq, Generic, Ord, Show)++instance ToJSON Message where+  toJSON (Message feed element) = object ["feed" .= renderFeed feed, "element" .= renderFeedElement element]++instance FromJSON Message where+  parseJSON = withObject "Message" $ \v -> Message+    <$> (v .: "feed" >>= (liftEither . parseFeed))+    <*> (v .: "element" >>= (liftEither . parseFeedElement))+    where liftEither :: Either e a -> Parser a+          liftEither = either (const mempty) return

@@ -1,174 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeFamilies          #-}-module Imm.Core (--- * Types-  FeedRef,--- * Actions-  printVersions,-  subscribe,-  showFeed,-  check,-  run,-  importOPML,-) where---- {{{ Imports-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 qualified Imm.HTTP                as HTTP-import           Imm.Logger              as Logger-import           Imm.Pretty-import           Imm.XML                 as XML--import           Control.Exception.Safe-import           Control.Monad.Time-import           Data.Conduit-import qualified Data.Map                as Map-import           Data.Set                (Set)-import qualified Data.Set                as Set-import           Data.Tree-import           Data.Version-import qualified Paths_imm               as Package-import           Refined-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           URI.ByteString--- }}}---printVersions :: (MonadBase IO m) => m ()-printVersions = liftBase $ do-  putStrLn $ "imm-" <> showVersion Package.version-  putStrLn $ "compiled by " <> compilerName <> "-" <> showVersion compilerVersion---- | Print database status for given feed(s)-showFeed :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> [FeedID] -> m ()-showFeed logger database feedIDs = do-  entries <- Database.fetchList database feedIDs-  flushLogs logger-  when (null entries) $ log logger Warning "No subscription"-  forM_ (zip [1..] $ Map.elems entries) $ \(i, entry) ->-    log logger Info $ pretty (i :: Int) <+> prettyDatabaseEntry entry---- | Register the given feed URI in database-subscribe :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> URI -> Set Text -> m ()-subscribe logger database uri = Database.register logger database (FeedID uri)---- | Check for unread elements without processing them-check :: (MonadAsync m, MonadCatch m)-      => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> XML.Handle m -> [FeedID] -> m ()-check logger database httpClient xmlParser feedIDs = do-  progress <- liftBase $ newTVarIO 0--  results <- Stream.toList $ wAsyncly $ do-    feedID <- Stream.fromFoldable feedIDs-    result <- lift $ tryAny $ checkOne logger database httpClient xmlParser feedID-    let logResult = either (red . pretty . displayException) (\n -> green (pretty n) <+> "new element(s)") result-    n <- liftBase $ atomically $ do-      modifyTVar' (progress :: TVar Int) (+ 1)-      readTVar progress-    lift $ log logger Info $ brackets (fill width (bold $ cyan $ pretty n) <+> "/" <+> pretty total) <+> "Checked" <+> magenta (pretty feedID) <+> "=>" <+> logResult-    return result--  flushLogs logger--  let (failures, successes) = partitionEithers $ zipWith (\a -> bimap (a,) (a,)) feedIDs results-  unless (null failures) $ log logger Error $ bold (pretty $ length failures) <+> "feeds in error"-  log logger Info $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall"--  where width = length (show total :: String)-        total = length feedIDs--checkOne :: (MonadBase IO m, MonadCatch m)-         => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> XML.Handle m -> FeedID -> m Int-checkOne logger database httpClient xmlParser feedID = do-  feed <- getFeed logger httpClient xmlParser feedID-  case feed of-    Atom _ -> log logger Debug $ "Parsed Atom feed: " <> pretty feedID-    Rss _  -> log logger Debug $ "Parsed RSS feed: " <> pretty feedID--  let dates = mapMaybe getDate $ getElements feed--  log logger Debug $ vsep $ map prettyElement $ getElements feed-  status <- Database.getStatus database feedID--  return $ length $ filter (unread status) dates-  where unread (LastUpdate t1) t2 = t2 > t1-        unread _ _                = True---run :: (MonadTime m, MonadAsync m, MonadCatch m)-    => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> Hooks.Handle m -> XML.Handle m -> [FeedID] -> m ()-run logger database httpClient hooks xmlParser feedIDs = do-  progress <- liftBase $ newTVarIO 0--  results <- Stream.toList $ wAsyncly $ do-    feedID <- Stream.fromFoldable feedIDs-    result <- lift $ tryAny $ runOne logger database httpClient hooks xmlParser feedID-    let logResult = either (red . pretty . displayException) (\n -> green (pretty n) <+> "new element(s)") result-    n <- liftBase $ atomically $ do-      modifyTVar' progress (+ 1)-      readTVar progress :: STM Int-    lift $ log logger Info $ brackets (fill width (bold $ cyan $ pretty n) <+> "/" <+> pretty total) <+> "Processed" <+> magenta (pretty feedID) <+> "=>" <+> logResult-    return $ bimap (feedID,) (feedID,) result--  flushLogs logger--  let (failures, successes) = partitionEithers results--  unless (null failures) $ log logger Error $ bold (pretty $ length failures) <+> "feeds in error"-  log logger Info $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall"--  where width = length (show total :: String)-        total = length feedIDs--runOne :: (MonadTime m, MonadCatch m)-       => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> Hooks.Handle m -> XML.Handle m -> FeedID -> m Int-runOne logger database httpClient hooks xmlParser feedID = do-  feed <- getFeed logger httpClient xmlParser feedID-  unreadElements <- filterM (fmap not . isRead database feedID) $ getElements feed--  forM_ unreadElements $ \element -> do-    onNewElement logger hooks feed element-    mapM_ (Database.addReadHash logger database feedID) $ getHashes element--  Database.markAsRead logger database feedID-  return $ length unreadElements---isRead :: MonadCatch m => Database.Handle m FeedTable -> FeedID -> FeedElement -> m Bool-isRead database feedID element = do-  DatabaseEntry _ _ readHashes lastCheck <- Database.fetch database feedID-  let matchHash = not $ Set.null $ Set.fromList (getHashes element) `Set.intersection` readHashes-      matchDate = case (lastCheck, getDate element) of-        (Nothing, _)     -> False-        (_, Nothing)     -> False-        (Just a, Just b) -> a > b-  return $ matchHash || matchDate---- | 'subscribe' to all feeds described by the OPML document provided in input-importOPML :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> ConduitT () ByteString m () -> m ()-importOPML logger database input = do-  opml <- runConduit $ input .| XML.parseBytes def .| force "Invalid OPML" parseOpml-  forM_ (opmlOutlines opml) $ importOPML' logger database mempty--importOPML' :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> Set Text -> Tree OpmlOutline -> m ()-importOPML' logger database _ (Node (OpmlOutlineGeneric b _) sub) = mapM_ (importOPML' logger database (Set.singleton . unrefine $ OPML.text b)) sub-importOPML' logger database c (Node (OpmlOutlineSubscription _ s) _) = subscribe logger database (xmlUri s) c-importOPML' _ _ _ _ = return ()---getFeed :: MonadCatch m => Logger.Handle m -> HTTP.Handle m -> XML.Handle m -> FeedID -> m Feed-getFeed logger httpClient xmlParser (FeedID uri) = HTTP.get logger httpClient uri >>= parseXml xmlParser uri

@@ -32,7 +32,7 @@   rep :: t  data Handle m t = Handle-  { _describeDatabase :: forall a . m (Doc a)+  { _describeDatabase :: m (Doc AnsiStyle)   , _fetchList        :: [Key t] -> m (Map (Key t) (Entry t))   , _fetchAll         :: m (Map (Key t) (Entry t))   , _update           :: Key t -> (Entry t -> Entry t) -> m ()@@ -41,6 +41,19 @@   , _purge            :: m ()   , _commit           :: m ()   }++readOnly :: Monad m => Pretty (Key t) => Logger.Handle m -> Handle m t -> Handle m t+readOnly logger handle = handle+  { _describeDatabase = do+      output <- _describeDatabase handle+      return $ output <+> yellow (brackets "read only")+  , _update = \key _ -> log logger Debug $ "Not updating database for key " <> pretty key+  , _insertList = \list -> log logger Debug $ "Not inserting " <> yellow (pretty $ length list) <> " entries"+  , _deleteList = \list -> log logger Debug $ "Not deleting " <> yellow (pretty $ length list) <> " entries"+  , _purge = log logger Debug "Not purging database"+  , _commit = log logger Debug "Not committing database"+  }+   data DatabaseException t

@@ -1,21 +1,31 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeApplications  #-} {-# LANGUAGE TypeFamilies      #-} -- | Feed table definitions. This is a specialization of "Imm.Database". module Imm.Database.FeedTable where  -- {{{ Imports-import           Imm.Aeson import           Imm.Database           as Database+import           Imm.Feed import           Imm.Logger             as Logger import           Imm.Pretty  import           Control.Exception.Safe import           Control.Monad.Time import           Data.Aeson-import qualified Data.Set               as Set (insert)+import           Data.Aeson.Types+import           Data.Hashable+import           Data.Map.Lazy          (mapKeys)+import qualified Data.Map.Lazy          as Map (insert, filter, keys)+import qualified Data.Set               as Set (intersection) import           Data.Time import           URI.ByteString++-- To be removed soon+import           Text.Atom.Types+import           Text.RSS.Types -- }}}  -- * Types@@ -28,50 +38,112 @@ prettyFeedID (FeedID uri) = prettyURI uri  instance FromJSON FeedID where-  parseJSON = fmap FeedID . parseJsonURI+  parseJSON value = FeedID . _unwrapURI <$> parseJSON value  instance ToJSON FeedID where-  toJSON (FeedID uri) = toJsonURI uri+  toJSON (FeedID uri) = toJSON $ JsonURI uri  instance Pretty FeedID where   pretty (FeedID uri) = prettyURI uri  +-- DEPRECATED+getHashes :: FeedElement -> [Int]+getHashes (RssElement item) = map (hash @String . show . prettyGuid) (maybeToList $ itemGuid item)+  <> map (hash @String . show . withRssURI prettyURI) (maybeToList $ itemLink item)+  <> [hash $ itemTitle item]+  <> [hash $ itemDescription item]+getHashes (AtomElement entry) = [hash $ entryId entry, (hash :: String -> Int) $ show $ prettyAtomText $ entryTitle entry]+++-- | Newtype wrapper to provide 'FromJSON' and 'ToJSON' instances for 'URI'+newtype JsonURI = JsonURI { _unwrapURI :: URI }++instance FromJSON JsonURI where+  parseJSON = withText "URI" $ \s ->+    either (const $ fail "Invalid URI") (return . JsonURI) $ parseURI laxURIParserOptions $ encodeUtf8 s++instance ToJSON JsonURI where+  toJSON = String . decodeUtf8 . serializeURIRef' . _unwrapURI+++-- | Newtype wrapper to provide `FromJSON` and `ToJSON` instances for 'FeedElement'+newtype JsonElement = JsonElement { unwrapElement :: FeedElement } deriving(Eq, Ord)++instance FromJSON JsonElement where+  parseJSON = withText "Feed element" $ \t -> parseFeedElement t & liftEither <&> JsonElement+    where liftEither :: Either e a -> Parser a+          liftEither = either (const mempty) return++instance FromJSONKey JsonElement++instance ToJSON JsonElement where+  toJSON (JsonElement element) = String $ renderFeedElement element++instance ToJSONKey JsonElement++ data DatabaseEntry = DatabaseEntry-  { entryURI        :: URI-  , entryTags       :: Set Text-  , entryReadHashes :: Set Int-  , entryLastCheck  :: Maybe UTCTime+  { entryURI         :: URI+  , entryTags        :: Set Text+  , entryReadHashes  :: Set Int+  , entryFeed        :: Maybe Feed+  , entryItems       :: Map FeedElement Bool+  , entryLastUpdate  :: Maybe UTCTime   } deriving(Eq, Show) -prettyDatabaseEntry :: DatabaseEntry -> Doc AnsiStyle-prettyDatabaseEntry entry = magenta feedID+prettyShortDatabaseEntry :: DatabaseEntry -> Doc AnsiStyle+prettyShortDatabaseEntry DatabaseEntry{..} = magenta feedID   <++> indent 3 tags-  <++> indent 3 ("Last checked:" <+> lastCheck)+  <++> indent 3 ("Last update:" <+> lastUpdate)+  <++> indent 3 (yellow (pretty totalItems) <+> "items," <+> yellow (pretty totalUnprocessedItems) <+> "unprocessed") -  where feedID = prettyURI $ entryURI entry-        tags = sep $ map ((<>) "#" . pretty) $ toList $ entryTags entry-        lastCheck = format $ entryLastCheck entry-        format = maybe "never" (fromString . formatTime defaultTimeLocale "%F %R")+  where feedID = prettyURI entryURI+        tags = sep $ map ((<>) "#" . pretty) $ toList entryTags+        lastUpdate = maybe "never" prettyTime entryLastUpdate+        totalItems = length entryItems+        totalUnprocessedItems = length $ Map.filter not entryItems +prettyDatabaseEntry :: DatabaseEntry -> Doc AnsiStyle+prettyDatabaseEntry DatabaseEntry{..} = magenta feedID+  <++> tags+  <++> ("Last update:" <+> lastUpdate)+  <++> (yellow (pretty $ length $ Map.filter id entryItems) <+> "processed items")+  <++> indent 3 (vsep $ map displayItem $ Map.keys $ Map.filter id entryItems)+  <++> (yellow (pretty $ length $ Map.filter not entryItems) <+> "unprocessed items")+  <++> indent 3 (vsep $ map displayItem $ Map.keys $ Map.filter not entryItems)+  where feedID = prettyURI entryURI+        tags = sep $ map ((<>) "#" . pretty) $ toList entryTags+        lastUpdate = maybe "never" prettyTime entryLastUpdate+        displayItem item = maybe "<unknown>" prettyTime (getDate item) <+> pretty (getTitle item)+ instance FromJSON DatabaseEntry where-  parseJSON (Object v) = DatabaseEntry <$> (parseJsonURI =<< v .: "uri") <*> v .: "tags" <*> v.: "readHashes" <*> v .: "lastCheck"+  parseJSON (Object v) = DatabaseEntry+    <$> (_unwrapURI <$> (v .: "uri"))+    <*> v .: "tags"+    <*> (v .: "readHashes" <|> pure mempty)+    <*> ((v .:? "feed") >>= maybe (pure Nothing) (fmap Just . liftEither . parseFeed))+    <*> (v .:? "items" >>= maybe (pure mempty) (return . mapKeys unwrapElement))+    <*> (v .: "lastUpdate" <|> v .: "lastCheck")+    where liftEither :: Either e a -> Parser a+          liftEither = either (const mempty) return+   parseJSON _          = mzero  instance ToJSON DatabaseEntry where-  toJSON entry = object-    [ "uri"        .= toJsonURI (entryURI entry)-    , "tags"       .= entryTags entry-    , "readHashes" .= entryReadHashes entry-    , "lastCheck"  .= entryLastCheck entry-    ]+  toJSON DatabaseEntry{..} = object $+    [ "uri"        .= JsonURI entryURI+    , "tags"       .= entryTags+    , "items"      .= mapKeys JsonElement entryItems+    , "lastUpdate"  .= entryLastUpdate+    ] <> maybeToList (fmap (("feed" .=) . renderFeed) entryFeed)+      <> if null entryReadHashes then mempty else ["readHashes" .= entryReadHashes]  newDatabaseEntry :: FeedID -> Set Text -> DatabaseEntry-newDatabaseEntry (FeedID uri) tags = DatabaseEntry uri tags mempty Nothing+newDatabaseEntry (FeedID uri) tags = DatabaseEntry uri tags mempty mzero mempty Nothing  -- | Singleton type to represent feeds table-data FeedTable = FeedTable-  deriving(Show)+data FeedTable = FeedTable deriving(Eq, Ord, Read, Show)  instance Pretty FeedTable where   pretty _ = "Feeds table"@@ -103,25 +175,36 @@ getStatus :: MonadCatch m => Database.Handle m FeedTable -> FeedID -> m FeedStatus getStatus database feedID = handleAny (\_ -> return Unknown) $ do   result <- fmap Just (fetch database feedID) `catchAny` (\_ -> return Nothing)-  return $ maybe New LastUpdate $ entryLastCheck =<< result--addReadHash :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> Int -> m ()-addReadHash logger database feedID hash = do-  log logger Debug $ "Adding read hash:" <+> pretty hash <> "..."-  update database feedID f-  where f a = a { entryReadHashes = Set.insert hash $ entryReadHashes a }+  return $ maybe New LastUpdate $ entryLastUpdate =<< result --- | Set the last check time to now-markAsRead :: (MonadTime m, MonadThrow m)-           => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m ()-markAsRead logger database feedID = do-  log logger Debug $ "Marking feed as read:" <+> pretty feedID <> "..."+markAsProcessed :: MonadThrow m => MonadTime m+                => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> FeedElement -> m ()+markAsProcessed logger database feedID element = do+  log logger Debug $ "Marking as processed:" <+> pretty (PrettyKey element) <> "..."   utcTime <- currentTime-  update database feedID (f utcTime)-  where f time a = a { entryLastCheck = Just time }+  update database feedID $ \entry -> entry+    { entryItems = Map.insert element True $ entryItems entry+    , entryLastUpdate = Just utcTime+    } --- | Unset feed's last update and remove all read hashes-markAsUnread :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m ()-markAsUnread logger database feedID = do-  log logger Info $ "Marking feed as unread:" <+> prettyFeedID feedID <> "..."-  update database feedID $ \a -> a { entryReadHashes = mempty, entryLastCheck = Nothing }++markAsUnprocessed :: MonadThrow m+                  => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m ()+markAsUnprocessed logger database feedID = do+  log logger Debug $ "Marking as unprocessed:" <+> pretty feedID <> "..."+  update database feedID $ \entry -> entry+    { entryItems = False <$ entryItems entry+    , entryLastUpdate = Nothing+    , entryReadHashes = mempty+    }++isRead :: MonadCatch m => Database.Handle m FeedTable -> FeedID -> FeedElement -> m Bool+isRead database feedID element = do+  DatabaseEntry _ _ readHashes _ items lastUpdate <- Database.fetch database feedID+  let matchHash = not $ null $ fromList (getHashes element) `Set.intersection` readHashes+      matchDate = case (lastUpdate, getDate element) of+        (Nothing, _)     -> False+        (_, Nothing)     -> False+        (Just a, Just b) -> a > b+      matchKey = lookup element items & fromMaybe False+  return $ matchHash || matchDate || matchKey

@@ -1,122 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedLists       #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE UndecidableInstances  #-}--- | Implementation of "Imm.Database" based on a JSON file.-module Imm.Database.JsonFile-  ( JsonFileDatabase-  , mkJsonFileDatabase-  , defaultDatabase-  , mkHandle-  , JsonException(..)-  , module Imm.Database.FeedTable-  ) where---- {{{ Imports-import           Imm.Database                hiding (commit, delete, insert,-                                              purge, update)-import           Imm.Database.FeedTable-import           Imm.Error-import           Imm.Pretty--import           Control.Concurrent.STM.TVar (swapTVar)-import           Data.Aeson-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              hiding (withFile)-import           System.Directory-import           System.FilePath--- }}}--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: " <+> 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 (TVar (JsonFileDatabase t))-defaultDatabase = do-  databaseFile <- getXdgDirectory XdgConfig "imm/feeds.json"-  newTVarIO $ mkJsonFileDatabase databaseFile---data JsonException = UnableDecode-  deriving(Eq, Show)--instance Exception JsonException where-  displayException _ = "Unable to parse JSON"---mkHandle :: (Table t, FromJSON (Key t), FromJSON (Entry t), ToJSON (Key t), ToJSON (Entry t), MonadIO m, MonadMask m)-         => TVar (JsonFileDatabase t) -> Handle m t-mkHandle tvar = Handle-  { _describeDatabase = pretty <$> readTVarIO tvar-  , _fetchList = \keys -> loadInCache tvar >> (Map.filterWithKey (\uri _ -> Set.member uri $ Set.fromList keys) <$> getCache tvar)-  , _fetchAll = loadInCache tvar >> getCache tvar-  , _update = \key f -> loadInCache tvar >> atomically (modifyTVar' tvar $ updateInCache key f)-  , _insertList = \list -> loadInCache tvar >> atomically (modifyTVar' tvar $ insertInCache list)-  , _deleteList = \list -> loadInCache tvar >> atomically (modifyTVar' tvar $ deleteInCache list)-  , _purge = loadInCache tvar >> atomically (modifyTVar' tvar purgeInCache)-  , _commit = commit tvar-  }---- * Low-level implementation--loadInCache :: (Table t, FromJSON (Key t), FromJSON (Entry t), MonadIO m, MonadMask m) => TVar (JsonFileDatabase t) -> m ()-loadInCache tvar = do-  JsonFileDatabase file _ status <- readTVarIO tvar-  when (status == Empty) $ do-    database <- loadFromDisk file-    atomically $ do-      JsonFileDatabase _ _ status' <- readTVar tvar-      when (status' == Empty) $ writeTVar tvar database--loadFromDisk :: (Table t, FromJSON (Key t), FromJSON (Entry t), MonadIO m, MonadMask m) => FilePath -> m (JsonFileDatabase t)-loadFromDisk file = do-  liftIO $ createDirectoryIfMissing True $ takeDirectory file-  fileContent <- withBinaryFile file ReadWriteMode (toLazy_ . hGetContents)-  cache <- (`failWith` UnableDecode) $ fmap Map.fromList $ decode $ fromEmpty "[]" fileContent-  return $ JsonFileDatabase file cache Clean-  where fromEmpty x "" = x-        fromEmpty _ y  = y--getCache :: MonadIO m => TVar (JsonFileDatabase t) -> m (Map (Key t) (Entry t))-getCache tvar = do-  JsonFileDatabase _ cache _ <- readTVarIO tvar-  return cache---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--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--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--purgeInCache :: Table t => JsonFileDatabase t -> JsonFileDatabase t-purgeInCache (JsonFileDatabase file _ _) = JsonFileDatabase file mempty Dirty--commit :: (ToJSON (Key t), ToJSON (Entry t), MonadIO m)-       => TVar (JsonFileDatabase t) -> m ()-commit tvar = do-  JsonFileDatabase file cache status <- atomically $ do-    database@(JsonFileDatabase file cache status) <- readTVar tvar-    when (status == Dirty) $ void $ swapTVar tvar $ JsonFileDatabase file cache Clean-    return database--  when (status == Dirty) $ liftIO $ withFile file WriteMode $ \h -> hPut h $ encode $ Map.toList cache

@@ -1,71 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE TypeFamilies      #-}-module Imm.Dyre-  ( Mode(..)-  , defaultMode-  , describePaths-  , wrap-  , recompile-  ) where---- {{{ Imports-import           Imm.Pretty--import           Config.Dyre-import           Config.Dyre.Compile-import           Config.Dyre.Paths--import           System.IO--- }}}---- | How dynamic reconfiguration process should behave.-data Mode = Normal | Vanilla | ForceReconfiguration | IgnoreReconfiguration-  deriving(Eq, Show)---- | Default mode is 'Normal', that is: use custom configuration file and recompile if change detected.-defaultMode :: Mode-defaultMode = Normal----- | Describe the paths used for dynamic reconfiguration-describePaths :: (MonadIO m) => m (Doc AnsiStyle)-describePaths = io $ do-  (a, b, c, d, e) <- getPaths baseParameters-  return $ vsep-    [ "Current binary" <+> equals <+> magenta (fromString a)-    , "Custom binary" <+> equals <+> magenta (fromString b)-    , "Config file" <+> equals <+> magenta (fromString c)-    , "Cache directory" <+> equals <+> magenta (fromString d)-    , "Lib directory" <+> equals <+> magenta (fromString e)-    ]---- | Dynamic reconfiguration settings-parameters :: Mode -> (a -> IO ()) -> Params (Either String a)-parameters mode main = baseParameters-    { configCheck = mode /= Vanilla-    , realMain = main'-    }-  where-    main' (Left e)  = hPutStrLn stderr e-    main' (Right x) = main x--baseParameters :: Params (Either String a)-baseParameters = defaultParams-  { projectName             = "imm"-  , showError               = const Left-  , ghcOpts                 = ["-threaded"]-  , statusOut               = hPutStrLn stderr-  , includeCurrentDirectory = False-  }--wrap :: Mode -> (a -> IO ()) -> a -> IO ()-wrap mode result args = wrapMain (parameters mode result) (Right args)----- | Launch a recompilation of the configuration file-recompile :: (MonadIO m) => m (Maybe Text)-recompile = io $ do-  customCompile baseParameters-  fmap fromString <$> getErrorString baseParameters

@@ -1,15 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Imm.Error (module Imm.Error) where---- {{{ Imports-import           Control.Exception.Safe--- }}}--liftE :: (MonadThrow m, Exception e) => Either e a -> m a-liftE (Left e)  = throwM e-liftE (Right a) = return a---- | Wrap a 'Maybe' value in 'MonadError'-failWith, (<!>) :: (MonadThrow m, Exception e) => Maybe a -> e -> m a-failWith x e = maybe (throwM e) return x-(<!>) = failWith

@@ -1,21 +1,35 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TypeOperators             #-} -- | Helpers to manipulate feeds module Imm.Feed where  -- {{{ Imports import           Imm.Pretty -import           Data.Hashable+import           Conduit+import           Control.Exception.Safe+import           Data.Binary.Builder import           Data.Text                      as Text (null) import           Data.Time+import           Data.Type.Equality import           Lens.Micro+import           Text.Atom.Conduit.Parse+import           Text.Atom.Conduit.Render import           Text.Atom.Types+import           Text.RSS.Conduit.Parse+import           Text.RSS.Conduit.Render import           Text.RSS.Extensions.Content import           Text.RSS.Extensions.DublinCore import           Text.RSS.Lens import           Text.RSS.Types+import           Text.RSS1.Conduit.Parse+import           Text.XML.Stream.Parse          as XML hiding (content)+import           Text.XML.Stream.Render         hiding (content) import           URI.ByteString -- }}} @@ -23,19 +37,81 @@  -- | Feed reference: either its URI, or its UID from database data FeedRef = ByUID Int | ByURI URI-  deriving(Eq, Show)+  deriving(Eq, Ord, Show)  instance Pretty FeedRef where   pretty (ByUID n) = "feed" <+> pretty n   pretty (ByURI u) = prettyURI u  data Feed = Rss (RssDocument '[ContentModule, DublinCoreModule]) | Atom AtomFeed-  deriving(Eq, Show)+  deriving(Eq, Ord, Show)  data FeedElement = RssElement (RssItem '[ContentModule, DublinCoreModule]) | AtomElement AtomEntry-  deriving(Eq, Show)+  deriving(Show) +instance Pretty (PrettyKey FeedElement) where+  pretty (PrettyKey element) = "element" <+> pretty (getTitle element) +instance Ord FeedElement where+  compare element1 element2 = compare (getId element1) (getId element2)+    <> compare (getLink element1) (getLink element2)+    <> compare (getTitle element1) (getTitle element2)+    <> compare (getContent element1) (getContent element2)++instance Eq FeedElement where+  element1 == element2 = compare element1 element2 == EQ+++data FeedURI = forall a . FeedURI (URIRef a)++deriving instance Show FeedURI+instance Eq FeedURI where+  (FeedURI a) == (FeedURI b) = case sameURIType a b of+    Just Refl -> a == b+    _         -> False++instance Ord FeedURI where+  compare (FeedURI a) (FeedURI b) = case (a, b) of+    (URI{}, URI{})                 -> compare a b+    (RelativeRef{}, RelativeRef{}) -> compare a b+    (URI{}, RelativeRef{})         -> LT+    (RelativeRef{}, URI{})         -> GT++sameURIType :: URIRef a1 -> URIRef a2 -> Maybe (URIRef a1 :~: URIRef a2)+sameURIType a b = case (a, b) of+  (URI{}, URI{})                 -> Just Refl+  (RelativeRef{}, RelativeRef{}) -> Just Refl+  _                              -> Nothing+++withFeedURI :: (forall a . URIRef a -> b) -> FeedURI -> b+withFeedURI f (FeedURI a) = f a+++-- * Generic parsers/renderers++renderFeed :: Feed -> Text+renderFeed (Rss rss) = decodeUtf8 $ toLazyByteString $ runConduitPure $ renderRssDocument rss .| renderBuilder def .| foldC+renderFeed (Atom atom) = decodeUtf8 $ toLazyByteString $ runConduitPure $ renderAtomFeed atom .| renderBuilder def .| foldC++renderFeedElement :: FeedElement -> Text+renderFeedElement (RssElement item) = decodeUtf8 $ toLazyByteString $ runConduitPure $ renderRssItem item .| renderBuilder def .| foldC+renderFeedElement (AtomElement entry) = decodeUtf8 $ toLazyByteString $ runConduitPure $ renderAtomEntry entry .| renderBuilder def .| foldC++parseFeed :: MonadCatch m => Text -> m Feed+parseFeed text = runConduit $ parseLBS def (encodeUtf8 text) .| XML.force "Invalid feed" ((fmap Atom <$> atomFeed) `orE` (fmap Rss <$> rssDocument) `orE` (fmap Rss <$> rss1Document))++parseFeedElement :: MonadCatch m => Text -> m FeedElement+parseFeedElement text = runConduit $ parseLBS def (encodeUtf8 text) .| XML.force "Invalid feed element" ((fmap AtomElement <$> atomEntry) `orE` (fmap RssElement <$> rssItem) `orE` (fmap RssElement <$> rss1Item))+++-- * Generic mutators++removeElements :: Feed -> Feed+removeElements (Rss rss)   = Rss $ rss { channelItems = mempty }+removeElements (Atom atom) = Atom $ atom { feedEntries = mempty }++ -- * Generic getters  getFeedTitle :: Feed -> Text@@ -61,14 +137,16 @@   content = show . prettyAtomContent <$> entryContent entry   summary = show . prettyAtomText <$> entrySummary entry --getHashes :: FeedElement -> [Int]-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]-getHashes (AtomElement entry) = [hash $ entryId entry, (hash :: String -> Int) $ show $ prettyAtomText $ entryTitle entry]+getLink :: FeedElement -> Maybe FeedURI+getLink (RssElement item) = itemLink item <&> withRssURI FeedURI+getLink (AtomElement entry) = (alternateLink <|> defaultLink) <&> linkHref <&> withAtomURI FeedURI where+  links = entryLinks entry+  alternateLink = links & filter (\link -> linkRel link == "alternate") & nonEmpty <&> head+  defaultLink = links & filter (Text.null . linkRel) & nonEmpty <&> head +getId :: FeedElement -> Text+getId (RssElement item)   = itemGuid item <&> prettyGuid & maybe mempty show+getId (AtomElement entry) = entryId entry  -- * Misc 

@@ -1,46 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--- | Implementation of "Imm.HTTP" based on "Network.HTTP.Client".-module Imm.HTTP.Simple (mkHandle, defaultManager, module Reexport) where---- {{{ Imports-import           Imm.HTTP-import           Imm.Pretty--import           Control.Exception.Safe-import           Data.CaseInsensitive-import           Network.Connection         as Reexport-import           Network.HTTP.Client        as Reexport-import           Network.HTTP.Client.TLS    as Reexport-import           URI.ByteString--- }}}--mkHandle :: MonadBase IO m => Manager -> Handle m-mkHandle manager = Handle-  { httpGet = liftBase . httpGet' manager-  }---- | Default manager uses TLS and no proxy-defaultManager :: IO Manager-defaultManager = newManager $ mkManagerSettings (TLSSettingsSimple False False False) Nothing----- | Perform an HTTP GET request and return the response body-httpGet' :: Manager -> URI -> IO LByteString-httpGet' manager uri = do-  request <- makeRequest uri-  responseBody <$> httpLbs request manager-    -- codec'   <- reader $ view (config.codec)-    -- return $ response $=+ decode codec'--parseRequest' :: MonadThrow m => URI -> m Request-parseRequest' = parseRequest . show . prettyURI---- | Build an HTTP request for given URI-makeRequest :: URI -> IO Request-makeRequest uri = do-  req <- parseRequest' uri-  return $ req { requestHeaders = [-    (mk "User-Agent", "Mozilla/4.0"),-    (mk "Accept", "*/*")]}

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

@@ -1,20 +0,0 @@-{-# 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 (module Imm.Hooks.Dummy, module Imm.Hooks) where---- {{{ Imports-import           Imm.Hooks--import           Control.Exception-import           Control.Exception.Safe--- }}}--data DummyHooks = DummyHooks--mkHandle :: MonadThrow m => Handle m-mkHandle = Handle-  { processNewElement = \_ _ -> throwM $ NoMethodError "Please define a valid Imm.Hooks.processNewElement function"-  }

@@ -1,144 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}--- | 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:------ > sendmail :: SendMailSettings--- > sendmail = SendMailSettings smtpServer formatMail--- >--- > formatMail :: FormatMail--- > formatMail = FormatMail--- >   (\a b -> (defaultFormatFrom a b) { addressEmail = "user@host" } )--- >   defaultFormatSubject--- >   defaultFormatBody--- >   (\_ _ -> [Address Nothing "user@host"])--- >--- > smtpServer :: Feed -> FeedElement -> SMTPServer--- > smtpServer _ _ = SMTPServer--- >   (Just $ Authentication PLAIN "user" "password")--- >   (StartTls "smtp.server" defaultSettingsSMTPSTARTTLS)----module Imm.Hooks.SendMail (module Imm.Hooks.SendMail, module Imm.Hooks, module Reexport) where---- {{{ Imports-import           Imm.Feed-import           Imm.Hooks-import           Imm.Pretty--import           Data.Text                   as Text (intercalate)-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           Refined-import           Text.Atom.Types-import           Text.RSS.Types--- }}}---- * Types--type Username = String-type Password = String-type ServerName = String---- | How to connect to the SMTP server-data ConnectionSettings = Plain ServerName PortNumber | Ssl ServerName Settings | StartTls ServerName Settings-  deriving(Eq, Show)---- | How to authenticate to the SMTP server-data Authentication = Authentication AuthType Username Password-  deriving(Eq, Show)--data SMTPServer = SMTPServer (Maybe Authentication) ConnectionSettings-  deriving (Eq, Show)---- | How to format outgoing mails from feed elements-data FormatMail = FormatMail-  { formatFrom    :: Feed -> FeedElement -> Address    -- ^ How to write the From: header of feed mails-  , formatSubject :: Feed -> FeedElement -> Text       -- ^ How to write the Subject: header of feed mails-  , formatBody    :: Feed -> FeedElement -> Text       -- ^ How to write the body of feed mails (sic!)-  , formatTo      :: Feed -> FeedElement -> [Address]  -- ^ How to write the To: header of feed mails-  }--data SendMailSettings = SendMailSettings (Feed -> FeedElement -> SMTPServer) FormatMail--mkHandle :: MonadBase IO m => SendMailSettings -> Handle m-mkHandle (SendMailSettings connectionSettings formatMail) = Handle-  { processNewElement = \feed element -> do-      timezone <- liftBase getCurrentTimeZone-      currentTime <- liftBase getCurrentTime-      let mail = buildMail formatMail currentTime timezone feed element-      liftBase $ withSMTPConnection (connectionSettings feed element) $ sendMimeMail2 mail-  }----- * Default behavior---- | Fill 'addressName' with the feed title and, if available, the authors' names.------ This function leaves 'addressEmail' empty. You are expected to fill it adequately, because many SMTP servers enforce constraints on the From: email.-defaultFormatFrom :: Feed -> FeedElement -> Address-defaultFormatFrom (Rss doc) (RssElement item) = Address (Just $ channelTitle doc <> " (" <> itemAuthor item <> ")") ""-defaultFormatFrom (Atom feed) (AtomElement entry) = Address (Just $ title <> " (" <> authors <> ")") ""-  where title = show . prettyAtomText $ feedTitle feed-        authors = Text.intercalate ", " $ map (unrefine . personName) $ entryAuthors entry <> feedAuthors feed-defaultFormatFrom _ _ = Address (Just "Unknown") ""---- | Fill mail subject with the element title-defaultFormatSubject :: Feed -> FeedElement -> Text-defaultFormatSubject _ = getTitle---- | Fill mail body with:------ - a list of links associated to the element--- - the element's content or description/summary-defaultFormatBody :: Feed -> FeedElement -> Text-defaultFormatBody _ (RssElement item) = "<p>" <> maybe "<no link>" (withRssURI (show . prettyURI)) (itemLink item) <> "</p><p>" <> itemDescription item <> "</p>"-defaultFormatBody _ (AtomElement entry) = "<p>" <> Text.intercalate "<br/>" links <> "</p><p>" <> fromMaybe "<empty>" (content <|> summary) <> "</p>"-  where links   = map (withAtomURI (show . prettyURI) . linkHref) $ entryLinks entry-        content = show . prettyAtomContent <$> entryContent entry-        summary = show . prettyAtomText <$> entrySummary entry----- * Low-level helpers--authenticate_ :: SMTPConnection -> Authentication -> IO Bool-authenticate_ connection (Authentication t u p) = do-  result <- authenticate t u p connection-  unless result $ putStrLn "Authentication failed"-  return result--withSMTPConnection :: SMTPServer -> (SMTPConnection -> IO a) -> IO a-withSMTPConnection (SMTPServer authentication (Plain server port)) f =-  doSMTPPort server port $ \connection -> do-    forM_ authentication (authenticate_ connection)-    f connection-withSMTPConnection (SMTPServer authentication (Ssl server settings)) f =-  doSMTPSSLWithSettings server settings $ \connection -> do-    forM_ authentication (authenticate_ connection)-    f connection-withSMTPConnection (SMTPServer authentication (StartTls server settings)) f =-  doSMTPSTARTTLSWithSettings server settings $ \connection -> do-    forM_ authentication (authenticate_ connection)-    f connection---- | Build mail from a given feed-buildMail :: FormatMail -> UTCTime -> TimeZone -> Feed -> FeedElement -> Mail-buildMail format currentTime timeZone feed element =-  let date = formatTime defaultTimeLocale "%a, %e %b %Y %T %z" $ utcToZonedTime timeZone $ fromMaybe currentTime $ getDate element-  in Mail-    { mailFrom = formatFrom format feed element-    , mailTo   = formatTo format feed element-    , mailCc   = []-    , mailBcc  = []-    , mailHeaders =-        [ ("Return-Path", "<imm@noreply>")-        , ("Date", fromString date)-        , ("Subject", formatSubject format feed element)-        , ("Content-disposition", "inline")-        ]-    , mailParts = [[htmlPart $ fromStrict $ formatBody format feed element]]-    }

@@ -1,123 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}--- | Implementation of "Imm.Hooks" that writes a file for each new RSS/Atom item.-module Imm.Hooks.WriteFile (module Imm.Hooks.WriteFile, module Imm.Hooks) where---- {{{ Imports-import           Imm.Feed-import           Imm.Hooks-import           Imm.Pretty--import           Data.ByteString.Builder-import           Data.ByteString.Streaming     (toStreamingByteString)-import qualified Data.Text as Text             (null, replace)-import           Data.Time-import           Streaming.With-import           System.Directory              (createDirectoryIfMissing)-import           System.FilePath-import           Text.Atom.Types-import           Text.Blaze.Html.Renderer.Utf8-import           Text.Blaze.Html5              (Html, docTypeHtml,-                                                preEscapedToHtml, (!))-import qualified Text.Blaze.Html5              as H-import qualified Text.Blaze.Html5.Attributes   as H (charset, href)-import           Text.RSS.Types-import           URI.ByteString--- }}}---- * Types---- | Where and what to write in a file-data FileInfo = FileInfo FilePath Builder--newtype WriteFileSettings = WriteFileSettings (Feed -> FeedElement -> FileInfo)--mkHandle :: MonadBase IO m => MonadIO m => MonadMask m => WriteFileSettings -> Handle m-mkHandle (WriteFileSettings f) = Handle-  { processNewElement = \feed element -> do-      let FileInfo path content = f feed element-      liftBase $ createDirectoryIfMissing True $ takeDirectory path-      writeBinaryFile path $ toStreamingByteString content-  }---- * Default behavior---- | Wrapper around 'defaultFilePath' and 'defaultFileContent'-defaultSettings :: FilePath            -- ^ Root directory for 'defaultFilePath'-                -> WriteFileSettings-defaultSettings root = WriteFileSettings $ \feed element -> FileInfo-  (defaultFilePath root feed element)-  (defaultFileContent feed element)---- | Generate a path @<root>/<feed title>/<element date>-<element title>.html@, where @<root>@ is the first argument-defaultFilePath :: FilePath -> Feed -> FeedElement -> FilePath-defaultFilePath root feed element = makeValid $ root </> toString title </> fileName <.> "html" where-  date = maybe "" (formatTime defaultTimeLocale "%F-") $ getDate element-  fileName = date <> toString (sanitize $ getTitle element)-  title = sanitize $ getFeedTitle feed-  sanitize = appEndo (mconcat [Endo $ Text.replace (toText [s]) "_" | s <- pathSeparators])-    >>> Text.replace "." "_"-    >>> Text.replace "?" "_"-    >>> Text.replace "!" "_"-    >>> Text.replace "#" "_"---- | Generate an HTML page, with a title, a header and an article that contains the feed element-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-  H.body $ do-    H.h1 $ convertText $ getFeedTitle feed-    H.article $ do-      H.header $ do-        defaultArticleTitle feed element-        defaultArticleAuthor feed element-        defaultArticleDate feed element-      defaultBody feed element----- * Low-level helpers--defaultArticleTitle :: Feed -> FeedElement -> Html-defaultArticleTitle _ element@(RssElement item) = H.h2 $ maybe id (\uri -> H.a ! H.href uri) link $ convertText $ getTitle element where-  link = withRssURI (convertDoc . prettyURI) <$> itemLink item-defaultArticleTitle _ element@(AtomElement _) = H.h2 $ convertText $ getTitle element--defaultArticleAuthor :: Feed -> FeedElement -> Html-defaultArticleAuthor _ (RssElement item) = unless (Text.null author) $ H.address $ "Published by " >> convertText author where-  author = itemAuthor item-defaultArticleAuthor _ (AtomElement entry) = H.address $ do-  "Published by "-  forM_ (entryAuthors entry) $ \author -> do-    convertDoc $ prettyPerson author-    ", "--defaultArticleDate :: Feed -> FeedElement -> Html-defaultArticleDate _ element = forM_ (getDate element) $ \date -> H.p $ " on " >> H.time (convertDoc $ prettyTime date)----- | Generate the HTML content for a given feed element-defaultBody :: Feed -> FeedElement -> Html-defaultBody _ element@(RssElement _) = H.p $ preEscapedToHtml $ getContent element-defaultBody _ element@(AtomElement entry) = do-  unless (null links) $ H.p $ do-    "Related links:"-    H.ul $ forM_ links $ \uri -> H.li (H.a ! withAtomURI href uri $ convertAtomURI uri)-  H.p $ preEscapedToHtml $ getContent element-  where links   = map linkHref $ entryLinks entry--href :: URIRef a -> H.Attribute-href = H.href . convertURI--convertAtomURI :: (IsString t) => AtomURI -> t-convertAtomURI = withAtomURI convertURI--convertURI :: (IsString t) => URIRef a -> t-convertURI = convertText . decodeUtf8 . serializeURIRef'--convertText :: (IsString t) => Text -> t-convertText = fromString . toString--convertDoc :: (IsString t) => Doc a -> t-convertDoc = show

@@ -1,46 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}--- | 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.Pretty--import           Data.Text.Prettyprint.Doc.Render.Terminal-import           System.Log.FastLogger                     as Reexport--- }}}--data LoggerSettings = LoggerSettings-  { _loggerSet      :: LoggerSet       -- ^ 'LoggerSet' used for 'Debug', 'Info' and 'Warning' logs-  , _errorLoggerSet :: LoggerSet       -- ^ 'LoggerSet' used for 'Error' logs-  , _logLevel       :: MVar LogLevel   -- ^ Discard logs that are strictly less serious than this level-  , _colorizeLogs   :: MVar Bool       -- ^ Enable log colorisation-  }----- | Default logger forwards error messages to stderr, and other messages to stdout.-defaultLogger :: IO LoggerSettings-defaultLogger = LoggerSettings-  <$> newStdoutLoggerSet defaultBufSize-  <*> newStderrLoggerSet defaultBufSize-  <*> newMVar Info-  <*> newMVar True---mkHandle :: MonadIO m => LoggerSettings -> Handle m-mkHandle settings = Handle-  { log = \l t -> do-      refLevel <- readMVar $ _logLevel settings-      handleColor <- (\c -> if c then id else unAnnotate) <$> readMVar (_colorizeLogs settings)-      let loggerSet = (if l == Error then _errorLoggerSet else _loggerSet) settings-      when (l >= refLevel) $ liftIO $ pushLogStrLn loggerSet $ toLogStr $ renderLazy $ layoutPretty defaultLayoutOptions $ handleColor t--  , getLogLevel = readMVar $ _logLevel settings-  , setLogLevel = void . swapMVar (_logLevel settings)-  , setColorizeLogs = void . swapMVar (_colorizeLogs settings)-  , flushLogs = liftIO $ do-      flushLogStr $ _loggerSet settings-      flushLogStr $ _errorLoggerSet settings-  }

@@ -1,150 +0,0 @@-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications   #-}-module Imm.Options where---- {{{ Imports-import           Imm.Dyre                       as Dyre (Mode (..))-import qualified Imm.Dyre                       as Dyre-import           Imm.Feed-import           Imm.Logger                     as Logger-import           Imm.Pretty--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--- }}}---- | Available commands.-data Command = Check (Maybe FeedRef)-             | Import-             | Read (Maybe FeedRef)-             | Rebuild-             | Unread (Maybe FeedRef)-             | Run (Maybe FeedRef)-             | Show (Maybe FeedRef)-             | Help-             | ShowVersion-             | Subscribe URI (Set Text)-             | Unsubscribe (Maybe FeedRef)--deriving instance Eq Command-deriving instance Show Command--instance Pretty Command where-  pretty (Check f)       = "Check feed(s):" <+> pretty f-  pretty Import          = "Import feeds"-  pretty (Read f)        = "Mark feed(s) as read:" <+> pretty f-  pretty Rebuild         = "Rebuild configuration"-  pretty (Unread f)      = "Mark feed(s) as unread:" <+> pretty f-  pretty (Run f)         = "Download new entries from feed(s):" <+> pretty f-  pretty (Show f)        = "Show status for feed(s):" <+> pretty f-  pretty 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--defaultCommand :: Command-defaultCommand = Show Nothing---- | Available commandline options.-data CliOptions = CliOptions-  { optionCommand      :: Command-  , optionDyreMode     :: Dyre.Mode-  , optionLogLevel     :: LogLevel-  , optionColorizeLogs :: Bool-  }---- deriving instance Eq CliOptions-defaultOptions :: CliOptions-defaultOptions = CliOptions defaultCommand Dyre.defaultMode Info True---- instance Pretty CliOptions where---     pretty opts = text "ACTION" <> equals <>  $ opts^.command_---         , ("RECONFIGURATION_MODE=" ++) . show $ opts^.dyreMode_---         ]---         ++ catMaybes [("CONFIG=" ++) <$> opts^.configurationLabel_]--helpString :: Text-helpString = Text.pack $ renderHelp 100 $ Help.parserHelp defaultPrefs optionsParser--parseOptions :: (MonadIO m) => m 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-  <*> (vanillaFlag <|> forceReconfFlag <|> denyReconfFlag <|> pure Dyre.defaultMode)-  <*> (verboseFlag <|> quietFlag <|> logLevel <|> pure Info)-  <*> (colorizeLogs <|> pure True)---commands :: Parser Command-commands = subparser $ mconcat-  [ 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."-  ]----- {{{ Dynamic reconfiguration options-vanillaFlag, forceReconfFlag, denyReconfFlag :: Parser Dyre.Mode-vanillaFlag      = flag' Vanilla $ long "vanilla" <> short '1' <> help "Ignore custom configuration file."-forceReconfFlag  = flag' ForceReconfiguration $ long "force-reconf" <> help "Recompile configuration file before starting the application."-denyReconfFlag   = flag' IgnoreReconfiguration $ long "deny-reconf" <> help "Do not recompile configuration file even if it has changed."--dyreDebug :: Parser Bool-dyreDebug = switch $ long "dyre-debug" <> help "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program."--dyreMasterBinary :: Parser String-dyreMasterBinary = strOption $ long "dyre-master-binary" <> metavar "PATH" <> hidden <> internal <> help "Internal flag used for dynamic reconfiguration."--- }}}---- {{{ Log options-verboseFlag, quietFlag, logLevel :: Parser LogLevel-verboseFlag = flag' Logger.Debug $ long "verbose" <> short 'v' <> help "Set log level to DEBUG."-quietFlag   = flag' Logger.Error $ long "quiet" <> short 'q' <> help "Set log level to ERROR."-logLevel    = option auto $ long "log-level" <> short 'l' <> metavar "LOG-LEVEL" <> value Info <> completeWith ["Debug", "Info", "Warning", "Error"] <> help "Set log level. Available values: Debug, Info, Warning, Error."--colorizeLogs :: Parser Bool-colorizeLogs = flag' False $ long "nocolor" <> help "Disable log colorisation."--- }}}---- {{{ Other options-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." <*> (Set.fromList <$> many tagOption)-unsubscribeOptions  = Unsubscribe <$> optional feedRefOption--- }}}---- {{{ Util-uriReader :: ReadM URI-uriReader = eitherReader $ first show . parseURI laxURIParserOptions . encodeUtf8 @Text . fromString--feedRefOption :: Parser FeedRef-feedRefOption = argument ((ByUID <$> auto) <|> (ByURI <$> uriReader)) $ metavar "TARGET"--uriArgument :: String -> Parser URI-uriArgument helpText = argument uriReader $ metavar "URI" <> help helpText--- }}}

@@ -5,10 +5,11 @@ module Imm.Pretty (module Imm.Pretty, module X) where  -- {{{ Imports-import           Data.Text                                 as Text+import           Data.Text                                 (Text)+import qualified Data.Text                                 as Text import           Data.Time import           Data.Tree-+import           Data.XML.Types                            as XML import           Text.Atom.Types                           as Atom -- import           Text.OPML.Types              as OPML hiding (text) -- import qualified Text.OPML.Types              as OPML@@ -23,6 +24,10 @@ import           URI.ByteString -- }}} ++-- | Newtype wrapper to prettyprint a key uniquely identifying an object+newtype PrettyKey a = PrettyKey a+ -- | Infix operator for 'line' (<++>) :: Doc a -> Doc a -> Doc a x <++> y = x <> line <> y@@ -31,7 +36,7 @@ prettyTree (Node n s) = pretty n <++> indent 2 (vsep $ prettyTree <$> s)  prettyTime :: UTCTime -> Doc a-prettyTime = pretty . formatTime defaultTimeLocale rfc822DateFormat+prettyTime = pretty . formatTime defaultTimeLocale "%F %T"  -- instance Pretty OpmlHead where --   pretty h = hsep $ catMaybes@@ -69,9 +74,23 @@ prettyLink l = withAtomURI prettyURI $ linkHref l  prettyAtomText :: AtomText -> Doc a-prettyAtomText (AtomPlainText _ t) = pretty t-prettyAtomText (AtomXHTMLText t)   = pretty t+prettyAtomText (AtomPlainText _ t)     = pretty t+prettyAtomText (AtomXHTMLText element) = prettyElement element +prettyElement :: Element -> Doc a+prettyElement (Element _ _ nodes) = mconcat $ map prettyNode nodes++prettyNode :: Node -> Doc a+prettyNode (NodeElement element) = prettyElement element+prettyNode (NodeContent content) = prettyContent content+prettyNode _                     = mempty++prettyContent :: Content -> Doc a+prettyContent (ContentText t)      = pretty t+prettyContent (ContentEntity "lt") = "<"+prettyContent (ContentEntity "gt") = ">"+prettyContent _                    = "?"+ prettyEntry :: AtomEntry -> Doc a prettyEntry e = "Entry:" <+> prettyAtomText (entryTitle e) <++> indent 4   (         "By" <+> equals <+> list (prettyPerson <$> entryAuthors e)@@ -95,10 +114,10 @@ prettyGuid (GuidUri (RssURI u)) = prettyURI u  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+prettyAtomContent (AtomContentInlineText _ t)      = pretty t+prettyAtomContent (AtomContentInlineXHTML element) = prettyElement element+prettyAtomContent (AtomContentInlineOther _ t)     = pretty t+prettyAtomContent (AtomContentOutOfLine _ u)       = withAtomURI prettyURI u  magenta :: Doc AnsiStyle -> Doc AnsiStyle magenta = annotate $ color Magenta

@@ -1,32 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes        #-}--- | Implementation of "Imm.XML" based on 'Conduit'.-module Imm.XML.Conduit (module Imm.XML.Conduit, module Imm.XML) where---- {{{ Imports-import           Imm.Feed-import           Imm.XML--import           Control.Exception.Safe-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   as XML-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-mkHandle :: MonadIO m => MonadCatch m => XmlParser -> Handle m-mkHandle (XmlParser preProcess) = Handle-  { parseXml = \uri bytestring -> liftIO $ runConduit $ parseLBS def bytestring .| preProcess uri .| XML.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,8 +1,7 @@-module Prelude (io, module Relude, module Relude.Extra.Map, module Control.Monad.Base) where+module Prelude (io, module Relude, module Relude.Extra.Map) where  import Relude hiding(Handle, force) import Relude.Extra.Map (lookup)-import           Control.Monad.Base  io :: MonadIO m => IO a -> m a io = liftIO

@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TypeFamilies          #-}+module Core (+-- * Types+  FeedRef,+-- * Actions+  subscribe,+  listFeeds,+  showFeed,+  importOPML,+) where++-- {{{ Imports+import qualified Imm.Database            as Database+import           Imm.Database.FeedTable+import qualified Imm.Database.FeedTable  as Database+import           Imm.Feed+import           Imm.Logger              as Logger+import           Imm.Pretty++import           Control.Exception.Safe+import           Data.Conduit+import qualified Data.Map                as Map+import           Data.Set                (Set)+import qualified Data.Set                as Set+import           Data.Tree+import           Refined+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+-- }}}++++-- | Print database status for given feed(s)+showFeed :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m ()+showFeed logger database feedID = do+  entry <- Database.fetch database feedID+  flushLogs logger+  log logger Info $ prettyDatabaseEntry entry++-- | Register the given feed URI in database+subscribe :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> URI -> Set Text -> m ()+subscribe logger database uri = Database.register logger database (FeedID uri)++-- | List all subscribed feeds and their status+listFeeds :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> m ()+listFeeds logger database = do+  entries <- Database.fetchAll database+  flushLogs logger+  when (null entries) $ log logger Warning "No subscription"+  forM_ (zip [1..] $ Map.elems entries) $ \(i, entry) ->+    log logger Info $ pretty (i :: Int) <+> prettyShortDatabaseEntry entry+++-- | 'subscribe' to all feeds described by the OPML document provided in input+importOPML :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> ConduitT () ByteString m () -> m ()+importOPML logger database input = do+  opml <- runConduit $ input .| XML.parseBytes def .| force "Invalid OPML" parseOpml+  forM_ (opmlOutlines opml) $ importOPML' logger database mempty++importOPML' :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> Set Text -> Tree OpmlOutline -> m ()+importOPML' logger database _ (Node (OpmlOutlineGeneric b _) sub) = mapM_ (importOPML' logger database (Set.singleton . unrefine $ OPML.text b)) sub+importOPML' logger database c (Node (OpmlOutlineSubscription _ s) _) = subscribe logger database (xmlUri s) c+importOPML' _ _ _ _ = return ()

@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists       #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE UndecidableInstances  #-}+-- | Implementation of "Imm.Database" based on a JSON file.+module Database+  ( JsonFileDatabase+  , mkJsonFileDatabase+  , defaultDatabase+  , mkHandle+  , JsonException(..)+  , module Imm.Database.FeedTable+  ) where++-- {{{ Imports+import           Imm.Database                hiding (commit, delete, insert,+                                              purge, update)+import           Imm.Database.FeedTable+import           Imm.Pretty++import           Control.Concurrent.STM.TVar (swapTVar)+import           Control.Exception.Safe+import           Data.Aeson+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              hiding (withFile)+import           System.Directory+import           System.FilePath+-- }}}++data CacheStatus = Empty | Clean | Dirty+  deriving(Eq, Ord, Read, Show)++data JsonFileDatabase t = JsonFileDatabase FilePath (Map (Key t) (Entry t)) CacheStatus++instance Pretty (JsonFileDatabase t) where+  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 (TVar (JsonFileDatabase t))+defaultDatabase = do+  databaseFile <- getXdgDirectory XdgConfig "imm/feeds.json"+  newTVarIO $ mkJsonFileDatabase databaseFile+++data JsonException = UnableDecode+  deriving(Eq, Show)++instance Exception JsonException where+  displayException _ = "Unable to parse JSON"+++mkHandle :: (Table t, FromJSON (Key t), FromJSON (Entry t), ToJSON (Key t), ToJSON (Entry t), MonadIO m, MonadMask m)+         => TVar (JsonFileDatabase t) -> Handle m t+mkHandle tvar = Handle+  { _describeDatabase = pretty <$> readTVarIO tvar+  , _fetchList = \keys -> loadInCache tvar >> (Map.filterWithKey (\uri _ -> Set.member uri $ Set.fromList keys) <$> getCache tvar)+  , _fetchAll = loadInCache tvar >> getCache tvar+  , _update = \key f -> loadInCache tvar >> atomically (modifyTVar' tvar $ updateInCache key f)+  , _insertList = \list -> loadInCache tvar >> atomically (modifyTVar' tvar $ insertInCache list)+  , _deleteList = \list -> loadInCache tvar >> atomically (modifyTVar' tvar $ deleteInCache list)+  , _purge = loadInCache tvar >> atomically (modifyTVar' tvar purgeInCache)+  , _commit = commit tvar+  }++-- * Low-level implementation++loadInCache :: (Table t, FromJSON (Key t), FromJSON (Entry t), MonadIO m, MonadMask m) => TVar (JsonFileDatabase t) -> m ()+loadInCache tvar = do+  JsonFileDatabase file _ status <- readTVarIO tvar+  when (status == Empty) $ do+    database <- loadFromDisk file+    atomically $ do+      JsonFileDatabase _ _ status' <- readTVar tvar+      when (status' == Empty) $ writeTVar tvar database++loadFromDisk :: (Table t, FromJSON (Key t), FromJSON (Entry t), MonadIO m, MonadMask m) => FilePath -> m (JsonFileDatabase t)+loadFromDisk file = do+  liftIO $ createDirectoryIfMissing True $ takeDirectory file+  fileContent <- withBinaryFile file ReadWriteMode (toLazy_ . hGetContents)+  cache <- (`failWith` UnableDecode) $ fmap Map.fromList $ decode $ fromEmpty "[]" fileContent+  return $ JsonFileDatabase file cache Clean+  where fromEmpty x "" = x+        fromEmpty _ y  = y++getCache :: MonadIO m => TVar (JsonFileDatabase t) -> m (Map (Key t) (Entry t))+getCache tvar = do+  JsonFileDatabase _ cache _ <- readTVarIO tvar+  return cache+++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++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++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++purgeInCache :: Table t => JsonFileDatabase t -> JsonFileDatabase t+purgeInCache (JsonFileDatabase file _ _) = JsonFileDatabase file mempty Dirty++commit :: (ToJSON (Key t), ToJSON (Entry t), MonadIO m)+       => TVar (JsonFileDatabase t) -> m ()+commit tvar = do+  JsonFileDatabase file cache status <- atomically $ do+    database@(JsonFileDatabase file cache status) <- readTVar tvar+    when (status == Dirty) $ void $ swapTVar tvar $ JsonFileDatabase file cache Clean+    return database++  when (status == Dirty) $ liftIO $ withFile file WriteMode $ \h -> hPut h $ encode $ Map.toList cache+++-- | Wrap a 'Maybe' value in 'MonadThrow'+failWith :: (MonadThrow m, Exception e) => Maybe a -> e -> m a+failWith x e = maybe (throwM e) return x

@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Implementation of "Imm.HTTP" based on "Network.HTTP.Client".+module HTTP (mkHandle, defaultManager, module Reexport) where++-- {{{ Imports+import           Imm.HTTP+import           Imm.Pretty++import           Control.Exception.Safe+import           Data.CaseInsensitive+import           Network.Connection         as Reexport+import           Network.HTTP.Client        as Reexport+import           Network.HTTP.Client.TLS    as Reexport+import           URI.ByteString+-- }}}++mkHandle :: MonadIO m => Manager -> Handle m+mkHandle manager = Handle+  { httpGet = io . httpGet' manager+  }++-- | Default manager uses TLS and no proxy+defaultManager :: IO Manager+defaultManager = newManager $ mkManagerSettings (TLSSettingsSimple False False False) Nothing+++-- | Perform an HTTP GET request and return the response body+httpGet' :: Manager -> URI -> IO LByteString+httpGet' manager uri = do+  request <- makeRequest uri+  responseBody <$> httpLbs request manager+    -- codec'   <- reader $ view (config.codec)+    -- return $ response $=+ decode codec'++parseRequest' :: MonadThrow m => URI -> m Request+parseRequest' = parseRequest . show . prettyURI++-- | Build an HTTP request for given URI+makeRequest :: URI -> IO Request+makeRequest uri = do+  req <- parseRequest' uri+  return $ req { requestHeaders = [+    (mk "User-Agent", "Mozilla/4.0"),+    (mk "Accept", "*/*")]}

@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+-- | Implementation of "Imm.Logger" based on @fast-logger@.+-- For further information, please consult "System.Log.FastLogger".+module Logger (module Logger, module Reexport) where++-- {{{ Imports+import           Imm.Logger                                as Reexport+import           Imm.Pretty++import           Data.Text.Prettyprint.Doc.Render.Terminal+import           System.Log.FastLogger                     as Reexport+-- }}}++data LoggerSettings = LoggerSettings+  { _loggerSet      :: LoggerSet       -- ^ 'LoggerSet' used for 'Debug', 'Info' and 'Warning' logs+  , _errorLoggerSet :: LoggerSet       -- ^ 'LoggerSet' used for 'Error' logs+  , _logLevel       :: MVar LogLevel   -- ^ Discard logs that are strictly less serious than this level+  , _colorizeLogs   :: MVar Bool       -- ^ Enable log colorisation+  }+++-- | Default logger forwards error messages to stderr, and other messages to stdout.+defaultLogger :: IO LoggerSettings+defaultLogger = LoggerSettings+  <$> newStdoutLoggerSet defaultBufSize+  <*> newStderrLoggerSet defaultBufSize+  <*> newMVar Info+  <*> newMVar True+++mkHandle :: MonadIO m => LoggerSettings -> Handle m+mkHandle settings = Handle+  { log = \l t -> do+      refLevel <- readMVar $ _logLevel settings+      handleColor <- do+        keepColor <- readMVar (_colorizeLogs settings)+        case (l, keepColor) of+          (_, False) -> return unAnnotate+          (Error, _) -> return red+          (Warning, _) -> return yellow+          _ -> return id+      let loggerSet = (if l == Error then _errorLoggerSet else _loggerSet) settings+      when (l >= refLevel) $ liftIO $ pushLogStrLn loggerSet $ toLogStr $ renderLazy $ layoutPretty defaultLayoutOptions $ handleColor t++  , getLogLevel = readMVar $ _logLevel settings+  , setLogLevel = void . swapMVar (_logLevel settings)+  , setColorizeLogs = void . swapMVar (_colorizeLogs settings)+  , flushLogs = liftIO $ do+      flushLogStr $ _loggerSet settings+      flushLogStr $ _errorLoggerSet settings+  }

@@ -0,0 +1,228 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeApplications      #-}+-- {{{ Imports+import           Imm+import           Imm.Database                  as Database+import qualified Imm.HTTP                      as HTTP+import           Imm.Pretty++import qualified Core+import           Database+import           HTTP+import           Logger+import           Options+import           XML++import           Control.Concurrent.Async+import           Control.Concurrent.STM.TMChan+import           Control.Exception.Safe+import           Data.Aeson                    hiding (Error)+import           Data.Conduit.Combinators      as Conduit (stdin)+import qualified Data.Map                      as Map+import qualified Data.Text                     as Text+import qualified Data.Text.IO                  as Text+import           Dhall+import           Relude.Unsafe                 (at)+import           System.Exit+import           System.IO                     (hFlush)+import           System.Process.Typed+-- }}}+++main :: IO ()+main = do+  AllOptions{..} <- parseOptions+  let GlobalOptions{..} = optionGlobal++  -- Setup logger+  logger <- Logger.mkHandle <$> defaultLogger+  setColorizeLogs logger optionColorizeLogs+  setLogLevel logger optionLogLevel+  log logger Debug $ "Options: " <> pretty optionCommand++  handleAny (log logger Error . pretty . displayException) $ do+    -- Setup database+    database <- Database.mkHandle <$> defaultDatabase+    let database' = if optionReadOnlyDatabase then readOnly logger database else database+    log logger Debug . ("Using database:" <++>) . indent 2 =<< _describeDatabase database'++    case optionCommand of+      Import           -> Core.importOPML logger database' Conduit.stdin+      Subscribe u c    -> Core.subscribe logger database' u c+      List             -> Core.listFeeds logger database'+      ShowFeed feedRef -> Core.showFeed logger database =<< toFeedID database' feedRef+      OnFeedRef t c    -> main2 logger database' optionCallbacksFile t c++    Database.commit logger database'++  flushLogs logger+++main2 :: Logger.Handle IO -> Database.Handle IO FeedTable -> FilePath -> Maybe FeedRef -> CommandOnFeedRef -> IO ()+main2 logger database callbacksFile feedRef command = do+  feedIDs <- resolveTarget database ByPassConfirmation feedRef++  case command of+    Unsubscribe      -> Database.deleteList logger database feedIDs+    Reset            -> mapM_ (Database.markAsUnprocessed logger database) feedIDs+    Run callbackMode -> do+      callbacks <- case callbackMode of+        EnableCallbacks -> input auto $ fromString callbacksFile+        _               -> return []+      main3 logger database callbacks feedIDs+++main3 :: Logger.Handle IO -> Database.Handle IO FeedTable -> [Callback] -> [FeedID] -> IO ()+main3 logger database callbacks feedIDs = do+  httpClient <- HTTP.mkHandle <$> defaultManager++  targetFeedChan <- newTMChanIO+  newItemsChan <- newTMChanIO+  processedChan <- newTMChanIO+  fetchErrorsChan <- newTMChanIO+  callbackErrorsChan <- newTMChanIO++  newItemsCount <- newTVarIO (0 :: Int)+  errorsCount <- newTVarIO (0 :: Int)++  -- => Feed IDs events+  producer <- async $ forM_ feedIDs $ atomically . writeTMChan targetFeedChan++  -- Feed IDs events => new item events+  fetchers <- replicateM 5 $ async $ fix $ \recurse -> do+    target <- atomically $ readTMChan targetFeedChan+    forM_ target $ \feedID@(FeedID uri) -> do+      catchAny+        (do+          feed <- HTTP.get logger httpClient uri >>= parseXml xmlParser uri++          unreadElements <- filterM (fmap not . isRead database feedID) $ getElements feed+          forM_ unreadElements $ \element -> do+            log logger Info $ "New item:" <+> magenta (pretty feedID) <+> "/" <+> yellow (pretty $ getTitle element)+            atomically $ do+              writeTMChan newItemsChan (feedID, removeElements feed, element)+              count <- readTVar newItemsCount+              writeTVar newItemsCount (count + 1) )++        (\e -> atomically $ do+          writeTMChan fetchErrorsChan (feedID, e)+          count <- readTVar errorsCount+          writeTVar errorsCount (count + 1) )++      recurse++  -- New items events => execute callback => processed/error events+  runners <- replicateM 5 $ async $ fix $ \recurse -> do+    newItem <- atomically $ readTMChan newItemsChan+    forM_ newItem $ \(feedID, feed, element) -> do+      results <- forM callbacks $ \callback@(Callback executable arguments) -> do+        let processInput = byteStringInput $ encode $ Message feed element+            processConfig = proc executable (map toString arguments) & setStdin processInput++        log logger Debug $ "Running" <+> cyan (pretty executable) <+> "on" <+> magenta (pretty feedID) <+> "/" <+> yellow (pretty $ getTitle element)++        (exitCode, output, errors) <- readProcess processConfig+        case exitCode of+          ExitSuccess   -> return $ Right callback+          ExitFailure i -> return $ Left (callback, i, output, errors)++      case lefts results of+        [] -> atomically $ writeTMChan processedChan (feedID, element)+        e  -> atomically $ do+          writeTMChan callbackErrorsChan (feedID, element, e)+          count <- readTVar errorsCount+          writeTVar errorsCount (count + 1)++      recurse++  -- Processed events => update database+  storer <- async $ fix $ \recurse -> do+    item <- atomically $ readTMChan processedChan+    forM_ item $ \(feedID, element) -> do+      log logger Debug $ "Updating database for" <+> pretty feedID <+> "/" <+> pretty (getTitle element)+      Database.markAsProcessed logger database feedID element+      recurse++  -- Wait for all async processes to complete+  wait producer+  atomically $ closeTMChan targetFeedChan++  mapM_ wait fetchers+  atomically $ closeTMChan newItemsChan++  mapM_ wait runners+  atomically $ do+    closeTMChan processedChan+    closeTMChan fetchErrorsChan+    closeTMChan callbackErrorsChan++  wait storer++  -- Error events => log+  printErrors logger fetchErrorsChan callbackErrorsChan+  flushLogs logger++  readTVarIO newItemsCount <&> pretty <&> bold <&> (<+> "new items") >>= log logger Info+  readTVarIO errorsCount <&> pretty <&> bold <&> (<+> "errors") >>= log logger Info++printErrors :: (MonadIO m, Exception e, Pretty a1, Pretty a2, Pretty a3, Pretty a4, ConvertUtf8 Text b1, ConvertUtf8 Text b2)+            => Logger.Handle m -> TMChan (a1, e) -> TMChan (a2, FeedElement, [(a3, a4, b1, b2)]) -> m ()+printErrors logger fetchErrorsChan callbackErrorsChan = do+  fix $ \recurse -> do+    items <- atomically $ readTMChan fetchErrorsChan+    forM_ items $ \(feedID, e) -> do+      log logger Error $ bold ("Fetch error for" <+> pretty feedID) <++> indent 2 (pretty $ displayException e)+      recurse++  fix $ \recurse -> do+    items <- atomically $ readTMChan callbackErrorsChan+    forM_ items $ \(feedID, element, errors) -> do+      let prettyErrors = vsep $ do+            (callback, i, stdout', stderr') <- errors+            return $ "When running:" <+> pretty callback+              <++> "Exit code:" <+> pretty i+              <++> "Stdout:" <++> indent 2 (pretty $ decodeUtf8 @Text stdout')+              <++> "Stderr:" <++> indent 2 (pretty $ decodeUtf8 @Text stderr')+      log logger Error $ bold ("Callback error for" <+> pretty feedID <+> "/" <+> pretty (getTitle element)) <++> indent 2 prettyErrors+      recurse+++xmlParser :: XML.Handle IO+xmlParser = XML.mkHandle defaultXmlParser+++-- * Util++data SafeGuard = AskConfirmation | ByPassConfirmation+  deriving(Eq, Read, Show)++data InterruptedException = InterruptedException deriving(Eq, Read, Show)+instance Exception InterruptedException where+  displayException _ = "Process interrupted"++promptConfirm :: Text -> IO ()+promptConfirm s = do+  Text.putStr $ s <> " Confirm [Y/n] "+  hFlush stdout+  x <- Text.getLine+  unless (Text.null x || x == "Y") $ throwM InterruptedException+++resolveTarget :: MonadIO m => MonadThrow m => Database.Handle m FeedTable -> SafeGuard -> Maybe FeedRef -> m [FeedID]+resolveTarget database s Nothing = do+  result <- Map.keys <$> Database.fetchAll database+  when (s == AskConfirmation) $ liftIO $ promptConfirm $ "This will affect " <> show (length result) <> " feeds."+  return result+resolveTarget database _ (Just feedRef) = do+  result <- toFeedID database feedRef+  return [result]++toFeedID :: Monad m => Database.Handle m FeedTable -> FeedRef -> m FeedID+toFeedID database (ByUID i) = fst . at (i-1) . Map.toList <$> Database.fetchAll database+toFeedID _ (ByURI uri) = return $ FeedID uri

@@ -0,0 +1,144 @@+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications   #-}+module Options where++-- {{{ Imports+import           Imm.Feed+import           Imm.Logger                     as Logger+import           Imm.Pretty+import qualified Paths_imm                      as Package++import           Data.List+import           Data.Set                       (Set)+import qualified Data.Set                       as Set+import           Data.Version+import           Options.Applicative+import           System.Directory+import           System.FilePath+import           System.Info+import           URI.ByteString+-- }}}++-- * Types++data AllOptions = AllOptions+  { optionCommand :: Command+  , optionGlobal  :: GlobalOptions+  } deriving(Eq, Show)+++data GlobalOptions = GlobalOptions+  { optionLogLevel         :: LogLevel+  , optionColorizeLogs     :: Bool+  , optionReadOnlyDatabase :: Bool+  , optionCallbacksFile    :: FilePath+  } deriving(Eq, Ord, Read, Show)+++data Command = Import | Subscribe URI (Set Text) | List | ShowFeed FeedRef | OnFeedRef (Maybe FeedRef) CommandOnFeedRef++deriving instance Eq Command+deriving instance Ord Command+deriving instance Show Command++instance Pretty Command where+  pretty Import          = "Import feeds"+  pretty (Subscribe f _) = "Subscribe to feed:" <+> prettyURI f+  pretty (OnFeedRef t c) = pretty c <> ":" <+> pretty t+  pretty List            = "List all feeds"+  pretty (ShowFeed f)    = "Show details of feed" <+> pretty f+++data CallbackMode = DisableCallbacks | EnableCallbacks+  deriving(Eq, Ord, Read, Show)+++data CommandOnFeedRef = Reset | Run CallbackMode | Unsubscribe+  deriving(Eq, Ord, Read, Show)++instance Pretty CommandOnFeedRef where+  pretty Reset       = "Mark feed as unprocessed"+  pretty (Run c)     = "Download new entries from feeds" <> (if c == DisableCallbacks then space <> brackets "callbacks disabled" else mempty)+  pretty Unsubscribe = "Unsubscribe from feed"++-- * Option parsers++parseOptions :: (MonadIO m) => m AllOptions+parseOptions = io $ do+  defaultCallbacksFile <- getXdgDirectory XdgConfig $ "imm" </> "callbacks.dhall"+  customExecParser defaultPrefs $ info (allOptions defaultCallbacksFile <**> helper <**> versionPrinter) $ progDesc description++description :: String+description = "Execute arbitrary callbacks for each element of RSS/Atom feeds."++allOptions :: FilePath -> Parser AllOptions+allOptions defaultCallbacksFile = AllOptions+  <$> commandParser+  <*> globalOptions defaultCallbacksFile++globalOptions :: FilePath -> Parser GlobalOptions+globalOptions defaultCallbacksFile = GlobalOptions+  <$> (verboseFlag <|> quietFlag <|> logLevel <|> pure Info)+  <*> colorizeLogs+  <*> readOnlyDatabase+  <*> (callbacksFileOption <|> pure defaultCallbacksFile)++commandParser :: Parser Command+commandParser = hsubparser $ mconcat+  [ command "add" $ info subscribeOptions $ progDesc "Alias for subscribe."+  , command "import" $ info (pure Import) $ progDesc "Import feeds list from an OPML descriptor (read from stdin)."+  , command "subscribe" $ info subscribeOptions $ progDesc "Subscribe to a feed."++  , command "remove" $ info unsubscribeOptions $ progDesc "Alias for unsubscribe."+  , command "run" $ info (OnFeedRef <$> optional feedRefOption <*> runOptions) $ progDesc "Update list of feeds."+  , command "show" $ info (ShowFeed <$> feedRefOption) $ progDesc "Show details about given feed."+  , command "list" $ info (pure List) $ progDesc "List all feed sources currently configured, along with their status."+  , command "reset" $ info (OnFeedRef <$> optional feedRefOption <*> pure Reset) $ progDesc "Mark given feed as unprocessed."+  , command "unsubscribe" $ info unsubscribeOptions $ progDesc "Unsubscribe from a feed."+  ]++-- {{{ Log options+verboseFlag, quietFlag, logLevel :: Parser LogLevel+verboseFlag = flag' Logger.Debug $ long "verbose" <> short 'v' <> help "Set log level to DEBUG."+quietFlag   = flag' Logger.Error $ long "quiet" <> short 'q' <> help "Set log level to ERROR."+logLevel    = option auto $ long "log-level" <> short 'l' <> metavar "LOG-LEVEL" <> value Info <> completeWith ["Debug", "Info", "Warning", "Error"] <> help "Set log level. Available values: Debug, Info, Warning, Error."++colorizeLogs :: Parser Bool+colorizeLogs = flag True False $ long "nocolor" <> help "Disable log colorisation."+-- }}}++-- {{{ Other options+readOnlyDatabase :: Parser Bool+readOnlyDatabase = switch $ long "read-only" <> help "Disable database writes."++runOptions :: Parser CommandOnFeedRef+runOptions = Run <$> flag EnableCallbacks DisableCallbacks (long "no-callbacks" <> help "Disable callbacks.")++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." <*> (Set.fromList <$> many tagOption)+unsubscribeOptions  = OnFeedRef <$> optional feedRefOption <*> pure Unsubscribe++callbacksFileOption :: Parser FilePath+callbacksFileOption = strOption $ long "callbacks" <> short 'c' <> metavar "FILE" <> help "Dhall configuration file for callbacks"+-- }}}++-- {{{ Util+uriReader :: ReadM URI+uriReader = eitherReader $ first show . parseURI laxURIParserOptions . encodeUtf8 @Text . fromString++feedRefOption :: Parser FeedRef+feedRefOption = argument ((ByUID <$> auto) <|> (ByURI <$> uriReader)) $ metavar "TARGET"++uriArgument :: String -> Parser URI+uriArgument helpText = argument uriReader $ metavar "URI" <> help helpText++versionPrinter :: Parser (a -> a)+versionPrinter = infoOption+  (Data.List.unlines ["imm-" <> showVersion Package.version, "built with " <> compilerName <> "-" <> showVersion compilerVersion])+  (long "version" <> short 'V' <> help "Print versions.")+-- }}}

@@ -0,0 +1,7 @@+module Prelude (io, module Relude, module Relude.Extra.Map) where++import Relude hiding(Handle, force)+import Relude.Extra.Map (lookup)++io :: MonadIO m => IO a -> m a+io = liftIO

@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes        #-}+-- | Implementation of "Imm.XML" based on 'Conduit'.+module XML (module XML, module Imm.XML) where++-- {{{ Imports+import           Imm.Feed+import           Imm.XML++import           Control.Exception.Safe+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   as XML+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+mkHandle :: MonadIO m => MonadCatch m => XmlParser -> Handle m+mkHandle (XmlParser preProcess) = Handle+  { parseXml = \uri bytestring -> liftIO $ runConduit $ parseLBS def bytestring .| preProcess uri .| XML.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)

@@ -0,0 +1,185 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+-- | 'Callback' for @imm@ that sends a mail via a SMTP server the input RSS/Atom item.+-- {{{ Imports+import           Imm.Callback+import           Imm.Feed+import           Imm.Pretty++import           Data.Aeson+import           Data.ByteString             (getContents)+import           Data.Text                   as Text (intercalate)+import           Data.Time+import           Network.HaskellNet.SMTP+import           Network.HaskellNet.SMTP.SSL+import           Network.Mail.Mime           hiding (sendmail)+import           Network.Socket+import           Options.Applicative+import           Refined+import           Text.Atom.Types+import           Text.RSS.Types+-- }}}++-- * Types++type Username = String+type Password = String+type ServerName = String++-- | How to connect to the SMTP server+data ConnectionSettings = Plain ServerName PortNumber | Encrypted ServerName Settings Bool+  deriving(Eq, Generic, Ord, Show)++-- | How to authenticate to the SMTP server+data Authentication = Authentication AuthType Username Password+  deriving(Eq, Generic, Show)++data SMTPServer = SMTPServer (Maybe Authentication) ConnectionSettings+  deriving (Eq, Generic, Show)++-- | How to format outgoing mails from feed elements+data FormatMail = FormatMail+  { formatFrom    :: Feed -> FeedElement -> Address    -- ^ How to write the From: header of feed mails+  , formatSubject :: Feed -> FeedElement -> Text       -- ^ How to write the Subject: header of feed mails+  , formatBody    :: Feed -> FeedElement -> Text       -- ^ How to write the body of feed mails (sic!)+  , formatTo      :: Feed -> FeedElement -> [Address]  -- ^ How to write the To: header of feed mails+  }++data CliOptions = CliOptions+  { _smtpServer :: SMTPServer+  , _recipients :: [Address]+  , _dryRun     :: Bool+  } deriving (Eq, Generic, Show)+++parseOptions :: MonadIO m => m CliOptions+parseOptions = io $ customExecParser (prefs $ showHelpOnError <> showHelpOnEmpty) (info (cliOptions <**> helper) $ progDesc "Send a mail for each new RSS/Atom item.")++cliOptions :: Parser CliOptions+cliOptions = CliOptions+  <$> smtpServerParser+  <*> many recipientParser+  <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.")++smtpServerParser :: Parser SMTPServer+smtpServerParser = SMTPServer+  <$> ((Just <$> authenticationParser) <|> pure Nothing)+  <*> (plainConnection <|> encryptedConnection)++authenticationParser :: Parser Authentication+authenticationParser = Authentication+  <$> authenticationType+  <*> strOption (long "user" <> short 'u' <> help "SMTP username")+  <*> strOption (long "password" <> short 'P' <> help "SMTP password")++authenticationType :: Parser AuthType+authenticationType = flag' PLAIN (long "plain" <> help "Use plain authentication.")+  <|> flag' LOGIN (long "login" <> help "Use login authentication")+  <|> flag' CRAM_MD5 (long "cram-md5" <> help "Use CRAM MD5 authentication")++plainConnection :: Parser ConnectionSettings+plainConnection = Plain+  <$> strOption (long "server" <> short 's' <> help "SMTP server address.")+  <*> option auto (long "port" <> short 'p' <> help "SMTP server port.")++encryptedConnection :: Parser ConnectionSettings+encryptedConnection = Encrypted+  <$> strOption (long "server" <> short 's' <> help "SMTP server address.")+  <*> encryptionSettings+  <*> switch (long "starttls" <> help "Use STARTTLS.")++encryptionSettings :: Parser Settings+encryptionSettings = Settings+  <$> option auto (long "ssl-port" <> short 's' <> help "SSL port.")+  <*> option auto (long "max-line-length" <> short 'l' <> help "Maximum line length.")+  <*> switch (long "log" <> help "Log to console.")+  <*> switch (long "disable-certificate-validation" <> help "Disable certificate validation.")++recipientParser :: Parser Address+recipientParser = strOption (long "to" <> help "Mail recipients.")++main :: IO ()+main = do+  CliOptions smtpServer recipients dryRun <- parseOptions++  message <- getContents <&> fromStrict <&> eitherDecode+  case message of+    Left e -> putStrLn e+    Right (Message feed element) -> do+      timezone <- io getCurrentTimeZone+      currentTime <- io getCurrentTime+      let formatMail = FormatMail defaultFormatFrom defaultFormatSubject defaultFormatBody (const $ const recipients)+          mail = buildMail formatMail currentTime timezone feed element+      unless dryRun $ io $ withSMTPConnection smtpServer $ sendMimeMail2 mail++  return ()+++-- * Default behavior++-- | Fill 'addressName' with the feed title and, if available, the authors' names.+--+-- This function leaves 'addressEmail' empty. You are expected to fill it adequately, because many SMTP servers enforce constraints on the From: email.+defaultFormatFrom :: Feed -> FeedElement -> Address+defaultFormatFrom (Rss doc) (RssElement item) = Address (Just $ channelTitle doc <> " (" <> itemAuthor item <> ")") ""+defaultFormatFrom (Atom feed) (AtomElement entry) = Address (Just $ title <> " (" <> authors <> ")") ""+  where title = show . prettyAtomText $ feedTitle feed+        authors = Text.intercalate ", " $ map (unrefine . personName) $ entryAuthors entry <> feedAuthors feed+defaultFormatFrom _ _ = Address (Just "Unknown") ""++-- | Fill mail subject with the element title+defaultFormatSubject :: Feed -> FeedElement -> Text+defaultFormatSubject _ = getTitle++-- | Fill mail body with:+--+-- - a list of links associated to the element+-- - the element's content or description/summary+defaultFormatBody :: Feed -> FeedElement -> Text+defaultFormatBody _ (RssElement item) = "<p>" <> maybe "<no link>" (withRssURI (show . prettyURI)) (itemLink item) <> "</p><p>" <> itemDescription item <> "</p>"+defaultFormatBody _ (AtomElement entry) = "<p>" <> Text.intercalate "<br/>" links <> "</p><p>" <> fromMaybe "<empty>" (content <|> summary) <> "</p>"+  where links   = map (withAtomURI (show . prettyURI) . linkHref) $ entryLinks entry+        content = show . prettyAtomContent <$> entryContent entry+        summary = show . prettyAtomText <$> entrySummary entry+++-- * Low-level helpers++authenticate_ :: SMTPConnection -> Authentication -> IO Bool+authenticate_ connection (Authentication t u p) = do+  result <- authenticate t u p connection+  unless result $ putStrLn "Authentication failed"+  return result++withSMTPConnection :: SMTPServer -> (SMTPConnection -> IO a) -> IO a+withSMTPConnection (SMTPServer authentication (Plain server port)) f =+  doSMTPPort server port $ \connection -> do+    forM_ authentication (authenticate_ connection)+    f connection+withSMTPConnection (SMTPServer authentication (Encrypted server settings False)) f =+  doSMTPSSLWithSettings server settings $ \connection -> do+    forM_ authentication (authenticate_ connection)+    f connection+withSMTPConnection (SMTPServer authentication (Encrypted server settings True)) f =+  doSMTPSTARTTLSWithSettings server settings $ \connection -> do+    forM_ authentication (authenticate_ connection)+    f connection++-- | Build mail from a given feed+buildMail :: FormatMail -> UTCTime -> TimeZone -> Feed -> FeedElement -> Mail+buildMail format currentTime timeZone feed element =+  let date = formatTime defaultTimeLocale "%a, %e %b %Y %T %z" $ utcToZonedTime timeZone $ fromMaybe currentTime $ getDate element+  in Mail+    { mailFrom = formatFrom format feed element+    , mailTo   = formatTo format feed element+    , mailCc   = []+    , mailBcc  = []+    , mailHeaders =+        [ ("Return-Path", "<imm@noreply>")+        , ("Date", fromString date)+        , ("Subject", formatSubject format feed element)+        , ("Content-disposition", "inline")+        ]+    , mailParts = [[htmlPart $ fromStrict $ formatBody format feed element]]+    }

@@ -0,0 +1,7 @@+module Prelude (io, module Relude, module Relude.Extra.Map) where++import Relude hiding(Handle, force)+import Relude.Extra.Map (lookup)++io :: MonadIO m => IO a -> m a+io = liftIO

@@ -0,0 +1,134 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Write a file from the input RSS/Atom item.+--+-- Meant to be use as a callback for imm.+-- {{{ Imports+import           Imm.Callback+import           Imm.Feed+import           Imm.Pretty++import           Data.Aeson+import           Data.ByteString (getContents)+import           Data.ByteString.Builder+import           Data.ByteString.Streaming     (toStreamingByteString)+import qualified Data.Text                     as Text (null, replace)+import           Data.Time+import           Options.Applicative+import           Streaming.With+import           System.Directory              (createDirectoryIfMissing)+import           System.FilePath+import           Text.Atom.Types+import           Text.Blaze.Html.Renderer.Utf8+import           Text.Blaze.Html5              (Html, docTypeHtml,+                                                preEscapedToHtml, (!))+import qualified Text.Blaze.Html5              as H+import qualified Text.Blaze.Html5.Attributes   as H (charset, href)+import           Text.RSS.Types+import           URI.ByteString+-- }}}++data CliOptions = CliOptions+  { _directory :: FilePath+  , _dryRun    :: Bool+  } deriving (Eq, Ord, Read, Show)++parseOptions :: MonadIO m => m CliOptions+parseOptions = io $ customExecParser defaultPrefs (info cliOptions $ progDesc "Write a file for each new RSS/Atom item. An intermediate folder will be created for each feed.")++cliOptions :: Parser CliOptions+cliOptions = CliOptions+  <$> strOption (long "directory" <> short 'd' <> metavar "PATH" <> help "Root directory where files will be created.")+  <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.")++++main :: IO ()+main = do+  CliOptions directory dryRun <- parseOptions+  message <- getContents <&> fromStrict <&> eitherDecode+  case message of+    Left e -> putStrLn e+    Right (Message feed element) -> do+      let content = defaultFileContent feed element+          filePath = defaultFilePath directory feed element+      putStrLn filePath+      unless dryRun $ do+        createDirectoryIfMissing True $ takeDirectory filePath+        writeBinaryFile filePath $ toStreamingByteString content+  return ()++-- * Default behavior++-- | 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 </> toString title </> fileName <.> "html" where+  date = maybe "" (formatTime defaultTimeLocale "%F-") $ getDate element+  fileName = date <> toString (sanitize $ getTitle element)+  title = sanitize $ getFeedTitle feed+  sanitize = appEndo (mconcat [Endo $ Text.replace (toText [s]) "_" | s <- pathSeparators])+    >>> Text.replace "." "_"+    >>> Text.replace "?" "_"+    >>> Text.replace "!" "_"+    >>> Text.replace "#" "_"++-- | Generate an HTML page, with a title, a header and an article that contains the feed element+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+  H.body $ do+    H.h1 $ convertText $ getFeedTitle feed+    H.article $ do+      H.header $ do+        defaultArticleTitle feed element+        defaultArticleAuthor feed element+        defaultArticleDate feed element+      defaultBody feed element+++-- * Low-level helpers++defaultArticleTitle :: Feed -> FeedElement -> Html+defaultArticleTitle _ element@(RssElement item) = H.h2 $ maybe id (\uri -> H.a ! H.href uri) link $ convertText $ getTitle element where+  link = withRssURI (convertDoc . prettyURI) <$> itemLink item+defaultArticleTitle _ element@(AtomElement _) = H.h2 $ convertText $ getTitle element++defaultArticleAuthor :: Feed -> FeedElement -> Html+defaultArticleAuthor _ (RssElement item) = unless (Text.null author) $ H.address $ "Published by " >> convertText author where+  author = itemAuthor item+defaultArticleAuthor _ (AtomElement entry) = H.address $ do+  "Published by "+  forM_ (entryAuthors entry) $ \author -> do+    convertDoc $ prettyPerson author+    ", "++defaultArticleDate :: Feed -> FeedElement -> Html+defaultArticleDate _ element = forM_ (getDate element) $ \date -> H.p $ " on " >> H.time (convertDoc $ prettyTime date)+++-- | Generate the HTML content for a given feed element+defaultBody :: Feed -> FeedElement -> Html+defaultBody _ element@(RssElement _) = H.p $ preEscapedToHtml $ getContent element+defaultBody _ element@(AtomElement entry) = do+  unless (null links) $ H.p $ do+    "Related links:"+    H.ul $ forM_ links $ \uri -> H.li (H.a ! withAtomURI href uri $ convertAtomURI uri)+  H.p $ preEscapedToHtml $ getContent element+  where links   = map linkHref $ entryLinks entry++href :: URIRef a -> H.Attribute+href = H.href . convertURI++convertAtomURI :: (IsString t) => AtomURI -> t+convertAtomURI = withAtomURI convertURI++convertURI :: (IsString t) => URIRef a -> t+convertURI = convertText . decodeUtf8 . serializeURIRef'++convertText :: (IsString t) => Text -> t+convertText = fromString . toString++convertDoc :: (IsString t) => Doc a -> t+convertDoc = show

@@ -0,0 +1,7 @@+module Prelude (io, module Relude, module Relude.Extra.Map) where++import Relude hiding(Handle, force)+import Relude.Extra.Map (lookup)++io :: MonadIO m => IO a -> m a+io = liftIO