imm 1.8.0.0 → 1.9.0.0

raw patch · 22 files changed

+918/−642 lines, 22 filesdep +pipesdep +pipes-bytestringdep +safedep −case-insensitivedep −connectiondep −http-clientdep ~rss-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: pipes, pipes-bytestring, safe

Dependencies removed: case-insensitive, connection, http-client, http-client-tls, http-types, tls

Dependency ranges changed: rss-conduit

API changes (from Hackage documentation)

Files

• README.md +34/−7
• default.nix +73/−0
• imm.cabal +13/−11
• shell.nix +1/−0
• src/lib/Data/Aeson/Extended.hs +19/−0
• src/lib/Imm.hs +6/−6
• src/lib/Imm/Database.hs +0/−128
• src/lib/Imm/Database/Feed.hs +307/−0
• src/lib/Imm/Database/FeedTable.hs +0/−216
• src/lib/Imm/Feed.hs +36/−10
• src/lib/Imm/HTTP.hs +10/−8
• src/lib/Imm/Pretty.hs +1/−3
• src/lib/Prelude.hs +2/−2
• src/main/Alternate.hs +118/−0
• src/main/Core.hs +41/−27
• src/main/Database.hs +72/−35
• src/main/HTTP.hs +15/−34
• src/main/Main.hs +110/−116
• src/main/Options.hs +54/−33
• src/main/Prelude.hs +2/−2
• src/send-mail/Prelude.hs +2/−2
• src/write-file/Prelude.hs +2/−2

@@ -6,10 +6,32 @@  - a main executable `imm` that users run directly - secondary executables (`imm-writefile`, `imm-sendmail`) which can be used as callbacks triggered by `imm`-- a [*Haskell*][2] library, that exports functions useful to both the main executable and callbacks; the API is documented [in Hackage][1].+- a [Haskell][2] library, that exports functions useful to both the main executable and callbacks; the API is documented [in Hackage][1]. -## Callbacks+## Installation +### Using nix++This repository includes a *nix* package that can be installed by running the following command at the root folder:+```bash+nix-build --attr exe+```++### Without nix++*imm*'s executables can be installed using *cabal-install* tool:+```bash+cabal install imm+```++Then, the following runtime dependencies must be installed separately and provided in `PATH`:+- [httpie](https://github.com/jakubroztocil/httpie)+- [pup](https://github.com/ericchiang/pup)++## Configuration++### 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 [MessagePack][4]-encoded object structured as follows:@@ -71,14 +93,19 @@  ## Example usage -- Subscribe to a feed:+- Subscribe to a feed through direct URL:   ```bash-  imm subscribe http://your.feed.org+  imm subscribe -u http://your.feed.org   ``` +- Subscribe to a feed through an alternate link:+  ```bash+  imm subscribe -a http://your.website.org+  ```+ - Import feeds from an OPML file:   ```bash-  cat feeds.opml | imm import+  imm import < feeds.opml   ```  - List subscribed feeds:@@ -101,9 +128,9 @@   imm --read-only run --no-callbacks   ``` -- Execute configured callbacks for each new element from subscribed feeds:+- Execute configured callbacks for each new element from all subscribed feeds:   ```bash-  imm run+  imm run --all   ```  [1]: http://hackage.haskell.org/package/imm

@@ -0,0 +1,73 @@+{ nixpkgs ? import <nixpkgs> { } }:++let+  hlib = nixpkgs.haskell.lib;++  thisPackage =+    addRuntimeDependencies (myHaskellPackages.callCabal2nix "imm" ./. { }) [+      nixpkgs.httpie+      nixpkgs.pup+    ];++  my-atom-conduit = {+    pkg = "atom-conduit";+    ver = "0.8.0.0";+    sha256 = "17p8180dz3kv9ljfhjqspxp6km50xdcgsdnkknz9w3nfbkpk0l25";+  };++  my-opml-conduit = {+    pkg = "opml-conduit";+    ver = "0.8.0.0";+    sha256 = "14106j2rr6fk6hjhypm5hp1dk1rlxf7svswbj21ad3l40nx7qm7r";+  };++  my-rss-conduit = {+    pkg = "rss-conduit";+    ver = "0.6.0.0";+    sha256 = "1gdq1bv1ayx9qx9ppwld8b5qjfsq1pgkqd29qni3jcldw9w4wfb8";+  };++  myHaskellPackages = nixpkgs.haskellPackages.override {+    overrides = hself: hsuper: {+      imm = thisPackage;+      atom-conduit = hlib.dontCheck+        (hlib.dontHaddock (hsuper.callHackageDirect my-atom-conduit { }));+      opml-conduit = hlib.dontCheck+        (hlib.dontHaddock (hsuper.callHackageDirect my-opml-conduit { }));+      rss-conduit = hlib.dontCheck+        (hlib.dontHaddock (hsuper.callHackageDirect my-rss-conduit { }));+      msgpack = hlib.doJailbreak hsuper.msgpack;+    };+  };++  addRuntimeDependencies = drv: xs:+    hlib.overrideCabal drv (drv: {+      buildDepends = (drv.buildDepends or [ ]) ++ [ nixpkgs.makeWrapper ];+      postInstall = ''+        ${drv.postInstall or ""}+        for exe in "$out/bin/"* ; do+          wrapProgram "$exe" --prefix PATH ":" \+            ${nixpkgs.lib.makeBinPath xs}+        done+      '';+    });++  shell = myHaskellPackages.shellFor {+    packages = p: [ p.imm ];++    buildInputs = with nixpkgs.haskellPackages; [+      cabal-install+      haskell-ci+      hlint+      ghcid+    ];++    withHoogle = false;+  };++  exe = hlib.justStaticExecutables (myHaskellPackages.imm);++in {+  inherit shell;+  inherit exe;+}

@@ -1,18 +1,18 @@ cabal-version:       2.2 name:                imm-version:             1.8.0.0+version:             1.9.0.0 synopsis:            Execute arbitrary callbacks for each element of RSS/Atom feeds description:         Cf README file homepage:            https://github.com/k0ral/imm license:             CC0-1.0 license-file:        LICENSE author:              kamaradclimber, koral-maintainer:          chahine.moreau@gmail.com+maintainer:          mail@cmoreau.info category:            Web build-type:          Simple data-files:          data/*.dhall-extra-source-files:  README.md-tested-with:         GHC <8.8 && >=8.4+extra-source-files:  README.md, *.nix+tested-with:         GHC <8.10 && >=8.4.2  source-repository head   type:     git@@ -29,13 +29,14 @@   exposed-modules:     Imm     Imm.Callback-    Imm.Database-    Imm.Database.FeedTable+    Imm.Database.Feed     Imm.Feed     Imm.HTTP     Imm.Logger     Imm.Pretty     Imm.XML+  other-modules:+    Data.Aeson.Extended   build-depends:     aeson,     async,@@ -47,19 +48,20 @@     directory >= 1.2.3.0,     filepath,     hashable,-    http-types,     msgpack,     microlens,     monad-time,+    pipes,+    pipes-bytestring,     prettyprinter,     prettyprinter-ansi-terminal,     refined >=0.4.1,-    rss-conduit >= 0.4.1,+    rss-conduit >= 0.5.1,     safe-exceptions,     text,     time,     timerep >= 2.0.0.0,-    tls,+    typed-process,     uri-bytestring,     xml-conduit >= 1.5,     xml-types@@ -68,9 +70,9 @@  executable imm   import: common-  build-depends: imm, aeson, async, atom-conduit >=0.7, bytestring, case-insensitive, conduit, connection, containers, dhall >= 1.27, directory, fast-logger, filepath, http-client >=0.4.30, http-client-tls, msgpack, 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+  build-depends: imm, aeson, async, atom-conduit >=0.7, bytestring, conduit, containers, dhall >= 1.27, directory, fast-logger, filepath, msgpack, opml-conduit >=0.7, optparse-applicative, prettyprinter-ansi-terminal, pipes, pipes-bytestring, refined >=0.4.1, rss-conduit >=0.4.1, safe, safe-exceptions, stm, stm-chans, 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+  other-modules: Alternate, 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

@@ -0,0 +1,1 @@+(import ./default.nix { }).shell

@@ -0,0 +1,19 @@+module Data.Aeson.Extended+  ( module Data.Aeson+  , module Data.Aeson.Types+  , module Data.Aeson.Extended+  ) where++import           Data.Aeson+import           Data.Aeson.Types+import           URI.ByteString++-- | 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

@@ -1,9 +1,9 @@ -- | Meta-module that reexports many Imm sub-modules. module Imm (module X) where -import           Imm.Callback as X-import           Imm.Database as X hiding(Handle)-import           Imm.Feed     as X-import           Imm.HTTP     as X hiding(Handle)-import           Imm.Logger   as X hiding(Handle)-import           Imm.XML      as X hiding(Handle)+import           Imm.Callback      as X+import           Imm.Database.Feed as X hiding (Handle)+import           Imm.Feed          as X+import           Imm.HTTP          as X hiding (Handle)+import           Imm.Logger        as X hiding (Handle)+import           Imm.XML           as X hiding (Handle)

@@ -1,128 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE UndecidableInstances  #-}--- | Database module abstracts over a key-value database that supports CRUD operations.------ This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).------ > import qualified Imm.Database as Database-module Imm.Database where---- {{{ Imports-import           Imm.Logger             hiding (Handle)-import qualified Imm.Logger             as Logger-import           Imm.Pretty--import           Control.Exception.Safe hiding (handle)-import           Data.Map               (Map)--- }}}---- * Types---- | Generic database table-class (Ord (Key t), Show (Key t), Show (Entry t), Typeable t, Show t, Pretty t, Pretty (Key t))-  => Table t where-  type Key t :: *-  type Entry t :: *-  rep :: t--data Handle m t = Handle-  { _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 ()-  , _insertList       :: [(Key t, Entry t)] -> m ()-  , _deleteList       :: [Key t] -> m ()-  , _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-  = NotCommitted t-  | NotDeleted t [Key t]-  | NotFound t [Key t]-  | NotInserted t [(Key t, Entry t)]-  | NotPurged t-  | NotUpdated t (Key t)-  | UnableFetchAll t--deriving instance (Eq t, Eq (Key t), Eq (Entry t)) => Eq (DatabaseException t)-deriving instance (Show t, Show (Key t), Show (Entry t)) => Show (DatabaseException t)--instance (Table t, Show (Key t), Show (Entry t), Pretty (Key t), Typeable t) => Exception (DatabaseException t) where-  displayException = show . pretty--instance (Pretty t, Pretty (Key t)) => Pretty (DatabaseException t) where-  pretty (NotCommitted _) = "Unable to commit database changes."-  pretty (NotDeleted _ x) = "Unable to delete the following entries in database:" <++> indent 2 (vsep $ map pretty x)-  pretty (NotFound _ x) = "Unable to find the following entries in database:" <++> indent 2 (vsep $ map pretty x)-  pretty (NotInserted _ x) = "Unable to insert the following entries in database:" <++> indent 2 (vsep $ map (pretty . fst) x)-  pretty (NotPurged t) = "Unable to purge database" <+> pretty t-  pretty (NotUpdated _ x) = "Unable to update the following entry in database:" <++> indent 2 (pretty x)-  pretty (UnableFetchAll _) = "Unable to fetch all entries from database."----- * Primitives--fetch :: Monad m => Table t => MonadThrow m => Handle m t -> Key t -> m (Entry t)-fetch handle k = do-  results <- _fetchList handle [k]-  maybe (throwM $ NotFound (table handle) [k]) return $ lookup k results--fetchList :: Monad m => Handle m t -> [Key t] -> m (Map (Key t) (Entry t))-fetchList = _fetchList--fetchAll :: Monad m => Handle m t -> m (Map (Key t) (Entry t))-fetchAll = _fetchAll--update :: Monad m => Handle m t -> Key t -> (Entry t -> Entry t) -> m ()-update  = _update--insert :: Monad m => Logger.Handle m -> Handle m t -> Key t -> Entry t -> m ()-insert logger handle k v = insertList logger handle [(k, v)]--insertList :: Monad m => Logger.Handle m -> Handle m t -> [(Key t, Entry t)] -> m ()-insertList logger handle i = do-  log logger Info $ "Inserting " <> yellow (pretty $ length i) <> " entries..."-  _insertList handle i--delete :: Monad m => Logger.Handle m -> Handle m t -> Key t -> m ()-delete logger handle k = deleteList logger handle [k]--deleteList :: Monad m => Logger.Handle m -> Handle m t -> [Key t] -> m ()-deleteList logger handle k = do-  log logger Info $ "Deleting " <> yellow (pretty $ length k) <> " entries..."-  _deleteList handle k--purge :: Monad m => Logger.Handle m -> Handle m t -> m ()-purge logger handle = do-  log logger Info "Purging database..."-  _purge handle--commit :: Monad m => Logger.Handle m -> Handle m t -> m ()-commit logger handle = do-  log logger Debug "Committing database transaction..."-  _commit handle-  log logger Debug "Database transaction committed"--table :: Table t => Handle m t -> t-table _ = rep

@@ -0,0 +1,307 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE TypeFamilies      #-}+-- | Feed table definitions.+module Imm.Database.Feed where++-- {{{ Imports+import           Imm.Feed+import           Imm.Logger             (log, LogLevel(..))+import qualified           Imm.Logger             as Logger+import           Imm.Pretty++import           Control.Exception.Safe hiding(handle)+import           Control.Monad.Time+import           Data.Aeson.Extended+import           Data.Hashable+import           Data.Map          (mapKeys)+import qualified Data.Map          as Map+import qualified Data.Set               as Set (intersection)+import           Data.Time++-- To be removed soon+import           Text.Atom.Types+import           Text.RSS.Types+-- }}}++-- * Types++-- 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 '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 Entry = Entry+  { entryLocation    :: FeedLocation+  , entryTags        :: Set Text+  , entryReadHashes  :: Set Int+  , entryFeed        :: Maybe Feed+  , entryItems       :: Map FeedElement Bool+  , entryLastUpdate  :: Maybe UTCTime+  }+  deriving(Eq, Ord, Show)++prettyShortEntry :: Entry -> Doc AnsiStyle+prettyShortEntry Entry{..} = magenta feedID+  <++> indent 3 tags+  <++> indent 3 ("Last update:" <+> lastUpdate)+  <++> indent 3 (yellow (pretty totalItems) <+> "items," <+> yellow (pretty totalUnprocessedItems) <+> "unprocessed")++  where feedID = pretty entryLocation+        tags = sep $ map ((<>) "#" . pretty) $ toList entryTags+        lastUpdate = maybe "never" prettyTime entryLastUpdate+        totalItems = length entryItems+        totalUnprocessedItems = length $ Map.filter not entryItems++prettyEntry :: Entry -> Doc AnsiStyle+prettyEntry Entry{..} = magenta (pretty entryLocation)+  <++> 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 tags = sep $ map ((<>) "#" . pretty) $ toList entryTags+        lastUpdate = maybe "never" prettyTime entryLastUpdate+        displayItem item = maybe "<unknown>" prettyTime (getDate item) <+> pretty (getTitle item)++instance FromJSON Entry where+  parseJSON (Object v) = Entry+    <$> ((parseJSON =<< v .: "uri") <|> (parseJSON =<< v .: "location"))+    <*> 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 Entry where+  toJSON Entry{..} = object $+    [ "location"   .= toJSON entryLocation+    , "tags"       .= entryTags+    , "items"      .= mapKeys JsonElement entryItems+    , "lastUpdate"  .= entryLastUpdate+    ] <> maybeToList (fmap (("feed" .=) . renderFeed) entryFeed)+      <> if null entryReadHashes then mempty else ["readHashes" .= entryReadHashes]++makeEntry :: FeedLocation -> Set Text -> Entry+makeEntry feedLocation tags = Entry feedLocation tags mempty mzero mempty Nothing++matching :: FeedQuery -> Int -> Entry -> Bool+matching AllFeeds _ _ = True+matching (ByURI uri) _ entry = case entryLocation entry of+  FeedDirectURI uri' -> uri == uri'+  FeedAlternateLink uri' _ -> uri == uri'+matching (ByDatabaseID i) j _ = i == j+++data FeedStatus = Unknown | New | LastUpdate UTCTime++instance Pretty FeedStatus where+  pretty Unknown        = "Unknown"+  pretty New            = "New"+  pretty (LastUpdate x) = "Last update:" <+> pretty (formatTime defaultTimeLocale rfc822DateFormat x)++++data EntryKey = ByLocation FeedLocation | ById Int+  deriving(Eq, Ord, Show)++instance Pretty EntryKey where+  pretty (ByLocation location) = pretty location+  pretty (ById i) = "ID" <+> pretty i+++data Handle m = Handle+  { _describeDatabase :: m (Doc AnsiStyle)+  , _fetch  :: [EntryKey] -> m (Map EntryKey (Int, Entry))+  , _fetchAll         :: m (Map Int Entry)+  , _update :: [EntryKey] -> (Entry -> Entry) -> m ()+  , _insert           :: [Entry ] -> m (Map FeedLocation Int)+  , _delete      :: [EntryKey] -> m ()+  , _purge            :: m ()+  , _commit           :: m ()+  }++readOnly :: Monad m => Logger.Handle m -> Handle m -> Handle m+readOnly logger handle = handle+  { _describeDatabase = do+      output <- _describeDatabase handle+      return $ output <+> yellow (brackets "read only")+  , _update = \keys _ -> log logger Debug $ "Not updating database for keys" <+> pretty keys+  , _insert = \entries -> log logger Debug ("Not inserting " <> yellow (pretty $ length entries) <> " entries") $> mempty+  , _delete = \keys -> log logger Debug $ "Not deleting " <> yellow (pretty $ length keys) <> " entries"+  , _purge = log logger Debug "Not purging database"+  , _commit = log logger Debug "Not committing database"+  }++++data DatabaseException+  = NotCommitted+  | NotDeleted [FeedLocation]+  | KeyNotFound [EntryKey]+  | NotInserted [Entry]+  | NotPurged+  | NotUpdated FeedLocation+  | UnableFetchAll+  deriving(Eq, Show)++instance Exception DatabaseException where+  displayException = show . pretty++instance Pretty DatabaseException where+  pretty NotCommitted = "Unable to commit database changes."+  pretty (NotDeleted x) = "Unable to delete the following entries in database:" <++> indent 2 (vsep $ map pretty x)+  pretty (KeyNotFound x) = "Unable to find the following entries in database:" <++> indent 2 (vsep $ map pretty x)+  pretty (NotInserted x) = "Unable to insert the following entries in database:" <++> indent 2 (vsep $ map (pretty . entryLocation) x)+  pretty NotPurged = "Unable to purge feed database"+  pretty (NotUpdated x) = "Unable to update the following entry in database:" <++> indent 2 (pretty x)+  pretty UnableFetchAll = "Unable to fetch all entries from database."+++-- * Low-level primitives++fetch1 :: Monad m => MonadThrow m => Handle m -> EntryKey -> m (Int, Entry)+fetch1 handle k = do+  results <- _fetch handle [k]+  maybe (throwM $ KeyNotFound [k]) return $ lookup k results+++fetch :: Monad m => Handle m -> [EntryKey] -> m (Map EntryKey (Int, Entry))+fetch = _fetch++fetchQuery :: Monad m => Handle m -> (Int -> Entry -> Bool) -> m (Map Int Entry)+fetchQuery handle f = _fetchAll handle+  <&> Map.filterWithKey f++fetchAll :: Monad m => Handle m -> m (Map Int Entry)+fetchAll = _fetchAll++update :: Monad m => Handle m -> [EntryKey] -> (Entry -> Entry) -> m ()+update = _update++insert :: MonadThrow m => Logger.Handle m -> Handle m -> Entry -> m Int+insert logger handle entry = insertList logger handle [entry]+  <&> Map.lookup (entryLocation entry)+  >>= maybe (throwM $ NotInserted [entry]) pure++insertList :: Monad m => Logger.Handle m -> Handle m -> [Entry] -> m (Map FeedLocation Int)+insertList logger handle i = do+  log logger Info $ "Inserting " <> yellow (pretty $ length i) <> " entries..."+  _insert handle i++delete1 :: Monad m => Logger.Handle m -> Handle m -> EntryKey -> m ()+delete1 logger handle k = delete logger handle [k]++delete :: Monad m => Logger.Handle m -> Handle m -> [EntryKey] -> m ()+delete logger handle k = do+  log logger Info $ "Deleting " <> yellow (pretty $ length k) <> " entries..."+  _delete handle k++purge :: Monad m => Logger.Handle m -> Handle m -> m ()+purge logger handle = do+  log logger Info "Purging database..."+  _purge handle++commit :: Monad m => Logger.Handle m -> Handle m -> m ()+commit logger handle = do+  log logger Debug "Committing database transaction..."+  _commit handle+  log logger Debug "Database transaction committed"+++-- * High-level queries++register :: MonadThrow m => Logger.Handle m -> Handle m -> FeedLocation -> Set Text -> m Int+register logger database feedLocation tags = do+  log logger Info $ "Registering feed" <+> magenta (pretty feedLocation) <> "..."+  insert logger database $ makeEntry feedLocation tags++getStatus :: MonadCatch m => Handle m -> EntryKey -> m FeedStatus+getStatus database key = handleAny (\_ -> return Unknown) $ do+  result <- fmap Just (fetch1 database key) `catchAny` (\_ -> return Nothing)+  return $ maybe New LastUpdate $ entryLastUpdate . snd =<< result++markAsProcessed :: MonadThrow m => MonadTime m+                => Logger.Handle m -> Handle m -> EntryKey -> FeedElement -> m ()+markAsProcessed logger database key element = do+  log logger Debug $ "Marking as processed:" <+> pretty (PrettyKey element) <> "..."+  utcTime <- currentTime+  update database [key] $ \entry -> entry+    { entryItems = Map.insert element True $ entryItems entry+    , entryLastUpdate = Just utcTime+    }+++markAsUnprocessed :: MonadThrow m => Logger.Handle m -> Handle m -> EntryKey -> m ()+markAsUnprocessed logger database key = do+  log logger Debug $ "Marking as unprocessed:" <+> pretty key <> "..."+  update database [key] $ \entry -> entry+    { entryItems = False <$ entryItems entry+    , entryLastUpdate = Nothing+    , entryReadHashes = mempty+    }++listUnprocessedElements :: MonadThrow m => Handle m -> EntryKey -> m [FeedElement]+listUnprocessedElements database key = fetch1 database key+  <&> snd+  <&> entryItems+  <&> Map.filterWithKey (\_ v -> not v)+  <&> Map.keys++isRead :: MonadCatch m => Handle m -> EntryKey -> FeedElement -> m Bool+isRead database key element = do+  (_, entry) <- fetch1 database key+  let matchHash = not $ null $ fromList (getHashes element) `Set.intersection` entryReadHashes entry+      matchDate = case (entryLastUpdate entry, getDate element) of+        (Nothing, _)     -> False+        (_, Nothing)     -> False+        (Just a, Just b) -> a > b+      matchKey = Map.findWithDefault False element $ entryItems entry+  return $ matchHash || matchDate || matchKey++resolveEntryKey :: Monad m => Handle m -> FeedQuery -> m [EntryKey]+resolveEntryKey _ (ByDatabaseID i) = pure [ById i]+resolveEntryKey database (ByURI uri) = fetchAll database+  <&> Map.filter f+  <&> toList+  <&> map (ByLocation . entryLocation)+  where f entry = case entryLocation entry of+          FeedDirectURI uri' -> uri == uri'+          FeedAlternateLink uri' _ -> uri == uri'+resolveEntryKey database AllFeeds = fetchAll database+  <&> toList+  <&> map (ByLocation . entryLocation)++resolveFeedLocation :: Monad m => Handle m -> EntryKey -> m FeedLocation+resolveFeedLocation database (ById i) = fetchAll database+  <&> Map.elemAt i+  <&> snd+  <&> entryLocation+resolveFeedLocation _ (ByLocation location) = return location

@@ -1,216 +0,0 @@-{-# 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.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           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---- | Unique key in feeds table-newtype FeedID = FeedID URI-  deriving(Eq, Ord, Show)--prettyFeedID :: FeedID -> Doc AnsiStyle-prettyFeedID (FeedID uri) = prettyURI uri--instance FromJSON FeedID where-  parseJSON value = FeedID . _unwrapURI <$> parseJSON value--instance ToJSON FeedID where-  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-  , entryFeed        :: Maybe Feed-  , entryItems       :: Map FeedElement Bool-  , entryLastUpdate  :: Maybe UTCTime-  } deriving(Eq, Show)--prettyShortDatabaseEntry :: DatabaseEntry -> Doc AnsiStyle-prettyShortDatabaseEntry DatabaseEntry{..} = magenta feedID-  <++> indent 3 tags-  <++> indent 3 ("Last update:" <+> lastUpdate)-  <++> indent 3 (yellow (pretty totalItems) <+> "items," <+> yellow (pretty totalUnprocessedItems) <+> "unprocessed")--  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-    <$> (_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 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 mzero mempty Nothing---- | Singleton type to represent feeds table-data FeedTable = FeedTable deriving(Eq, Ord, Read, Show)--instance Pretty FeedTable where-  pretty _ = "Feeds table"--instance Table FeedTable where-  type Key FeedTable = FeedID-  type Entry FeedTable = DatabaseEntry-  rep = FeedTable---data FeedStatus = Unknown | New | LastUpdate UTCTime--instance Pretty FeedStatus where-  pretty Unknown        = "Unknown"-  pretty New            = "New"-  pretty (LastUpdate x) = "Last update:" <+> pretty (formatTime defaultTimeLocale rfc822DateFormat x)---newtype Database = Database [DatabaseEntry]-  deriving (Eq, Show)---- * Primitives--register :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> Set Text -> m ()-register logger database feedID tags = do-  log logger Info $ "Registering feed" <+> magenta (pretty feedID) <> "..."-  insert logger database feedID $ newDatabaseEntry feedID tags--getStatus :: 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 $ entryLastUpdate =<< result--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 $ \entry -> entry-    { entryItems = Map.insert element True $ entryItems entry-    , entryLastUpdate = Just utcTime-    }---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-    }--listUnprocessedElements :: MonadThrow m -                        => Database.Handle m FeedTable -> FeedID -> m [FeedElement]-listUnprocessedElements database feedID = do-  DatabaseEntry{..} <- fetch database feedID-  return $ Map.keys $ Map.filter not entryItems--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

@@ -13,11 +13,11 @@  import           Conduit import           Control.Exception.Safe+import           Data.Aeson.Extended 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@@ -25,7 +25,6 @@ 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)@@ -35,18 +34,45 @@  -- * Types --- | Feed reference: either its URI, or its UID from database-data FeedRef = ByUID Int | ByURI URI+-- | Feed location identifies a feed. It is either:+-- - the feed URI+-- - a webpage URI that refers to the feed through an alternate link, in which case an optional feed title can be provided to disambiguate multiple such links+data FeedLocation = FeedDirectURI URI | FeedAlternateLink URI Text   deriving(Eq, Ord, Show) -instance Pretty FeedRef where-  pretty (ByUID n) = "feed" <+> pretty n+instance Pretty FeedLocation where+  pretty (FeedDirectURI uri) = prettyURI uri+  pretty (FeedAlternateLink uri title) = prettyURI uri+    <> if Text.null title then mempty else space <> brackets (pretty title)++instance FromJSON FeedLocation where+  parseJSON value = oldStyleDirectURI <|> newStyleDirectURI value <|> alternateLink value where+    oldStyleDirectURI = FeedDirectURI . _unwrapURI <$> parseJSON value+    newStyleDirectURI = withObject "Feed direct URI" $ \v -> FeedDirectURI . _unwrapURI+      <$> v .: "direct"+    alternateLink = withObject "Feed alternate link" $ \v -> FeedAlternateLink+      <$> (v .: "alternate" <&> _unwrapURI)+      <*> (v .: "title" <|> pure mempty)++instance ToJSON FeedLocation where+  toJSON (FeedDirectURI uri) = object [ "direct" .= toJSON (JsonURI uri) ]+  toJSON (FeedAlternateLink uri title) = object $ [ "alternate" .= toJSON (JsonURI uri) ] <> [ "title" .= toJSON title | not (Text.null title)]+++-- | A query describes a set of feeds through some criteria.+data FeedQuery = ByDatabaseID Int | ByURI URI | AllFeeds+  deriving(Eq, Ord, Show)++instance Pretty FeedQuery where+  pretty AllFeeds = "All subscribed feeds"   pretty (ByURI u) = prettyURI u+  pretty (ByDatabaseID n) = "database feed" <+> pretty n -data Feed = Rss (RssDocument '[ContentModule, DublinCoreModule]) | Atom AtomFeed++data Feed = Rss (RssDocument (ContentModule (DublinCoreModule NoExtensions))) | Atom AtomFeed   deriving(Eq, Ord, Show) -data FeedElement = RssElement (RssItem '[ContentModule, DublinCoreModule]) | AtomElement AtomEntry+data FeedElement = RssElement (RssItem (ContentModule (DublinCoreModule NoExtensions))) | AtomElement AtomEntry   deriving(Show)  instance Pretty (PrettyKey FeedElement) where@@ -123,7 +149,7 @@ getElements (Atom feed) = map AtomElement $ feedEntries feed  getDate :: FeedElement -> Maybe UTCTime-getDate (RssElement item)   = itemPubDate item <|> elementDate (itemDcMetaData $ item ^. itemExtensionL)+getDate (RssElement item)   = itemPubDate item <|> (item & itemExtensions & itemContentOther & itemDcMetaData & elementDate) getDate (AtomElement entry) = Just $ entryUpdated entry  getTitle :: FeedElement -> Text@@ -132,7 +158,7 @@  getContent :: FeedElement -> Text getContent (RssElement item) = if not (Text.null content) then content else itemDescription item where-  ContentItem content = item ^. itemExtensionL+  content = item & itemExtensions & itemContent getContent (AtomElement entry) = fromMaybe "<empty>" $ content <|> summary where   content = show . prettyAtomContent <$> entryContent entry   summary = show . prettyAtomText <$> entrySummary entry

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-} -- | HTTP module abstracts over HTTP requests to the external world. -- -- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).@@ -9,10 +10,11 @@ module Imm.HTTP where  -- {{{ Imports-import qualified Imm.Logger as Logger-import           Imm.Logger hiding(Handle)+import           Imm.Logger     hiding (Handle)+import qualified Imm.Logger     as Logger import           Imm.Pretty +import           Pipes.Core import           URI.ByteString -- }}} @@ -20,14 +22,14 @@  -- | Handle to perform GET HTTP requests. newtype Handle m = Handle-  { httpGet :: URI -> m LByteString+  { _withGet :: forall a. URI -> (Producer' ByteString m () -> m a) -> m a   }   -- * Primitives --- | Simple wrapper around 'httpGet' that also logs the requested URI.-get :: Monad m => Logger.Handle m -> Handle m -> URI -> m LByteString-get logger handle uri = do-  log logger Debug $ "Fetching " <> prettyURI uri-  httpGet handle uri+-- | Simple wrapper around '_withGet' that also logs the requested URI.+withGet :: Monad m => Logger.Handle m -> Handle m -> URI -> (Producer' ByteString m () -> m a) -> m a+withGet logger handle uri f = do+  log logger Debug $ "GET" <+> prettyURI uri+  _withGet handle uri f

@@ -5,7 +5,6 @@ module Imm.Pretty (module Imm.Pretty, module X) where  -- {{{ Imports-import           Data.Text                                 (Text) import qualified Data.Text                                 as Text import           Data.Time import           Data.Tree@@ -13,8 +12,7 @@ import           Text.Atom.Types                           as Atom -- import           Text.OPML.Types              as OPML hiding (text) -- import qualified Text.OPML.Types              as OPML-import           Data.Text.Prettyprint.Doc                 as X hiding (list,-                                                                 width)+import           Data.Text.Prettyprint.Doc                 as X hiding (list, width) import           Data.Text.Prettyprint.Doc                 (list) import           Data.Text.Prettyprint.Doc.Render.Terminal as X (AnsiStyle) import           Data.Text.Prettyprint.Doc.Render.Terminal

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

@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE TypeFamilies      #-}+module Alternate (AlternateException(..), resolveFeedURI) where++-- {{{ Imports+import           Control.Exception.Safe+import           Data.Aeson+import qualified Data.ByteString.Char8  as Char8+import qualified Data.Text              as Text+import           Imm.Feed+import qualified Imm.HTTP               as HTTP+import           Imm.Logger             as Logger+import           Imm.Pretty+import           Pipes+import           Pipes.ByteString       as Pipes (toHandle)+import           Safe+import           System.IO              (hClose)+import           System.Process.Typed+import           URI.ByteString+-- }}}+++newtype AlternateException = FeedNotFound URI+  deriving(Eq, Show)++instance Exception AlternateException where+  displayException = show . pretty++instance Pretty AlternateException where+  pretty (FeedNotFound uri) = "No feeds found at" <+> prettyURI uri+++data AlternateLink = AlternateLink Text Text Text+  deriving(Eq, Ord, Show)++instance Pretty AlternateLink where+  pretty (AlternateLink title linkType uri) = "Alternate link" <+> braces (hsep parameters) where+    parameters = [ "title" <> equals <> dquotes (pretty title)+                 , "type" <> equals <> dquotes (pretty linkType)+                 , "href" <> equals <> dquotes (pretty uri)+                 ]++instance FromJSON AlternateLink where+  parseJSON (Object v) = AlternateLink <$> v .: "title" <*> v .: "type" <*> v .: "href"+  parseJSON _          = mzero+++data FeedType = RssXml | AtomXml+  deriving(Eq, Ord, Read, Show)++asFeedType :: MonadFail m => Text -> m FeedType+asFeedType "application/rss+xml"  = pure RssXml+asFeedType "application/atom+xml" = pure AtomXml+asFeedType t                      = fail $ "Invalid feed type: " <> show t+++asFeedURI :: MonadFail m => URI -> Text -> m URI+asFeedURI baseURI href = let bytes = encodeUtf8 @Text href in+  case parseURI laxURIParserOptions bytes of+    Right uri -> pure uri+    _ -> case parseRelativeRef laxURIParserOptions bytes of+      Right relativeRef -> pure $ mergeURIs baseURI relativeRef+      Left e            -> fail $ show e++mergeURIs :: URI -> URIRef Relative -> URI+mergeURIs uri relativeRef = URI scheme authority path query fragment where+  scheme = uriScheme uri+  authority = rrAuthority relativeRef <|> uriAuthority uri+  path = mergePaths (uriPath uri) (rrPath relativeRef)+  query = rrQuery relativeRef+  fragment = rrFragment relativeRef++mergePaths :: ByteString -> ByteString -> ByteString+mergePaths basePath path = case Char8.head path of+  '/' -> path+  _   -> basePath <> "/" <> path+++data FeedLink = FeedLink+  { _feedTitle :: Text+  , _feedType  :: FeedType+  , _feedURI   :: URI+  } deriving(Eq, Ord, Show)++asFeedLink :: MonadFail m => URI -> AlternateLink -> m FeedLink+asFeedLink baseURI (AlternateLink a b c) = FeedLink a <$> asFeedType b <*> asFeedURI baseURI c+++extractAlternateLinks :: MonadIO m => Logger.Handle IO -> Producer' ByteString IO () -> m [AlternateLink]+extractAlternateLinks logger html = io $ withProcessWait pup $ \pupProcess -> do+  log logger Debug $ pretty $ show @String pupProcess++  runEffect $ html >-> toHandle (getStdin pupProcess)+  hClose (getStdin pupProcess)++  links <- getStdout pupProcess & atomically <&> decode <&> fromMaybe mempty+  log logger Debug $ "Found alternate links:" <+> pretty links++  return links+  where pup = proc "pup" ["html head link[rel=\"alternate\"] json{}"]+          & setStdin createPipe+          & setStdout byteStringOutput+          & setStderr nullStream+++resolveFeedURI :: m ~ IO => Logger.Handle m -> HTTP.Handle m -> FeedLocation -> m URI+resolveFeedURI _ _ (FeedDirectURI uri) = pure uri+resolveFeedURI logger httpClient (FeedAlternateLink uri title) = HTTP.withGet logger httpClient uri $ \html -> extractAlternateLinks logger html+  <&> concatMap (asFeedLink uri)+  <&> filterByTitle+  <&> maximumByMay compareFeeds+  >>= maybe (throwM $ FeedNotFound uri) (return . _feedURI)+  where filterByTitle = if Text.null title then id else filter (\f -> _feedTitle f == title)+        compareFeeds (FeedLink _ AtomXml _) (FeedLink _ RssXml _) = GT+        compareFeeds (FeedLink _ RssXml _) (FeedLink _ AtomXml _) = LT+        compareFeeds _ _                                          = EQ

@@ -2,69 +2,83 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RankNTypes            #-} {-# LANGUAGE TypeFamilies          #-} module Core (--- * Types-  FeedRef,--- * Actions+  markAsUnprocessed,   subscribe,+  unsubscribe,   listFeeds,-  showFeed,+  describeFeed,   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 qualified Imm.Database.Feed       as Database+import           Imm.Feed+import           Imm.Logger              as Logger+import           Imm.Pretty 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+import           Text.XML.Stream.Parse   as XML (def, force, parseBytes) -- }}}  +markAsUnprocessed :: MonadThrow m+                  => Logger.Handle m+                  -> Database.Handle m+                  -> FeedQuery+                  -> m ()+markAsUnprocessed logger database query = Database.resolveEntryKey database query+  >>= mapM_ (Database.markAsUnprocessed logger database)  -- | 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+describeFeed :: MonadThrow m => Logger.Handle m -> Database.Handle m -> FeedQuery -> m ()+describeFeed logger database feedQuery = do+  entries <- Database.fetchQuery database (Database.matching feedQuery)   flushLogs logger-  log logger Info $ prettyDatabaseEntry entry+  forM_ (Map.toList entries) $ \(index, entry) ->+    log logger Info $ pretty index <+> Database.prettyEntry 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)+-- | Register the given set of feeds in database+subscribe :: MonadCatch m => Logger.Handle m -> Database.Handle m -> FeedLocation -> Set Text -> m ()+subscribe logger database feedLocation tags = do+  index <- Database.register logger database feedLocation tags+  log logger Info $ "Subscribed with index" <+> pretty index +-- | Un-register the given set of feeds from database+unsubscribe :: MonadThrow m+            => Logger.Handle m+            -> Database.Handle m+            -> FeedQuery+            -> m ()+unsubscribe logger database query = Database.resolveEntryKey database query+  >>= Database.delete logger database+ -- | List all subscribed feeds and their status-listFeeds :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> m ()+listFeeds :: MonadCatch m => Logger.Handle m -> Database.Handle m -> 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+  forM_ (zip [0..] $ Map.elems entries) $ \(i, entry) ->+    log logger Info $ pretty (i :: Int) <+> Database.prettyShortEntry 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 :: MonadCatch m => Logger.Handle m -> Database.Handle m -> 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' :: MonadCatch m => Logger.Handle m -> Database.Handle m -> 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' logger database c (Node (OpmlOutlineSubscription _ s) _) = void $ subscribe logger database (FeedDirectURI $ xmlUri s) c importOPML' _ _ _ _ = return ()

@@ -3,49 +3,47 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLists       #-} {-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TupleSections         #-} {-# LANGUAGE UndecidableInstances  #-}--- | Implementation of "Imm.Database" based on a JSON file.+-- | Implementation of "Imm.Database.Feed" based on a JSON file. module Database   ( JsonFileDatabase   , mkJsonFileDatabase   , defaultDatabase   , mkHandle   , JsonException(..)-  , module Imm.Database.FeedTable+  , module Imm.Database.Feed   ) where  -- {{{ Imports-import           Imm.Database                hiding (commit, delete, insert,-                                              purge, update)-import           Imm.Database.FeedTable+import           Imm.Database.Feed           hiding (commit, delete1)+import           Imm.Feed import           Imm.Pretty  import           Control.Concurrent.STM.TVar (swapTVar) import           Control.Exception.Safe import           Data.Aeson+import qualified Data.ByteString             as ByteString 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+import           System.IO                   hiding (Handle) -- }}}  data CacheStatus = Empty | Clean | Dirty   deriving(Eq, Ord, Read, Show) -data JsonFileDatabase t = JsonFileDatabase FilePath (Map (Key t) (Entry t)) CacheStatus+data JsonFileDatabase = JsonFileDatabase FilePath (Map FeedLocation Entry) CacheStatus -instance Pretty (JsonFileDatabase t) where+instance Pretty JsonFileDatabase where   pretty (JsonFileDatabase file _ _) = "JSON database: " <+> pretty file -mkJsonFileDatabase :: (Table t) => FilePath -> JsonFileDatabase t+mkJsonFileDatabase :: FilePath -> JsonFileDatabase 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 :: IO (TVar JsonFileDatabase) defaultDatabase = do   databaseFile <- getXdgDirectory XdgConfig "imm/feeds.json"   newTVarIO $ mkJsonFileDatabase databaseFile@@ -58,22 +56,44 @@   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 :: (MonadIO m, MonadMask m)+         => TVar JsonFileDatabase -> Handle m 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+  , _fetch = \keys -> do+      loadInCache tvar+      database <- readTVarIO tvar+      return $ Map.fromList $ do+        key <- keys+        entry <- maybeToList $ fetchFromCache key database+        return (key, entry)+  , _fetchAll = loadInCache tvar+      >> getCache tvar+      <&> Map.toList+      <&> map snd+      <&> zip [0..]+      <&> Map.fromList   , _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)+  , _insert = \entries -> do+      loadInCache tvar+      atomically $ do+        modifyTVar' tvar $ insertInCache entries+        database <- readTVar tvar+        return $ Map.fromList $ do+          location <- entries <&> entryLocation+          i <- maybeToList $ getIndex location database+          return (location, i)+  , _delete = \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 ()+getIndex :: FeedLocation -> JsonFileDatabase -> Maybe Int+getIndex location (JsonFileDatabase _ cache _) = Map.lookupIndex location cache++loadInCache :: (MonadIO m, MonadMask m) => TVar JsonFileDatabase -> m () loadInCache tvar = do   JsonFileDatabase file _ status <- readTVarIO tvar   when (status == Empty) $ do@@ -82,37 +102,54 @@       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 :: (MonadIO m, MonadMask m) => FilePath -> m JsonFileDatabase loadFromDisk file = do   liftIO $ createDirectoryIfMissing True $ takeDirectory file-  fileContent <- withBinaryFile file ReadWriteMode (toLazy_ . hGetContents)-  cache <- (`failWith` UnableDecode) $ fmap Map.fromList $ decode $ fromEmpty "[]" fileContent+  fileContent <- io $ withBinaryFile file ReadWriteMode ByteString.hGetContents+  cache <- fileContent+    & fromEmpty "[]"+    & decodeStrict+    & fmap Map.fromList+    & (`failWith` UnableDecode)   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 :: MonadIO m => TVar JsonFileDatabase -> m (Map FeedLocation Entry) getCache tvar = do   JsonFileDatabase _ cache _ <- readTVarIO tvar   return cache +fetchFromCache :: EntryKey -> JsonFileDatabase -> Maybe (Int, Entry)+fetchFromCache (ByLocation location) (JsonFileDatabase _ cache _) = (,)+  <$> Map.lookupIndex location cache+  <*> Map.lookup location cache+fetchFromCache (ById i) (JsonFileDatabase _ cache _) = if i >= 0 && i < Map.size cache+  then Just $ (i,) $ snd $ Map.elemAt i cache+  else Nothing -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+insertInCache :: [Entry] -> JsonFileDatabase -> JsonFileDatabase+insertInCache entries (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where+  newCache = Map.union cache $ Map.fromList $ map (\entry -> (entryLocation entry, entry)) entries -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+updateInCache :: [EntryKey] -> (Entry -> Entry) -> JsonFileDatabase -> JsonFileDatabase+updateInCache keys f (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where+  newCache = foldr update1 cache keys+  update1 (ByLocation location) = Map.update (Just . f) location+  update1 (ById i)              = Map.updateAt (const $ Just . f) i -purgeInCache :: Table t => JsonFileDatabase t -> JsonFileDatabase t+deleteInCache :: [EntryKey] -> JsonFileDatabase -> JsonFileDatabase+deleteInCache keys (JsonFileDatabase file oldCache _) = JsonFileDatabase file newCache Dirty where+  newCache = foldr delete1 oldCache keys+  delete1 (ByLocation location) = Map.delete location+  delete1 (ById i)              = Map.deleteAt i++purgeInCache :: JsonFileDatabase -> JsonFileDatabase purgeInCache (JsonFileDatabase file _ _) = JsonFileDatabase file mempty Dirty -commit :: (ToJSON (Key t), ToJSON (Entry t), MonadIO m)-       => TVar (JsonFileDatabase t) -> m ()+commit :: (MonadIO m)+       => TVar JsonFileDatabase -> m () commit tvar = do   JsonFileDatabase file cache status <- atomically $ do     database@(JsonFileDatabase file cache status) <- readTVar tvar

@@ -1,46 +1,27 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-} -- | Implementation of "Imm.HTTP" based on "Network.HTTP.Client".-module HTTP (mkHandle, defaultManager, module Reexport) where+module HTTP (mkHandle) where  -- {{{ Imports import           Imm.HTTP+import           Imm.Logger           hiding (Handle)+import qualified Imm.Logger           as Logger 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+import           Pipes.ByteString+import           System.Process.Typed -- }}} -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+mkHandle :: Logger.Handle IO -> Handle IO+mkHandle logger = Handle $ \uri f ->+  withProcessWait (httpie uri) $ \httpieProcess -> do+    log logger Debug $ pretty $ show @String httpieProcess+    f (fromHandle $ getStdout httpieProcess) --- | 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", "*/*")]}+  where httpie uri = proc "http" ["--timeout", "10", "--follow", "--print", "b", "GET", show $ prettyURI uri]+          & setStdin nullStream+          & setStdout createPipe+          & setStderr nullStream

@@ -7,11 +7,7 @@ {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE TypeApplications      #-} -- {{{ Imports-import           Imm-import           Imm.Database                  as Database-import qualified Imm.HTTP                      as HTTP-import           Imm.Pretty-+import           Alternate import qualified Core import           Database import           HTTP@@ -23,15 +19,16 @@ import           Control.Concurrent.STM.TMChan import           Control.Exception.Safe import           Data.Conduit.Combinators      as Conduit (stdin)-import qualified Data.Map                      as Map import qualified Data.MessagePack              as MsgPack-import qualified Data.Text                     as Text-import qualified Data.Text.IO                  as Text import           Dhall-import           Relude.Unsafe                 (at)+import           Imm+import           Imm.Database.Feed             as Database+import qualified Imm.HTTP                      as HTTP+import           Imm.Pretty+import           Pipes.ByteString import           System.Exit-import           System.IO                     (hFlush) import           System.Process.Typed+import           URI.ByteString -- }}}  @@ -53,94 +50,90 @@     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+      Import            -> Core.importOPML logger database' Conduit.stdin+      Subscribe u c     -> Core.subscribe logger database' u c+      Unsubscribe query -> Core.unsubscribe logger database' query+      List              -> Core.listFeeds logger database'+      Describe query    -> Core.describeFeed logger database query+      Reset feedKeys    -> Core.markAsUnprocessed logger database' feedKeys+      Run f c           -> main2 logger database' f =<< resolveCallbacks c optionCallbacksFile      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+resolveCallbacks :: MonadIO m => CallbackMode -> FilePath -> m [Callback]+resolveCallbacks EnableCallbacks callbacksFile = io $ input auto $ fromString callbacksFile+resolveCallbacks _ _                           = return mempty -  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 +main2 :: Logger.Handle IO -> Database.Handle IO -> FeedQuery -> [Callback] -> IO ()+main2 logger database feedQuery callbacks = do+  let httpClient = HTTP.mkHandle logger -main3 :: Logger.Handle IO -> Database.Handle IO FeedTable -> [Callback] -> [FeedID] -> IO ()-main3 logger database callbacks feedIDs = do-  httpClient <- HTTP.mkHandle <$> defaultManager+  feedLocations <- mapM (Database.resolveFeedLocation database)+    =<< Database.resolveEntryKey database feedQuery +  feedLocationsChan <- newTMChanIO   targetFeedChan <- newTMChanIO   newItemsChan <- newTMChanIO   processedChan <- newTMChanIO++  resolveErrorsChan <- newTMChanIO   fetchErrorsChan <- newTMChanIO+  runErrorsChan <- newTMChanIO   callbackErrorsChan <- newTMChanIO    newItemsCount <- newTVarIO (0 :: Int)   errorsCount <- newTVarIO (0 :: Int)    -- => Feed IDs events-  producer <- async $ forM_ feedIDs $ atomically . writeTMChan targetFeedChan+  producer <- async $ forM_ feedLocations $ atomically . writeTMChan feedLocationsChan -  -- 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+  -- Feed locations => feed direct URIs+  let resolverF feedLocation = do+        uri <- resolveFeedURI logger httpClient feedLocation+        atomically $ writeTMChan targetFeedChan (feedLocation, uri) -          unreadElements <- filterM (fmap not . isRead database feedID) $ getElements feed-          unprocessedElements <- listUnprocessedElements database feedID-          forM_ (unprocessedElements <> 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) )+  resolvers <- spawnConsumers logger 5 feedLocationsChan resolverF resolveErrorsChan errorsCount -        (\e -> atomically $ do-          writeTMChan fetchErrorsChan (feedID, e)-          count <- readTVar errorsCount-          writeTVar errorsCount (count + 1) )+  -- Feed direct URIs events => new item events+  let fetcherF (feedLocation, uri) = do+        feed <- HTTP.withGet logger httpClient uri+          $ toLazyM >=> parseXml xmlParser uri+        let entryKey = ByLocation feedLocation -      recurse+        unreadElements <- filterM (fmap not . isRead database entryKey) $ getElements feed+        unprocessedElements <- listUnprocessedElements database entryKey+        forM_ (unprocessedElements <> unreadElements) $ \element -> do+          log logger Info $ "New item:" <+> magenta (pretty entryKey) <+> "/" <+> yellow (pretty $ getTitle element)+          atomically $ do+            writeTMChan newItemsChan (entryKey, removeElements feed, element)+            modifyTVar' newItemsCount (+ 1) +  fetchers <- spawnConsumers logger 5 targetFeedChan fetcherF fetchErrorsChan errorsCount+   -- 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 $ MsgPack.pack $ Message feed element-            processConfig = proc executable (toString <$> arguments) & setStdin processInput+  let runnerF (entryKey, feed, element) = do+        results <- forM callbacks $ \callback@(Callback executable arguments) -> do+          let processInput = byteStringInput $ MsgPack.pack $ Message feed element+              processConfig = proc executable (toString <$> arguments) & setStdin processInput -        log logger Debug $ "Running" <+> cyan (pretty executable) <+> "on" <+> magenta (pretty feedID) <+> "/" <+> yellow (pretty $ getTitle element)+          log logger Debug $ "Running" <+> cyan (pretty executable) <+> "on" <+> magenta (pretty entryKey) <+> "/" <+> yellow (pretty $ getTitle element) -        (exitCode, output, errors) <- readProcess processConfig-        case exitCode of-          ExitSuccess   -> return $ Right callback-          ExitFailure i -> return $ Left (callback, i, output, errors)+          (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)+        case lefts results of+          [] -> atomically $ writeTMChan processedChan (entryKey, element)+          e  -> atomically $ do+            writeTMChan callbackErrorsChan ((entryKey, element), e)+            modifyTVar' errorsCount (+ 1) -      recurse+  runners <- spawnConsumers logger 5 newItemsChan runnerF runErrorsChan errorsCount    -- Processed events => update database   storer <- async $ fix $ \recurse -> do@@ -152,8 +145,13 @@    -- Wait for all async processes to complete   wait producer-  atomically $ closeTMChan targetFeedChan+  atomically $ closeTMChan feedLocationsChan +  mapM_ wait resolvers+  atomically $ do+    closeTMChan targetFeedChan+    closeTMChan resolveErrorsChan+   mapM_ wait fetchers   atomically $ closeTMChan newItemsChan @@ -162,68 +160,64 @@     closeTMChan processedChan     closeTMChan fetchErrorsChan     closeTMChan callbackErrorsChan+    closeTMChan runErrorsChan    wait storer    -- Error events => log-  printErrors logger fetchErrorsChan callbackErrorsChan+  handleErrors resolveErrorsChan (printResolveError logger)+  handleErrors fetchErrorsChan (printFetchError logger)+  handleErrors callbackErrorsChan (printCallbackError logger)+  handleErrors runErrorsChan (printRunError logger)   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+spawnConsumers :: Logger.Handle IO -> Int -> TMChan i -> (i -> IO ()) -> TMChan (i, SomeException) -> TVar Int -> IO [Async ()]+spawnConsumers logger n inputChan f errorsChan errorsCount =+  replicateM n $ async $ fix $ \recurse -> do+    maybeItem <- atomically $ readTMChan inputChan+    forM_ maybeItem $ \item -> do+      catchAny (f item) $ \e -> do+        log logger Debug $ "Error:" <+> pretty (displayException e)+        atomically $ do+          writeTMChan errorsChan (item, e)+          modifyTVar' errorsCount (+ 1)       recurse --xmlParser :: XML.Handle IO-xmlParser = XML.mkHandle defaultXmlParser-+handleErrors :: MonadIO m => TMChan (input, error) -> ((input, error) -> m ()) -> m ()+handleErrors errorsChan handler = fix $ \recurse -> do+  items <- atomically $ readTMChan errorsChan+  forM_ items $ \(i, e) -> handler (i, e) >> recurse --- * Util+printResolveError :: Exception e => Logger.Handle m -> (FeedLocation, e) -> m ()+printResolveError logger (feedLocation, e) = log logger Error $+  bold ("Resolve error for" <+> pretty feedLocation)+  <++> indent 2 (pretty $ displayException e) -data SafeGuard = AskConfirmation | ByPassConfirmation-  deriving(Eq, Read, Show)+printFetchError :: Exception e => Logger.Handle m -> ((FeedLocation, URIRef a), e) -> m ()+printFetchError logger ((_, uri), e) = log logger Error $+  bold ("Fetch error for" <+> prettyURI uri)+  <++> indent 2 (pretty $ displayException e) -data InterruptedException = InterruptedException deriving(Eq, Read, Show)-instance Exception InterruptedException where-  displayException _ = "Process interrupted"+printCallbackError :: Logger.Handle m -> ((EntryKey, FeedElement), _) -> m ()+printCallbackError logger ((entryKey, element), e) = log logger Error $+  bold ("Callback error for" <+> pretty entryKey <+> "/" <+> pretty (getTitle element))+  <++> indent 2 prettyErrors+  where prettyErrors = vsep $ do+          (callback, i, stdout', stderr') <- e+          return $ "When running:" <+> pretty callback+            <++> "Exit code:" <+> pretty i+            <++> "Stdout:" <++> indent 2 (pretty $ decodeUtf8 @Text stdout')+            <++> "Stderr:" <++> indent 2 (pretty $ decodeUtf8 @Text stderr') -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+printRunError :: Exception e => Logger.Handle m -> ((EntryKey, Feed, FeedElement), e) -> m ()+printRunError logger ((entryKey, _feed, element), e) = log logger Error $+  bold ("Error for" <+> pretty entryKey <+> "/" <+> pretty (getTitle element))+  <++> indent 2 (pretty $ displayException e)  -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+xmlParser :: XML.Handle IO+xmlParser = XML.mkHandle defaultXmlParser

@@ -6,13 +6,12 @@  -- {{{ Imports import           Imm.Feed-import           Imm.Logger                     as Logger+import           Imm.Logger          as Logger import           Imm.Pretty-import qualified Paths_imm                      as Package+import qualified Paths_imm           as Package  import           Data.List-import           Data.Set                       (Set)-import qualified Data.Set                       as Set+import qualified Data.Set            as Set import           Data.Version import           Options.Applicative import           System.Directory@@ -37,7 +36,13 @@   } deriving(Eq, Ord, Read, Show)  -data Command = Import | Subscribe URI (Set Text) | List | ShowFeed FeedRef | OnFeedRef (Maybe FeedRef) CommandOnFeedRef+data Command = Import+             | Subscribe FeedLocation (Set Text)+             | List+             | Describe FeedQuery+             | Reset FeedQuery+             | Run FeedQuery CallbackMode+             | Unsubscribe FeedQuery  deriving instance Eq Command deriving instance Ord Command@@ -45,24 +50,18 @@  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 (Subscribe f _) = "Subscribe to feed:" <+> pretty f   pretty List            = "List all feeds"-  pretty (ShowFeed f)    = "Show details of feed" <+> pretty f+  pretty (Describe f)    = "Describe feed" <+> pretty f+  pretty (Reset q)       = "Mark feeds as unprocessed:" <+> pretty q+  pretty (Run q c)       = "Download new entries from feeds" <> (if c == DisableCallbacks then space <> brackets "callbacks disabled" else mempty) <+> pretty q+  pretty (Unsubscribe q) = "Unsubscribe from feeds:" <+> pretty q   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@@ -87,18 +86,38 @@  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 "import" $ info (pure Import) $ progDesc "Import feeds list from an OPML descriptor (read from stdin)."+  , command "subscribe" $ info subscribeCommand $ progDesc "Subscribe to a feed."+  , command "add" $ info subscribeCommand $ progDesc "Alias for subscribe." -  , 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 "run" $ info runCommand $ progDesc "Update list of feeds."+  , command "describe" $ info describeCommand $ progDesc "Show details about given feed."+  , command "show" $ info describeCommand $ progDesc "Alias for describe."   , 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."+  , command "reset" $ info resetCommand $ progDesc "Mark given feed as unprocessed."+  , command "unsubscribe" $ info unsubscribeCommand $ progDesc "Unsubscribe from a feed."+  , command "remove" $ info unsubscribeCommand $ progDesc "Alias for unsubscribe."   ] +-- {{{ Commands+describeCommand :: Parser Command+describeCommand = Describe <$> feedQueryParser++subscribeCommand :: Parser Command+subscribeCommand    = Subscribe <$> feedLocationParser <*> (Set.fromList <$> many tagOption)++unsubscribeCommand :: Parser Command+unsubscribeCommand  = Unsubscribe <$> feedQueryParser++runCommand :: Parser Command+runCommand = Run+  <$> feedQueryParser+  <*> flag EnableCallbacks DisableCallbacks (long "no-callbacks" <> help "Disable callbacks.")++resetCommand :: Parser Command+resetCommand = Reset <$> feedQueryParser+-- }}}+ -- {{{ Log options verboseFlag, quietFlag, logLevel :: Parser LogLevel verboseFlag = flag' Logger.Debug $ long "verbose" <> short 'v' <> help "Set log level to DEBUG."@@ -113,16 +132,9 @@ 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" -- }}}@@ -131,8 +143,17 @@ uriReader :: ReadM URI uriReader = eitherReader $ first show . parseURI laxURIParserOptions . encodeUtf8 @Text . fromString -feedRefOption :: Parser FeedRef-feedRefOption = argument ((ByUID <$> auto) <|> (ByURI <$> uriReader)) $ metavar "TARGET"+feedLocationParser :: Parser FeedLocation+feedLocationParser = byUri <|> byAlternateLink where+  byUri = FeedDirectURI <$> option uriReader (long "uri" <> short 'u' <> metavar "URI" <> help "URI to feed")+  byAlternateLink = FeedAlternateLink+    <$> option uriReader (long "alternate" <> short 'a' <> metavar "URI" <> help "URI to webpage with alternate link")+    <*> (strOption (long "title" <> short 't' <> help "Alternate link title") <|> pure mempty)++feedQueryParser :: Parser FeedQuery+feedQueryParser = argument parser (metavar "TARGET") <|> allFeeds where+  parser = (ByDatabaseID <$> auto) <|> (ByURI <$> uriReader)+  allFeeds = flag' AllFeeds $ short 'a' <> long "all" <> help "Run action on all subscribed feeds."  uriArgument :: String -> Parser URI uriArgument helpText = argument uriReader $ metavar "URI" <> help helpText

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

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

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