imm 1.10.0.0 → 2.0.0.0
raw patch · 36 files changed
+1892/−1281 lines, 36 filesdep +aeson-prettydep +beam-coredep +beam-sqlitedep −avrodep −binarydep −fast-loggerdep ~atom-conduitdep ~refineddep ~rss-conduit
Dependencies added: aeson-pretty, beam-core, beam-sqlite, chronos, co-log, http-client, http-types, parsec, parsers, pipes-http, sqlite-simple, streamly, typerep-map
Dependencies removed: avro, binary, fast-logger, hashable, opml-conduit
Dependency ranges changed: atom-conduit, refined, rss-conduit
Files
- README.md +5/−12
- default.nix +19/−22
- idl/callback.json +0/−14
- imm.cabal +28/−14
- schema/imm.json +115/−0
- src/lib/Imm.hs +5/−6
- src/lib/Imm/Callback.hs +45/−18
- src/lib/Imm/Database/Feed.hs +0/−307
- src/lib/Imm/Feed.hs +163/−117
- src/lib/Imm/HTTP.hs +10/−6
- src/lib/Imm/Link.hs +118/−0
- src/lib/Imm/Logger.hs +1/−3
- src/lib/Imm/Pretty.hs +20/−32
- src/lib/Imm/XML.hs +1/−1
- src/lib/Prelude.hs +14/−2
- src/lib/URI/ByteString/Extended.hs +55/−0
- src/main/Alternate.hs +13/−45
- src/main/Core.hs +81/−50
- src/main/Database.hs +0/−164
- src/main/Database/Async.hs +68/−0
- src/main/Database/Handle.hs +180/−0
- src/main/Database/ReadOnly.hs +22/−0
- src/main/Database/Record.hs +150/−0
- src/main/Database/SQLite.hs +295/−0
- src/main/HTTP.hs +13/−15
- src/main/Input.hs +149/−0
- src/main/Logger.hs +44/−37
- src/main/Main.hs +135/−160
- src/main/Options.hs +0/−165
- src/main/Output.hs +27/−0
- src/main/Prelude.hs +14/−2
- src/main/XML.hs +4/−5
- src/send-mail/Main.hs +29/−33
- src/send-mail/Prelude.hs +14/−2
- src/write-file/Main.hs +41/−47
- src/write-file/Prelude.hs +14/−2
README.md view
@@ -25,7 +25,6 @@ ``` 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@@ -34,7 +33,7 @@ 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 [Avro][4]-encoded binary data, which schema is described in file [`idl/callback.json`](idl/callback.json).+*imm* will call each callback once per feed item, and will fill its standard input (`stdin`) with a JSON structure, which schema is described in file [`schema/imm.json`](schema/imm.json). Callback process is expected 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. @@ -88,17 +87,12 @@ - Subscribe to a feed through direct URL: ```bash- imm subscribe -u http://your.feed.org+ imm subscribe 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- imm import < feeds.opml+ imm subscribe http://your.website.org ``` - List subscribed feeds:@@ -108,12 +102,12 @@ - Show details about a feed: ```bash- imm show http://your.feed.org+ imm show 10 # 10 is the index of a subscribed feed, as shown with `imm list` ``` - Unsubscribe from a feed: ```bash- imm unsubscribe http://your.feed.org+ imm unsubscribe 10 # 10 is the index of a subscribed feed, as shown with `imm list` ``` - Check for new elements without executing any action:@@ -129,4 +123,3 @@ [1]: http://hackage.haskell.org/package/imm [2]: https://www.haskell.org [3]: https://dhall-lang.org/-[4]: https://avro.apache.org/
default.nix view
@@ -6,30 +6,25 @@ source = nixpkgs.nix-gitignore.gitignoreSource [ ] ./.; packageWithoutRuntimeDependencies = myHaskellPackages.callCabal2nix "imm" source { };- packageWithRuntimeDependencies =+ packageWithRuntimeDependencies = with nixpkgs; addRuntimeDependencies packageWithoutRuntimeDependencies [- nixpkgs.httpie- nixpkgs.pup+ pup+ sqliteInteractive ]; exe = hlib.justStaticExecutables packageWithRuntimeDependencies; - my-avro = {- pkg = "avro";- ver = "0.5.2.0";- sha256 = "0inznspd7lwrc4z7bz12zrdh75zmyibidyb5yblxd3vmni68dx5c";- };- my-atom-conduit = { pkg = "atom-conduit";- ver = "0.8.0.0";- sha256 = "17p8180dz3kv9ljfhjqspxp6km50xdcgsdnkknz9w3nfbkpk0l25";+ ver = "0.9.0.0";+ sha256 = "11x41fxj0g93kg46z06i1kxfms84wqbad41i7fnm7ixpw4n464pp"; }; - my-opml-conduit = {- pkg = "opml-conduit";- ver = "0.8.0.0";- sha256 = "14106j2rr6fk6hjhypm5hp1dk1rlxf7svswbj21ad3l40nx7qm7r";+ my-beam = nixpkgs.fetchFromGitHub {+ owner = "haskell-beam";+ repo = "beam";+ rev = "3bde0615b6eccfe5ca44ed907b79a3cd74eee33f";+ sha256 = "0fy8p70pxhrllr2njwxa8lijf35hlds2zkhh7fkkv5b3i34jqx29"; }; my-rss-conduit = {@@ -45,9 +40,10 @@ hlib.dontCheck (hlib.dontHaddock (hsuper.callHackageDirect x { })); in { imm = packageWithRuntimeDependencies;- avro = fromHackage my-avro; atom-conduit = fromHackage my-atom-conduit;- opml-conduit = fromHackage my-opml-conduit;+ beam-core = hself.callCabal2nix "beam-core" "${my-beam}/beam-core" {};+ beam-migrate = hself.callCabal2nix "beam-core" "${my-beam}/beam-migrate" {};+ beam-sqlite = hself.callCabal2nix "beam-core" "${my-beam}/beam-sqlite" {}; rss-conduit = fromHackage my-rss-conduit; }; };@@ -67,11 +63,12 @@ shell = myHaskellPackages.shellFor { packages = p: [ p.imm ]; - buildInputs = with nixpkgs.haskellPackages; [- cabal-install- haskell-ci- hlint- ghcid+ buildInputs = with nixpkgs; [+ haskellPackages.cabal-install+ haskellPackages.haskell-ci+ haskellPackages.hlint+ haskellPackages.ghcid+ sqliteInteractive ]; withHoogle = false;
− idl/callback.json
@@ -1,14 +0,0 @@-{- "type": "record",- "name": "message",- "fields": [- {- "name": "feed",- "type": "string"- },- {- "name": "element",- "type": "string"- }- ]-}
imm.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: imm-version: 1.10.0.0-synopsis: Execute arbitrary callbacks for each element of RSS/Atom feeds+version: 2.0.0.0+synopsis: Execute arbitrary actions for each item from RSS/Atom feeds description: Cf README file homepage: https://github.com/k0ral/imm license: CC0-1.0@@ -11,8 +11,8 @@ category: Web build-type: Simple data-files: data/*.dhall-extra-source-files: README.md, *.nix, idl/*.json-tested-with: GHC <8.10 && >=8.4.2+extra-source-files: README.md, *.nix, schema/*.json+tested-with: GHC <8.12 && >=8.4.4 source-repository head type: git@@ -29,34 +29,35 @@ exposed-modules: Imm Imm.Callback- Imm.Database.Feed Imm.Feed Imm.HTTP+ Imm.Link Imm.Logger Imm.Pretty Imm.XML+ URI.ByteString.Extended other-modules: Data.Aeson.Extended build-depends: aeson,- async,- avro,+ aeson-pretty, atom-conduit >= 0.7,- binary, conduit, containers, dhall >= 1.27, directory >= 1.2.3.0, filepath,- hashable,+ http-client, microlens,- monad-time,+ parsec,+ parsers, pipes, pipes-bytestring, prettyprinter, prettyprinter-ansi-terminal, refined >=0.4.1, rss-conduit >= 0.5.1,+ safe, safe-exceptions, text, time,@@ -70,23 +71,36 @@ executable imm import: common- build-depends: imm, aeson, async, atom-conduit >=0.7, avro >=0.5, bytestring, conduit, containers, dhall >= 1.27, directory, fast-logger, filepath, 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+ build-depends: imm, aeson, async, beam-core, beam-sqlite, bytestring, chronos, co-log, conduit, containers, dhall >= 1.27, directory, filepath, http-types, microlens, monad-time, optparse-applicative, prettyprinter-ansi-terminal, pipes, pipes-bytestring, pipes-http, safe, safe-exceptions, sqlite-simple, stm, stm-chans, streamly, text, time, typed-process, typerep-map, uri-bytestring, xml-conduit >=1.5, xml-types main-is: Main.hs- other-modules: Alternate, Core, Database, HTTP, Logger, Options, Paths_imm, XML+ other-modules: + Alternate+ Core+ Database.Async+ Database.Handle+ Database.ReadOnly+ Database.Record+ Database.SQLite+ HTTP+ Input+ Logger+ Output+ 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, atom-conduit, blaze-html, blaze-markup, bytestring, directory, filepath, optparse-applicative, prettyprinter, rss-conduit, text, time, uri-bytestring+ build-depends: imm, aeson, blaze-html, blaze-markup, bytestring, directory, filepath, optparse-applicative, prettyprinter, safe-exceptions, 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, atom-conduit, blaze-html, blaze-markup, bytestring, dhall >= 1.27, directory, filepath, mime-mail, optparse-applicative, prettyprinter, refined, rss-conduit, text, time, typed-process, uri-bytestring+ build-depends: imm, aeson, blaze-html, blaze-markup, bytestring, dhall >= 1.27, directory, filepath, mime-mail, optparse-applicative, prettyprinter, refined, safe-exceptions, text, time, typed-process, uri-bytestring main-is: Main.hs hs-source-dirs: src/send-mail ghc-options: -Wall -fno-warn-unused-do-bind -threaded
+ schema/imm.json view
@@ -0,0 +1,115 @@+{+ "$schema": "http://json-schema.org/draft-07/schema#",+ "definitions": {+ "CallbackMessage": {+ "type": "object",+ "properties": {+ "feed_definition": {+ "$ref": "#/definitions/FeedDefinition"+ },+ "feed_item": {+ "$ref": "#/definitions/ItemDefinition"+ }+ }+ },+ "FeedDefinition": {+ "type": "object",+ "properties": {+ "title": {+ "type": "string"+ }+ }+ },+ "ItemDefinition": {+ "type": "object",+ "properties": {+ "date": {+ "type": "string",+ "format": "datetime"+ },+ "title": {+ "type": "string"+ },+ "content": {+ "type": "string"+ },+ "links": {+ "type": "array",+ "items": {+ "$ref": "#/definitions/Link"+ }+ },+ "authors": {+ "type": "array",+ "items": {+ "$ref": "#/definitions/Author"+ }+ },+ "identifier": {+ "type": "string"+ }+ }+ },+ "Link": {+ "type": "object",+ "properies": {+ "relation": {+ "$ref": "#/definitions/Relation"+ },+ "title": {+ "type": "string"+ },+ "type": {+ "$ref": "#/definitions/MediaType"+ },+ "uri": {+ "type": "string",+ "format": "uri"+ }+ }+ },+ "Relation": {+ "type": "object",+ "properties": {+ "tag": {+ "type": "string"+ }+ }+ },+ "MediaType": {+ "type": "object",+ "properties": {+ "type": {+ "type": "string"+ },+ "subtype": {+ "type": "string"+ },+ "suffix": {+ "type": "string"+ },+ "parameters": {+ "type": "array",+ "items": {+ "type": "string"+ }+ }+ }+ },+ "Author": {+ "type": "object",+ "properies": {+ "name": {+ "type": "string"+ },+ "email": {+ "type": "string"+ },+ "uri": {+ "type": "string",+ "format": "uri"+ }+ }+ }+ }+}
src/lib/Imm.hs view
@@ -1,9 +1,8 @@ -- | Meta-module that reexports many Imm sub-modules. module Imm (module X) where -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)+import Imm.Callback as X+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)
src/lib/Imm/Callback.hs view
@@ -1,21 +1,24 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}-module Imm.Callback (Callback(..), serializeMessage, deserializeMessage) where+module Imm.Callback (Callback(..), CallbackMessage(..), runCallback) where -- {{{ Imports-import Imm.Feed--import qualified Data.Avro as Avro-import Data.Avro.Deriving+import Data.Aeson+import Data.Aeson.Encode.Pretty import Data.Text.Prettyprint.Doc import Dhall hiding (maybe)+import Imm.Feed+import Imm.Logger as Logger+import Imm.Pretty+import System.Exit+import System.Process.Typed -- }}} -- | External program run for each feed element. ----- Data is passed to that program through standard input (@stdin@), using Avro (<https://hackage.haskell.org/package/avro>) serialization format. The data schema is described in file @ids/callback.json@, provided with this library.+-- Data is passed to that program through standard input (@stdin@). data Callback = Callback { _executable :: FilePath , _arguments :: [Text]@@ -26,17 +29,41 @@ instance Pretty Callback where pretty (Callback executable arguments) = pretty executable <+> sep (pretty <$> arguments) +-- | Data structure passed to the external program, through JSON format.+--+-- The data schema is described in file @schema/imm.json@, provided with this library.+data CallbackMessage = CallbackMessage+ { _callbackFeedDefinition :: FeedDefinition+ , _callbackFeedItem :: FeedItem+ } deriving(Eq, Generic, Ord, Show, Typeable) -deriveAvroWithOptions defaultDeriveOptions "idl/callback.json"+customOptions :: Options+customOptions = defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_callback")+ , omitNothingFields = True+ } --- | Meant to be called by the main @imm@ process.-serializeMessage :: Feed -> FeedElement -> LByteString-serializeMessage feed element = Avro.encodeValue $ Message (renderFeed feed) (renderFeedElement element)+instance ToJSON CallbackMessage where+ toJSON = genericToJSON customOptions+ toEncoding = genericToEncoding customOptions --- | Meant to be called by callback process.-deserializeMessage :: MonadFail m => LByteString -> m (Feed, FeedElement)-deserializeMessage bytestring = do- Message feedText elementText <- Avro.decodeValue bytestring & either fail pure- feed <- parseFeed feedText & either (fail . displayException) pure- element <- parseFeedElement elementText & either (fail . displayException) pure- return (feed, element)+instance FromJSON CallbackMessage where+ parseJSON = genericParseJSON customOptions++instance Pretty (PrettyShort CallbackMessage) where+ pretty (PrettyShort (CallbackMessage feed item)) = prettyName feed <+> "/" <+> pretty (_itemTitle item)+++runCallback :: MonadIO m+ => Logger.Handle m -> Callback -> CallbackMessage -> m (Either (Callback, Int, LByteString, LByteString) (Callback, LByteString, LByteString))+runCallback logger callback@(Callback executable arguments) message = do+ log logger Info $ "Running" <+> cyan (pretty executable) <+> "on" <+> prettyShort message+ log logger Debug $ "Callback message:" <+> pretty (decodeUtf8 @Text $ encodePretty message)++ let processInput = byteStringInput $ encode message+ processConfig = proc executable (toString <$> arguments) & setStdin processInput+ (exitCode, output, errors) <- readProcess processConfig++ case exitCode of+ ExitSuccess -> return $ Right (callback, output, errors)+ ExitFailure i -> return $ Left (callback, i, output, errors)
− src/lib/Imm/Database/Feed.hs
@@ -1,307 +0,0 @@-{-# 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
src/lib/Imm/Feed.hs view
@@ -1,181 +1,227 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeOperators #-}--- | Helpers to manipulate feeds-module Imm.Feed where+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+-- | Feed data structures.+module Imm.Feed+ ( -- * Types+ FeedLocation(..)+ , UID+ , FeedQuery(..)+ , FeedDefinition(..)+ , FeedItem(..)+ , Author(..)+ , -- * Parsers+ parseFeed+ , feedC+ , parseFeedItem+ , -- * Utilities+ getMainLink+ , areSameItem+ ) where -- {{{ Imports-import Imm.Pretty- 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 Data.XML.Types+import Imm.Link+import Imm.Pretty+import Refined+import Safe 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.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+import URI.ByteString.Extended -- }}} --- * Types- -- | 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)+data FeedLocation = FeedLocation URI Text+ deriving(Eq, Generic, Ord, Show, Typeable) instance Pretty FeedLocation where- pretty (FeedDirectURI uri) = prettyURI uri- pretty (FeedAlternateLink uri title) = prettyURI uri+ pretty (FeedLocation uri title) = prettyURI uri <> if Text.null title then mempty else space <> brackets (pretty title) +instance ToJSON FeedLocation where+ toJSON (FeedLocation uri title) = object+ [ "uri" .= toJSON (JsonURI uri)+ , "title" .= 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)+ parseJSON = withObject "FeedLocation" $ \v -> do+ FeedLocation <$> (_unwrapURI <$> (v .: "uri")) <*> (v .: "title") -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)] +-- | Database identifier for a feed+type UID = Int -- | A query describes a set of feeds through some criteria.-data FeedQuery = ByDatabaseID Int | ByURI URI | AllFeeds- deriving(Eq, Ord, Show)+data FeedQuery = QueryByUID UID | QueryAll+ deriving(Eq, Ord, Read, Show, Typeable) instance Pretty FeedQuery where- pretty AllFeeds = "All subscribed feeds"- pretty (ByURI u) = prettyURI u- pretty (ByDatabaseID n) = "database feed" <+> pretty n+ pretty QueryAll = "All subscribed feeds"+ pretty (QueryByUID k) = "Feed" <+> pretty k -data Feed = Rss (RssDocument (ContentModule (DublinCoreModule NoExtensions))) | Atom AtomFeed- deriving(Eq, Ord, Show)+newtype FeedDefinition = FeedDefinition+ { _feedTitle :: Text+ } deriving(Eq, Generic, Ord, Read, Show, Typeable) -data FeedElement = RssElement (RssItem (ContentModule (DublinCoreModule NoExtensions))) | AtomElement AtomEntry- deriving(Show)+feedDefinitionOptions :: Options+feedDefinitionOptions = defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_feed")+ , omitNothingFields = True+ } -instance Pretty (PrettyKey FeedElement) where- pretty (PrettyKey element) = "element" <+> pretty (getTitle element)+instance ToJSON FeedDefinition where+ toJSON = genericToJSON feedDefinitionOptions+ toEncoding = genericToEncoding feedDefinitionOptions -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 FromJSON FeedDefinition where+ parseJSON = genericParseJSON feedDefinitionOptions -instance Eq FeedElement where- element1 == element2 = compare element1 element2 == EQ+instance Pretty FeedDefinition where+ pretty definition = pretty $ _feedTitle definition +instance Pretty (PrettyName FeedDefinition) where+ pretty (PrettyName definition) = pretty $ _feedTitle definition -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+data Author = Author+ { _authorName :: Text+ , _authorEmail :: Text+ , _authorURI :: Maybe AnyURI+ } deriving(Eq, Generic, Ord, Show, Typeable) -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+authorOptions :: Options+authorOptions = defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_author")+ , omitNothingFields = True+ } -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+instance ToJSON Author where+ toJSON = genericToJSON authorOptions+ toEncoding = genericToEncoding authorOptions +instance FromJSON Author where+ parseJSON = genericParseJSON authorOptions -withFeedURI :: (forall a . URIRef a -> b) -> FeedURI -> b-withFeedURI f (FeedURI a) = f a+instance Pretty Author where+ pretty Author{..} = pretty _authorName <+> brackets (pretty _authorEmail) --- * Generic parsers/renderers+data FeedItem = FeedItem+ { _itemDate :: Maybe UTCTime+ , _itemTitle :: Text+ , _itemContent :: Text+ , _itemLinks :: [Link]+ , _itemIdentifier :: Text+ , _itemAuthors :: [Author]+ } deriving(Eq, Generic, Ord, Show, Typeable) -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+feedItemOptions :: Options+feedItemOptions = defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_item")+ , omitNothingFields = True+ } -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+instance ToJSON FeedItem where+ toJSON = genericToJSON feedItemOptions+ toEncoding = genericToEncoding feedItemOptions -parseFeed :: MonadCatch m => Text -> m Feed-parseFeed text = runConduit $ parseLBS def (encodeUtf8 text) .| XML.force "Invalid feed" (choose [fmap Atom <$> atomFeed, fmap Rss <$> rssDocument, fmap Rss <$> rss1Document])+instance FromJSON FeedItem where+ parseJSON = genericParseJSON feedItemOptions -parseFeedElement :: MonadCatch m => Text -> m FeedElement-parseFeedElement text = runConduit $ parseLBS def (encodeUtf8 text) .| XML.force "Invalid feed element" (choose [fmap AtomElement <$> atomEntry, fmap RssElement <$> rssItem, fmap RssElement <$> rss1Item])+instance Pretty (PrettyName FeedItem) where+ pretty (PrettyName item) = pretty (_itemTitle item) +instance Pretty FeedItem where+ pretty FeedItem{..} = maybe "<unknown>" prettyTime _itemDate <+> pretty _itemTitle --- * Generic mutators -removeElements :: Feed -> Feed-removeElements (Rss rss) = Rss $ rss { channelItems = mempty }-removeElements (Atom atom) = Atom $ atom { feedEntries = mempty }+parseFeed :: MonadCatch m => Text -> m (FeedDefinition, [FeedItem])+parseFeed text = runConduit $ parseLBS def (encodeUtf8 text) .| XML.force "Invalid feed" feedC +parseAtomFeed :: AtomFeed -> (FeedDefinition, [FeedItem])+parseAtomFeed feed = (definition, items) where+ definition = FeedDefinition (show $ prettyAtomText $ feedTitle feed)+ items = parseAtomItem <$> feedEntries feed --- * Generic getters+parseRssFeed :: RssDocument (ContentModule (DublinCoreModule NoExtensions)) -> (FeedDefinition, [FeedItem])+parseRssFeed doc = (definition, items) where+ definition = FeedDefinition (channelTitle doc)+ items = parseRssItem <$> channelItems doc -getFeedTitle :: Feed -> Text-getFeedTitle (Rss doc) = channelTitle doc-getFeedTitle (Atom feed) = show $ prettyAtomText $ feedTitle feed+-- | Conduit version of 'parseFeed'+feedC :: MonadCatch m => ConduitT Event o m (Maybe (FeedDefinition, [FeedItem]))+feedC = choose [atom, rss, rss1] where+ atom = fmap parseAtomFeed <$> atomFeed+ rss = fmap parseRssFeed <$> rssDocument+ rss1 = fmap parseRssFeed <$> rss1Document -getElements :: Feed -> [FeedElement]-getElements (Rss doc) = map RssElement $ channelItems doc-getElements (Atom feed) = map AtomElement $ feedEntries feed+parseFeedItem :: MonadCatch m => Text -> m FeedItem+parseFeedItem text = runConduit $ parseLBS def (encodeUtf8 text) .| XML.force "Invalid feed element" (choose [fmap parseAtomItem <$> atomEntry, fmap parseRssItem <$> rssItem, fmap parseRssItem <$> rss1Item]) -getDate :: FeedElement -> Maybe UTCTime-getDate (RssElement item) = itemPubDate item <|> (item & itemExtensions & itemContentOther & itemDcMetaData & elementDate)-getDate (AtomElement entry) = Just $ entryUpdated entry+parseAtomItem :: AtomEntry -> FeedItem+parseAtomItem entry = FeedItem date title content links identifier authors where+ date = Just $ entryUpdated entry+ title = show $ prettyAtomText $ entryTitle entry+ content = fromMaybe "<empty>" $ rawContent <|> summary+ rawContent = show . prettyAtomContent <$> entryContent entry+ summary = show . prettyAtomText <$> entrySummary entry+ links = parseLink <$> entryLinks entry+ parseLink link = Link (pure $ fromMaybe Alternate $ parseRelation $ linkRel link) (linkTitle link) (parseMediaType $ linkType link) (withAtomURI AnyURI $ linkHref link)+ identifier = entryId entry+ authors = [Author (unrefine name) email (withAtomURI AnyURI <$> uri) | AtomPerson name email uri <- entryAuthors entry] -getTitle :: FeedElement -> Text-getTitle (RssElement item) = itemTitle item-getTitle (AtomElement entry) = show $ prettyAtomText $ entryTitle entry+parseRssItem :: RssItem (ContentModule (DublinCoreModule NoExtensions)) -> FeedItem+parseRssItem item = FeedItem date title content links identifier authors where+ date = itemPubDate item <|> (item & itemExtensions & itemContentOther & itemDcMetaData & elementDate)+ title = itemTitle item+ content = if not (Text.null rawContent) then rawContent else itemDescription item+ rawContent = item & itemExtensions & itemContent+ links = [Link (Just Alternate) mempty mzero (withRssURI AnyURI uri) | uri <- maybeToList $ itemLink item]+ identifier = itemGuid item <&> prettyGuid & maybe mempty show+ authors = [Author (itemAuthor item) mempty mzero] -getContent :: FeedElement -> Text-getContent (RssElement item) = if not (Text.null content) then content else itemDescription item where- content = item & itemExtensions & itemContent-getContent (AtomElement entry) = fromMaybe "<empty>" $ content <|> summary where- content = show . prettyAtomContent <$> entryContent entry- summary = show . prettyAtomText <$> entrySummary 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+-- TODO: replace headMay with singleMay+getMainLink :: FeedItem -> Maybe Link+getMainLink item = _itemLinks item & filter (\l -> _linkRelation l == Just Alternate) & headMay -getId :: FeedElement -> Text-getId (RssElement item) = itemGuid item <&> prettyGuid & maybe mempty show-getId (AtomElement entry) = entryId entry+haveSameIdentifier :: FeedItem -> FeedItem -> Maybe Bool+haveSameIdentifier item1 item2 = case (_itemIdentifier item1, _itemIdentifier item2) of+ ("", "") -> Nothing+ (a, b) -> Just (a == b) --- * Misc+haveSameLink :: FeedItem -> FeedItem -> Maybe Bool+haveSameLink item1 item2 = case (getMainLink item1, getMainLink item2) of+ (Just a, Just b) -> Just (a == b)+ (Nothing, Nothing) -> Nothing+ _ -> Just False -prettyElement :: FeedElement -> Doc a-prettyElement (RssElement item) = prettyItem item-prettyElement (AtomElement entry) = prettyEntry entry+haveSameTitle :: FeedItem -> FeedItem -> Maybe Bool+haveSameTitle item1 item2 = case (_itemTitle item1, _itemTitle item2) of+ ("" :: Text, "" :: Text) -> Nothing+ (a, b) -> Just (a == b)++areSameItem :: FeedItem -> FeedItem -> Bool+areSameItem a b = fromMaybe (comparing _itemContent a b == EQ) $ haveSameIdentifier a b <|> haveSameLink a b <|> haveSameTitle a b
src/lib/Imm/HTTP.hs view
@@ -7,13 +7,17 @@ -- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html). -- -- > import qualified Imm.HTTP as HTTP-module Imm.HTTP where+module Imm.HTTP+ ( module Imm.HTTP+ , module Network.HTTP.Client+ ) where -- {{{ Imports-import Imm.Logger hiding (Handle)-import qualified Imm.Logger as Logger+import Imm.Logger hiding (Handle)+import qualified Imm.Logger as Logger import Imm.Pretty +import Network.HTTP.Client import Pipes.Core import URI.ByteString -- }}}@@ -22,14 +26,14 @@ -- | Handle to perform GET HTTP requests. newtype Handle m = Handle- { _withGet :: forall a. URI -> (Producer' ByteString m () -> m a) -> m a+ { _withGet :: forall a. URI -> (Response (Producer ByteString m ()) -> m a) -> m a } -- * Primitives -- | 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 :: Monad m => Logger.Handle m -> Handle m -> URI -> (Response (Producer ByteString m ()) -> m a) -> m a withGet logger handle uri f = do- log logger Debug $ "GET" <+> prettyURI uri+ log logger Info $ "GET" <+> prettyURI uri _withGet handle uri f
+ src/lib/Imm/Link.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeApplications #-}+-- | Simplified model for RFC 8288 links.+--+-- Cf <https://tools.ietf.org/html/rfc8288> . .+module Imm.Link+ ( Link(..)+ , Relation(..)+ , parseRelation+ , MediaType(..)+ , parseMediaType+ , pattern MediaTypeRSS+ , pattern MediaTypeAtom+ , pattern MediaTypeApplicationXML+ , pattern MediaTypeTextXML+ , pattern MediaTypeHTML+ ) where++import Data.Aeson+import Text.Parsec (Stream, parse)+import Text.Parser.Char+import URI.ByteString.Extended+++data Link = Link+ { _linkRelation :: Maybe Relation+ , _linkTitle :: Text+ , _linkType :: Maybe MediaType+ , _linkURI :: AnyURI+ } deriving(Eq, Generic, Ord, Show, Typeable)++linkOptions :: Options+linkOptions = defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_link")+ , omitNothingFields = True+ }++instance ToJSON Link where+ toJSON = genericToJSON linkOptions+ toEncoding = genericToEncoding linkOptions++instance FromJSON Link where+ parseJSON = genericParseJSON linkOptions+++-- | Cf <https://www.iana.org/assignments/link-relations/link-relations.xhtml> .+data Relation = Alternate | Edit | Next | NoFollow | Replies | Self | OtherRelation Text+ deriving (Eq, Generic, Ord, Read, Show, Typeable)++instance ToJSON Relation where+ toEncoding = genericToEncoding defaultOptions++instance FromJSON Relation++parseRelation :: Text -> Maybe Relation+parseRelation "alternate" = pure Alternate+parseRelation "edit" = pure Edit+parseRelation "next" = pure Next+parseRelation "nofollow" = pure NoFollow+parseRelation "replies" = pure Replies+parseRelation "self" = pure Self+parseRelation "" = Nothing+parseRelation t = pure $ OtherRelation t+++-- | https://tools.ietf.org/html/rfc6838+-- https://en.wikipedia.org/wiki/Media_type+data MediaType = MediaType+ { _mediaType :: Text+ , _mediaSubtype :: Text+ , _mediaSuffix :: Text+ , _mediaParameters :: [Text]+ } deriving (Eq, Generic, Ord, Read, Show, Typeable)++mediaTypeOptions :: Options+mediaTypeOptions = defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_media")+ , omitNothingFields = True+ }++instance ToJSON MediaType where+ toJSON = genericToJSON mediaTypeOptions+ toEncoding = genericToEncoding mediaTypeOptions++instance FromJSON MediaType where+ parseJSON = genericParseJSON mediaTypeOptions+++parseMediaType :: Stream s Identity Char => s -> Maybe MediaType+parseMediaType = either (const Nothing) pure . parse parser "" where+ parser = do+ t <- some $ noneOf "/"+ char '/'+ subtype <- some $ noneOf "+;"+ suffix <- optional $ char '+' >> some (noneOf ";")+ parameters <- many $ char ';' >> some (noneOf ";")++ return $ MediaType (toText t) (toText subtype) (toText $ fromMaybe mempty suffix) $ map toText parameters+++pattern MediaTypeRSS :: [Text] -> MediaType+pattern MediaTypeRSS parameters = MediaType "application" "rss" "xml" parameters++pattern MediaTypeAtom :: [Text] -> MediaType+pattern MediaTypeAtom parameters = MediaType "application" "atom" "xml" parameters++pattern MediaTypeApplicationXML :: Text -> [Text] -> MediaType+pattern MediaTypeApplicationXML suffix parameters = MediaType "application" "xml" suffix parameters++pattern MediaTypeTextXML :: Text -> [Text] -> MediaType+pattern MediaTypeTextXML suffix parameters = MediaType "text" "xml" suffix parameters++pattern MediaTypeHTML :: Text -> [Text] -> MediaType+pattern MediaTypeHTML suffix parameters = MediaType "text" "html" suffix parameters
src/lib/Imm/Logger.hs view
@@ -17,11 +17,9 @@ -- * Types data Handle m = Handle- { log :: LogLevel -> Doc AnsiStyle -> m ()+ { log :: LogLevel -> Doc AnsiStyle -> m () , getLogLevel :: m LogLevel , setLogLevel :: LogLevel -> m ()- , setColorizeLogs :: Bool -> m ()- , flushLogs :: m () } data LogLevel = Debug | Info | Warning | Error
src/lib/Imm/Pretty.hs view
@@ -6,18 +6,16 @@ -- {{{ Imports 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 import Data.Text.Prettyprint.Doc as X hiding (list, width) import Data.Text.Prettyprint.Doc (list) import Data.Text.Prettyprint.Doc.Render.Terminal as X (AnsiStyle) import Data.Text.Prettyprint.Doc.Render.Terminal import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty+import Data.Time+import Data.Tree+import Data.XML.Types as XML import Refined+import Text.Atom.Types as Atom import Text.RSS.Types as RSS import URI.ByteString -- }}}@@ -26,6 +24,22 @@ -- | Newtype wrapper to prettyprint a key uniquely identifying an object newtype PrettyKey a = PrettyKey a +prettyKey :: Pretty (PrettyKey a) => a -> Doc b+prettyKey = pretty . PrettyKey++-- | Newtype wrapper to prettyprint a user-friendly name referring to an object+newtype PrettyName a = PrettyName a++prettyName :: Pretty (PrettyName a) => a -> Doc b+prettyName = pretty . PrettyName++-- | Newtype wrapper to prettyprint a short description of an object+newtype PrettyShort a = PrettyShort a++prettyShort :: Pretty (PrettyShort a) => a -> Doc b+prettyShort = pretty . PrettyShort++ -- | Infix operator for 'line' (<++>) :: Doc a -> Doc a -> Doc a x <++> y = x <> line <> y@@ -35,32 +49,6 @@ prettyTime :: UTCTime -> Doc a prettyTime = pretty . formatTime defaultTimeLocale "%F %T"---- instance Pretty OpmlHead where--- pretty h = hsep $ catMaybes--- [ pretty <$> fromNullable (opmlTitle h)--- , (text "created at:" <+>) . pretty <$> opmlCreated h--- , (text "modified at:" <+>) . pretty <$> modified h--- , (text "by" <+>) . pretty <$> fromNullable (ownerName h)--- , angles . pretty <$> fromNullable (ownerEmail h)--- ]---- instance Pretty OutlineBase where--- pretty b = pretty $ OPML.text b---- instance Pretty OutlineSubscription where--- pretty b = angles $ pretty $ xmlUri b---- instance Pretty OpmlOutline where--- pretty (OpmlOutlineGeneric base otype) = hsep--- [ text "type:" <+> pretty otype--- , pretty base--- ]--- pretty (OpmlOutlineSubscription base s) = text "Subscription:" <+> pretty base <+> pretty s--- pretty (OpmlOutlineLink base uri) = text "Link:" <+> pretty base <+> pretty uri---- instance Pretty Opml where--- pretty o = text "OPML" <+> pretty (opmlVersion o) <++> indent 2 (pretty (opmlHead o) <++> (vsep . map pretty $ opmlOutlines o)) prettyPerson :: AtomPerson -> Doc a prettyPerson p = pretty (unrefine $ personName p) <> email where
src/lib/Imm/XML.hs view
@@ -12,5 +12,5 @@ -- }}} newtype Handle m = Handle- { parseXml :: URI -> LByteString -> m Feed+ { parseXml :: URI -> LByteString -> m (FeedDefinition, [FeedItem]) }
src/lib/Prelude.hs view
@@ -1,7 +1,19 @@-module Prelude (io, module Relude, module Relude.Extra.Map) where+module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, appendFile, force, readFile, writeFile)+import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) import Relude.Extra.Map (lookup)+import Control.Exception.Safe io :: MonadIO m => IO a -> m a io = liftIO++for :: [a] -> (a -> b) -> [b]+for = flip map++headThrow :: MonadThrow m => Exception e => e -> [a] -> m a+headThrow _ (a:_) = return a+headThrow e _ = throwM e++headFail :: MonadFail m => String -> [a] -> m a+headFail _ (a:_) = return a+headFail e _ = fail e
+ src/lib/URI/ByteString/Extended.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+module URI.ByteString.Extended (module URI.ByteString.Extended, module URI.ByteString) where++import Data.Aeson.Extended+import Data.Type.Equality+import Imm.Pretty+import URI.ByteString+++data AnyURI = forall a . AnyURI (URIRef a)++deriving instance Show AnyURI+instance Eq AnyURI where+ (AnyURI a) == (AnyURI b) = case sameURIType a b of+ Just Refl -> a == b+ _ -> False++instance Ord AnyURI where+ compare (AnyURI a) (AnyURI b) = case (a, b) of+ (URI{}, URI{}) -> compare a b+ (RelativeRef{}, RelativeRef{}) -> compare a b+ (URI{}, RelativeRef{}) -> LT+ (RelativeRef{}, URI{}) -> GT++instance Pretty AnyURI where+ pretty (AnyURI a@URI{}) = prettyURI a+ pretty (AnyURI a@RelativeRef{}) = prettyURI a++instance ToJSON AnyURI where+ toJSON (AnyURI a@URI{}) = toJSON $ String $ decodeUtf8 $ serializeURIRef' a+ toJSON (AnyURI a@RelativeRef{}) = toJSON $ String $ decodeUtf8 $ serializeURIRef' a++instance FromJSON AnyURI where+ parseJSON = withText "URI" $ \s ->+ let bytes = encodeUtf8 s+ uri = parseURI laxURIParserOptions bytes+ relativeRef = parseRelativeRef laxURIParserOptions bytes+ in either (const $ fail "Invalid URI") pure $ (AnyURI <$> uri) <> (AnyURI <$> relativeRef)+++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++withAnyURI :: (forall a . URIRef a -> b) -> AnyURI -> b+withAnyURI f (AnyURI a) = f a++toAbsoluteURI :: Scheme -> AnyURI -> URI+toAbsoluteURI scheme (AnyURI a) = toAbsolute scheme a
src/main/Alternate.hs view
@@ -2,23 +2,19 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-module Alternate (AlternateException(..), resolveFeedURI) where+module Alternate (AlternateException(..), extractAlternateLinks) 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 qualified Data.ByteString.Char8 as Char8+import Imm.Link+import Imm.Logger as Logger import Imm.Pretty import Pipes-import Pipes.ByteString as Pipes (toHandle)-import Safe-import System.IO (hClose)+import Pipes.ByteString as Pipes (toHandle)+import System.IO (hClose) import System.Process.Typed-import URI.ByteString+import URI.ByteString.Extended -- }}} @@ -47,15 +43,6 @@ 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@@ -78,41 +65,22 @@ _ -> 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+asLink :: MonadFail m => URI -> AlternateLink -> m Link+asLink baseURI (AlternateLink title type' uri) = Link (Just Alternate) title (parseMediaType type') . AnyURI <$> asFeedURI baseURI uri -extractAlternateLinks :: MonadIO m => Logger.Handle IO -> Producer' ByteString IO () -> m [AlternateLink]-extractAlternateLinks logger html = io $ withProcessWait pup $ \pupProcess -> do+extractAlternateLinks :: MonadIO m => MonadFail m => Logger.Handle IO -> URI -> Producer ByteString IO () -> m [Link]+extractAlternateLinks logger baseUri 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+ log logger Info $ "Found alternate links:" <+> pretty links - return links+ mapM (asLink baseUri) 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
src/main/Core.hs view
@@ -3,55 +3,81 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module Core ( markAsUnprocessed, subscribe, unsubscribe,- listFeeds,+ describeFeeds, describeFeed,- importOPML,+ downloadFeed, ) where -- {{{ Imports+import Alternate+import Database.Record+-- (FeedItemRecord (..), FeedItemStatus (..), FeedRecord (..), Inserted)+import qualified Database.Handle as Database+import Output (putDocLn)+import qualified Output+ import Control.Exception.Safe-import Data.Conduit-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Tree-import qualified Imm.Database.Feed as Database+import qualified Data.Text as Text import Imm.Feed-import Imm.Logger as Logger+import Imm.HTTP as HTTP+import Imm.Link+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 (def, force, parseBytes)+import Network.HTTP.Types.Header+import Pipes+import Safe+import Text.XML as XML ()+import URI.ByteString.Extended -- }}} -markAsUnprocessed :: MonadThrow m- => Logger.Handle m- -> Database.Handle m- -> FeedQuery- -> m ()-markAsUnprocessed logger database query = Database.resolveEntryKey database query- >>= mapM_ (Database.markAsUnprocessed logger database)+markAsUnprocessed :: MonadThrow m => MonadIO m+ => Logger.Handle m+ -> Database.Handle m+ -> FeedQuery+ -> m ()+markAsUnprocessed logger database QueryAll = Database.markAllFeedsAsUnprocessed logger database+markAsUnprocessed logger database (QueryByUID uid) = Database.markFeedAsUnprocessed logger database uid -- | Print database status for given feed(s)-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- forM_ (Map.toList entries) $ \(index, entry) ->- log logger Info $ pretty index <+> Database.prettyEntry entry+describeFeeds :: MonadThrow m => MonadIO m+ => Output.Handle m -> Database.Handle m -> FeedQuery -> m ()+describeFeeds output database QueryAll = do+ feeds <- Database._fetchAllFeeds database+ when (null feeds) $ putDocLn output "No subscriptions"+ forM_ feeds $ describeFeed output database+describeFeeds output database (QueryByUID uid) = do+ feed <- Database._fetchFeed database uid+ describeFeed output database feed ++describeFeed :: MonadThrow m => MonadIO m+ => Output.Handle m -> Database.Handle m -> FeedRecord Inserted -> m ()+describeFeed output database FeedRecord{..} = do+ items <- Database._fetchItems database _feedKey++ let newItems = length $ filter (not . _isProcessed . _itemStatus) items+ description = pretty _feedDefinition+ <++> pretty _feedStatus+ <++> yellow (pretty newItems) <> "/" <> pretty (length items) <+> "new items"++ putDocLn output $ pretty _feedKey <+> magenta (pretty _feedLocation)+ <++> indent 3 description++ -- | 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+subscribe :: MonadCatch m => MonadIO m+ => Logger.Handle m -> Output.Handle m -> Database.Handle m+ -> FeedLocation -> Set Text -> m ()+subscribe logger output database feedLocation tags = do+ feedRecord <- Database.register logger database feedLocation tags+ putDocLn output $ "Subscribed with index" <+> prettyKey feedRecord -- | Un-register the given set of feeds from database unsubscribe :: MonadThrow m@@ -59,26 +85,31 @@ -> Database.Handle m -> FeedQuery -> m ()-unsubscribe logger database query = Database.resolveEntryKey database query- >>= Database.delete logger database+unsubscribe logger database QueryAll = Database.purge logger database+unsubscribe logger database (QueryByUID uid) = Database.deleteFeed logger database uid --- | List all subscribed feeds and their status-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 [0..] $ Map.elems entries) $ \(i, entry) ->- log logger Info $ pretty (i :: Int) <+> Database.prettyShortEntry entry+-- | Download feed data, following alternate links if necessary+downloadFeed :: m ~ IO => Logger.Handle m -> HTTP.Handle m -> (Producer ByteString m () -> m a) -> FeedLocation -> m a+downloadFeed logger httpClient f (FeedLocation uri title) = HTTP.withGet logger httpClient uri $ \response -> do+ case getHeader hContentType response >>= parseMediaType of+ Just MediaTypeRSS{} -> f (responseBody response)+ Just MediaTypeAtom{} -> f (responseBody response)+ Just MediaTypeApplicationXML{} -> f (responseBody response)+ Just MediaTypeTextXML{} -> f (responseBody response)+ Just MediaTypeHTML{} -> extractAlternateLinks logger uri (responseBody response)+ <&> filterByTitle+ <&> maximumByMay compareFeeds+ >>= maybe (throwM $ FeedNotFound uri) (\l -> downloadFeed logger httpClient f $ FeedLocation (toAbsoluteURI (Scheme "https") $ _linkURI l) mempty)+ _ -> fail "Unexpected media type"+ where filterByTitle = if Text.null title then id else filter (\l -> _linkTitle l == title)+ compareFeeds (Link _ _ (Just MediaTypeAtom{}) _) (Link _ _ (Just MediaTypeRSS{}) _) = GT+ compareFeeds (Link _ _ (Just MediaTypeAtom{}) _) (Link _ _ (Just MediaTypeAtom{}) _) = EQ+ compareFeeds (Link _ _ (Just MediaTypeAtom{}) _) _ = GT+ compareFeeds (Link _ _ (Just MediaTypeRSS{}) _) (Link _ _ (Just MediaTypeAtom{}) _) = LT+ compareFeeds (Link _ _ (Just MediaTypeRSS{}) _) (Link _ _ (Just MediaTypeRSS{}) _) = EQ+ compareFeeds (Link _ _ (Just MediaTypeRSS{}) _) _ = GT+ compareFeeds _ _ = EQ --- | 'subscribe' to all feeds described by the OPML document provided in input-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 -> 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) _) = void $ subscribe logger database (FeedDirectURI $ xmlUri s) c-importOPML' _ _ _ _ = return ()+getHeader :: HeaderName -> Response a -> Maybe ByteString+getHeader name response = response & responseHeaders & filter (\h-> fst h == name) & map snd & listToMaybe
− src/main/Database.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE UndecidableInstances #-}--- | Implementation of "Imm.Database.Feed" based on a JSON file.-module Database- ( JsonFileDatabase- , mkJsonFileDatabase- , defaultDatabase- , mkHandle- , JsonException(..)- , module Imm.Database.Feed- ) where---- {{{ Imports-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 qualified Data.Map as Map-import System.Directory-import System.FilePath-import System.IO hiding (Handle)--- }}}--data CacheStatus = Empty | Clean | Dirty- deriving(Eq, Ord, Read, Show)--data JsonFileDatabase = JsonFileDatabase FilePath (Map FeedLocation Entry) CacheStatus--instance Pretty JsonFileDatabase where- pretty (JsonFileDatabase file _ _) = "JSON database: " <+> pretty file--mkJsonFileDatabase :: FilePath -> JsonFileDatabase-mkJsonFileDatabase file = JsonFileDatabase file mempty Empty---- | Default database is stored in @$XDG_CONFIG_HOME\/imm\/feeds.json@-defaultDatabase :: IO (TVar JsonFileDatabase)-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 :: (MonadIO m, MonadMask m)- => TVar JsonFileDatabase -> Handle m-mkHandle tvar = Handle- { _describeDatabase = pretty <$> readTVarIO 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)- , _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--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- database <- loadFromDisk file- atomically $ do- JsonFileDatabase _ _ status' <- readTVar tvar- when (status' == Empty) $ writeTVar tvar database--loadFromDisk :: (MonadIO m, MonadMask m) => FilePath -> m JsonFileDatabase-loadFromDisk file = do- liftIO $ createDirectoryIfMissing True $ takeDirectory file- 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 -> 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 :: [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--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--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 :: (MonadIO m)- => TVar JsonFileDatabase -> 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
+ src/main/Database/Async.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+module Database.Async (withAsyncHandle) where++import Database.Handle+import Output (putDocLn)+import qualified Output++import Control.Concurrent.Async+import Control.Concurrent.STM.TMChan+import Control.Exception.Safe+import Imm.Logger (LogLevel (..), log)+import qualified Imm.Logger as Logger+import Imm.Pretty+++-- | Run an existing database handle in a separate thread+withAsyncHandle :: m ~ IO => Logger.Handle m -> Output.Handle m -> Handle m -> (Handle m -> m ()) -> m ()+withAsyncHandle logger output database f = do+ channel <- newTMChanIO++ thread <- async $ fix $ \recurse -> do+ maybeMessage <- atomically $ readTMChan channel+ forM_ maybeMessage $ \message -> do+ interpret database message+ recurse++ log logger Debug "Database thread started"+ catchAny (f $ command channel) $ \e -> do+ log logger Error $ pretty $ displayException e+ putDocLn output $ pretty $ displayException e+ log logger Debug "Closing database thread..."+ atomically (closeTMChan channel) >> wait thread++withMVar :: MonadIO m => TMChan a -> ((b -> m ()) -> a) -> m b+withMVar channel message = do+ result <- newEmptyMVar+ atomically $ writeTMChan channel (message $ putMVar result)+ takeMVar result++withMVarE :: (MonadIO m, MonadThrow m, Exception e)+ => TMChan a -> ((Either e b -> m ()) -> a) -> m b+withMVarE channel message = do+ result <- newEmptyMVar+ atomically $ writeTMChan channel (message $ putMVar result)+ takeMVar result >>= either throwM return++asyncCommand :: MonadIO m => TMChan a -> (m () -> a) -> m ()+asyncCommand channel message = do+ atomically $ writeTMChan channel (message $ return ())++command :: MonadIO m => MonadThrow m => TMChan (HandleF (m ())) -> Handle m+command channel = Handle+ { _describeDatabase = withMVar channel DescribeDatabase+ , _fetchAllFeeds = withMVar channel FetchAllFeeds+ , _fetchFeed = withMVarE channel . FetchFeed+ , _fetchAllItems = withMVar channel FetchAllItems+ , _fetchItems = withMVar channel . FetchItems+ , _fetchItem = withMVarE channel . FetchItem+ , _updateFeedDefinition = asyncCommand channel . UpdateFeedDefinition+ , _updateFeedStatus = asyncCommand channel . UpdateFeedStatus+ , _updateItemStatus = asyncCommand channel . UpdateItemStatus+ , _insertFeed = withMVarE channel . InsertFeed+ , _insertItem = withMVar channel . InsertItem+ , _deleteFeed = asyncCommand channel . DeleteFeed+ , _purge = asyncCommand channel Purge+ , _commit = asyncCommand channel Commit+ }
+ src/main/Database/Handle.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Database.Handle+ ( -- * 1st-level primitives+ HandleF(..)+ , Handle(..)+ , interpret+ , DatabaseException(..)+ , -- * 2nd-level primitives+ insertFeed+ , deleteFeed+ , insertItem+ , purge+ , commit+ , -- * 3rd-level primitives+ register+ , markItemAsProcessed+ , markFeedAsUnprocessed+ , markAllFeedsAsUnprocessed+ , -- * Re-exports+ module Database.Record+ ) where++import Database.Record hiding (markFeedAsUnprocessed, markItemAsProcessed)+import qualified Database.Record as Record++import Control.Exception.Safe hiding (handle)+import Control.Monad.Time+import Imm.Feed+import Imm.Logger (LogLevel (..), log)+import qualified Imm.Logger as Logger+import Imm.Pretty+import URI.ByteString hiding (OtherError)+++-- | 1st-level primitives+data Handle m = Handle+ { _describeDatabase :: m (Doc AnsiStyle)+ , _fetchAllFeeds :: m [FeedRecord Inserted]+ , _fetchFeed :: UID -> m (FeedRecord Inserted)+ , _fetchAllItems :: m [FeedItemRecord Inserted]+ , _fetchItems :: UID -> m [FeedItemRecord Inserted]+ , _fetchItem :: UID -> m (FeedItemRecord Inserted)+ , _updateFeedDefinition :: FeedRecord Inserted -> m ()+ , _updateFeedStatus :: FeedRecord Inserted -> m ()+ , _updateItemStatus :: FeedItemRecord Inserted -> m ()+ , _insertFeed :: FeedRecord NotInserted -> m (FeedRecord Inserted)+ , _insertItem :: FeedItemRecord NotInserted -> m (FeedItemRecord Inserted)+ , _deleteFeed :: UID -> m ()+ , _purge :: m ()+ , _commit :: m ()+ }++-- | Database functor+data HandleF a+ = DescribeDatabase (Doc AnsiStyle -> a)+ | FetchAllFeeds ([FeedRecord Inserted] -> a)+ | FetchFeed UID (Either SomeException (FeedRecord Inserted) -> a)+ | FetchAllItems ([FeedItemRecord Inserted] -> a)+ | FetchItems UID ([FeedItemRecord Inserted] -> a)+ | FetchItem UID (Either SomeException (FeedItemRecord Inserted) -> a)+ | UpdateFeedDefinition (FeedRecord Inserted) a+ | UpdateFeedStatus (FeedRecord Inserted) a+ | UpdateItemStatus (FeedItemRecord Inserted) a+ | InsertFeed (FeedRecord NotInserted) (Either SomeException (FeedRecord Inserted) -> a)+ | InsertItem (FeedItemRecord NotInserted) (FeedItemRecord Inserted -> a)+ | DeleteFeed UID a+ | Purge a+ | Commit a+ deriving (Functor)++interpret :: MonadCatch m => Handle m -> HandleF (m a) -> m a+interpret database (DescribeDatabase f) = _describeDatabase database >>= f+interpret database (FetchAllFeeds f) = _fetchAllFeeds database >>= f+interpret database (FetchFeed uid f) = tryAny (_fetchFeed database uid) >>= f+interpret database (FetchAllItems f) = _fetchAllItems database >>= f+interpret database (FetchItems uid f) = _fetchItems database uid >>= f+interpret database (FetchItem uid f) = tryAny (_fetchItem database uid) >>= f+interpret database (UpdateFeedDefinition record f) = _updateFeedDefinition database record >> f+interpret database (UpdateFeedStatus record f) = _updateFeedStatus database record >> f+interpret database (UpdateItemStatus record f) = _updateItemStatus database record >> f+interpret database (InsertFeed record f) = tryAny (_insertFeed database record) >>= f+interpret database (InsertItem record f) = _insertItem database record >>= f+interpret database (DeleteFeed uid f) = _deleteFeed database uid >> f+interpret database (Purge f) = _purge database >> f+interpret database (Commit f) = _commit database >> f++data DatabaseException+ = NotCommitted+ | NotDeleted [FeedLocation]+ | FeedNotFound UID+ | FeedsNotInserted [FeedRecord NotInserted]+ | ItemsNotInserted [FeedItemRecord NotInserted]+ | NotPurged+ | NotUpdated FeedLocation+ | UnableFetchAll+ | InvalidURI URIParseError+ | OtherError Text+ 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 (FeedNotFound x) = "Unable to find feed in database using UID" <+> pretty x+ pretty (FeedsNotInserted x) = "Unable to insert the following feeds in database:" <++> indent 2 (vsep $ map (pretty . _feedLocation) x)+ pretty (ItemsNotInserted x) = "Unable to insert the following items in database:" <++> indent 2 (vsep $ map (pretty . _itemFeedKey) 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."+ pretty (InvalidURI e) = pretty $ show @Text e+ pretty (OtherError e) = "Other database error:" <+> pretty e+++-- * 2nd-level primitives++insertFeed :: Monad m => Logger.Handle m -> Handle m -> FeedRecord NotInserted -> m (FeedRecord Inserted)+insertFeed logger handle i = do+ log logger Info $ "Inserting feed" <+> magenta (prettyName $ _feedDefinition i)+ _insertFeed handle i++deleteFeed :: Monad m => Logger.Handle m -> Handle m -> UID -> m ()+deleteFeed logger handle k = do+ log logger Info $ "Deleting feed" <+> magenta (pretty k) <+> "..."+ _deleteFeed handle k++insertItem :: Monad m => Logger.Handle m -> Handle m -> FeedItemRecord NotInserted -> m (FeedItemRecord Inserted)+insertItem logger handle i = do+ log logger Info $ "Inserting item" <+> magenta (prettyName $ _itemDefinition i)+ _insertItem handle i++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"+++-- * 3rd-level primitives++register :: MonadThrow m => Logger.Handle m -> Handle m -> FeedLocation -> Set Text -> m (FeedRecord Inserted)+register logger database feedLocation tags = do+ log logger Info $ "Registering feed" <+> magenta (pretty feedLocation) <> "..."+ insertFeed logger database $ mkFeedRecord feedLocation definition status+ where definition = FeedDefinition mempty+ status = FeedStatus tags mzero++markItemAsProcessed :: MonadThrow m => MonadTime m+ => Logger.Handle m -> Handle m -> FeedItemRecord Inserted -> m ()+markItemAsProcessed logger database item = do+ log logger Debug $ "Marking item as processed:" <+> prettyName item <> "..."+ _updateItemStatus database $ item { _itemStatus = Record.markItemAsProcessed $ _itemStatus item }++markFeedAsUnprocessed :: MonadThrow m => Logger.Handle m -> Handle m -> UID -> m ()+markFeedAsUnprocessed logger database key = do+ log logger Debug $ "Marking as unprocessed:" <+> pretty key <> "..."+ feed <- _fetchFeed database key+ items <- _fetchItems database key+ forM_ items $ \item -> _updateItemStatus database $ item { _itemStatus = markItemAsUnprocessed $ _itemStatus item }+ _updateFeedStatus database $ feed { _feedStatus = Record.markFeedAsUnprocessed $ _feedStatus feed }++markAllFeedsAsUnprocessed :: MonadThrow m => Logger.Handle m -> Handle m -> m ()+markAllFeedsAsUnprocessed logger database = do+ log logger Debug $ "Marking all feeds as unprocessed..."+ feeds <- _fetchAllFeeds database+ items <- _fetchAllItems database+ forM_ items $ \item -> _updateItemStatus database $ item { _itemStatus = markItemAsUnprocessed $ _itemStatus item }+ forM_ feeds $ \feed -> _updateFeedStatus database $ feed { _feedStatus = Record.markFeedAsUnprocessed $ _feedStatus feed }
+ src/main/Database/ReadOnly.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.ReadOnly where++import Database.Handle+import Imm.Logger (LogLevel (..), log)+import qualified Imm.Logger as Logger+import Imm.Pretty++readOnly :: MonadFail m => Logger.Handle m -> Handle m -> Handle m+readOnly logger handle = handle+ { _describeDatabase = do+ output <- _describeDatabase handle+ return $ output <+> yellow (brackets "read only")+ , _updateFeedDefinition = \record -> log logger Debug $ "Not updating feed" <+> prettyKey record+ , _updateFeedStatus = \record -> log logger Debug $ "Not updating feed" <+> prettyKey record+ , _updateItemStatus = \record -> log logger Debug $ "Not updating item" <+> prettyKey record+ , _insertFeed = \record -> fail $ "Not inserting feed " <> show (prettyKey record)+ , _insertItem = \record -> fail $ "Not inserting item " <> show (prettyItemRecord record)+ , _deleteFeed = \key -> log logger Debug $ "Not deleting feed" <+> pretty key+ , _purge = log logger Debug "Not purging database"+ , _commit = log logger Debug "Not committing database"+ }
+ src/main/Database/Record.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Database.Record+ ( FeedStatus(..)+ , markFeedAsUnprocessed+ , touchFeed+ , FeedItemStatus(..)+ , markItemAsProcessed+ , markItemAsUnprocessed+ , FeedRecord(..)+ , mkFeedRecord+ , FeedItemRecord(..)+ , prettyItemRecord+ , mkFeedItemRecord+ , Inserted+ , NotInserted+ ) where++import Control.Monad.Time+import Data.Aeson+import Data.Time+import Imm.Feed+import Imm.Pretty+++-- | Stateful information on a feed+data FeedStatus = FeedStatus+ { _feedTags :: Set Text+ , _feedLastUpdate :: Maybe UTCTime+ } deriving(Eq, Generic, Ord, Read, Show, Typeable)++feedStatusOptions :: Options+feedStatusOptions = defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_feed")+ , omitNothingFields = True+ }++instance ToJSON FeedStatus where+ toJSON = genericToJSON feedStatusOptions+ toEncoding = genericToEncoding feedStatusOptions++instance FromJSON FeedStatus where+ parseJSON = genericParseJSON feedStatusOptions++instance Pretty FeedStatus where+ pretty FeedStatus{..} = tags <++> "Last update:" <+> lastUpdate+ where tags = sep $ map ((<>) "#" . pretty) $ toList _feedTags+ lastUpdate = maybe "never" prettyTime _feedLastUpdate++markFeedAsUnprocessed :: FeedStatus -> FeedStatus+markFeedAsUnprocessed status = status+ { _feedLastUpdate = Nothing+ }++touchFeed :: FeedStatus -> IO FeedStatus+touchFeed status = do+ utcTime <- currentTime+ return $ status { _feedLastUpdate = Just utcTime }+++-- | Stateful information on a feed item+newtype FeedItemStatus = FeedItemStatus+ { _isProcessed :: Bool+ } deriving(Eq, Generic, Ord, Read, Show, Typeable)++instance Pretty FeedItemStatus where+ pretty FeedItemStatus{..} = pretty _isProcessed++feedItemStatusOptions :: Options+feedItemStatusOptions = defaultOptions+ { fieldLabelModifier = camelTo2 '_'+ , omitNothingFields = True+ }++instance ToJSON FeedItemStatus where+ toJSON = genericToJSON feedItemStatusOptions+ toEncoding = genericToEncoding feedItemStatusOptions++instance FromJSON FeedItemStatus where+ parseJSON = genericParseJSON feedItemStatusOptions++markItemAsProcessed :: FeedItemStatus -> FeedItemStatus+markItemAsProcessed status = status { _isProcessed = True }++markItemAsUnprocessed :: FeedItemStatus -> FeedItemStatus+markItemAsUnprocessed status = status { _isProcessed = False }+++-- | Consistent record of information for a single feed+data FeedRecord status = FeedRecord+ { _feedKey :: StatusUID status+ , _feedLocation :: FeedLocation+ , _feedDefinition :: FeedDefinition+ , _feedStatus :: FeedStatus+ }++deriving instance (Eq (StatusUID s)) => Eq (FeedRecord s)+deriving instance (Ord (StatusUID s)) => Ord (FeedRecord s)+deriving instance (Show (StatusUID s)) => Show (FeedRecord s)++instance Pretty (PrettyKey (FeedRecord Inserted)) where+ pretty (PrettyKey record) = pretty $ _feedKey record++instance Pretty (PrettyKey (FeedRecord NotInserted)) where+ pretty (PrettyKey record) = pretty $ _feedLocation record++mkFeedRecord :: FeedLocation -> FeedDefinition -> FeedStatus -> FeedRecord NotInserted+mkFeedRecord = FeedRecord ()+++-- | Consistent record of information for a single feed item+data FeedItemRecord status = FeedItemRecord+ { _itemKey :: StatusUID status+ , _itemFeedKey :: UID+ , _itemDefinition :: FeedItem+ , _itemStatus :: FeedItemStatus+ }++deriving instance (Eq (StatusUID s)) => Eq (FeedItemRecord s)+deriving instance (Ord (StatusUID s)) => Ord (FeedItemRecord s)+deriving instance (Show (StatusUID s)) => Show (FeedItemRecord s)++instance Pretty (PrettyKey (FeedItemRecord Inserted)) where+ pretty (PrettyKey record) = pretty $ _itemKey record++instance Pretty (PrettyName (FeedItemRecord a)) where+ pretty (PrettyName record) = pretty $ _itemTitle $ _itemDefinition record++prettyItemRecord :: Pretty (StatusUID s) => FeedItemRecord s -> Doc AnsiStyle+prettyItemRecord FeedItemRecord{..} = pretty _itemKey <+> magenta (pretty _itemFeedKey)+ <++> pretty _itemDefinition+ <++> pretty _itemStatus++mkFeedItemRecord :: UID -> FeedItem -> FeedItemStatus -> FeedItemRecord NotInserted+mkFeedItemRecord = FeedItemRecord ()+++data Inserted+data NotInserted++type family StatusUID s where+ StatusUID Inserted = UID+ StatusUID NotInserted = ()
+ src/main/Database/SQLite.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Database.SQLite+ ( DatabaseSQLite(..)+ , defaultDatabase+ , mkHandle+ ) where++import Database.Handle hiding (deleteFeed, insertFeed, insertItem, purge)++import Data.Aeson+import Database.Beam+import Database.Beam.Backend.SQL (BeamSqlBackend, HasSqlValueSyntax (..))+import Database.Beam.Backend.SQL.BeamExtensions+-- import Database.Beam.Migrate+import Database.Beam.Sqlite (runBeamSqlite)+import Database.SQLite.Simple+import Imm.Feed+import Imm.Pretty+import System.Directory++-- * Schema++data FeedLocationT f = FeedLocationT+ { _locationID :: Columnar f Int32+ , _locationValue :: Columnar f FeedLocation+ } deriving(Generic, Beamable)++instance Table FeedLocationT where+ data PrimaryKey FeedLocationT f = FeedLocationKey (Columnar f Int32)+ deriving(Generic, Beamable)+ primaryKey = FeedLocationKey . _locationID+++data FeedT f = Feed+ { _feedKeyT :: PrimaryKey FeedLocationT f+ , _feedDefinitionT :: Columnar f FeedDefinition+ , _feedStatusT :: Columnar f FeedStatus+ } deriving(Generic, Beamable)++instance Table FeedT where+ data PrimaryKey FeedT f = FeedKey (PrimaryKey FeedLocationT f)+ deriving(Generic, Beamable)+ primaryKey = FeedKey . _feedKeyT+++data FeedItemT f = FeedItemT+ { _itemKeyT :: Columnar f Int32+ , _itemFeedKeyT :: PrimaryKey FeedLocationT f+ , _itemDefinitionT :: Columnar f FeedItem+ , _itemStatusT :: Columnar f FeedItemStatus+ } deriving(Generic, Beamable)++instance Table FeedItemT where+ data PrimaryKey FeedItemT f = FeedItemKey (Columnar f Int32)+ deriving(Generic, Beamable)+ primaryKey = FeedItemKey . _itemKeyT+++data FeedDatabase f = FeedDatabase+ { _feedLocations :: f (TableEntity FeedLocationT)+ , _feeds :: f (TableEntity FeedT)+ , _feedItems :: f (TableEntity FeedItemT)+ } deriving (Generic, Database be)+++feedDatabase :: DatabaseSettings be FeedDatabase+feedDatabase = defaultDbSettings `withDbModification`+ dbModification+ { _feedItems = modifyTableFields tableModification+ { _itemKeyT = fieldNamed "key"+ , _itemFeedKeyT = FeedLocationKey $ fieldNamed "feed_key"+ , _itemDefinitionT = fieldNamed "definition"+ , _itemStatusT = fieldNamed "status"+ }+ , _feeds = modifyTableFields tableModification+ { _feedKeyT = FeedLocationKey $ fieldNamed "key"+ , _feedDefinitionT = fieldNamed "definition"+ , _feedStatusT = fieldNamed "status"+ }+ , _feedLocations = modifyTableFields tableModification+ { _locationID = fieldNamed "key"+ , _locationValue = fieldNamed "value"+ }+ }+++feedLocationsTable :: DatabaseEntity be FeedDatabase (TableEntity FeedLocationT)+feedLocationsTable = _feedLocations feedDatabase++feedsTable :: DatabaseEntity be FeedDatabase (TableEntity FeedT)+feedsTable = _feeds feedDatabase++feedItemsTable :: DatabaseEntity be FeedDatabase (TableEntity FeedItemT)+feedItemsTable = _feedItems feedDatabase++-- * Queries++fetchAllFeeds :: _ [FeedRecord Inserted]+fetchAllFeeds = fmap (map asFeedRecord) $ runSelectReturningList $ select $ do+ feed <- feedsTable & all_+ location <- feedLocationsTable & all_++ guard_ $ _feedKeyT feed `references_` location++ pure (location, feed)++asFeedRecord :: f ~ Identity => (FeedLocationT f, FeedT f) -> FeedRecord Inserted+asFeedRecord (locationT, feed) = FeedRecord+ (fromIntegral $ _locationID locationT)+ (_locationValue locationT)+ (_feedDefinitionT feed)+ (_feedStatusT feed)++fetchFeed :: UID -> _+fetchFeed uid = select (queryFeed uid) & runSelectReturningOne+ >>= maybe (fail $ "Feed not found: " <> show uid) return+ <&> asFeedRecord++queryFeed :: UID -> _+queryFeed uid = do+ feed <- feedsTable & all_+ location <- feedLocationsTable & all_++ guard_ $ _feedKeyT feed `references_` location+ guard_ $ _locationID location ==. val_ (fromIntegral uid)++ pure (location, feed)++fetchItem :: UID -> _+fetchItem uid = feedItemsTable+ & all_+ & filter_ (\i -> primaryKey i ==. val_ (FeedItemKey $ fromIntegral uid))+ & select+ & runSelectReturningOne+ >>= maybe (fail $ "Item not found: " <> show uid) return+ <&> asFeedItemRecord++fetchAllItems :: _ [FeedItemRecord Inserted]+fetchAllItems = select (feedItemsTable & all_)+ & runSelectReturningList+ <&> map asFeedItemRecord++fetchItems :: UID -> _+fetchItems uid = select (queryItems uid) & runSelectReturningList <&> map asFeedItemRecord++queryItems :: UID -> _+queryItems uid = do+ item <- feedItemsTable & all_+ guard_ $ _itemFeedKeyT item ==. val_ (FeedLocationKey $ fromIntegral uid)+ pure item+++asFeedItemRecord :: FeedItemT Identity -> FeedItemRecord Inserted+asFeedItemRecord item = FeedItemRecord+ (fromIntegral $ _itemKeyT item)+ (fromIntegral feedKey)+ (_itemDefinitionT item)+ (_itemStatusT item)+ where FeedLocationKey feedKey = _itemFeedKeyT item+++deleteFeed :: UID -> _ ()+deleteFeed uid = do+ -- runDelete $ delete feedItemsTable $ \item -> _itemFeedKeyT item ==. val_ (FeedLocationKey $ fromIntegral uid)+ -- runDelete $ delete feedsTable $ \feed -> _feedKeyT feed ==. val_ (FeedLocationKey $ fromIntegral uid)+ runDelete $ delete feedLocationsTable $ \location -> _locationID location ==. val_ (fromIntegral uid)++insertFeed :: FeedRecord NotInserted -> _ (FeedRecord Inserted)+insertFeed record = do+ location <- insertFeedLocation $ _feedLocation record+ let value = Feed (primaryKey location) (_feedDefinition record) (_feedStatus record)+ feed <- insertValues [value]+ & insert feedsTable+ & runInsertReturningList+ >>= headFail (displayException $ FeedsNotInserted [record])+ return $ asFeedRecord (location, feed)++insertFeedLocation :: FeedLocation -> _+insertFeedLocation location = insertExpressions [FeedLocationT default_ (val_ location)]+ & insert feedLocationsTable+ & runInsertReturningList+ >>= headFail ("Unable to insert feed location " <> show location)++insertItem :: FeedItemRecord NotInserted -> _+insertItem record = do+ inserted <- insertExpressions [FeedItemT default_ (val_ $ FeedLocationKey $ fromIntegral $ _itemFeedKey record) (val_ $ _itemDefinition record) (val_ $ _itemStatus record)]+ & insert feedItemsTable+ & runInsertReturningList+ >>= headFail (displayException $ ItemsNotInserted [record])+ return $ FeedItemRecord (fromIntegral $ _itemKeyT inserted) (_itemFeedKey record) (_itemDefinition record) (_itemStatus record)++purge = runDelete $ delete feedLocationsTable $ const $ val_ True++updateItemStatus :: FeedItemRecord Inserted -> _+updateItemStatus record = runUpdate $ update feedItemsTable+ (\item -> _itemStatusT item <-. val_ (_itemStatus record))+ (\item -> primaryKey item ==. val_ (FeedItemKey $ fromIntegral $ _itemKey record))++updateFeedDefinition :: FeedRecord Inserted -> _+updateFeedDefinition record = runUpdate $ update feedsTable+ (\feed -> _feedDefinitionT feed <-. val_ (_feedDefinition record))+ (\feed -> primaryKey feed ==. val_ (FeedKey $ FeedLocationKey $ fromIntegral $ _feedKey record))++updateFeedStatus :: FeedRecord Inserted -> _+updateFeedStatus record = runUpdate $ update feedsTable+ (\feed -> _feedStatusT feed <-. val_ (_feedStatus record))+ (\feed -> primaryKey feed ==. val_ (FeedKey $ FeedLocationKey $ fromIntegral $ _feedKey record))++-- * Handle++newtype DatabaseSQLite = DatabaseSQLite+ { _sqliteFile :: FilePath+ }++instance Pretty DatabaseSQLite where+ pretty db = "SQLite database: " <+> pretty (_sqliteFile db)++-- | Default database is stored in @$XDG_CONFIG_HOME\/imm\/database.sqlite@+defaultDatabase :: IO DatabaseSQLite+defaultDatabase = DatabaseSQLite <$> getXdgDirectory XdgConfig "imm/database.sqlite"+++createTables :: Connection -> IO ()+createTables conn = do+ execute_ conn "CREATE TABLE IF NOT EXISTS locations (key INTEGER NOT NULL PRIMARY KEY, value BLOB NOT NULL UNIQUE);"+ execute_ conn "CREATE TABLE IF NOT EXISTS feeds ( \+ \ key INTEGER NOT NULL PRIMARY KEY, definition BLOB NOT NULL, status BLOB NOT NULL, \+ \ CONSTRAINT fk_feeds FOREIGN KEY (key) REFERENCES locations(key) ON DELETE CASCADE \+ \ );"+ execute_ conn "CREATE TABLE IF NOT EXISTS items ( \+ \ key INTEGER NOT NULL PRIMARY KEY, feed_key INTEGER NOT NULL, definition BLOB NOT NULL, status BLOB NOT NULL, \+ \ CONSTRAINT fk_feeds FOREIGN KEY (feed_key) REFERENCES locations(key) ON DELETE CASCADE \+ \ );"++mkHandle :: DatabaseSQLite -> IO (Handle IO)+mkHandle database = do+ conn <- open $ _sqliteFile database+ createTables conn+ execute_ conn "PRAGMA foreign_keys = ON;"++ return $ Handle+ { _describeDatabase = return $ pretty database+ , _fetchAllFeeds = runBeamSqlite conn fetchAllFeeds+ , _fetchFeed = runBeamSqlite conn . fetchFeed+ , _fetchItems = runBeamSqlite conn . fetchItems+ , _fetchAllItems = runBeamSqlite conn fetchAllItems+ , _fetchItem = runBeamSqlite conn . fetchItem+ , _updateFeedDefinition = runBeamSqlite conn . updateFeedDefinition+ , _updateFeedStatus = runBeamSqlite conn . updateFeedStatus+ , _updateItemStatus = runBeamSqlite conn . updateItemStatus+ , _insertFeed = runBeamSqlite conn . insertFeed+ , _insertItem = runBeamSqlite conn . insertItem+ , _deleteFeed = runBeamSqlite conn . deleteFeed+ , _purge = runBeamSqlite conn purge+ , _commit = return ()+ }++instance (BeamSqlBackend be, FromBackendRow be LByteString) => FromBackendRow be FeedLocation where+ fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure++instance HasSqlValueSyntax be ByteString => HasSqlValueSyntax be FeedLocation where+ sqlValueSyntax = sqlValueSyntax . toStrict . encode++instance (BeamSqlBackend be, FromBackendRow be LByteString) => FromBackendRow be FeedItem where+ fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure++instance HasSqlValueSyntax be ByteString => HasSqlValueSyntax be FeedItem where+ sqlValueSyntax = sqlValueSyntax . toStrict . encode++instance (BeamSqlBackend be, FromBackendRow be LByteString) => FromBackendRow be FeedDefinition where+ fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure++instance HasSqlValueSyntax be ByteString => HasSqlValueSyntax be FeedDefinition where+ sqlValueSyntax = sqlValueSyntax . toStrict . encode++instance (BeamSqlBackend be, FromBackendRow be LByteString) => FromBackendRow be FeedStatus where+ fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure++instance HasSqlValueSyntax be ByteString => HasSqlValueSyntax be FeedStatus where+ sqlValueSyntax = sqlValueSyntax . toStrict . encode++instance (BeamSqlBackend be, FromBackendRow be LByteString) => FromBackendRow be FeedItemStatus where+ fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure++instance HasSqlValueSyntax be ByteString => HasSqlValueSyntax be FeedItemStatus where+ sqlValueSyntax = sqlValueSyntax . toStrict . encode
src/main/HTTP.hs view
@@ -1,27 +1,25 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}--- | Implementation of "Imm.HTTP" based on "Network.HTTP.Client".+{-# LANGUAGE TypeFamilies #-}+-- | Implementation of "Imm.HTTP" based on "Pipes.HTTP". module HTTP (mkHandle) where -- {{{ Imports import Imm.HTTP-import Imm.Logger hiding (Handle)-import qualified Imm.Logger as Logger import Imm.Pretty -import Pipes.ByteString-import System.Process.Typed+import Network.HTTP.Types.Header+import Pipes.HTTP -- }}} -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)+headers :: [Header]+headers = [(hUserAgent, "imm/1.0")] - where httpie uri = proc "http" ["--timeout", "10", "--follow", "--print", "b", "GET", show $ prettyURI uri]- & setStdin nullStream- & setStdout createPipe- & setStderr nullStream+mkHandle :: m ~ IO => m (Handle m)+mkHandle = do+ manager <- newManager tlsManagerSettings++ return $ Handle $ \uri f -> do+ request <- parseUrlThrow $ show $ prettyURI uri+ withHTTP request { requestHeaders = headers } manager f
+ src/main/Input.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+module Input where++-- {{{ Imports+import Imm.Feed+import Imm.Logger as Logger+import Imm.Pretty+import qualified Paths_imm as Package++import Data.List+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 ProgramInput = ProgramInput+ { inputCommand :: Command+ , inputLogLevel :: LogLevel+ , inputReadOnlyDatabase :: Bool+ , inputCallbacksFile :: FilePath+ } deriving(Eq, Ord, Show)++instance Pretty ProgramInput where+ pretty input = encloseSep "{ " " }" ", "+ [ "command" <+> equals <+> pretty (inputCommand input)+ , "log level" <+> equals <+> pretty (inputLogLevel input)+ , "database read-only" <+> equals <+> pretty (inputReadOnlyDatabase input)+ , "callbacks file" <+> equals <+> pretty (inputCallbacksFile input)+ ]+++data Command = Subscribe FeedLocation (Set Text)+ | Describe FeedQuery+ | Reset FeedQuery+ | Run FeedQuery CallbackMode+ | Unsubscribe FeedQuery++deriving instance Eq Command+deriving instance Ord Command+deriving instance Show Command++instance Pretty Command where+ pretty (Subscribe f _) = "Subscribe to 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:" <+> (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)+++-- * Option parsers++parseOptions :: (MonadIO m) => m ProgramInput+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 ProgramInput+allOptions defaultCallbacksFile = ProgramInput+ <$> commandParser+ <*> (verboseFlag <|> quietFlag <|> logLevel <|> pure Info)+ <*> readOnlyDatabase+ <*> (callbacksFileOption <|> pure defaultCallbacksFile)++commandParser :: Parser Command+commandParser = hsubparser $ mconcat+ [ command "subscribe" $ info subscribeCommand $ progDesc "Subscribe to a feed."+ , command "add" $ info subscribeCommand $ progDesc "Alias for subscribe."++ , 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 $ Describe QueryAll) $ progDesc "Alias for describe --all ."+ , 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."+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."+-- }}}++-- {{{ Other options+readOnlyDatabase :: Parser Bool+readOnlyDatabase = switch $ long "read-only" <> help "Disable database writes."++tagOption :: Parser Text+tagOption = option auto $ long "tag" <> short 't' <> metavar "TAG" <> help "Set the given tag."++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++feedLocationParser :: Parser FeedLocation+feedLocationParser = FeedLocation <$> argument uriReader (metavar "URI" <> help "URI to RSS/Atom document, or to HTML page.") <*> strOption (long "title" <> short 'T' <> value mempty <> help "Title used to disambiguate multiple alternate links in HTML page.")++feedQueryParser :: Parser FeedQuery+feedQueryParser = (QueryByUID <$> argument auto (metavar "TARGET")) <|> allFeeds where+ allFeeds = flag' QueryAll $ short 'a' <> long "all" <> help "Run action on all subscribed feeds."++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.")+-- }}}
src/main/Logger.hs view
@@ -1,52 +1,59 @@+{-# LANGUAGE DataKinds #-} {-# 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+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+-- | Implementation of "Imm.Logger" based on @co-log@.+module Logger (withLogHandler, module Reexport) where -- {{{ Imports import Imm.Logger as Reexport import Imm.Pretty +import Chronos+import Colog hiding (Severity (..))+import qualified Colog as Colog import Data.Text.Prettyprint.Doc.Render.Terminal-import System.Log.FastLogger as Reexport+import qualified Data.TypeRepMap as TypeRepMap+import System.Directory+import System.FilePath -- }}} -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- }+mkHandle :: MonadIO m => MonadIO m' => LogAction m (RichMsg m' (Msg Colog.Severity)) -> IO (Handle m)+mkHandle logAction = do+ logLevel <- newTVarIO Debug+ return $ Handle+ (myLog logAction)+ (readTVarIO logLevel)+ (atomically . writeTVar logLevel) --- | 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+myLog :: MonadIO m' => MonadIO m => LogAction m' (RichMsg m (Msg Colog.Severity)) -> LogLevel -> Doc AnsiStyle -> m' ()+myLog logAction logLevel document = logAction <& RichMsg (Msg (level2severity logLevel) callStack message) defaultFieldMap where+ level2severity Debug = Colog.Debug+ level2severity Info = Colog.Info+ level2severity Warning = Colog.Warning+ level2severity Error = Colog.Error+ message = renderStrict $ layoutPretty defaultLayoutOptions document -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+withLogHandler :: MonadIO m => (Handle m -> IO a) -> IO a+withLogHandler f = do+ logFile <- getXdgDirectory XdgConfig $ "imm" </> "imm.log"+ withLogByteStringFile logFile $ \logFileAction ->+ withBackgroundLogger defCapacity logFileAction $ \logAction ->+ f =<< mkHandle (cmapM serializeMessage logAction)+ where serializeMessage = fmap encodeUtf8 . formatMessage - , getLogLevel = readMVar $ _logLevel settings- , setLogLevel = void . swapMVar (_logLevel settings)- , setColorizeLogs = void . swapMVar (_colorizeLogs settings)- , flushLogs = liftIO $ do- flushLogStr $ _loggerSet settings- flushLogStr $ _errorLoggerSet settings- }+formatMessage :: Monad m => RichMsg m (Msg Colog.Severity) -> m Text+formatMessage (RichMsg (Msg severity stack text) fields) = do+ posixTime <- extractField $ TypeRepMap.lookup @"posixTime" fields+ threadId <- extractField $ TypeRepMap.lookup @"threadId" fields+ return $ showSeverity severity+ <> " " <> maybe mempty showTime posixTime+ <> " " <> showSourceLoc stack+ <> " " <> showThread threadId+ <> " " <> text+ where showTime posixTime = "[" <> encode_YmdHMS (SubsecondPrecisionFixed 0) hyphen (timeToDatetime posixTime) <> "]"+ showThread (Just tid) = "[" <> show tid <> "]"+ showThread _ = mempty
src/main/Main.hs view
@@ -1,225 +1,200 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- {{{ Imports-import Alternate import qualified Core-import Database+import Database.Async as Database+import Database.Handle as Database+import Database.ReadOnly as Database+import Database.SQLite as SQLite import HTTP+import Input import Logger-import Options+import Output (putDocLn)+import qualified Output import XML -import Control.Concurrent.Async import Control.Concurrent.STM.TMChan import Control.Exception.Safe-import Data.Conduit.Combinators as Conduit (stdin)-import Dhall+import Dhall (auto, input) import Imm-import qualified Imm.Callback as Callback-import Imm.Database.Feed as Database-import qualified Imm.HTTP as HTTP import Imm.Pretty-import Pipes.ByteString-import System.Exit-import System.Process.Typed-import URI.ByteString+import Pipes.ByteString hiding (filter, stdout)+import Safe+import Streamly as Stream (async, asyncly, (|&))+import qualified Streamly.Prelude as Stream -- }}} main :: IO () main = do- AllOptions{..} <- parseOptions- let GlobalOptions{..} = optionGlobal+ programInput <- parseOptions+ Output.withHandle $ \stdout -> do+ withLogger programInput $ \logger -> do+ handleAny (log logger Error . pretty . displayException) $ do+ withDatabase logger stdout programInput $ \database -> do+ case inputCommand programInput of+ Subscribe u c -> Core.subscribe logger stdout database u c+ Unsubscribe query -> Core.unsubscribe logger database query+ Describe query -> Core.describeFeeds stdout database query+ Reset query -> Core.markAsUnprocessed logger database query+ Run f c -> main2 logger stdout database f =<< resolveCallbacks c (inputCallbacksFile programInput) - -- Setup logger- logger <- Logger.mkHandle <$> defaultLogger- setColorizeLogs logger optionColorizeLogs- setLogLevel logger optionLogLevel- log logger Debug $ "Options: " <> pretty optionCommand+ Database.commit logger database - 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- 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+withLogger :: ProgramInput -> (Logger.Handle IO -> IO ()) -> IO ()+withLogger programInput f = withLogHandler $ \logger -> do+ setLogLevel logger $ inputLogLevel programInput+ log logger Info $ "Input:" <+> pretty programInput+ f logger +withDatabase :: m ~ IO => Logger.Handle m -> Output.Handle m -> ProgramInput -> (Database.Handle m -> m ()) -> m ()+withDatabase logger stdout programInput f = do+ database <- SQLite.mkHandle =<< SQLite.defaultDatabase+ let database' = if inputReadOnlyDatabase programInput then readOnly logger database else database+ log logger Info . ("Using database:" <++>) . indent 2 =<< _describeDatabase database'+ Database.withAsyncHandle logger stdout database' f resolveCallbacks :: MonadIO m => CallbackMode -> FilePath -> m [Callback] resolveCallbacks EnableCallbacks callbacksFile = io $ input auto $ fromString callbacksFile resolveCallbacks _ _ = return mempty -main2 :: Logger.Handle IO -> Database.Handle IO -> FeedQuery -> [Callback] -> IO ()-main2 logger database feedQuery callbacks = do- let httpClient = HTTP.mkHandle logger+main2 :: Logger.Handle IO -> Output.Handle IO -> Database.Handle IO+ -> FeedQuery -> [Callback] -> IO ()+main2 logger stdout database feedQuery callbacks = do+ newItemsCount <- newTVarIO (0 :: Int)+ errorsCount <- newTVarIO (0 :: Int)+ errorsChan <- newTMChanIO - feedLocations <- mapM (Database.resolveFeedLocation database)- =<< Database.resolveEntryKey database feedQuery+ httpClient <- HTTP.mkHandle - feedLocationsChan <- newTMChanIO- targetFeedChan <- newTMChanIO- newItemsChan <- newTMChanIO- processedChan <- newTMChanIO+ -- Feed record => (feed record, items)+ let fetcher = catchErrors logger errorsChan errorsCount $ \feedRecord -> do+ log logger Debug "Fetch worker starts" - resolveErrorsChan <- newTMChanIO- fetchErrorsChan <- newTMChanIO- runErrorsChan <- newTMChanIO- callbackErrorsChan <- newTMChanIO+ let location@(FeedLocation uri _) = _feedLocation feedRecord+ (feedDefinition, items) <- Core.downloadFeed logger httpClient (toLazyM >=> parseXml xmlParser uri) location - newItemsCount <- newTVarIO (0 :: Int)- errorsCount <- newTVarIO (0 :: Int)+ newFeedStatus <- touchFeed $ _feedStatus feedRecord - -- => Feed IDs events- producer <- async $ forM_ feedLocations $ atomically . writeTMChan feedLocationsChan+ let newFeedRecord = feedRecord { _feedDefinition = feedDefinition, _feedStatus = newFeedStatus }+ _updateFeedDefinition database newFeedRecord+ _updateFeedStatus database newFeedRecord+ return $ Just (newFeedRecord, items) - -- Feed locations => feed direct URIs- let resolverF feedLocation = do- uri <- resolveFeedURI logger httpClient feedLocation- atomically $ writeTMChan targetFeedChan (feedLocation, uri)+ -- (Feed record, items) => (feed record, items, item records)+ let itemRetriever = catchErrors logger errorsChan errorsCount $ \(feedRecord, items) -> do+ itemRecords <- _fetchItems database $ _feedKey feedRecord+ return $ Just (feedRecord, items, itemRecords) - resolvers <- spawnConsumers logger 5 feedLocationsChan resolverF resolveErrorsChan errorsCount+ -- (Feed record, items, item records) => multiple (feed record, item, item records)+ let itemSplitter = \(feedRecord, items, itemRecords) ->+ Stream.fromList [(feedRecord, item, itemRecords) | item <- items] - -- 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+ let itemMatcher = \(feedRecord, item, itemRecords) -> do+ let itemRecord = itemRecords & filter (\r -> _itemDefinition r `areSameItem` item) & headMay+ return (feedRecord, item, itemRecord) - 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)+ -- Filter for unread items+ let unreadSelector (feedRecord, item, itemRecord) = checkDate || checkStatus where+ checkDate = case (_feedLastUpdate $ _feedStatus feedRecord, _itemDate item) of+ (Nothing, _) -> True+ (Just t0, Just t1) -> t0 < t1+ _ -> False+ checkStatus = itemRecord <&> _itemStatus <&> (not . _isProcessed) & fromMaybe True+ -- unprocessedElements <- listUnprocessedElements database entryKey - fetchers <- spawnConsumers logger 5 targetFeedChan fetcherF fetchErrorsChan errorsCount+ let logNewItem (feedRecord, item, _) = putDocLn stdout $ "New item:"+ <+> maybe "<unknown>" prettyTime (_itemDate item)+ <+> magenta (prettyName $ _feedDefinition feedRecord)+ <+> "/" <+> yellow (prettyName item) -- New items events => execute callback => processed/error events- let runnerF (entryKey, feed, element) = do- results <- forM callbacks $ \callback@(Callback executable arguments) -> do- let processInput = byteStringInput $ Callback.serializeMessage feed element- processConfig = proc executable (toString <$> arguments) & setStdin processInput-- 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)+ let runner = catchErrors logger errorsChan errorsCount $ \(feedRecord, item, itemRecord) -> do+ results <- forM callbacks $ \callback -> io $ do+ runCallback logger callback $ CallbackMessage (_feedDefinition feedRecord) item case lefts results of- [] -> atomically $ writeTMChan processedChan (entryKey, element)- e -> atomically $ do- writeTMChan callbackErrorsChan ((entryKey, element), e)- modifyTVar' errorsCount (+ 1)+ [] -> return $ Just (feedRecord, item, itemRecord)+ e -> do+ io $ atomically $ do+ writeTMChan errorsChan (toException $ CallbackException feedRecord item e)+ modifyTVar' errorsCount (+ 1)+ return Nothing - runners <- spawnConsumers logger 5 newItemsChan runnerF runErrorsChan errorsCount+ let storer (_, _, Just itemRecord) =+ Database.markItemAsProcessed logger database itemRecord+ storer (feedRecord, item, _) = do+ let itemRecord = mkFeedItemRecord (_feedKey feedRecord) item (FeedItemStatus True)+ void $ Database.insertItem logger database itemRecord - -- 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 feedLocationsChan-- mapM_ wait resolvers- atomically $ do- closeTMChan targetFeedChan- closeTMChan resolveErrorsChan-- mapM_ wait fetchers- atomically $ closeTMChan newItemsChan+ entries <- case feedQuery of+ QueryAll -> Database._fetchAllFeeds database+ QueryByUID uid -> pure <$> Database._fetchFeed database uid - mapM_ wait runners- atomically $ do- closeTMChan processedChan- closeTMChan fetchErrorsChan- closeTMChan callbackErrorsChan- closeTMChan runErrorsChan+ Stream.fromList entries+ |& Stream.mapMaybeM fetcher+ |& Stream.mapMaybeM itemRetriever+ |& Stream.concatMapWith async itemSplitter+ |& Stream.mapM itemMatcher+ |& Stream.filter unreadSelector+ |& Stream.trace logNewItem+ |& Stream.trace (const $ atomically $ modifyTVar' newItemsCount (+ 1))+ |& Stream.mapMaybeM runner+ |& Stream.mapM storer+ & Stream.asyncly+ & Stream.drain - wait storer+ atomically $ closeTMChan errorsChan -- Error events => log- handleErrors resolveErrorsChan (printResolveError logger)- handleErrors fetchErrorsChan (printFetchError logger)- handleErrors callbackErrorsChan (printCallbackError logger)- handleErrors runErrorsChan (printRunError logger)- flushLogs logger+ handleErrors stdout errorsChan - readTVarIO newItemsCount <&> pretty <&> bold <&> (<+> "new items") >>= log logger Info- readTVarIO errorsCount <&> pretty <&> bold <&> (<+> "errors") >>= log logger Info+ readTVarIO newItemsCount <&> pretty <&> bold <&> (<+> "new items") >>= putDocLn stdout+ readTVarIO errorsCount <&> pretty <&> bold <&> (<+> "errors") >>= putDocLn stdout -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+data CallbackException = CallbackException (FeedRecord Inserted) FeedItem [(Callback, Int, LByteString, LByteString)]+ deriving(Eq, Generic, Ord, Show, Typeable) -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+instance Exception CallbackException where+ displayException = show . pretty -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)+instance Pretty CallbackException where+ pretty (CallbackException feedRecord item e) =+ "Callback error for" <+> prettyName (_feedDefinition feedRecord) <+> "/" <+> prettyName item+ <++> 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') -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) -printCallbackError :: i ~ (EntryKey, FeedElement)- => e ~ (Callback, Int, LByteString, LByteString)- => Logger.Handle m -> (i, [e]) -> 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')+catchErrors :: MonadIO m => MonadCatch m+ => Logger.Handle m -> TMChan SomeException -> TVar Int -> (i -> m (Maybe a)) -> i -> m (Maybe a)+catchErrors logger errorsChan errorsCount f input_ = catchAny (f input_) $ \e -> do+ log logger Error $ pretty (displayException e)+ io $ atomically $ do+ writeTMChan errorsChan e+ modifyTVar' errorsCount (+ 1)+ return Nothing -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)++handleErrors :: MonadIO m => Output.Handle m -> TMChan SomeException -> m ()+handleErrors stdout errorsChan = fix $ \recurse -> do+ items <- atomically $ readTMChan errorsChan+ forM_ items $ \e -> putDocLn stdout (red $ pretty $ displayException e) >> recurse xmlParser :: XML.Handle IO
− src/main/Options.hs
@@ -1,165 +0,0 @@-{-# 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 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 FeedLocation (Set Text)- | List- | Describe FeedQuery- | Reset FeedQuery- | Run FeedQuery CallbackMode- | Unsubscribe FeedQuery--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:" <+> pretty f- pretty List = "List all feeds"- 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)----- * 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 "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 "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 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."-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."--tagOption :: Parser Text-tagOption = option auto $ long "tag" <> short 't' <> metavar "TAG" <> help "Set the given tag."--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--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--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.")--- }}}
+ src/main/Output.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}+module Output where++import Control.Concurrent.Async+import Control.Concurrent.STM.TMChan+import Data.Text.Prettyprint.Doc.Render.Terminal+import Imm.Pretty++-- * Types++-- | Handle to push messages to the program's output+newtype Handle m = Handle+ { putDocLn :: Doc AnsiStyle -> m ()+ }++withHandle :: (Handle IO -> IO ()) -> IO ()+withHandle f = do+ channel <- newTMChanIO++ thread <- async $ fix $ \recurse -> do+ maybeMessage <- atomically $ readTMChan channel+ forM_ maybeMessage $ \message -> do+ putLTextLn $ renderLazy $ layoutPretty defaultLayoutOptions message+ recurse++ f $ Handle { putDocLn = atomically . writeTMChan channel }+ atomically (closeTMChan channel) >> wait thread
src/main/Prelude.hs view
@@ -1,7 +1,19 @@-module Prelude (io, module Relude, module Relude.Extra.Map) where+module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, appendFile, force, readFile, writeFile)+import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) import Relude.Extra.Map (lookup)+import Control.Exception.Safe io :: MonadIO m => IO a -> m a io = liftIO++for :: [a] -> (a -> b) -> [b]+for = flip map++headThrow :: MonadThrow m => Exception e => e -> [a] -> m a+headThrow _ (a:_) = return a+headThrow e _ = throwM e++headFail :: MonadFail m => String -> [a] -> m a+headFail _ (a:_) = return a+headFail e _ = fail e
src/main/XML.hs view
@@ -10,10 +10,7 @@ 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 Text.XML.Stream.Parse as XML import URI.ByteString -- }}} @@ -24,7 +21,9 @@ -- | '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))+ { parseXml = \uri bytestring -> liftIO $ runConduit $ parseLBS def bytestring+ .| preProcess uri+ .| XML.force "Invalid feed" feedC } -- | Forward all 'Event's without any pre-process
src/send-mail/Main.hs view
@@ -3,23 +3,23 @@ {-# LANGUAGE OverloadedStrings #-} -- | 'Callback' for @imm@ that sends a mail via a SMTP server the input RSS/Atom item. -- {{{ Imports-import qualified Imm.Callback as Callback+import Imm.Callback (CallbackMessage (..)) import Imm.Feed+import Imm.Link import Imm.Pretty -import Data.ByteString.Lazy (getContents)-import Data.Text as Text (intercalate)+import Data.Aeson+import Data.ByteString.Lazy (getContents)+import Data.Text as Text (intercalate) import Data.Time-import Dhall hiding (map, maybe)-import Network.Mail.Mime hiding (sendmail)-import Options.Applicative hiding (auto)-import Refined-import System.Directory (XdgDirectory (..), getXdgDirectory)-import System.Exit (ExitCode (..))+import Dhall hiding (map, maybe)+import Network.Mail.Mime hiding (sendmail)+import Options.Applicative hiding (auto)+import System.Directory (XdgDirectory (..), getXdgDirectory)+import System.Exit (ExitCode (..)) import System.FilePath import System.Process.Typed-import Text.Atom.Types-import Text.RSS.Types+import URI.ByteString.Extended -- }}} -- | How to call external command@@ -32,10 +32,10 @@ -- | 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+ { formatFrom :: FeedDefinition -> FeedItem -> Address -- ^ How to write the From: header of feed mails+ , formatSubject :: FeedDefinition -> FeedItem -> Text -- ^ How to write the Subject: header of feed mails+ , formatBody :: FeedDefinition -> FeedItem -> Text -- ^ How to write the body of feed mails (sic!)+ , formatTo :: FeedDefinition -> FeedItem -> [Address] -- ^ How to write the To: header of feed mails } data CliOptions = CliOptions@@ -70,9 +70,9 @@ CliOptions configFile recipients dryRun <- parseOptions Command executable arguments <- input auto $ fromString configFile - message <- getContents <&> Callback.deserializeMessage+ message <- getContents <&> eitherDecode case message of- Right (feed, element) -> do+ Right (CallbackMessage feed element) -> do timezone <- io getCurrentTimeZone currentTime <- io getCurrentTime let formatMail = FormatMail defaultFormatFrom defaultFormatSubject defaultFormatBody (const $ const recipients)@@ -97,35 +97,31 @@ -- | 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") ""+defaultFormatFrom :: FeedDefinition -> FeedItem -> Address+defaultFormatFrom feed item = Address (Just $ title <> " (" <> authors <> ")") ""+ where title = _feedTitle feed+ authors = Text.intercalate ", " $ map _authorName $ _itemAuthors item -- | Fill mail subject with the element title-defaultFormatSubject :: Feed -> FeedElement -> Text-defaultFormatSubject _ = getTitle+defaultFormatSubject :: FeedDefinition -> FeedItem -> Text+defaultFormatSubject _ = _itemTitle -- | 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+defaultFormatBody :: FeedDefinition -> FeedItem -> Text+defaultFormatBody _ item = "<p>" <> Text.intercalate "<br/>" links <> "</p><p>" <> content <> "</p>"+ where links = map (withAnyURI (show . prettyURI) . _linkURI) $ _itemLinks item+ content = _itemContent item -- * Low-level helpers -- | Build mail from a given feed-buildMail :: FormatMail -> UTCTime -> TimeZone -> Feed -> FeedElement -> Mail+buildMail :: FormatMail -> UTCTime -> TimeZone -> FeedDefinition -> FeedItem -> Mail buildMail format currentTime timeZone feed element =- let date = formatTime defaultTimeLocale "%a, %e %b %Y %T %z" $ utcToZonedTime timeZone $ fromMaybe currentTime $ getDate element+ let date = formatTime defaultTimeLocale "%a, %e %b %Y %T %z" $ utcToZonedTime timeZone $ fromMaybe currentTime $ _itemDate element in Mail { mailFrom = formatFrom format feed element , mailTo = formatTo format feed element
src/send-mail/Prelude.hs view
@@ -1,7 +1,19 @@-module Prelude (io, module Relude, module Relude.Extra.Map) where+module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, appendFile, force, readFile, writeFile)+import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) import Relude.Extra.Map (lookup)+import Control.Exception.Safe io :: MonadIO m => IO a -> m a io = liftIO++for :: [a] -> (a -> b) -> [b]+for = flip map++headThrow :: MonadThrow m => Exception e => e -> [a] -> m a+headThrow _ (a:_) = return a+headThrow e _ = throwM e++headFail :: MonadFail m => String -> [a] -> m a+headFail _ (a:_) = return a+headFail e _ = fail e
src/write-file/Main.hs view
@@ -4,24 +4,24 @@ -- -- Meant to be use as a callback for imm. -- {{{ Imports-import Imm.Callback as Callback+import Imm.Callback import Imm.Feed+import Imm.Link import Imm.Pretty +import Data.Aeson import Data.ByteString.Builder import Data.ByteString.Lazy (getContents, writeFile)-import qualified Data.Text as Text (null, replace)+import qualified Data.Text as Text (replace) import Data.Time import Options.Applicative 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+import URI.ByteString.Extended -- }}} data CliOptions = CliOptions@@ -42,12 +42,12 @@ main :: IO () main = do CliOptions directory dryRun <- parseOptions- input <- getContents <&> Callback.deserializeMessage+ input <- getContents <&> eitherDecode - case input :: Either String (Feed, FeedElement) of- Right (feed, element) -> do- let content = defaultFileContent feed element- filePath = defaultFilePath directory feed element+ case input :: Either String CallbackMessage of+ Right (CallbackMessage feedDefinition item) -> do+ let content = defaultFileContent feedDefinition item+ filePath = defaultFilePath directory feedDefinition item putStrLn filePath unless dryRun $ do createDirectoryIfMissing True $ takeDirectory filePath@@ -58,11 +58,11 @@ -- * 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+defaultFilePath :: FilePath -> FeedDefinition -> FeedItem -> FilePath+defaultFilePath root feedDefinition element = makeValid $ root </> toString title </> fileName <.> "html" where+ date = maybe "" (formatTime defaultTimeLocale "%F-") $ _itemDate element+ fileName = date <> toString (sanitize $ _itemTitle element)+ title = sanitize $ _feedTitle feedDefinition sanitize = appEndo (mconcat [Endo $ Text.replace (toText [s]) "_" | s <- pathSeparators]) >>> Text.replace "." "_" >>> Text.replace "?" "_"@@ -70,59 +70,53 @@ >>> 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+defaultFileContent :: FeedDefinition -> FeedItem -> Builder+defaultFileContent feedDefinition element = renderHtmlBuilder $ docTypeHtml $ do H.head $ do H.meta ! H.charset "utf-8"- H.title $ convertText $ getFeedTitle feed <> " | " <> getTitle element+ H.title $ convertText $ _feedTitle feedDefinition <> " | " <> _itemTitle element H.body $ do- H.h1 $ convertText $ getFeedTitle feed+ H.h1 $ convertText $ _feedTitle feedDefinition H.article $ do H.header $ do- defaultArticleTitle feed element- defaultArticleAuthor feed element- defaultArticleDate feed element- defaultBody feed element+ defaultArticleTitle feedDefinition element+ defaultArticleAuthor feedDefinition element+ defaultArticleDate feedDefinition element+ defaultBody feedDefinition 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+defaultArticleTitle :: FeedDefinition -> FeedItem -> Html+defaultArticleTitle _ item = H.h2+ $ maybe id (\link -> H.a ! href (_linkURI link)) (getMainLink item)+ $ convertText $ _itemTitle item -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+defaultArticleAuthor :: FeedDefinition -> FeedItem -> Html+defaultArticleAuthor _ item = H.address $ do "Published by "- forM_ (entryAuthors entry) $ \author -> do- convertDoc $ prettyPerson author+ forM_ (_itemAuthors item) $ \author -> do+ convertDoc $ pretty author ", " -defaultArticleDate :: Feed -> FeedElement -> Html-defaultArticleDate _ element = forM_ (getDate element) $ \date -> H.p $ " on " >> H.time (convertDoc $ prettyTime date)+defaultArticleDate :: FeedDefinition -> FeedItem -> Html+defaultArticleDate _ element = forM_ (_itemDate 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+defaultBody :: FeedDefinition -> FeedItem -> Html+defaultBody _ item = 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+ H.ul $ forM_ links $ \uri -> H.li (H.a ! href uri $ convertURI uri)+ H.p $ preEscapedToHtml $ _itemContent item+ where links = _linkURI <$> _itemLinks item -href :: URIRef a -> H.Attribute+href :: AnyURI -> H.Attribute href = H.href . convertURI -convertAtomURI :: (IsString t) => AtomURI -> t-convertAtomURI = withAtomURI convertURI--convertURI :: (IsString t) => URIRef a -> t-convertURI = convertText . decodeUtf8 . serializeURIRef'+convertURI :: (IsString t) => AnyURI -> t+convertURI = convertText . decodeUtf8 . withAnyURI serializeURIRef' convertText :: (IsString t) => Text -> t convertText = fromString . toString
src/write-file/Prelude.hs view
@@ -1,7 +1,19 @@-module Prelude (io, module Relude, module Relude.Extra.Map) where+module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Relude hiding (Handle, appendFile, force, readFile, writeFile)+import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile) import Relude.Extra.Map (lookup)+import Control.Exception.Safe io :: MonadIO m => IO a -> m a io = liftIO++for :: [a] -> (a -> b) -> [b]+for = flip map++headThrow :: MonadThrow m => Exception e => e -> [a] -> m a+headThrow _ (a:_) = return a+headThrow e _ = throwM e++headFail :: MonadFail m => String -> [a] -> m a+headFail _ (a:_) = return a+headFail e _ = fail e