imm 2.1.1.0 → 2.1.2.0
raw patch · 39 files changed
+1923/−1521 lines, 39 filesdep +fast-loggerdep +reqdep +streamly-coredep −co-logdep −typerep-mapdep ~prettyprinterdep ~refineddep ~streamlysetup-changednew-component:exe:imm-wallabag
Dependencies added: fast-logger, req, streamly-core
Dependencies removed: co-log, typerep-map
Dependency ranges changed: prettyprinter, refined, streamly
Files
- README.md +37/−6
- Setup.hs +1/−0
- data/callbacks.dhall +20/−1
- flake.nix +9/−60
- imm.cabal +15/−8
- schema/imm.json +14/−0
- src/lib/Data/Aeson/Extended.hs +13/−10
- src/lib/Imm.hs +7/−5
- src/lib/Imm/Callback.hs +40/−31
- src/lib/Imm/Feed.hs +131/−118
- src/lib/Imm/HTTP.hs +17/−15
- src/lib/Imm/Link.hs +69/−66
- src/lib/Imm/Logger.hs +14/−11
- src/lib/Imm/Pretty.hs +86/−63
- src/lib/Imm/XML.hs +5/−3
- src/lib/Prelude.hs +13/−11
- src/lib/URI/ByteString/Extended.hs +28/−27
- src/main/Alternate.hs +61/−55
- src/main/Core.hs +103/−75
- src/main/Database/Async.hs +45/−40
- src/main/Database/Handle.hs +105/−97
- src/main/Database/ReadOnly.hs +21/−18
- src/main/Database/Record.hs +103/−82
- src/main/Database/SQLite.hs +208/−176
- src/main/HTTP.hs +16/−12
- src/main/Input.hs +102/−84
- src/main/Logger.hs +31/−47
- src/main/Main.hs +143/−115
- src/main/Output.hs +16/−14
- src/main/Prelude.hs +13/−11
- src/main/XML.hs +24/−17
- src/monolith/Main.hs +73/−53
- src/monolith/Prelude.hs +13/−11
- src/send-mail/Main.hs +85/−78
- src/send-mail/Prelude.hs +13/−11
- src/wallabag/Main.hs +96/−0
- src/wallabag/Prelude.hs +21/−0
- src/write-file/Main.hs +99/−79
- src/write-file/Prelude.hs +13/−11
README.md view
@@ -1,7 +1,7 @@ # imm -[](https://builtwithnix.org) [](https://github.com/k0ral/imm/actions)+[](https://builtwithnix.org) *imm* is a program that executes arbitrary callbacks (e.g. sending a mail, or writing a file) for each element of RSS/Atom feeds.@@ -20,7 +20,7 @@ This repository is notably a [Nix flake][flakes] that can be installed by running the following command at the root folder: ```bash-nix build+nix develop --command cabal build ``` ### Without nix@@ -73,10 +73,10 @@ ### Offline read-it-later -*imm* is able to store a local copy of unread elements, to read them later while offline for example.+*imm* is able to store a local copy of unread elements, to read them later while offline for example. There are 3 alternate ways of achieving this. -There are 2 alternate ways of achieving this:-- using `imm-writefile` will produce a light HTML file with no stylesheets, no scripts and with links to online resources (images, fonts, ...) that won't be available offline:+#### `imm-writefile`+`imm-writefile` will produce a light HTML file with no stylesheets, no scripts and with links to online resources (images, fonts, ...) that won't be available offline: ```dhall let Callback : Type = { _executable : Text@@ -91,7 +91,9 @@ let config : List Callback = [ writeFile ] in config ```-- using `imm-monolith` will produce a heavy, self-contained HTML file, with embedded stylesheets, scripts, images and fonts; links to external web pages will still require an internet connection:++#### `imm-monolith`+`imm-monolith` will produce a heavy, self-contained HTML file, with embedded stylesheets, scripts, images and fonts; links to external web pages will still require an internet connection: ```dhall let Callback : Type = { _executable : Text@@ -106,8 +108,36 @@ let config : List Callback = [ downloadPage ] in config ```+#### `imm-wallabag`+`imm-wallabag` will save webpages into a [Wallabag][wallabag] server through its REST API:+ ```dhall+ let Callback : Type =+ { _executable : Text+ , _arguments : List Text+ } + let wallabag =+ { _executable = "imm-wallabag"+ , _arguments =+ [ "--host"+ , "INSERT_HOST"+ , "--port"+ , "INSERT_PORT"+ , "--client-id"+ , "INSERT_CLIENT_ID"+ , "--client-secret"+ , "INSERT_CLIENT_SECRET"+ , "--username"+ , "INSERT_WALLABAG_USERNAME"+ , "--password"+ , "INSERT_WALLABAG_PASSWORD"+ ]+ } + let config : List Callback = [ wallabag ]+ in config+ ```+ ## Example usage - Subscribe to a feed through direct URL:@@ -149,3 +179,4 @@ [2]: https://www.haskell.org [3]: https://dhall-lang.org/ [flakes]: https://nixos.wiki/wiki/Flakes+[wallabag]: https://www.wallabag.it/
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
data/callbacks.dhall view
@@ -5,7 +5,7 @@ , _arguments : List Text } --- Below are 3 basic callbacks bundled with imm.+-- Below are 4 basic callbacks bundled with imm. -- Check out `imm-monolith --help` let downloadPage = { _executable = "imm-monolith"@@ -23,6 +23,25 @@ { _executable = "imm-sendmail" , _arguments = ["--login", "-u", "user@domain.com", "-P", "password", "-s", "smtp.domain.com", "-p", "587", "--to", "foo.bar@domain.com"] }++-- Check out `imm-wallabag --help`+let wallabag =+ { _executable = "imm-wallabag"+ , _arguments =+ [ "--host"+ , "INSERT_HOST"+ , "--port"+ , "INSERT_PORT"+ , "--client-id"+ , "INSERT_CLIENT_ID"+ , "--client-secret"+ , "INSERT_CLIENT_SECRET"+ , "--username"+ , "INSERT_USERNAME"+ , "--password"+ , "INSERT_PASSWORD"+ ]+ } let config : List Callback = [ downloadPage ] in config
flake.nix view
@@ -2,71 +2,20 @@ description = "imm flake"; inputs = {- nixpkgs.url = "github:NixOS/nixpkgs/8e4fe32876ca15e3d5eb3ecd3ca0b224417f5f17";- flake-utils.url = "github:numtide/flake-utils/2ebf2558e5bf978c7fb8ea927dfaed8fefab2e28";- beam.url = "github:haskell-beam/beam/efd464b079755a781c2bb7a2fc030d6c141bbb8a";- beam.flake = false;- rss-conduit.url = "github:k0ral/rss-conduit/c1fec73d715fd1c9a95a155e87ba469887b8e543";- rss-conduit.flake = false;+ nixpkgs.url = "github:NixOS/nixpkgs/574d1eac1c200690e27b8eb4e24887f8df7ac27c";+ utils.url = "github:numtide/flake-utils";+ utils.inputs.nixpkgs.follows = "nixpkgs"; }; - outputs = { self, nixpkgs, flake-utils, beam, rss-conduit }:- flake-utils.lib.eachDefaultSystem (system:+ outputs = { self, nixpkgs, utils }:+ utils.lib.eachDefaultSystem (system: let pkgs = nixpkgs.legacyPackages.${system};- hlib = pkgs.haskell.lib;- packageName = "imm";-- source = pkgs.nix-gitignore.gitignoreSource [ ] ./.;- package = with pkgs;- add-runtime-dependencies (my-haskell-packages.callCabal2nix packageName source { }) [- monolith- pup- sqliteInteractive- ];-- my-haskell-packages = pkgs.haskellPackages.override {- overrides = hself: hsuper:- let from-hackage = x: hlib.doJailbreak (hlib.dontCheck (hlib.dontHaddock (hsuper.callHackageDirect x { })));- in {- imm = package;- beam-core = hlib.doJailbreak (hself.callCabal2nix "beam-core" "${beam}/beam-core" { });- beam-migrate = hlib.doJailbreak (hself.callCabal2nix "beam-core" "${beam}/beam-migrate" { });- beam-sqlite = hlib.doJailbreak (hself.callCabal2nix "beam-core" "${beam}/beam-sqlite" { });- rss-conduit = hself.callCabal2nix "rss-conduit" rss-conduit { };- };- };-- add-runtime-dependencies = drv: xs:- hlib.overrideCabal drv (drv: {- buildDepends = (drv.buildDepends or [ ]) ++ [ pkgs.makeWrapper ];- postInstall = ''- ${drv.postInstall or ""}- for exe in "$out/bin/"* ; do- wrapProgram "$exe" --prefix PATH ":" \- ${nixpkgs.lib.makeBinPath xs}- done- '';- });- in {- defaultPackage = self.packages.${system}.${packageName};-- packages.${packageName} = hlib.justStaticExecutables package;-- devShell = my-haskell-packages.shellFor {- packages = p: [ p.${packageName} ];-- buildInputs = with my-haskell-packages; [- cabal-install- ghcid- hlint- pkgs.sqliteInteractive- ];-- inputsFrom = builtins.attrValues self.packages.${system};- withHoogle = false;+ # `nix develop`+ devShells.default = pkgs.mkShell {+ buildInputs = with pkgs.haskellPackages;+ [ cabal-install ghcid haskell-language-server hlint fourmolu pkgs.sqlite-interactive pkgs.zlib ]; };- }); }
imm.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: imm-version: 2.1.1.0+version: 2.1.2.0 synopsis: Execute arbitrary actions for each item from RSS/Atom feeds description: Cf README file homepage: https://github.com/k0ral/imm@@ -12,7 +12,7 @@ build-type: Simple data-files: data/*.dhall extra-source-files: README.md, *.nix, schema/*.json-tested-with: GHC <8.12 && >=8.4.4+tested-with: GHC <=9.6 && >=8.10 source-repository head type: git@@ -54,7 +54,7 @@ parsers, pipes, pipes-bytestring,- prettyprinter,+ prettyprinter >=1.7.0, prettyprinter-ansi-terminal, refined >=0.4.1, rss-conduit >= 0.5.1,@@ -72,9 +72,9 @@ executable imm import: common- 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 >=0.7, text, time, typed-process, typerep-map, uri-bytestring, xml-conduit >=1.5, xml-types+ build-depends: imm, aeson, async, beam-core, beam-sqlite, bytestring, chronos, conduit, containers, dhall >=1.27, directory, fast-logger, 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 >=0.9, streamly-core, text, time, typed-process, uri-bytestring, xml-conduit >=1.5, xml-types main-is: Main.hs- other-modules: + other-modules: Alternate Core Database.Async@@ -94,21 +94,28 @@ executable imm-monolith import: common- build-depends: imm, aeson, bytestring, directory, filepath, optparse-applicative, prettyprinter, safe-exceptions, text, time, typed-process, uri-bytestring+ build-depends: imm, aeson, bytestring, directory, filepath, optparse-applicative, prettyprinter >=1.7.0, safe-exceptions, text, time, typed-process, uri-bytestring main-is: Main.hs hs-source-dirs: src/monolith ghc-options: -Wall -fno-warn-unused-do-bind -threaded executable imm-writefile import: common- build-depends: imm, aeson, blaze-html, blaze-markup, bytestring, directory, filepath, optparse-applicative, prettyprinter, safe-exceptions, text, time, uri-bytestring+ build-depends: imm, aeson, blaze-html, blaze-markup, bytestring, directory, filepath, optparse-applicative, prettyprinter >=1.7.0, 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, 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+ build-depends: imm, aeson, blaze-html, blaze-markup, bytestring, dhall >= 1.27, directory, filepath, mime-mail, optparse-applicative, prettyprinter >=1.7.0, 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++executable imm-wallabag+ import: common+ build-depends: imm, aeson, bytestring, dhall >= 1.27, optparse-applicative, prettyprinter >=1.7.0, refined, req, safe-exceptions, text, time, uri-bytestring+ main-is: Main.hs+ hs-source-dirs: src/wallabag ghc-options: -Wall -fno-warn-unused-do-bind -threaded
schema/imm.json view
@@ -4,11 +4,25 @@ "CallbackMessage": { "type": "object", "properties": {+ "feed_location": {+ "$ref": "#/definitions/FeedLocation"+ }, "feed_definition": { "$ref": "#/definitions/FeedDefinition" }, "feed_item": { "$ref": "#/definitions/ItemDefinition"+ }+ }+ },+ "FeedLocation": {+ "type": "object",+ "properties": {+ "uri": {+ "type": "string"+ },+ "title": {+ "type": "string" } } },
src/lib/Data/Aeson/Extended.hs view
@@ -1,18 +1,21 @@-module Data.Aeson.Extended- ( module Data.Aeson- , module Data.Aeson.Types- , module Data.Aeson.Extended- ) where+{-# LANGUAGE UnicodeSyntax #-} -import Data.Aeson-import Data.Aeson.Types-import URI.ByteString+module Data.Aeson.Extended (+ module Data.Aeson,+ module Data.Aeson.Types,+ module Data.Aeson.Extended,+)+where +import Data.Aeson+import Data.Aeson.Types+import URI.ByteString+ -- | Newtype wrapper to provide 'FromJSON' and 'ToJSON' instances for 'URI'-newtype JsonURI = JsonURI { _unwrapURI :: URI }+newtype JsonURI = JsonURI {_unwrapURI ∷ URI} instance FromJSON JsonURI where- parseJSON = withText "URI" $ \s ->+ parseJSON = withText "URI" $ \s → either (const $ fail "Invalid URI") (return . JsonURI) $ parseURI laxURIParserOptions $ encodeUtf8 s instance ToJSON JsonURI where
src/lib/Imm.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE UnicodeSyntax #-}+ -- | Meta-module that reexports many Imm sub-modules. module Imm (module X) where -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)+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,28 +1,31 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}-module Imm.Callback (Callback(..), CallbackMessage(..), runCallback) where+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnicodeSyntax #-} +module Imm.Callback (Callback (..), CallbackMessage (..), runCallback) where+ -- {{{ Imports-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+import Data.Aeson+import Data.Aeson.Encode.Pretty+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@). data Callback = Callback- { _executable :: FilePath- , _arguments :: [Text]- } deriving (Eq, Generic, Ord, Read, Show)+ { _executable ∷ FilePath+ , _arguments ∷ [Text]+ }+ deriving (Eq, Generic, Ord, Read, Show) instance FromDhall Callback @@ -33,37 +36,43 @@ -- -- 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)--customOptions :: Options-customOptions = defaultOptions- { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_callback")- , omitNothingFields = True+ { _callbackFeedLocation ∷ FeedLocation+ , _callbackFeedDefinition ∷ FeedDefinition+ , _callbackFeedItem ∷ FeedItem }+ deriving (Eq, Generic, Ord, Show, Typeable) +customOptions ∷ Options+customOptions =+ defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_callback")+ , omitNothingFields = True+ }+ instance ToJSON CallbackMessage where- toJSON = genericToJSON customOptions+ toJSON = genericToJSON customOptions toEncoding = genericToEncoding customOptions instance FromJSON CallbackMessage where parseJSON = genericParseJSON customOptions instance Pretty (PrettyShort CallbackMessage) where- pretty (PrettyShort (CallbackMessage feed item)) = prettyName feed <+> "/" <+> pretty (_itemTitle item)-+ pretty (PrettyShort (CallbackMessage location feed item)) = pretty location <+> "/" <+> prettyName feed <+> "/" <+> pretty (_itemTitle item) -runCallback :: MonadIO m- => Logger.Handle m -> Callback -> CallbackMessage -> m (Either (Callback, Int, LByteString, LByteString) (Callback, LByteString, LByteString))+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+ (exitCode, output, errors) ← readProcess processConfig case exitCode of- ExitSuccess -> return $ Right (callback, output, errors)- ExitFailure i -> return $ Left (callback, i, output, errors)+ ExitSuccess → return $ Right (callback, output, errors)+ ExitFailure i → return $ Left (callback, i, output, errors)
src/lib/Imm/Feed.hs view
@@ -1,98 +1,106 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnicodeSyntax #-}+ -- | Feed data structures.-module Imm.Feed- ( -- * Types- FeedLocation(..)- , UID- , FeedQuery(..)- , FeedDefinition(..)- , FeedItem(..)- , Author(..)- , -- * Parsers- parseFeed- , feedC- , parseFeedItem- , -- * Utilities- getMainLink- , areSameItem- ) where+module Imm.Feed (+ -- * Types+ FeedLocation (..),+ UID,+ FeedQuery (..),+ FeedDefinition (..),+ FeedItem (..),+ Author (..), + -- * Parsers+ parseFeed,+ feedC,+ parseFeedItem,++ -- * Utilities+ getMainLink,+ areSameItem,+)+where+ -- {{{ Imports-import Conduit-import Control.Exception.Safe-import Data.Aeson.Extended-import Data.Text as Text (null)-import Data.Time-import Data.XML.Types-import Imm.Link-import Imm.Pretty-import Refined-import Safe-import Text.Atom.Conduit.Parse-import Text.Atom.Types-import Text.RSS.Conduit.Parse-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 URI.ByteString.Extended+import Conduit+import Control.Exception.Safe+import Data.Aeson.Extended+import Data.Text as Text (null)+import Data.Time+import Data.XML.Types+import Imm.Link+import Imm.Pretty+import Refined+import Safe+import Text.Atom.Conduit.Parse+import Text.Atom.Types+import Text.RSS.Conduit.Parse+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 URI.ByteString.Extended+ -- }}} -- | 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 = FeedLocation URI Text- deriving(Eq, Generic, Ord, Show, Typeable)+ deriving (Eq, Generic, Ord, Show, Typeable) instance Pretty FeedLocation where- pretty (FeedLocation uri title) = prettyURI uri- <> if Text.null title then mempty else space <> brackets (pretty title)+ 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- ]+ toJSON (FeedLocation uri title) =+ object+ [ "uri" .= toJSON (JsonURI uri)+ , "title" .= title+ ] instance FromJSON FeedLocation where- parseJSON = withObject "FeedLocation" $ \v -> do+ parseJSON = withObject "FeedLocation" $ \v → do FeedLocation <$> (_unwrapURI <$> (v .: "uri")) <*> (v .: "title") - -- | Database identifier for a feed type UID = Int -- | A query describes a set of feeds through some criteria. data FeedQuery = QueryByUID UID | QueryAll- deriving(Eq, Ord, Read, Show, Typeable)+ deriving (Eq, Ord, Read, Show, Typeable) instance Pretty FeedQuery where- pretty QueryAll = "All subscribed feeds"+ pretty QueryAll = "All subscribed feeds" pretty (QueryByUID k) = "Feed" <+> pretty k - newtype FeedDefinition = FeedDefinition- { _feedTitle :: Text- } deriving(Eq, Generic, Ord, Read, Show, Typeable)--feedDefinitionOptions :: Options-feedDefinitionOptions = defaultOptions- { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_feed")- , omitNothingFields = True+ { _feedTitle ∷ Text }+ deriving (Eq, Generic, Ord, Read, Show, Typeable) +feedDefinitionOptions ∷ Options+feedDefinitionOptions =+ defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_feed")+ , omitNothingFields = True+ }+ instance ToJSON FeedDefinition where- toJSON = genericToJSON feedDefinitionOptions+ toJSON = genericToJSON feedDefinitionOptions toEncoding = genericToEncoding feedDefinitionOptions instance FromJSON FeedDefinition where@@ -104,21 +112,22 @@ instance Pretty (PrettyName FeedDefinition) where pretty (PrettyName definition) = pretty $ _feedTitle definition - data Author = Author- { _authorName :: Text- , _authorEmail :: Text- , _authorURI :: Maybe AnyURI- } deriving(Eq, Generic, Ord, Show, Typeable)--authorOptions :: Options-authorOptions = defaultOptions- { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_author")- , omitNothingFields = True+ { _authorName ∷ Text+ , _authorEmail ∷ Text+ , _authorURI ∷ Maybe AnyURI }+ deriving (Eq, Generic, Ord, Show, Typeable) +authorOptions ∷ Options+authorOptions =+ defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_author")+ , omitNothingFields = True+ }+ instance ToJSON Author where- toJSON = genericToJSON authorOptions+ toJSON = genericToJSON authorOptions toEncoding = genericToEncoding authorOptions instance FromJSON Author where@@ -127,24 +136,25 @@ instance Pretty Author where pretty Author{..} = pretty _authorName <+> brackets (pretty _authorEmail) - data FeedItem = FeedItem- { _itemDate :: Maybe UTCTime- , _itemTitle :: Text- , _itemContent :: Text- , _itemLinks :: [Link]- , _itemIdentifier :: Text- , _itemAuthors :: [Author]- } deriving(Eq, Generic, Ord, Show, Typeable)--feedItemOptions :: Options-feedItemOptions = defaultOptions- { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_item")- , omitNothingFields = True+ { _itemDate ∷ Maybe UTCTime+ , _itemTitle ∷ Text+ , _itemContent ∷ Text+ , _itemLinks ∷ [Link]+ , _itemIdentifier ∷ Text+ , _itemAuthors ∷ [Author] }+ deriving (Eq, Generic, Ord, Show, Typeable) +feedItemOptions ∷ Options+feedItemOptions =+ defaultOptions+ { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_item")+ , omitNothingFields = True+ }+ instance ToJSON FeedItem where- toJSON = genericToJSON feedItemOptions+ toJSON = genericToJSON feedItemOptions toEncoding = genericToEncoding feedItemOptions instance FromJSON FeedItem where@@ -156,32 +166,35 @@ instance Pretty FeedItem where pretty FeedItem{..} = maybe "<unknown>" prettyTime _itemDate <+> pretty _itemTitle --parseFeed :: MonadCatch m => Text -> m (FeedDefinition, [FeedItem])+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+parseAtomFeed ∷ AtomFeed → (FeedDefinition, [FeedItem])+parseAtomFeed feed = (definition, items)+ where definition = FeedDefinition (show $ prettyAtomText $ feedTitle feed) items = parseAtomItem <$> feedEntries feed -parseRssFeed :: RssDocument (ContentModule (DublinCoreModule NoExtensions)) -> (FeedDefinition, [FeedItem])-parseRssFeed doc = (definition, items) where+parseRssFeed ∷ RssDocument (ContentModule (DublinCoreModule NoExtensions)) → (FeedDefinition, [FeedItem])+parseRssFeed doc = (definition, items)+ where definition = FeedDefinition (channelTitle doc) items = parseRssItem <$> channelItems doc -- | Conduit version of 'parseFeed'-feedC :: MonadCatch m => ConduitT Event o m (Maybe (FeedDefinition, [FeedItem]))-feedC = choose [atom, rss, rss1] where+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 -parseFeedItem :: MonadCatch m => Text -> m FeedItem+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]) -parseAtomItem :: AtomEntry -> FeedItem-parseAtomItem entry = FeedItem date title content links identifier authors where+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@@ -190,38 +203,38 @@ 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]+ authors = [Author (unrefine name) email (withAtomURI AnyURI <$> uri) | AtomPerson name email uri ← entryAuthors entry] -parseRssItem :: RssItem (ContentModule (DublinCoreModule NoExtensions)) -> FeedItem-parseRssItem item = FeedItem date title content links identifier authors where+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]+ 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] - -- TODO: replace headMay with singleMay-getMainLink :: FeedItem -> Maybe Link-getMainLink item = _itemLinks item & filter (\l -> _linkRelation l == Just Alternate) & headMay+getMainLink ∷ FeedItem → Maybe Link+getMainLink item = _itemLinks item & filter (\l → _linkRelation l == Just Alternate) & headMay -haveSameIdentifier :: FeedItem -> FeedItem -> Maybe Bool+haveSameIdentifier ∷ FeedItem → FeedItem → Maybe Bool haveSameIdentifier item1 item2 = case (_itemIdentifier item1, _itemIdentifier item2) of- ("", "") -> Nothing- (a, b) -> Just (a == b)+ ("", "") → Nothing+ (a, b) → Just (a == b) -haveSameLink :: FeedItem -> FeedItem -> Maybe Bool+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+ (Just a, Just b) → Just (a == b)+ (Nothing, Nothing) → Nothing+ _ → Just False -haveSameTitle :: FeedItem -> FeedItem -> Maybe Bool+haveSameTitle ∷ FeedItem → FeedItem → Maybe Bool haveSameTitle item1 item2 = case (_itemTitle item1, _itemTitle item2) of- ("" :: Text, "" :: Text) -> Nothing- (a, b) -> Just (a == b)+ ("" ∷ Text, "" ∷ Text) → Nothing+ (a, b) → Just (a == b) -areSameItem :: FeedItem -> FeedItem -> Bool+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
@@ -1,39 +1,41 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnicodeSyntax #-}+ -- | HTTP module abstracts over HTTP requests to the external world. -- -- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html). -- -- > import qualified Imm.HTTP as HTTP-module Imm.HTTP- ( module Imm.HTTP- , module Network.HTTP.Client- ) 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.Pretty+import Imm.Logger hiding (Handle)+import qualified Imm.Logger as Logger+import Imm.Pretty+import Network.HTTP.Client+import Pipes.Core+import URI.ByteString -import Network.HTTP.Client-import Pipes.Core-import URI.ByteString -- }}} -- * Types -- | Handle to perform GET HTTP requests. newtype Handle m = Handle- { _withGet :: forall a. URI -> (Response (Producer ByteString m ()) -> m a) -> m a+ { _withGet ∷ ∀ 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 -> (Response (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 Info $ "GET" <+> prettyURI uri _withGet handle uri f
src/lib/Imm/Link.hs view
@@ -1,52 +1,55 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnicodeSyntax #-}+ -- | 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+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+ { _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+ 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)@@ -56,63 +59,63 @@ instance FromJSON Relation -parseRelation :: Text -> Maybe 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-+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+ { _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+ 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+parseMediaType ∷ Stream s Identity Char ⇒ s → Maybe MediaType+parseMediaType = either (const Nothing) pure . parse parser ""+ where parser = do- t <- some $ noneOf "/"+ t ← some $ noneOf "/" char '/'- subtype <- some $ noneOf "+;"- suffix <- optional $ char '+' >> some (noneOf ";")- parameters <- many $ char ';' >> some (noneOf ";")+ 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 ∷ [Text] → MediaType pattern MediaTypeRSS parameters = MediaType "application" "rss" "xml" parameters -pattern MediaTypeAtom :: [Text] -> MediaType+pattern MediaTypeAtom ∷ [Text] → MediaType pattern MediaTypeAtom parameters = MediaType "application" "atom" "xml" parameters -pattern MediaTypeApplicationXML :: Text -> [Text] -> MediaType+pattern MediaTypeApplicationXML ∷ Text → [Text] → MediaType pattern MediaTypeApplicationXML suffix parameters = MediaType "application" "xml" suffix parameters -pattern MediaTypeTextXML :: Text -> [Text] -> MediaType+pattern MediaTypeTextXML ∷ Text → [Text] → MediaType pattern MediaTypeTextXML suffix parameters = MediaType "text" "xml" suffix parameters -pattern MediaTypeHTML :: Text -> [Text] -> MediaType+pattern MediaTypeHTML ∷ Text → [Text] → MediaType pattern MediaTypeHTML suffix parameters = MediaType "text" "html" suffix parameters
src/lib/Imm/Logger.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}+ -- | Logger module abstracts over logging data. -- -- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).@@ -11,22 +13,23 @@ module Imm.Logger where -- {{{ Imports-import Imm.Pretty+import Imm.Pretty+ -- }}} -- * Types data Handle m = Handle- { log :: LogLevel -> Doc AnsiStyle -> m ()- , getLogLevel :: m LogLevel- , setLogLevel :: LogLevel -> m ()+ { log ∷ LogLevel → Doc AnsiStyle → m ()+ , getLogLevel ∷ m LogLevel+ , setLogLevel ∷ LogLevel → m () } data LogLevel = Debug | Info | Warning | Error- deriving(Eq, Ord, Read, Show)+ deriving (Eq, Ord, Read, Show) instance Pretty LogLevel where- pretty Debug = "DEBUG"- pretty Info = "INFO"+ pretty Debug = "DEBUG"+ pretty Info = "INFO" pretty Warning = "WARNING"- pretty Error = "ERROR"+ pretty Error = "ERROR"
src/lib/Imm/Pretty.hs view
@@ -1,124 +1,147 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnicodeSyntax #-}+ module Imm.Pretty (module Imm.Pretty, module X) where -- {{{ Imports-import qualified Data.Text as Text-import Data.Text.Prettyprint.Doc (list)-import Data.Text.Prettyprint.Doc as X hiding (list, width)-import Data.Text.Prettyprint.Doc.Render.Terminal-import Data.Text.Prettyprint.Doc.Render.Terminal as X (AnsiStyle)-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--- }}}+import qualified Data.Text as Text+import Data.Time+import Data.Tree+import Data.XML.Types as XML+import Prettyprinter (list)+import Prettyprinter as X hiding (list, width)+import Prettyprinter.Render.Terminal+import Prettyprinter.Render.Terminal as X (AnsiStyle)+import qualified Prettyprinter.Render.Terminal as Pretty+import Refined+import Text.Atom.Types as Atom+import Text.RSS.Types as RSS+import URI.ByteString +-- }}} -- | 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 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 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 a) ⇒ a → Doc b prettyShort = pretty . PrettyShort - -- | Infix operator for 'line'-(<++>) :: Doc a -> Doc a -> Doc a+(<++>) ∷ Doc a → Doc a → Doc a x <++> y = x <> line <> y -prettyTree :: (Pretty a) => Tree a -> Doc b+prettyTree ∷ Pretty a ⇒ Tree a → Doc b prettyTree (Node n s) = pretty n <++> indent 2 (vsep $ prettyTree <$> s) -prettyTime :: UTCTime -> Doc a+prettyTime ∷ UTCTime → Doc a prettyTime = pretty . formatTime defaultTimeLocale "%F %T" -prettyPerson :: AtomPerson -> Doc a-prettyPerson p = pretty (unrefine $ personName p) <> email where- email = if Text.null $ personEmail p- then mempty- else space <> angles (pretty $ personEmail p)+prettyPerson ∷ AtomPerson → Doc a+prettyPerson p = pretty (unrefine $ personName p) <> email+ where+ email =+ if Text.null $ personEmail p+ then mempty+ else space <> angles (pretty $ personEmail p) -prettyLink :: AtomLink -> Doc a+prettyLink ∷ AtomLink → Doc a prettyLink l = withAtomURI prettyURI $ linkHref l -prettyAtomText :: AtomText -> Doc a-prettyAtomText (AtomPlainText _ t) = pretty t+prettyAtomText ∷ AtomText → Doc a+prettyAtomText (AtomPlainText _ t) = pretty t prettyAtomText (AtomXHTMLText element) = prettyElement element -prettyElement :: Element -> Doc a+prettyElement ∷ Element → Doc a prettyElement (Element _ _ nodes) = mconcat $ map prettyNode nodes -prettyNode :: Node -> Doc a+prettyNode ∷ Node → Doc a prettyNode (NodeElement element) = prettyElement element prettyNode (NodeContent content) = prettyContent content-prettyNode _ = mempty+prettyNode _ = mempty -prettyContent :: Content -> Doc a-prettyContent (ContentText t) = pretty t+prettyContent ∷ Content → Doc a+prettyContent (ContentText t) = pretty t prettyContent (ContentEntity "lt") = "<" prettyContent (ContentEntity "gt") = ">"-prettyContent _ = "?"+prettyContent _ = "?" -prettyEntry :: AtomEntry -> Doc a-prettyEntry e = "Entry:" <+> prettyAtomText (entryTitle e) <++> indent 4- ( "By" <+> equals <+> list (prettyPerson <$> entryAuthors e)- <++> "Updated" <+> equals <+> prettyTime (entryUpdated e)- <++> "Links" <+> equals <+> list (prettyLink <$> entryLinks e)- -- , " Item Body: " ++ (Imm.Mail.getItemContent item),- )+prettyEntry ∷ AtomEntry → Doc a+prettyEntry e =+ "Entry:"+ <+> prettyAtomText (entryTitle e)+ <++> indent+ 4+ ( "By"+ <+> equals+ <+> list (prettyPerson <$> entryAuthors e)+ <++> "Updated"+ <+> equals+ <+> prettyTime (entryUpdated e)+ <++> "Links"+ <+> equals+ <+> list (prettyLink <$> entryLinks e)+ -- , " Item Body: " ++ (Imm.Mail.getItemContent item),+ ) -prettyItem :: RssItem e -> Doc a-prettyItem i = "Item:" <+> pretty (itemTitle i) <++> indent 4- ( "By" <+> equals <+> pretty (itemAuthor i)- <++> "Updated" <+> equals <+> maybe "<empty>" prettyTime (itemPubDate i)- <++> "Link" <+> equals <+> maybe "<empty>" (withRssURI prettyURI) (itemLink i)- )+prettyItem ∷ RssItem e → Doc a+prettyItem i =+ "Item:"+ <+> pretty (itemTitle i)+ <++> indent+ 4+ ( "By"+ <+> equals+ <+> pretty (itemAuthor i)+ <++> "Updated"+ <+> equals+ <+> maybe "<empty>" prettyTime (itemPubDate i)+ <++> "Link"+ <+> equals+ <+> maybe "<empty>" (withRssURI prettyURI) (itemLink i)+ ) -prettyURI :: URIRef a -> Doc b+prettyURI ∷ URIRef a → Doc b prettyURI uri = pretty @Text $ decodeUtf8 $ serializeURIRef' uri -prettyGuid :: RssGuid -> Doc a-prettyGuid (GuidText t) = pretty t+prettyGuid ∷ RssGuid → Doc a+prettyGuid (GuidText t) = pretty t prettyGuid (GuidUri (RssURI u)) = prettyURI u -prettyAtomContent :: AtomContent -> Doc a-prettyAtomContent (AtomContentInlineText _ t) = pretty t+prettyAtomContent ∷ AtomContent → Doc a+prettyAtomContent (AtomContentInlineText _ t) = pretty t prettyAtomContent (AtomContentInlineXHTML element) = prettyElement element-prettyAtomContent (AtomContentInlineOther _ t) = pretty t-prettyAtomContent (AtomContentOutOfLine _ u) = withAtomURI prettyURI u+prettyAtomContent (AtomContentInlineOther _ t) = pretty t+prettyAtomContent (AtomContentOutOfLine _ u) = withAtomURI prettyURI u -magenta :: Doc AnsiStyle -> Doc AnsiStyle+magenta ∷ Doc AnsiStyle → Doc AnsiStyle magenta = annotate $ color Magenta -yellow :: Doc AnsiStyle -> Doc AnsiStyle+yellow ∷ Doc AnsiStyle → Doc AnsiStyle yellow = annotate $ color Yellow -red :: Doc AnsiStyle -> Doc AnsiStyle+red ∷ Doc AnsiStyle → Doc AnsiStyle red = annotate $ color Red -green :: Doc AnsiStyle -> Doc AnsiStyle+green ∷ Doc AnsiStyle → Doc AnsiStyle green = annotate $ color Green -cyan :: Doc AnsiStyle -> Doc AnsiStyle+cyan ∷ Doc AnsiStyle → Doc AnsiStyle cyan = annotate $ color Cyan -bold :: Doc AnsiStyle -> Doc AnsiStyle+bold ∷ Doc AnsiStyle → Doc AnsiStyle bold = annotate Pretty.bold
src/lib/Imm/XML.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE UnicodeSyntax #-}+ -- | XML module abstracts over the parsing of RSS/Atom feeds. -- -- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html).@@ -6,11 +8,11 @@ module Imm.XML where -- {{{ Imports-import Imm.Feed+import Imm.Feed+import URI.ByteString -import URI.ByteString -- }}} newtype Handle m = Handle- { parseXml :: URI -> LByteString -> m (FeedDefinition, [FeedItem])+ { parseXml ∷ URI → LByteString → m (FeedDefinition, [FeedItem]) }
src/lib/Prelude.hs view
@@ -1,19 +1,21 @@+{-# LANGUAGE UnicodeSyntax #-}+ module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Control.Exception.Safe-import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)-import Relude.Extra.Map (lookup)+import Control.Exception.Safe+import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)+import Relude.Extra.Map (lookup) -io :: MonadIO m => IO a -> m a+io ∷ MonadIO m ⇒ IO a → m a io = liftIO -for :: [a] -> (a -> b) -> [b]+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+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+headFail ∷ MonadFail m ⇒ String → [a] → m a+headFail _ (a : _) = return a+headFail e _ = fail e
src/lib/URI/ByteString/Extended.hs view
@@ -1,55 +1,56 @@ {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeOperators #-}-module URI.ByteString.Extended (module URI.ByteString.Extended, module URI.ByteString) where+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-} -import Data.Aeson.Extended-import Data.Type.Equality-import Imm.Pretty-import URI.ByteString+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)+data AnyURI = ∀ 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+ 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+ (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@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@URI{}) = toJSON $ String $ decodeUtf8 $ serializeURIRef' a toJSON (AnyURI a@RelativeRef{}) = toJSON $ String $ decodeUtf8 $ serializeURIRef' a instance FromJSON AnyURI where- parseJSON = withText "URI" $ \s ->+ 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)-+ in either (const $ fail "Invalid URI") pure $ (AnyURI <$> uri) <> (AnyURI <$> relativeRef) -sameURIType :: URIRef a1 -> URIRef a2 -> Maybe (URIRef a1 :~: URIRef a2)+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+ (URI{}, URI{}) → Just Refl+ (RelativeRef{}, RelativeRef{}) → Just Refl+ _ → Nothing -withAnyURI :: (forall a . URIRef a -> b) -> AnyURI -> b+withAnyURI ∷ (∀ a. URIRef a → b) → AnyURI → b withAnyURI f (AnyURI a) = f a -toAbsoluteURI :: Scheme -> AnyURI -> URI+toAbsoluteURI ∷ Scheme → AnyURI → URI toAbsoluteURI scheme (AnyURI a) = toAbsolute scheme a
src/main/Alternate.hs view
@@ -1,25 +1,27 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-module Alternate (AlternateException(..), extractAlternateLinks) where+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-} +module Alternate (AlternateException (..), extractAlternateLinks) where+ -- {{{ Imports-import Data.Aeson-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 System.IO (hClose)-import System.Process.Typed-import URI.ByteString.Extended--- }}}+import Data.Aeson+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 System.IO (hClose)+import System.Process.Typed+import URI.ByteString.Extended +-- }}} newtype AlternateException = FeedNotFound URI- deriving(Eq, Show)+ deriving (Eq, Show) instance Exception AlternateException where displayException = show . pretty@@ -27,62 +29,66 @@ instance Pretty AlternateException where pretty (FeedNotFound uri) = "No feeds found at" <+> prettyURI uri - data AlternateLink = AlternateLink Text Text Text- deriving(Eq, Ord, Show)+ deriving (Eq, Ord, Show) instance Pretty AlternateLink where- pretty (AlternateLink title linkType uri) = "Alternate link" <+> braces (hsep parameters) where- parameters = [ "title" <> equals <> dquotes (pretty title)- , "type" <> equals <> dquotes (pretty linkType)- , "href" <> equals <> dquotes (pretty uri)- ]+ pretty (AlternateLink title linkType uri) = "Alternate link" <+> braces (hsep parameters)+ where+ parameters =+ [ "title" <> equals <> dquotes (pretty title)+ , "type" <> equals <> dquotes (pretty linkType)+ , "href" <> equals <> dquotes (pretty uri)+ ] instance FromJSON AlternateLink where- parseJSON = withObject "AlternateLink" $ \v -> AlternateLink- <$> (v .: "title" <|> pure mempty)- <*> v .: "type"- <*> v .: "href"-+ parseJSON = withObject "AlternateLink" $ \v →+ AlternateLink+ <$> (v .: "title" <|> pure mempty)+ <*> v .: "type"+ <*> v .: "href" -asFeedURI :: MonadFail m => URI -> Text -> m URI-asFeedURI baseURI href = let bytes = encodeUtf8 @Text href in- case parseURI laxURIParserOptions bytes of- Right uri -> pure uri- _ -> case parseRelativeRef laxURIParserOptions bytes of- Right relativeRef -> pure $ mergeURIs baseURI relativeRef- Left e -> fail $ show e+asFeedURI ∷ MonadFail m ⇒ URI → Text → m URI+asFeedURI baseURI href =+ let bytes = encodeUtf8 @Text href+ in case parseURI laxURIParserOptions bytes of+ Right uri → pure uri+ _ → case parseRelativeRef laxURIParserOptions bytes of+ Right relativeRef → pure $ mergeURIs baseURI relativeRef+ Left e → fail $ show e -mergeURIs :: URI -> URIRef Relative -> URI-mergeURIs uri relativeRef = URI scheme authority path query fragment where+mergeURIs ∷ URI → URIRef Relative → URI+mergeURIs uri relativeRef = URI scheme authority path query fragment+ where scheme = uriScheme uri authority = rrAuthority relativeRef <|> uriAuthority uri path = mergePaths (uriPath uri) (rrPath relativeRef) query = rrQuery relativeRef fragment = rrFragment relativeRef -mergePaths :: ByteString -> ByteString -> ByteString+mergePaths ∷ ByteString → ByteString → ByteString mergePaths basePath path = case Char8.head path of- '/' -> path- _ -> basePath <> "/" <> path-+ '/' → path+ _ → basePath <> "/" <> path -asLink :: MonadFail m => URI -> AlternateLink -> m Link+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 => 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+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)+ runEffect $ html >-> toHandle (getStdin pupProcess)+ hClose (getStdin pupProcess) - links <- getStdout pupProcess & atomically <&> decode <&> fromMaybe mempty- log logger Info $ "Found alternate links:" <+> pretty links+ links ← getStdout pupProcess & atomically <&> decode <&> fromMaybe mempty+ log logger Info $ "Found alternate links:" <+> pretty links - mapM (asLink baseUri) links- where pup = proc "pup" ["html head link[rel=\"alternate\"] json{}"]- & setStdin createPipe- & setStdout byteStringOutput- & setStderr nullStream+ mapM (asLink baseUri) links+ where+ pup =+ proc "pup" ["html head link[rel=\"alternate\"] json{}"]+ & setStdin createPipe+ & setStdout byteStringOutput+ & setStderr nullStream
src/main/Core.hs view
@@ -1,10 +1,13 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+ module Core ( markAsUnprocessed, subscribe,@@ -12,103 +15,128 @@ describeFeeds, describeFeed, downloadFeed,-) where+)+where -- {{{ Imports-import Alternate-import qualified Database.Handle as Database-import Database.Record-import Output (putDocLn)+import Alternate+import Control.Exception.Safe+import qualified Data.Text as Text+import qualified Database.Handle as Database+import Database.Record+import Imm.Feed+import Imm.HTTP as HTTP+import Imm.Link+import Imm.Logger as Logger+import Imm.Pretty+import Network.HTTP.Types.Header+import Output (putDocLn) import qualified Output+import Pipes+import Safe+import Text.XML as XML ()+import URI.ByteString.Extended -import Control.Exception.Safe-import qualified Data.Text as Text-import Imm.Feed-import Imm.HTTP as HTTP-import Imm.Link-import Imm.Logger as Logger-import Imm.Pretty-import Network.HTTP.Types.Header-import Pipes-import Safe-import Text.XML as XML ()-import URI.ByteString.Extended -- }}} --markAsUnprocessed :: MonadThrow m => MonadIO m- => Logger.Handle m- -> Database.Handle m- -> FeedQuery- -> m ()-markAsUnprocessed logger database QueryAll = Database.markAllFeedsAsUnprocessed 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)-describeFeeds :: MonadThrow m => MonadIO m- => Output.Handle m -> Database.Handle m -> FeedQuery -> m ()+describeFeeds+ ∷ MonadThrow m+ ⇒ MonadIO m+ ⇒ Output.Handle m+ → Database.Handle m+ → FeedQuery+ → m () describeFeeds output database QueryAll = do- feeds <- Database._fetchAllFeeds database+ 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+ feed ← Database._fetchFeed database uid describeFeed output database feed --describeFeed :: MonadThrow m => MonadIO m- => Output.Handle m -> Database.Handle m -> FeedRecord Inserted -> m ()+describeFeed+ ∷ MonadThrow m+ ⇒ MonadIO m+ ⇒ Output.Handle m+ → Database.Handle m+ → FeedRecord Inserted+ → m () describeFeed output database FeedRecord{..} = do- items <- Database._fetchItems database _feedKey+ 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+ 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 => MonadIO m- => Logger.Handle m -> Output.Handle m -> Database.Handle m- -> FeedLocation -> Set Text -> m ()+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+ 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- => Logger.Handle m- -> Database.Handle m- -> FeedQuery- -> m ()-unsubscribe logger database QueryAll = Database.purge logger database+unsubscribe+ ∷ MonadThrow m+ ⇒ Logger.Handle m+ → Database.Handle m+ → FeedQuery+ → m ()+unsubscribe logger database QueryAll = Database.purge logger database unsubscribe logger database (QueryByUID uid) = Database.deleteFeed logger database uid -- | 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+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-+ 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)+ Nothing → f (responseBody response)+ _ → 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 -getHeader :: HeaderName -> Response a -> Maybe ByteString-getHeader name response = response & responseHeaders & filter (\h-> fst h == name) & map snd & listToMaybe+getHeader ∷ HeaderName → Response a → Maybe ByteString+getHeader name response = response & responseHeaders & filter (\h → fst h == name) & map snd & listToMaybe
src/main/Database/Async.hs view
@@ -1,68 +1,73 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+ module Database.Async (withAsyncHandle) where -import Database.Handle-import Output (putDocLn)+import Control.Concurrent.Async+import Control.Concurrent.STM.TMChan+import Control.Exception.Safe+import Database.Handle+import Imm.Logger (LogLevel (..), log)+import qualified Imm.Logger as Logger+import Imm.Pretty+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 ∷ m ~ IO ⇒ Logger.Handle m → Output.Handle m → Handle m → (Handle m → m ()) → m () withAsyncHandle logger output database f = do- channel <- newTMChanIO+ channel ← newTMChanIO - thread <- async $ fix $ \recurse -> do- maybeMessage <- atomically $ readTMChan channel- forM_ maybeMessage $ \message -> do+ 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+ 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 ∷ MonadIO m ⇒ TMChan a → ((b → m ()) → a) → m b withMVar channel message = do- result <- newEmptyMVar+ 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+ ∷ (MonadIO m, MonadThrow m, Exception e)+ ⇒ TMChan a+ → ((Either e b → m ()) → a)+ → m b withMVarE channel message = do- result <- newEmptyMVar+ result ← newEmptyMVar atomically $ writeTMChan channel (message $ putMVar result) takeMVar result >>= either throwM return -asyncCommand :: MonadIO m => TMChan a -> (m () -> a) -> m ()+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- }+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
@@ -1,94 +1,98 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# 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+{-# LANGUAGE UnicodeSyntax #-} -import Database.Record hiding (markFeedAsUnprocessed, markItemAsProcessed)-import qualified Database.Record as Record+module Database.Handle (+ -- * 1st-level primitives+ HandleF (..),+ Handle (..),+ interpret,+ DatabaseException (..), -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)+ -- * 2nd-level primitives+ insertFeed,+ deleteFeed,+ insertItem,+ purge,+ commit, + -- * 3rd-level primitives+ register,+ markItemAsProcessed,+ markFeedAsUnprocessed,+ markAllFeedsAsUnprocessed, + -- * Re-exports+ module Database.Record,+)+where++import Control.Exception.Safe hiding (handle)+import Control.Monad.Time+import Database.Record hiding (markFeedAsUnprocessed, markItemAsProcessed)+import qualified Database.Record as Record+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 ()+ { _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)+ = 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)+ | 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 ∷ 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+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@@ -101,7 +105,7 @@ | UnableFetchAll | InvalidURI URIParseError | OtherError Text- deriving(Eq, Show)+ deriving (Eq, Show) instance Exception DatabaseException where displayException = show . pretty@@ -118,63 +122,67 @@ 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 ∷ 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 ∷ 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 ∷ 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 ∷ 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 ∷ 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 ∷ 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+ 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+ ∷ 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 }+ _updateItemStatus database $ item{_itemStatus = Record.markItemAsProcessed $ _itemStatus item} -markFeedAsUnprocessed :: MonadThrow m => Logger.Handle m -> Handle m -> UID -> m ()+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 }+ 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 ∷ 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 }+ 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
@@ -1,22 +1,25 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}+ module Database.ReadOnly where -import Database.Handle-import Imm.Logger (LogLevel (..), log)-import qualified Imm.Logger as Logger-import Imm.Pretty+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"- }+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
@@ -1,49 +1,55 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# 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+{-# LANGUAGE UnicodeSyntax #-} -import Control.Monad.Time-import Data.Aeson-import Data.Time-import Imm.Feed-import Imm.Pretty+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 qualified Data.Text as Text (null)+import Data.Time+import Imm.Feed+import Imm.Pretty+import URI.ByteString -- | 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+ { _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+ toJSON = genericToJSON feedStatusOptions toEncoding = genericToEncoding feedStatusOptions instance FromJSON FeedStatus where@@ -51,98 +57,113 @@ instance Pretty FeedStatus where pretty FeedStatus{..} = tags <++> "Last update:" <+> lastUpdate- where tags = sep $ map ((<>) "#" . pretty) $ toList _feedTags- lastUpdate = maybe "never" prettyTime _feedLastUpdate+ where+ tags = sep $ map ((<>) "#" . pretty) $ toList _feedTags+ lastUpdate = maybe "never" prettyTime _feedLastUpdate -markFeedAsUnprocessed :: FeedStatus -> FeedStatus-markFeedAsUnprocessed status = status- { _feedLastUpdate = Nothing- }+markFeedAsUnprocessed ∷ FeedStatus → FeedStatus+markFeedAsUnprocessed status =+ status+ { _feedLastUpdate = Nothing+ } -touchFeed :: FeedStatus -> IO FeedStatus+touchFeed ∷ FeedStatus → IO FeedStatus touchFeed status = do- utcTime <- currentTime- return $ status { _feedLastUpdate = Just utcTime }-+ 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)+ { _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- }+feedItemStatusOptions ∷ Options+feedItemStatusOptions =+ defaultOptions+ { fieldLabelModifier = camelTo2 '_'+ , omitNothingFields = True+ } instance ToJSON FeedItemStatus where- toJSON = genericToJSON feedItemStatusOptions+ 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 }+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+ { _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)+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 ()+instance Pretty (PrettyName (FeedRecord s)) where+ pretty (PrettyName record) = if Text.null title then location else definition+ where+ title = record & _feedDefinition & _feedTitle+ definition = prettyName $ _feedDefinition record+ location = feedUri & uriAuthority <&> authorityHost <&> hostBS & fromMaybe "unknown" & decodeUtf8 & pretty @Text+ FeedLocation feedUri _alternateTitle = _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+ { _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)+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+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 ∷ UID → FeedItem → FeedItemStatus → FeedItemRecord NotInserted mkFeedItemRecord = FeedItemRecord () - data Inserted+ data NotInserted type family StatusUID s where
src/main/Database/SQLite.hs view
@@ -1,295 +1,327 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-module Database.SQLite- ( DatabaseSQLite(..)- , defaultDatabase- , mkHandle- ) where+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UnicodeSyntax #-} -import Database.Handle hiding (deleteFeed, insertFeed, insertItem, purge)+module Database.SQLite (+ DatabaseSQLite (..),+ defaultDatabase,+ mkHandle,+)+where -import Data.Aeson-import Database.Beam-import Database.Beam.Backend.SQL (BeamSqlBackend, HasSqlValueSyntax (..))-import Database.Beam.Backend.SQL.BeamExtensions+import Data.Aeson (decode, encode)+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+import Database.Beam.Sqlite (SqliteM, runBeamSqlite)+import Database.Handle hiding (deleteFeed, insertFeed, insertItem, purge)+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)+ { _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)+ 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)+ { _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)+ 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)+ { _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)+ 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"- }- }+ { _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 ∷ DatabaseEntity be FeedDatabase (TableEntity FeedLocationT) feedLocationsTable = _feedLocations feedDatabase -feedsTable :: DatabaseEntity be FeedDatabase (TableEntity FeedT)+feedsTable ∷ DatabaseEntity be FeedDatabase (TableEntity FeedT) feedsTable = _feeds feedDatabase -feedItemsTable :: DatabaseEntity be FeedDatabase (TableEntity FeedItemT)+feedItemsTable ∷ DatabaseEntity be FeedDatabase (TableEntity FeedItemT) feedItemsTable = _feedItems feedDatabase -- * Queries -fetchAllFeeds :: _ [FeedRecord Inserted]+fetchAllFeeds ∷ SqliteM [FeedRecord Inserted] fetchAllFeeds = fmap (map asFeedRecord) $ runSelectReturningList $ select $ do- feed <- feedsTable & all_- location <- feedLocationsTable & all_+ 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)+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+fetchFeed ∷ UID → SqliteM (FeedRecord Inserted)+fetchFeed uid =+ select (queryFeed uid)+ & runSelectReturningOne+ >>= maybe (fail $ "Feed not found: " <> show uid) return+ <&> asFeedRecord -queryFeed :: UID -> _+queryFeed ∷ UID → _ queryFeed uid = do- feed <- feedsTable & all_- location <- feedLocationsTable & all_+ 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+fetchItem ∷ UID → SqliteM (FeedItemRecord Inserted)+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+fetchAllItems ∷ SqliteM [FeedItemRecord Inserted]+fetchAllItems =+ select (feedItemsTable & all_)+ & runSelectReturningList+ <&> map asFeedItemRecord -fetchItems :: UID -> _+fetchItems ∷ UID → SqliteM [FeedItemRecord Inserted] fetchItems uid = select (queryItems uid) & runSelectReturningList <&> map asFeedItemRecord -queryItems :: UID -> _+queryItems ∷ UID → _ queryItems uid = do- item <- feedItemsTable & all_+ 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-+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 → SqliteM () 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)+ runDelete $ delete feedLocationsTable $ \location → _locationID location ==. val_ (fromIntegral uid) -insertFeed :: FeedRecord NotInserted -> _ (FeedRecord Inserted)+insertFeed ∷ FeedRecord NotInserted → SqliteM (FeedRecord Inserted) insertFeed record = do- location <- insertFeedLocation $ _feedLocation record+ location ← insertFeedLocation $ _feedLocation record let value = Feed (primaryKey location) (_feedDefinition record) (_feedStatus record)- feed <- insertValues [value]- & insert feedsTable- & runInsertReturningList- >>= headFail (displayException $ FeedsNotInserted [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)+insertFeedLocation ∷ FeedLocation → SqliteM (FeedLocationT Identity)+insertFeedLocation location =+ insertExpressions [FeedLocationT default_ (val_ location)]+ & insert feedLocationsTable+ & runInsertReturningList+ >>= headFail ("Unable to insert feed location " <> show location) -insertItem :: FeedItemRecord NotInserted -> _+insertItem ∷ FeedItemRecord NotInserted → SqliteM (FeedItemRecord Inserted) 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])+ 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+purge ∷ SqliteM ()+purge = runDelete $ delete feedLocationsTable $ \_ → val_ True -updateItemStatus :: FeedItemRecord Inserted -> _-updateItemStatus record = runUpdate $ update feedItemsTable- (\item -> _itemStatusT item <-. val_ (_itemStatus record))- (\item -> primaryKey item ==. val_ (FeedItemKey $ fromIntegral $ _itemKey record))+updateItemStatus ∷ FeedItemRecord Inserted → SqliteM ()+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))+updateFeedDefinition ∷ FeedRecord Inserted → SqliteM ()+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))+updateFeedStatus ∷ FeedRecord Inserted → SqliteM ()+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- }+ { _sqliteFile ∷ FilePath+ } instance Pretty DatabaseSQLite where- pretty db = "SQLite database: " <+> pretty (_sqliteFile db)+ pretty db = "SQLite database: " <+> pretty (_sqliteFile db) -- | Default database is stored in @$XDG_CONFIG_HOME\/imm\/database.sqlite@-defaultDatabase :: IO DatabaseSQLite+defaultDatabase ∷ IO DatabaseSQLite defaultDatabase = DatabaseSQLite <$> getXdgDirectory XdgConfig "imm/database.sqlite" --createTables :: Connection -> IO ()+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 ( \+ 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 ( \+ 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 ∷ DatabaseSQLite → IO (Handle IO) mkHandle database = do- conn <- open $ _sqliteFile database+ 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 ()- }+ 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+instance (BeamSqlBackend be, FromBackendRow be LByteString) ⇒ FromBackendRow be FeedLocation where fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure -instance HasSqlValueSyntax be ByteString => HasSqlValueSyntax be FeedLocation where+instance HasSqlValueSyntax be ByteString ⇒ HasSqlValueSyntax be FeedLocation where sqlValueSyntax = sqlValueSyntax . toStrict . encode -instance (BeamSqlBackend be, FromBackendRow be LByteString) => FromBackendRow be FeedItem where+instance (BeamSqlBackend be, FromBackendRow be LByteString) ⇒ FromBackendRow be FeedItem where fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure -instance HasSqlValueSyntax be ByteString => HasSqlValueSyntax be FeedItem where+instance HasSqlValueSyntax be ByteString ⇒ HasSqlValueSyntax be FeedItem where sqlValueSyntax = sqlValueSyntax . toStrict . encode -instance (BeamSqlBackend be, FromBackendRow be LByteString) => FromBackendRow be FeedDefinition where+instance (BeamSqlBackend be, FromBackendRow be LByteString) ⇒ FromBackendRow be FeedDefinition where fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure -instance HasSqlValueSyntax be ByteString => HasSqlValueSyntax be FeedDefinition where+instance HasSqlValueSyntax be ByteString ⇒ HasSqlValueSyntax be FeedDefinition where sqlValueSyntax = sqlValueSyntax . toStrict . encode -instance (BeamSqlBackend be, FromBackendRow be LByteString) => FromBackendRow be FeedStatus where+instance (BeamSqlBackend be, FromBackendRow be LByteString) ⇒ FromBackendRow be FeedStatus where fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure -instance HasSqlValueSyntax be ByteString => HasSqlValueSyntax be FeedStatus where+instance HasSqlValueSyntax be ByteString ⇒ HasSqlValueSyntax be FeedStatus where sqlValueSyntax = sqlValueSyntax . toStrict . encode -instance (BeamSqlBackend be, FromBackendRow be LByteString) => FromBackendRow be FeedItemStatus where+instance (BeamSqlBackend be, FromBackendRow be LByteString) ⇒ FromBackendRow be FeedItemStatus where fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure -instance HasSqlValueSyntax be ByteString => HasSqlValueSyntax be FeedItemStatus where+instance HasSqlValueSyntax be ByteString ⇒ HasSqlValueSyntax be FeedItemStatus where sqlValueSyntax = sqlValueSyntax . toStrict . encode
src/main/HTTP.hs view
@@ -1,25 +1,29 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+ -- | Implementation of "Imm.HTTP" based on "Pipes.HTTP". module HTTP (mkHandle) where -- {{{ Imports-import Imm.HTTP-import Imm.Pretty+import Imm.HTTP+import Imm.Pretty+import Network.HTTP.Types.Header+import Pipes.HTTP -import Network.HTTP.Types.Header-import Pipes.HTTP -- }}} -headers :: [Header]+headers ∷ [Header] headers = [(hUserAgent, "imm/1.0")] -mkHandle :: m ~ IO => m (Handle m)+mkHandle ∷ m ~ IO ⇒ m (Handle m) mkHandle = do- manager <- newManager tlsManagerSettings+ manager ← newManager tlsManagerSettings - return $ Handle $ \uri f -> do- request <- parseUrlThrow $ show $ prettyURI uri- withHTTP request { requestHeaders = headers } manager f+ return $+ Handle $ \uri f → do+ request ← parseUrlThrow $ show $ prettyURI uri+ withHTTP request{requestHeaders = headers} manager f
src/main/Input.hs view
@@ -1,148 +1,166 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnicodeSyntax #-}+ 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+import Data.List+import qualified Data.Set as Set+import Data.Version+import Imm.Feed+import Imm.Logger as Logger+import Imm.Pretty+import Options.Applicative+import qualified Paths_imm as Package+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)+ { 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)- ]-+ 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+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 (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)-+ deriving (Eq, Ord, Read, Show) -- * Option parsers -parseOptions :: (MonadIO m) => m ProgramInput+parseOptions ∷ MonadIO m ⇒ m ProgramInput parseOptions = io $ do- defaultCallbacksFile <- getXdgDirectory XdgConfig $ "imm" </> "callbacks.dhall"+ defaultCallbacksFile ← getXdgDirectory XdgConfig $ "imm" </> "callbacks.dhall" execParser $ info (allOptions defaultCallbacksFile <**> helper <**> versionPrinter) $ progDesc description -description :: String+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)+allOptions ∷ FilePath → Parser ProgramInput+allOptions defaultCallbacksFile =+ ProgramInput+ <$> commandParser+ <*> (verboseFlag <|> quietFlag <|> logLevel <|> pure Info)+ <*> readOnlyDatabase+ <*> (callbacksFileOption <|> pure defaultCallbacksFile) -commandParser :: Parser Command-commandParser = hsubparser $ mconcat- [ command "add" $ info subscribeCommand $ progDesc "Alias for subscribe."- , command "describe" $ info describeCommand $ progDesc "Show details about given feed."- , command "list" $ info (pure $ Describe QueryAll) $ progDesc "Alias for describe --all ."- , command "remove" $ info unsubscribeCommand $ progDesc "Alias for unsubscribe."- , command "reset" $ info resetCommand $ progDesc "Mark given feed as unprocessed."- , command "run" $ info runCommand $ progDesc "Update list of feeds."- , command "show" $ info describeCommand $ progDesc "Alias for describe."- , command "subscribe" $ info subscribeCommand $ progDesc "Subscribe to a feed."- , command "unsubscribe" $ info unsubscribeCommand $ progDesc "Unsubscribe from a feed."- ]+commandParser ∷ Parser Command+commandParser =+ hsubparser $+ mconcat+ [ command "add" $ info subscribeCommand $ progDesc "Alias for subscribe."+ , command "describe" $ info describeCommand $ progDesc "Show details about given feed."+ , command "list" $ info (pure $ Describe QueryAll) $ progDesc "Alias for describe --all ."+ , command "remove" $ info unsubscribeCommand $ progDesc "Alias for unsubscribe."+ , command "reset" $ info resetCommand $ progDesc "Mark given feed as unprocessed."+ , command "run" $ info runCommand $ progDesc "Update list of feeds."+ , command "show" $ info describeCommand $ progDesc "Alias for describe."+ , command "subscribe" $ info subscribeCommand $ progDesc "Subscribe to a feed."+ , command "unsubscribe" $ info unsubscribeCommand $ progDesc "Unsubscribe from a feed."+ ] -- {{{ Commands-describeCommand :: Parser Command+describeCommand ∷ Parser Command describeCommand = Describe <$> feedQueryParser -subscribeCommand :: Parser Command-subscribeCommand = Subscribe <$> feedLocationParser <*> (Set.fromList <$> many tagOption)+subscribeCommand ∷ Parser Command+subscribeCommand = Subscribe <$> feedLocationParser <*> (Set.fromList <$> many tagOption) -unsubscribeCommand :: Parser Command-unsubscribeCommand = Unsubscribe <$> feedQueryParser+unsubscribeCommand ∷ Parser Command+unsubscribeCommand = Unsubscribe <$> feedQueryParser -runCommand :: Parser Command-runCommand = Run- <$> feedQueryParser- <*> flag EnableCallbacks DisableCallbacks (long "no-callbacks" <> help "Disable callbacks.")+runCommand ∷ Parser Command+runCommand =+ Run+ <$> feedQueryParser+ <*> flag EnableCallbacks DisableCallbacks (long "no-callbacks" <> help "Disable callbacks.") -resetCommand :: Parser Command+resetCommand ∷ Parser Command resetCommand = Reset <$> feedQueryParser+ -- }}} -- {{{ Log options-verboseFlag, quietFlag, logLevel :: Parser LogLevel+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."+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 ∷ Parser Bool readOnlyDatabase = switch $ long "read-only" <> help "Disable database writes." -tagOption :: Parser Text+tagOption ∷ Parser Text tagOption = option auto $ long "tag" <> short 't' <> metavar "TAG" <> help "Set the given tag." -callbacksFileOption :: Parser FilePath+callbacksFileOption ∷ Parser FilePath callbacksFileOption = strOption $ long "callbacks" <> short 'c' <> metavar "FILE" <> help "Dhall configuration file for callbacks"+ -- }}} -- {{{ Util-uriReader :: ReadM URI+uriReader ∷ ReadM URI uriReader = eitherReader $ first show . parseURI laxURIParserOptions . encodeUtf8 @Text . fromString -feedLocationParser :: Parser FeedLocation+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+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 ∷ 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.")+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,59 +1,43 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}--- | Implementation of "Imm.Logger" based on @co-log@.+{-# LANGUAGE UnicodeSyntax #-}++-- | Implementation of "Imm.Logger" based on @fast-logger@. module Logger (withLogHandler, module Reexport) where -- {{{ Imports-import Imm.Logger as Reexport-import Imm.Pretty+import Imm.Logger as Reexport+import Imm.Pretty+import Prettyprinter.Render.Terminal+import System.Directory+import System.FilePath+import System.Log.FastLogger (FormattedTime, LogStr, LogType' (..), TimedFastLogger, ToLogStr (..), defaultBufSize, newTimeCache, simpleTimeFormat', withTimedFastLogger) -import Chronos-import Colog hiding (Severity (..))-import qualified Colog-import Data.Text.Prettyprint.Doc.Render.Terminal-import qualified Data.TypeRepMap as TypeRepMap-import System.Directory-import System.FilePath -- }}} -mkHandle :: MonadIO m => MonadIO m' => LogAction m (RichMsg m' (Msg Colog.Severity)) -> IO (Handle m)+mkHandle ∷ MonadIO m ⇒ TimedFastLogger → IO (Handle m) mkHandle logAction = do- logLevel <- newTVarIO Debug- return $ Handle- (myLog logAction)- (readTVarIO logLevel)- (atomically . writeTVar logLevel)-+ logLevel ← newTVarIO Debug+ return $+ Handle+ (myLog logLevel logAction)+ (readTVarIO logLevel)+ (atomically . writeTVar logLevel) -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+myLog ∷ MonadIO m ⇒ TVar LogLevel → TimedFastLogger → LogLevel → Doc AnsiStyle → m ()+myLog minLogLevelTVar logAction logLevel document = io $ do+ minLogLevel ← readTVarIO minLogLevelTVar+ when (logLevel >= minLogLevel) $ logAction (\time → formatLog time logLevel document) +formatLog ∷ FormattedTime → LogLevel → Doc AnsiStyle → LogStr+formatLog time logLevel message =+ toLogStr $+ renderStrict $+ layoutPretty defaultLayoutOptions $+ pretty (decodeUtf8 time ∷ Text) <+> pretty logLevel <+> message <> hardline -withLogHandler :: MonadIO m => (Handle m -> IO a) -> IO a+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--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+ logFile ← getXdgDirectory XdgConfig $ "imm" </> "imm.log"+ timeCache ← newTimeCache simpleTimeFormat'+ withTimedFastLogger timeCache (LogFileNoRotate logFile defaultBufSize) $ f <=< mkHandle
src/main/Main.hs view
@@ -1,133 +1,145 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+ -- {{{ Imports++import Control.Concurrent.STM.TMChan+import Control.Exception.Safe import qualified Core-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 Output (putDocLn)+import Database.Async as Database+import Database.Handle as Database+import Database.ReadOnly as Database+import Database.SQLite as SQLite+import Dhall (auto, input)+import GHC.Conc (numCapabilities)+import HTTP+import Imm+import Imm.Pretty+import Input+import Logger+import Output (putDocLn) import qualified Output-import XML+import Pipes.ByteString hiding (filter, stdout)+import Safe+import qualified Streamly.Data.Fold as Fold+import qualified Streamly.Data.Stream.Prelude as Stream+import XML -import Control.Concurrent.STM.TMChan-import Control.Exception.Safe-import Dhall (auto, input)-import Imm-import Imm.Pretty-import Pipes.ByteString hiding (filter, stdout)-import Safe-import Streamly as Stream (async, asyncly, (|&))-import qualified Streamly.Prelude as Stream -- }}} --main :: IO ()+main ∷ IO () main = do- programInput <- parseOptions- Output.withHandle $ \stdout -> do- withLogger programInput $ \logger -> do+ programInput ← parseOptions+ Output.withHandle $ \stdout → do+ withLogger programInput $ \logger → do handleAny (log logger Error . pretty . displayException) $ do- withDatabase logger stdout programInput $ \database -> 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)+ 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) Database.commit logger database --withLogger :: ProgramInput -> (Logger.Handle IO -> IO ()) -> IO ()-withLogger programInput f = withLogHandler $ \logger -> do+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 ∷ 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+ 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 ∷ MonadIO m ⇒ CallbackMode → FilePath → m [Callback] resolveCallbacks EnableCallbacks callbacksFile = io $ input auto $ fromString callbacksFile-resolveCallbacks _ _ = return mempty-+resolveCallbacks _ _ = return mempty -main2 :: Logger.Handle IO -> Output.Handle IO -> Database.Handle IO- -> FeedQuery -> [Callback] -> IO ()+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+ newItemsCount ← newTVarIO (0 ∷ Int)+ errorsCount ← newTVarIO (0 ∷ Int)+ errorsChan ← newTMChanIO - httpClient <- HTTP.mkHandle+ httpClient ← HTTP.mkHandle -- Feed record => (feed record, items)- let fetcher = catchErrors logger errorsChan errorsCount $ \feedRecord -> do+ let fetcher = catchErrors logger errorsChan errorsCount $ \feedRecord → do log logger Debug "Fetch worker starts" let location@(FeedLocation uri _) = _feedLocation feedRecord- (feedDefinition, items) <- Core.downloadFeed logger httpClient (toLazyM >=> parseXml xmlParser uri) location+ (feedDefinition, items) ← Core.downloadFeed logger httpClient (toLazyM >=> parseXml xmlParser uri) location - newFeedStatus <- touchFeed $ _feedStatus feedRecord+ newFeedStatus ← touchFeed $ _feedStatus feedRecord - let newFeedRecord = feedRecord { _feedDefinition = feedDefinition, _feedStatus = newFeedStatus }+ let newFeedRecord = feedRecord{_feedDefinition = feedDefinition, _feedStatus = newFeedStatus} _updateFeedDefinition database newFeedRecord _updateFeedStatus database newFeedRecord return $ Just (newFeedRecord, items) -- (Feed record, items) => (feed record, items, item records)- let itemRetriever = catchErrors logger errorsChan errorsCount $ \(feedRecord, items) -> do- itemRecords <- _fetchItems database $ _feedKey feedRecord+ let itemRetriever = catchErrors logger errorsChan errorsCount $ \(feedRecord, items) → do+ itemRecords ← _fetchItems database $ _feedKey feedRecord return $ Just (feedRecord, items, itemRecords) -- (Feed record, items, item records) => multiple (feed record, item, item records)- let itemSplitter = \(feedRecord, items, itemRecords) ->- Stream.fromList [(feedRecord, item, itemRecords) | item <- items]+ let itemSplitter (feedRecord, items, itemRecords) =+ Stream.fromList [(feedRecord, item, itemRecords) | item ← items] - let itemMatcher = \(feedRecord, item, itemRecords) -> do- let itemRecord = itemRecords & filter (\r -> _itemDefinition r `areSameItem` item) & headMay+ let itemMatcher (feedRecord, item, itemRecords) = do+ let itemRecord = itemRecords & filter (\r → _itemDefinition r `areSameItem` item) & headMay return (feedRecord, item, itemRecord) -- Filter for unread items- let unreadSelector (feedRecord, item, itemRecord) = checkDate || checkStatus where+ 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+ (Nothing, _) → True+ (Just t0, Just t1) → t0 < t1+ _ → False checkStatus = itemRecord <&> _itemStatus <&> (not . _isProcessed) & fromMaybe True- -- unprocessedElements <- listUnprocessedElements database entryKey+ -- unprocessedElements <- listUnprocessedElements database entryKey - let logNewItem (feedRecord, item, _) = putDocLn stdout $ "New item:"- <+> maybe "<unknown>" prettyTime (_itemDate item)- <+> magenta (prettyName $ _feedDefinition feedRecord)- <+> "/" <+> yellow (prettyName item)+ let logNewItem (feedRecord, item, _) =+ putDocLn stdout $+ "New item:"+ <+> maybe "<unknown>" prettyTime (_itemDate item)+ <+> magenta (prettyName feedRecord)+ <+> "/"+ <+> yellow (prettyName item) -- New items events => execute callback => processed/error events- let runner = catchErrors logger errorsChan errorsCount $ \(feedRecord, item, itemRecord) -> do- results <- forM callbacks $ \callback -> io $ do- runCallback logger callback $ CallbackMessage (_feedDefinition feedRecord) item+ let runner = catchErrors logger errorsChan errorsCount $ \(feedRecord, item, itemRecord) → do+ results ← forM callbacks $ \callback → io $ do+ runCallback logger callback $ CallbackMessage (_feedLocation feedRecord) (_feedDefinition feedRecord) item case lefts results of- [] -> return $ Just (feedRecord, item, itemRecord)- e -> do- io $ atomically $ do- writeTMChan errorsChan (toException $ CallbackException feedRecord item 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 let storer (_, _, Just itemRecord) =@@ -136,23 +148,26 @@ let itemRecord = mkFeedItemRecord (_feedKey feedRecord) item (FeedItemStatus True) void $ Database.insertItem logger database itemRecord + entries ← case feedQuery of+ QueryAll → Database._fetchAllFeeds database+ QueryByUID uid → pure <$> Database._fetchFeed database uid - entries <- case feedQuery of- QueryAll -> Database._fetchAllFeeds database- QueryByUID uid -> pure <$> Database._fetchFeed database uid+ let streamConfig = Stream.maxThreads numCapabilities . Stream.maxBuffer 100 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+ & Stream.parMapM streamConfig fetcher+ & Stream.catMaybes+ & Stream.parMapM streamConfig itemRetriever+ & Stream.catMaybes+ & Stream.parConcatMap streamConfig itemSplitter+ & Stream.parMapM streamConfig itemMatcher+ & Stream.filter unreadSelector+ & Stream.trace logNewItem+ & Stream.trace (const $ atomically $ modifyTVar' newItemsCount (+ 1))+ & Stream.parMapM streamConfig runner+ & Stream.catMaybes+ & Stream.mapM storer+ & Stream.fold Fold.drain atomically $ closeTMChan errorsChan @@ -162,40 +177,53 @@ readTVarIO newItemsCount <&> pretty <&> bold <&> (<+> "new items") >>= putDocLn stdout readTVarIO errorsCount <&> pretty <&> bold <&> (<+> "errors") >>= putDocLn stdout - data CallbackException = CallbackException (FeedRecord Inserted) FeedItem [(Callback, Int, LByteString, LByteString)]- deriving(Eq, Generic, Ord, Show, Typeable)+ deriving (Eq, Generic, Ord, Show, Typeable) instance Exception CallbackException where displayException = show . pretty 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')-+ "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') -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+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)+ io $+ atomically $ do+ writeTMChan errorsChan e+ modifyTVar' errorsCount (+ 1) return Nothing --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-+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+xmlParser ∷ XML.Handle IO xmlParser = XML.mkHandle defaultXmlParser
src/main/Output.hs view
@@ -1,27 +1,29 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}+ module Output where -import Control.Concurrent.Async-import Control.Concurrent.STM.TMChan-import Data.Text.Prettyprint.Doc.Render.Terminal-import Imm.Pretty+import Control.Concurrent.Async+import Control.Concurrent.STM.TMChan+import Imm.Pretty+import Prettyprinter.Render.Terminal -- * Types -- | Handle to push messages to the program's output newtype Handle m = Handle- { putDocLn :: Doc AnsiStyle -> m ()+ { putDocLn ∷ Doc AnsiStyle → m () } -withHandle :: (Handle IO -> IO ()) -> IO ()+withHandle ∷ (Handle IO → IO ()) → IO () withHandle f = do- channel <- newTMChanIO+ channel ← newTMChanIO - thread <- async $ fix $ \recurse -> do- maybeMessage <- atomically $ readTMChan channel- forM_ maybeMessage $ \message -> do- putLTextLn $ renderLazy $ layoutPretty defaultLayoutOptions message- recurse+ 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 }+ f $ Handle{putDocLn = atomically . writeTMChan channel} atomically (closeTMChan channel) >> wait thread
src/main/Prelude.hs view
@@ -1,19 +1,21 @@+{-# LANGUAGE UnicodeSyntax #-}+ module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Control.Exception.Safe-import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)-import Relude.Extra.Map (lookup)+import Control.Exception.Safe+import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)+import Relude.Extra.Map (lookup) -io :: MonadIO m => IO a -> m a+io ∷ MonadIO m ⇒ IO a → m a io = liftIO -for :: [a] -> (a -> b) -> [b]+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+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+headFail ∷ MonadFail m ⇒ String → [a] → m a+headFail _ (a : _) = return a+headFail e _ = fail e
src/main/XML.hs view
@@ -1,31 +1,38 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnicodeSyntax #-}+ -- | Implementation of "Imm.XML" based on 'Conduit'. module XML (module XML, module Imm.XML) where -- {{{ Imports-import Imm.Feed-import Imm.XML -import Control.Exception.Safe-import Data.Conduit-import Data.XML.Types-import Text.XML.Stream.Parse as XML-import URI.ByteString+import Control.Exception.Safe+import Data.Conduit+import Data.XML.Types+import Imm.Feed+import Imm.XML+import Text.XML.Stream.Parse as XML+import URI.ByteString+ -- }}} -- | A pre-process 'Conduit' can be set to alter the raw XML before feeding it to the parser, -- depending on the feed 'URI'-newtype XmlParser = XmlParser (forall m . Monad m => URI -> ConduitT Event Event m ())+newtype XmlParser = XmlParser (∀ m. Monad m ⇒ URI → ConduitT Event Event m ()) -- | 'Conduit' based implementation-mkHandle :: MonadIO m => MonadCatch m => XmlParser -> Handle m-mkHandle (XmlParser preProcess) = Handle- { parseXml = \uri bytestring -> liftIO $ runConduit $ parseLBS def bytestring- .| preProcess uri- .| XML.force "Invalid feed" feedC- }+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" feedC+ } -- | Forward all 'Event's without any pre-process-defaultXmlParser :: XmlParser-defaultXmlParser = XmlParser $ const $ fix $ \loop -> await >>= maybe (return ()) (yield >=> const loop)+defaultXmlParser ∷ XmlParser+defaultXmlParser = XmlParser $ const $ fix $ \loop → await >>= maybe (return ()) (yield >=> const loop)
src/monolith/Main.hs view
@@ -1,77 +1,97 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}--- | Download a self-contained HTML file, using monolith, related to the input RSS/Atom item.+{-# LANGUAGE UnicodeSyntax #-}++-- Download a self-contained HTML file, using monolith, related to the input RSS/Atom item. ----- Meant to be use as a callback for imm.--- {{{ Imports-import Imm.Callback-import Imm.Feed-import Imm.Link-import Imm.Pretty+-- Meant to be used as a callback for imm.+-- {{{ Imports -import Data.Aeson-import Data.ByteString.Lazy (getContents)-import qualified Data.Text as Text (replace)-import Data.Time-import Options.Applicative-import System.Directory (createDirectoryIfMissing)-import System.Exit (ExitCode)-import System.FilePath-import System.Process.Typed-import URI.ByteString.Extended+import Data.Aeson+import Data.ByteString.Lazy (getContents)+import qualified Data.Text as Text (null, replace, unpack)+import Data.Time+import Imm.Callback+import Imm.Feed+import Imm.Link+import Imm.Pretty+import Options.Applicative+import System.Directory (createDirectoryIfMissing)+import System.FilePath+import System.Process.Typed+import URI.ByteString.Extended+ -- }}} data CliOptions = CliOptions- { _directory :: FilePath- , _dryRun :: Bool- , _forwardArguments :: [String]- } deriving (Eq, Ord, Read, Show)+ { _directory ∷ FilePath+ , _dryRun ∷ Bool+ , _forwardArguments ∷ [String]+ }+ deriving (Eq, Ord, Read, Show) -parseOptions :: MonadIO m => m CliOptions-parseOptions = io $ execParser $ info (cliOptions <**> helper) $ progDesc description <> forwardOptions where+parseOptions ∷ MonadIO m ⇒ m CliOptions+parseOptions = io $ execParser $ info (cliOptions <**> helper) $ progDesc description <> forwardOptions+ where description = "Download a self-contained HTML file, using monolith, for each new RSS/Atom item. An intermediate folder will be created for each feed." -cliOptions :: Parser CliOptions-cliOptions = CliOptions- <$> strOption (long "directory" <> short 'd' <> metavar "PATH" <> help "Root directory where files will be created.")- <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.")- <*> many (strArgument $ metavar "ARG" <> help "Argument to forward to monolith.")-+cliOptions ∷ Parser CliOptions+cliOptions =+ CliOptions+ <$> strOption (long "directory" <> short 'd' <> metavar "PATH" <> help "Root directory where files will be created.")+ <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.")+ <*> many (strArgument $ metavar "ARG" <> help "Argument to forward to monolith.") -main :: IO ()+main ∷ IO () main = do- CliOptions directory dryRun forwardArguments <- parseOptions- input <- getContents <&> eitherDecode+ CliOptions rootDirectory dryRun forwardArguments ← parseOptions+ input ← getContents <&> eitherDecode - case input :: Either String CallbackMessage of- Right (CallbackMessage feedDefinition item) -> do- let filePath = defaultFilePath directory feedDefinition item+ case input ∷ Either String CallbackMessage of+ Right (CallbackMessage feedLocation feedDefinition item) → do+ let filePath = defaultFilePath rootDirectory feedLocation feedDefinition item putStrLn filePath unless dryRun $ do createDirectoryIfMissing True $ takeDirectory filePath case getMainLink item of- Just link -> downloadPage forwardArguments filePath (_linkURI link) >>= exitWith- _ -> putStrLn ("No main link in item " <> show (prettyName item)) >> exitFailure- Left e -> putStrLn ("Invalid input: " <> e) >> exitFailure+ Just link → downloadPage forwardArguments filePath (_linkURI link) >>= exitWith+ _ → putStrLn ("No main link in item " <> show (prettyName item)) >> exitFailure+ Left e → putStrLn ("Invalid input: " <> e) >> exitFailure return () -- * Default behavior -downloadPage :: [String] -> FilePath -> AnyURI -> IO ExitCode-downloadPage forwardArguments filePath uri = runProcess $ proc "monolith" arguments- & setStdin nullStream- & setStdout inherit- & setStderr inherit- where arguments = ["-o", filePath, show $ pretty uri] <> forwardArguments+downloadPage ∷ [String] → FilePath → AnyURI → IO ExitCode+downloadPage forwardArguments filePath uri =+ runProcess $+ proc "monolith" arguments+ & setStdin nullStream+ & setStdout inherit+ & setStderr inherit+ where+ arguments = ["-o", filePath, show $ pretty uri] <> forwardArguments --- | Generate a path @<root>/<feed title>/<element date>-<element title>.html@, where @<root>@ is the first argument-defaultFilePath :: FilePath -> FeedDefinition -> FeedItem -> FilePath-defaultFilePath root feedDefinition element = makeValid $ root </> toString title </> fileName <.> "html" where+-- | Generate a path @<root>/<feed designator>/<element date>-<element title>.html@, where @<root>@ is the first argument+defaultFilePath ∷ FilePath → FeedLocation → FeedDefinition → FeedItem → FilePath+defaultFilePath root feedLocation feedDefinition element = makeValid $ root </> feedFolder </> fileName <.> "html"+ where+ FeedLocation feedUri _ = feedLocation+ feedFolder = if Text.null title then uriToFolder feedUri else toString title+ uriToFolder uri =+ uri+ & uriAuthority+ <&> authorityHost+ <&> hostBS+ <&> decodeUtf8+ & fromMaybe "unknown-host"+ & sanitize+ & Text.unpack 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 "?" "_"- >>> Text.replace "!" "_"- >>> Text.replace "#" "_"+ sanitize =+ appEndo (mconcat [Endo $ Text.replace (toText [s]) "_" | s ← pathSeparators])+ >>> Text.replace "." "_"+ >>> Text.replace "?" "_"+ >>> Text.replace "!" "_"+ >>> Text.replace "#" "_"
src/monolith/Prelude.hs view
@@ -1,19 +1,21 @@+{-# LANGUAGE UnicodeSyntax #-}+ module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Control.Exception.Safe-import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)-import Relude.Extra.Map (lookup)+import Control.Exception.Safe+import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)+import Relude.Extra.Map (lookup) -io :: MonadIO m => IO a -> m a+io ∷ MonadIO m ⇒ IO a → m a io = liftIO -for :: [a] -> (a -> b) -> [b]+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+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+headFail ∷ MonadFail m ⇒ String → [a] → m a+headFail _ (a : _) = return a+headFail e _ = fail e
src/send-mail/Main.hs view
@@ -1,137 +1,144 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}--- | 'Callback' for @imm@ that sends a mail via a SMTP server the input RSS/Atom item.--- {{{ Imports-import Imm.Callback (CallbackMessage (..))-import Imm.Feed-import Imm.Link-import Imm.Pretty+{-# LANGUAGE UnicodeSyntax #-} -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 System.Directory (XdgDirectory (..), getXdgDirectory)-import System.Exit (ExitCode (..))-import System.FilePath-import System.Process.Typed-import URI.ByteString.Extended+-- 'Callback' for @imm@ that sends a mail via a SMTP server the input RSS/Atom item.+-- {{{ Imports++import Data.Aeson+import Data.ByteString.Lazy (getContents)+import Data.Text as Text (intercalate)+import Data.Time+import Dhall (FromDhall (..), auto, input)+import Imm.Callback (CallbackMessage (..))+import Imm.Feed+import Imm.Link+import Imm.Pretty+import Network.Mail.Mime hiding (sendmail)+import Options.Applicative hiding (auto)+import System.Directory (XdgDirectory (..), getXdgDirectory)+import System.FilePath+import System.Process.Typed+import URI.ByteString.Extended+ -- }}} -- | How to call external command data Command = Command- { _executable :: FilePath- , _arguments :: [Text]- } deriving (Eq, Generic, Ord, Read, Show)+ { _executable ∷ FilePath+ , _arguments ∷ [Text]+ }+ deriving (Eq, Generic, Ord, Read, Show) instance FromDhall Command -- | How to format outgoing mails from feed elements data FormatMail = FormatMail- { 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+ { 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- { _configFile :: FilePath- , _recipients :: [Address]- , _dryRun :: Bool- } deriving (Eq, Generic, Show)-+ { _configFile ∷ FilePath+ , _recipients ∷ [Address]+ , _dryRun ∷ Bool+ }+ deriving (Eq, Generic, Show) -parseOptions :: MonadIO m => m CliOptions+parseOptions ∷ MonadIO m ⇒ m CliOptions parseOptions = io $ do- defaultConfigFile <- getXdgDirectory XdgConfig $ "imm" </> "sendmail.dhall"+ defaultConfigFile ← getXdgDirectory XdgConfig $ "imm" </> "sendmail.dhall" customExecParser (prefs $ showHelpOnError <> showHelpOnEmpty) (info (cliOptions defaultConfigFile <**> helper) $ progDesc description) -description :: String+description ∷ String description = "Send a mail for each new RSS/Atom item." -cliOptions :: FilePath -> Parser CliOptions-cliOptions defaultConfigFile = CliOptions- <$> (configFileOption <|> pure defaultConfigFile)- <*> many recipientParser- <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.")+cliOptions ∷ FilePath → Parser CliOptions+cliOptions defaultConfigFile =+ CliOptions+ <$> (configFileOption <|> pure defaultConfigFile)+ <*> many recipientParser+ <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.") -configFileOption :: Parser FilePath+configFileOption ∷ Parser FilePath configFileOption = strOption $ long "config" <> short 'c' <> metavar "FILE" <> help "Dhall configuration file for SMTP client call" -recipientParser :: Parser Address+recipientParser ∷ Parser Address recipientParser = strOption (long "to" <> help "Mail recipients.") -main :: IO ()+main ∷ IO () main = do- CliOptions configFile recipients dryRun <- parseOptions- Command executable arguments <- input auto $ fromString configFile+ CliOptions configFile recipients dryRun ← parseOptions+ Command executable arguments ← input auto $ fromString configFile - message <- getContents <&> eitherDecode+ message ← getContents <&> eitherDecode case message of- Right (CallbackMessage feed element) -> do- timezone <- io getCurrentTimeZone- currentTime <- io getCurrentTime+ Right (CallbackMessage _ feed element) → do+ timezone ← io getCurrentTimeZone+ currentTime ← io getCurrentTime let formatMail = FormatMail defaultFormatFrom defaultFormatSubject defaultFormatBody (const $ const recipients) mail = buildMail formatMail currentTime timezone feed element unless dryRun $ do- processInput <- renderMail' mail <&> byteStringInput+ processInput ← renderMail' mail <&> byteStringInput let processConfig = proc executable (toString <$> arguments) & setStdin processInput - (exitCode, _output, errors) <- readProcess processConfig+ (exitCode, _output, errors) ← readProcess processConfig case exitCode of- ExitSuccess -> exitSuccess- ExitFailure _ -> putStrLn (decodeUtf8 errors) >> exitFailure-- Left e -> putStrLn ("Invalid input: " <> e) >> exitFailure+ ExitSuccess → exitSuccess+ ExitFailure _ → putStrLn (decodeUtf8 errors) >> exitFailure+ Left e → putStrLn ("Invalid input: " <> e) >> exitFailure return () - -- * Default behavior -- | Fill 'addressName' with the feed title and, if available, the authors' names. -- -- This function leaves 'addressEmail' empty. You are expected to fill it adequately, because many SMTP servers enforce constraints on the From: email.-defaultFormatFrom :: FeedDefinition -> FeedItem -> Address+defaultFormatFrom ∷ FeedDefinition → FeedItem → Address defaultFormatFrom feed item = Address (Just $ title <> " (" <> authors <> ")") ""- where title = _feedTitle feed- authors = Text.intercalate ", " $ map _authorName $ _itemAuthors item+ where+ title = _feedTitle feed+ authors = Text.intercalate ", " $ map _authorName $ _itemAuthors item -- | Fill mail subject with the element title-defaultFormatSubject :: FeedDefinition -> FeedItem -> Text+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 :: FeedDefinition -> FeedItem -> Text+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-+ 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 -> FeedDefinition -> FeedItem -> 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 $ _itemDate element- in Mail- { mailFrom = formatFrom format feed element- , mailTo = formatTo format feed element- , mailCc = []- , mailBcc = []- , mailHeaders =- [ ("Return-Path", "<imm@noreply>")- , ("Date", fromString date)- , ("Subject", formatSubject format feed element)- , ("Content-disposition", "inline")- ]- , mailParts = [[htmlPart $ fromStrict $ formatBody format feed element]]- }+ in Mail+ { mailFrom = formatFrom format feed element+ , mailTo = formatTo format feed element+ , mailCc = []+ , mailBcc = []+ , mailHeaders =+ [ ("Return-Path", "<imm@noreply>")+ , ("Date", fromString date)+ , ("Subject", formatSubject format feed element)+ , ("Content-disposition", "inline")+ ]+ , mailParts = [[htmlPart $ fromStrict $ formatBody format feed element]]+ }
src/send-mail/Prelude.hs view
@@ -1,19 +1,21 @@+{-# LANGUAGE UnicodeSyntax #-}+ module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Control.Exception.Safe-import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)-import Relude.Extra.Map (lookup)+import Control.Exception.Safe+import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)+import Relude.Extra.Map (lookup) -io :: MonadIO m => IO a -> m a+io ∷ MonadIO m ⇒ IO a → m a io = liftIO -for :: [a] -> (a -> b) -> [b]+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+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+headFail ∷ MonadFail m ⇒ String → [a] → m a+headFail _ (a : _) = return a+headFail e _ = fail e
+ src/wallabag/Main.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}++-- Save page related to input RSS/Atom item, into a Wallabag server.+--+-- Meant to be used as a callback for imm.+-- {{{ Imports++import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecode, object, (.=))+import Data.ByteString.Lazy (getContents)+import Imm.Callback+import Imm.Feed+import Imm.Link+import Imm.Pretty+import Network.HTTP.Req+import Options.Applicative (Parser, auto, execParser, forwardOptions, help, helper, info, long, option, progDesc, short, strOption, switch)+import URI.ByteString.Extended++-- }}}++data CliOptions = CliOptions+ { _hostname ∷ Text+ , _port ∷ Int+ , _clientID ∷ String+ , _clientSecret ∷ String+ , _username ∷ String+ , _password ∷ String+ , _dryRun ∷ Bool+ }+ deriving (Eq, Ord, Read, Show)++parseOptions ∷ MonadIO m ⇒ m CliOptions+parseOptions = io $ execParser $ info (cliOptions <**> helper) $ progDesc description <> forwardOptions+ where+ description = "Save page into a Wallabag server, for each new RSS/Atom item."++cliOptions ∷ Parser CliOptions+cliOptions =+ CliOptions+ <$> strOption (long "host" <> short 'H' <> help "Hostname of the Wallabag server.")+ <*> option auto (long "port" <> short 'P' <> help "Port of the Wallabag server.")+ <*> strOption (long "client-id" <> short 'i' <> help "Client ID used to access the Wallabag API.")+ <*> strOption (long "client-secret" <> short 's' <> help "Client secret used to access the Wallabag API.")+ <*> strOption (long "username" <> short 'u' <> help "Username to log into Wallabag.")+ <*> strOption (long "password" <> short 'p' <> help "Password to log into Wallabag.")+ <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.")++main ∷ IO ()+main = do+ CliOptions wallabagHost wallabagPort clientID clientSecret username password dryRun ← parseOptions+ input ← getContents <&> eitherDecode++ case input ∷ Either String CallbackMessage of+ Right (CallbackMessage _feedLocation _feedDefinition item) → do+ unless dryRun $ do+ case getMainLink item of+ Just link → do+ runReq defaultHttpConfig $ do+ oAuthToken ← retrieveOAuthToken wallabagHost wallabagPort clientID clientSecret username password+ saveWallabag wallabagHost wallabagPort (access_token oAuthToken) $ _linkURI link+ _ → putStrLn ("No main link in item " <> show (prettyName item)) >> exitFailure+ Left e → putStrLn ("Invalid input: " <> e) >> exitFailure+ return ()++data OAuthTokenResponse = OAuthTokenResponse+ { access_token ∷ Text+ , expires_in ∷ Int+ , refresh_token ∷ Text+ , token_type ∷ Text+ }+ deriving (Generic, Show)++instance ToJSON OAuthTokenResponse++instance FromJSON OAuthTokenResponse++retrieveOAuthToken ∷ MonadHttp m ⇒ Text → Int → String → String → String → String → m OAuthTokenResponse+retrieveOAuthToken wallabagHost wallabagPort clientID clientSecret username password = do+ let payload =+ object+ [ "grant_type" .= ("password" ∷ String)+ , "client_id" .= clientID+ , "client_secret" .= clientSecret+ , "username" .= username+ , "password" .= password+ ]++ responseBody <$> req POST (http wallabagHost /: "oauth" /: "v2" /: "token") (ReqBodyJson payload) jsonResponse (port wallabagPort)++saveWallabag ∷ MonadHttp m ⇒ Text → Int → Text → AnyURI → m ()+saveWallabag wallabagHost wallabagPort accessToken uri = do+ let payload = object ["url" .= (decodeUtf8 $ withAnyURI serializeURIRef' uri ∷ Text)]+ options = port wallabagPort <> header "Authorization" ("Bearer " <> encodeUtf8 accessToken)+ responseBody <$> req POST (http wallabagHost /: "api" /: "entries.json") (ReqBodyJson payload) jsonResponse options
+ src/wallabag/Prelude.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE UnicodeSyntax #-}++module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where++import Control.Exception.Safe+import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)+import Relude.Extra.Map (lookup)++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
@@ -1,126 +1,146 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}--- | Write a file from the input RSS/Atom item.+{-# LANGUAGE UnicodeSyntax #-}++-- Write a file from the input RSS/Atom item. ----- Meant to be use as a callback for imm.--- {{{ Imports-import Imm.Callback-import Imm.Feed-import Imm.Link-import Imm.Pretty+-- Meant to be used as a callback for imm.+-- {{{ Imports -import Data.Aeson-import Data.ByteString.Builder-import Data.ByteString.Lazy (getContents, writeFile)-import qualified Data.Text as Text (replace)-import Data.Time-import Options.Applicative-import System.Directory (createDirectoryIfMissing)-import System.FilePath-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 URI.ByteString.Extended+import Data.Aeson+import Data.ByteString.Builder (Builder, toLazyByteString)+import Data.ByteString.Lazy (getContents, writeFile)+import qualified Data.Text as Text (null, replace, unpack)+import Data.Time+import Imm.Callback+import Imm.Feed+import Imm.Link+import Imm.Pretty+import Options.Applicative+import System.Directory (createDirectoryIfMissing)+import System.FilePath+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 URI.ByteString.Extended+ -- }}} data CliOptions = CliOptions- { _directory :: FilePath- , _dryRun :: Bool- } deriving (Eq, Ord, Read, Show)+ { _directory ∷ FilePath+ , _dryRun ∷ Bool+ }+ deriving (Eq, Ord, Read, Show) -parseOptions :: MonadIO m => m CliOptions-parseOptions = io $ execParser $ info (cliOptions <**> helper) $ progDesc description where+parseOptions ∷ MonadIO m ⇒ m CliOptions+parseOptions = io $ execParser $ info (cliOptions <**> helper) $ progDesc description+ where description = "Write a file for each new RSS/Atom item. An intermediate folder will be created for each feed." -cliOptions :: Parser CliOptions-cliOptions = CliOptions- <$> strOption (long "directory" <> short 'd' <> metavar "PATH" <> help "Root directory where files will be created.")- <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.")--+cliOptions ∷ Parser CliOptions+cliOptions =+ CliOptions+ <$> strOption (long "directory" <> short 'd' <> metavar "PATH" <> help "Root directory where files will be created.")+ <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.") -main :: IO ()+main ∷ IO () main = do- CliOptions directory dryRun <- parseOptions- input <- getContents <&> eitherDecode+ CliOptions directory dryRun ← parseOptions+ input ← getContents <&> eitherDecode - case input :: Either String CallbackMessage of- Right (CallbackMessage feedDefinition item) -> do+ case input ∷ Either String CallbackMessage of+ Right (CallbackMessage feedLocation feedDefinition item) → do let content = defaultFileContent feedDefinition item- filePath = defaultFilePath directory feedDefinition item+ filePath = defaultFilePath directory feedLocation feedDefinition item putStrLn filePath unless dryRun $ do createDirectoryIfMissing True $ takeDirectory filePath writeFile filePath $ toLazyByteString content- Left e -> putStrLn ("Invalid input: " <> e) >> exitFailure+ Left e → putStrLn ("Invalid input: " <> e) >> exitFailure return () -- * Default behavior --- | Generate a path @<root>/<feed title>/<element date>-<element title>.html@, where @<root>@ is the first argument-defaultFilePath :: FilePath -> FeedDefinition -> FeedItem -> FilePath-defaultFilePath root feedDefinition element = makeValid $ root </> toString title </> fileName <.> "html" where+-- | Generate a path @<root>/<feed designator>/<element date>-<element title>.html@, where @<root>@ is the first argument+defaultFilePath ∷ FilePath → FeedLocation → FeedDefinition → FeedItem → FilePath+defaultFilePath root feedLocation feedDefinition element = makeValid $ root </> feedFolder </> fileName <.> "html"+ where+ FeedLocation feedUri _ = feedLocation+ feedFolder = if Text.null title then uriToFolder feedUri else toString title+ uriToFolder uri =+ uri+ & uriAuthority+ <&> authorityHost+ <&> hostBS+ <&> decodeUtf8+ & fromMaybe "unknown-host"+ & sanitize+ & Text.unpack 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 "?" "_"- >>> Text.replace "!" "_"- >>> Text.replace "#" "_"+ sanitize =+ appEndo (mconcat [Endo $ Text.replace (toText [s]) "_" | s ← pathSeparators])+ >>> Text.replace "." "_"+ >>> Text.replace "?" "_"+ >>> Text.replace "!" "_"+ >>> Text.replace "#" "_" -- | Generate an HTML page, with a title, a header and an article that contains the feed element-defaultFileContent :: FeedDefinition -> FeedItem -> Builder-defaultFileContent feedDefinition element = renderHtmlBuilder $ docTypeHtml $ do- H.head $ do- H.meta ! H.charset "utf-8"- H.title $ convertText $ _feedTitle feedDefinition <> " | " <> _itemTitle element- H.body $ do- H.h1 $ convertText $ _feedTitle feedDefinition- H.article $ do- H.header $ do- defaultArticleTitle feedDefinition element- defaultArticleAuthor feedDefinition element- defaultArticleDate feedDefinition element- defaultBody feedDefinition element-+defaultFileContent ∷ FeedDefinition → FeedItem → Builder+defaultFileContent feedDefinition element = renderHtmlBuilder $+ docTypeHtml $ do+ H.head $ do+ H.meta ! H.charset "utf-8"+ H.title $ convertText $ _feedTitle feedDefinition <> " | " <> _itemTitle element+ H.body $ do+ H.h1 $ convertText $ _feedTitle feedDefinition+ H.article $ do+ H.header $ do+ defaultArticleTitle feedDefinition element+ defaultArticleAuthor feedDefinition element+ defaultArticleDate feedDefinition element+ defaultBody feedDefinition element -- * Low-level helpers -defaultArticleTitle :: FeedDefinition -> FeedItem -> Html-defaultArticleTitle _ item = H.h2- $ maybe id (\link -> H.a ! href (_linkURI link)) (getMainLink item)- $ convertText $ _itemTitle item+defaultArticleTitle ∷ FeedDefinition → FeedItem → Html+defaultArticleTitle _ item =+ H.h2 $+ maybe id (\link → H.a ! href (_linkURI link)) (getMainLink item) $+ convertText $+ _itemTitle item -defaultArticleAuthor :: FeedDefinition -> FeedItem -> Html+defaultArticleAuthor ∷ FeedDefinition → FeedItem → Html defaultArticleAuthor _ item = H.address $ do "Published by "- forM_ (_itemAuthors item) $ \author -> do+ forM_ (_itemAuthors item) $ \author → do convertDoc $ pretty author ", " -defaultArticleDate :: FeedDefinition -> FeedItem -> Html-defaultArticleDate _ element = forM_ (_itemDate 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 :: FeedDefinition -> FeedItem -> Html+defaultBody ∷ FeedDefinition → FeedItem → Html defaultBody _ item = do- unless (null links) $ H.p $ do- "Related links:"- H.ul $ forM_ links $ \uri -> H.li (H.a ! href uri $ convertURI uri)+ unless (null links) $+ H.p $ do+ "Related links:"+ H.ul $ forM_ links $ \uri → H.li (H.a ! href uri $ convertURI uri) H.p $ preEscapedToHtml $ _itemContent item- where links = _linkURI <$> _itemLinks item+ where+ links = _linkURI <$> _itemLinks item -href :: AnyURI -> H.Attribute+href ∷ AnyURI → H.Attribute href = H.href . convertURI -convertURI :: (IsString t) => AnyURI -> t+convertURI ∷ IsString t ⇒ AnyURI → t convertURI = convertText . decodeUtf8 . withAnyURI serializeURIRef' -convertText :: (IsString t) => Text -> t+convertText ∷ IsString t ⇒ Text → t convertText = fromString . toString -convertDoc :: (IsString t) => Doc a -> t+convertDoc ∷ IsString t ⇒ Doc a → t convertDoc = show
src/write-file/Prelude.hs view
@@ -1,19 +1,21 @@+{-# LANGUAGE UnicodeSyntax #-}+ module Prelude (for, io, headFail, headThrow, module Relude, module Relude.Extra.Map) where -import Control.Exception.Safe-import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)-import Relude.Extra.Map (lookup)+import Control.Exception.Safe+import Relude hiding (Handle, appendFile, force, readFile, stdout, writeFile)+import Relude.Extra.Map (lookup) -io :: MonadIO m => IO a -> m a+io ∷ MonadIO m ⇒ IO a → m a io = liftIO -for :: [a] -> (a -> b) -> [b]+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+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+headFail ∷ MonadFail m ⇒ String → [a] → m a+headFail _ (a : _) = return a+headFail e _ = fail e