diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,29 @@ # imm -*imm* is a tool to execute arbitrary actions for each new element from RSS/Atom feeds (e.g. sending a mail, or writing a file). +*imm* is a program that executes arbitrary callbacks (e.g. sending a mail, or writing a file) for each element of RSS/Atom feeds. -*imm* is written and configured in *Haskell*. +*imm* is written in [Haskell][2], configured in [Dhall][3]. The project includes: -Technical documentation is available at [hackage][1]. +- a main executable `imm` that users directly run +- additional executables (`imm-writefile` and `imm-sendmail`) that `imm` can be configured to use as callbacks +- a [*Haskell*][2] library, that exports functions useful to both the main executable and callbacks; the API is documented [in Hackage][1]. -To get started, please consult documentation of `Imm.Boot` module. +## Callbacks +Callbacks are configured through the `$XDG_CONFIG_HOME/imm/callbacks.dhall` file. A commented template file is bundled with the project. +`imm` will call each callback once per feed element, and will fill its standard input (`stdin`) with a JSON object structured as follows: + +```json +{ + "feed": "RSS document or Atom feed (XML)", + "element": "RSS item or Atom entry (XML)" +} +``` + +`imm` expects callbacks to return `0` in case of success, or any other exit code in case of failure, in which case the standard error output (`stderr`) will be displayed. + + ## Example use cases ### Online feed reader @@ -17,45 +32,78 @@ You can then browse your feeds through your favourite mail reader, and leverage any mail-related tool on your feeds. Bonus points if your mail reader is online as you can now access your feeds from any computer connected to the Internet. -Check out `Imm.Hooks.SendMail` module. +Here is an example configuration: +```dhall +let Callback : Type = + { _executable : Text + , _arguments : List Text + } +let sendMail = + { _executable = "imm-sendmail" + , _arguments = ["--login", "-u", "user@domain.com", "-P", "password", "-s", "smtp.domain.com", "-p", "587", "--to", "foo.bar@domain.com"] + } + +let config : List Callback = [ sendMail ] +in config +``` + ### Offline read-it-later *imm* is able to store a local copy of unread elements, to read them later while offline for example. External links won't work offline though. -Check out `Imm.Hooks.WriteFile` module. +``` +let Callback : Type = + { _executable : Text + , _arguments : List Text + } +let writeFile = + { _executable = "imm-writefile" + , _arguments = [ "-d", "/path/to/folder" ] + } +let config : List Callback = [ writeFile ] +in config +``` + ## Example usage - Subscribe to a feed: - - ``` + ```bash imm subscribe http://your.feed.org ``` -- Import feeds from an OPML file: - ``` +- Import feeds from an OPML file: + ```bash cat feeds.opml | imm import ``` -- List subscribed feeds: - ``` - imm show +- List subscribed feeds: + ```bash + imm list ``` -- Unsubscribe from a feed: +- Show details about a feed: + ```bash + imm show http://your.feed.org ``` + +- Unsubscribe from a feed: + ```bash imm unsubscribe http://your.feed.org ``` -- Check for new elements without executing any action: - ``` - imm check +- Check for new elements without executing any action: + ```bash + imm run --no-callbacks --read-only ``` -- Execute configured actions for each new element from subscribed feeds: - ``` +- Execute configured callbacks for each new element from subscribed feeds: + ```bash imm run ``` + [1]: http://hackage.haskell.org/package/imm +[2]: https://www.haskell.org +[3]: https://dhall-lang.org/ diff --git a/data/callbacks.dhall b/data/callbacks.dhall new file mode 100644 --- /dev/null +++ b/data/callbacks.dhall @@ -0,0 +1,23 @@ +-- This file must produce a `List Callback` expression, +-- where `Callback` is defined as follows: +let Callback : Type = + { _executable : Text + , _arguments : List Text + } + +-- Below are 2 basic callbacks bundled with imm. +-- +-- Check out `imm-writefile --help` +let writeFile = + { _executable = "imm-writefile" + , _arguments = [ "-d", "/path/to/folder" ] + } + +-- Check out `imm-sendmail --help` +let sendMail = + { _executable = "imm-sendmail" + , _arguments = ["--login", "-u", "user@domain.com", "-P", "password", "-s", "smtp.domain.com", "-p", "587", "--to", "foo.bar@domain.com"] + } + +let config : List Callback = [ writeFile ] +in config diff --git a/imm.cabal b/imm.cabal --- a/imm.cabal +++ b/imm.cabal @@ -1,102 +1,89 @@ +cabal-version: 2.2 name: imm -version: 1.5.0.0 -synopsis: Execute arbitrary actions for each unread element of RSS/Atom feeds +version: 1.6.0.0 +synopsis: Execute arbitrary callbacks for each element of RSS/Atom feeds description: Cf README file homepage: https://github.com/k0ral/imm -license: PublicDomain +license: CC0-1.0 license-file: LICENSE author: kamaradclimber, koral -maintainer: koral +maintainer: chahine.moreau@gmail.com category: Web build-type: Simple -cabal-version: >=1.8 +data-files: data/*.dhall extra-source-files: README.md +tested-with: GHC <8.8 && >=8.4 source-repository head type: git location: git://github.com/k0ral/imm.git +common common + build-depends: base-noprelude >=4.7 && <5, relude + default-language: Haskell2010 + other-modules: + Prelude + library + import: common exposed-modules: Imm - Imm.Boot - Imm.Core + Imm.Callback Imm.Database Imm.Database.FeedTable - Imm.Database.JsonFile Imm.Feed - Imm.Hooks - Imm.Hooks.Dummy - Imm.Hooks.SendMail - Imm.Hooks.WriteFile Imm.HTTP - Imm.HTTP.Simple Imm.Logger - Imm.Logger.Simple - Imm.XML - Imm.XML.Conduit - other-modules: - Imm.Aeson - Imm.Dyre - Imm.Error - Imm.Options Imm.Pretty - Paths_imm - Prelude + Imm.XML build-depends: aeson, - atom-conduit >= 0.6, - base-noprelude == 4.*, - blaze-html, - blaze-markup, - bytestring, - case-insensitive, + async, + atom-conduit >= 0.7, + binary, conduit, - connection, containers, + dhall, directory >= 1.2.3.0, - dyre, - fast-logger, filepath, hashable, - HaskellNet, - HaskellNet-SSL >= 0.3.3.0, - http-client >= 0.4.30, - http-client-tls, http-types, microlens, - mime-mail, monad-time, - monoid-subclasses, - mtl, - network, - opml-conduit >= 0.7, - optparse-applicative, prettyprinter, prettyprinter-ansi-terminal, - refined, - relude, + refined >=0.4.1, rss-conduit >= 0.4.1, safe-exceptions, - stm, - streaming-bytestring, - streaming-with, - streamly, text, - transformers-base, time, timerep >= 2.0.0.0, tls, uri-bytestring, - xml, xml-conduit >= 1.5, xml-types - -- Build-tools: hs-source-dirs: src/lib ghc-options: -Wall -fno-warn-unused-do-bind executable imm - build-depends: imm, base == 4.* - main-is: Executable.hs - hs-source-dirs: src/bin + import: common + build-depends: imm, aeson, async, atom-conduit >=0.7, bytestring, case-insensitive, conduit, connection, containers, dhall, directory, fast-logger, filepath, http-client >=0.4.30, http-client-tls, opml-conduit >=0.7, optparse-applicative, prettyprinter-ansi-terminal, refined >=0.4.1, rss-conduit >=0.4.1, safe-exceptions, stm, stm-chans, streaming-bytestring, streaming-with, text, typed-process, uri-bytestring, xml-conduit >=1.5, xml-types + main-is: Main.hs + other-modules: Core, Database, HTTP, Logger, Options, Paths_imm, XML + autogen-modules: Paths_imm + hs-source-dirs: src/main + ghc-options: -Wall -fno-warn-unused-do-bind -threaded + +executable imm-writefile + import: common + build-depends: imm, aeson, atom-conduit, blaze-html, blaze-markup, bytestring, directory, filepath, optparse-applicative, prettyprinter, rss-conduit, streaming-bytestring, streaming-with, text, time, uri-bytestring + main-is: Main.hs + hs-source-dirs: src/write-file + ghc-options: -Wall -fno-warn-unused-do-bind -threaded + +executable imm-sendmail + import: common + build-depends: imm, aeson, atom-conduit, blaze-html, blaze-markup, bytestring, directory, filepath, HaskellNet >=0.5, HaskellNet-SSL >= 0.3.3.0, mime-mail, network <3, optparse-applicative, prettyprinter, refined, rss-conduit, text, time, uri-bytestring + main-is: Main.hs + hs-source-dirs: src/send-mail ghc-options: -Wall -fno-warn-unused-do-bind -threaded diff --git a/src/bin/Executable.hs b/src/bin/Executable.hs deleted file mode 100644 --- a/src/bin/Executable.hs +++ /dev/null @@ -1,27 +0,0 @@ --- module Executable where - --- {{{ Imports -import Imm -import Imm.Database.JsonFile as Database -import Imm.Hooks.Dummy as Hooks -import Imm.HTTP.Simple as HTTP -import Imm.Logger.Simple as Logger -import Imm.XML.Conduit as XML --- }}} - - -main :: IO () -main = do - logger <- Logger.mkHandle <$> defaultLogger - database <- Database.mkHandle <$> defaultDatabase - httpClient <- HTTP.mkHandle <$> defaultManager - - imm logger database httpClient hooks xmlParser - -xmlParser :: XML.Handle IO -xmlParser = XML.mkHandle defaultXmlParser - -hooks :: Hooks.Handle IO -hooks = Hooks.mkHandle - - diff --git a/src/lib/Imm.hs b/src/lib/Imm.hs --- a/src/lib/Imm.hs +++ b/src/lib/Imm.hs @@ -1,12 +1,9 @@ -- | Meta-module that reexports many Imm sub-modules. --- --- To get started, please consult "Imm.Boot". module Imm (module X) where -import Imm.Boot as X -import Imm.Core as X +import Imm.Callback as X import Imm.Database as X hiding(Handle) import Imm.Feed as X -import Imm.Hooks as X hiding(Handle) import Imm.HTTP as X hiding(Handle) import Imm.Logger as X hiding(Handle) +import Imm.XML as X hiding(Handle) diff --git a/src/lib/Imm/Aeson.hs b/src/lib/Imm/Aeson.hs deleted file mode 100644 --- a/src/lib/Imm/Aeson.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Imm.Aeson where - --- {{{ Imports -import Data.Aeson - -import URI.ByteString --- }}} - -parseJsonURI :: MonadPlus m => Value -> m URI -parseJsonURI (String s) = either (const mzero) return $ parseURI laxURIParserOptions $ encodeUtf8 s -parseJsonURI _ = mzero - -toJsonURI :: URI -> Value -toJsonURI = String . decodeUtf8 . serializeURIRef' diff --git a/src/lib/Imm/Boot.hs b/src/lib/Imm/Boot.hs deleted file mode 100644 --- a/src/lib/Imm/Boot.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} --- | --- = Getting started --- --- == Dynamic reconfiguration --- --- This program is dynamically configured using the library. --- --- You may want to check out to know how to get started. --- --- Your personal configuration is located at @$XDG_CONFIG_HOME\/imm\/imm.hs@. --- --- == Handle pattern --- --- The behavior of this program can be customized through the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html). -module Imm.Boot (imm) where - --- {{{ Imports -import qualified Imm.Core as Core -import Imm.Database as Database -import Imm.Database.FeedTable as Database -import Imm.Dyre as Dyre -import Imm.Feed -import Imm.Hooks as Hooks -import Imm.HTTP as HTTP -import Imm.Logger as Logger -import Imm.Options as Options hiding (logLevel) -import Imm.Pretty -import Imm.XML as XML - -import Control.Exception.Safe -import Data.Conduit.Combinators as Conduit (stdin) -import qualified Data.Map as Map -import Data.Text as Text hiding (length) -import Data.Text.IO as Text -import Relude.Unsafe (at) -import System.IO (hFlush) --- }}} - --- | Main function, meant to be used in your personal configuration file. --- --- Here is an example: --- --- > import Imm.Boot --- > import Imm.Database.JsonFile as Database --- > import Imm.Feed --- > import Imm.Hooks.SendMail as Hooks --- > import Imm.HTTP.Simple as HTTP --- > import Imm.Logger.Simple as Logger --- > import Imm.XML.Conduit as XML --- > --- > main :: IO () --- > main = do --- > logger <- Logger.mkHandle <$> defaultLogger --- > database <- Database.mkHandle <$> defaultDatabase --- > httpClient <- HTTP.mkHandle <$> defaultManager --- > --- > imm logger database httpClient hooks xmlParser --- > --- > xmlParser :: XML.Handle IO --- > xmlParser = XML.mkHandle defaultXmlParser --- > --- > hooks :: Hooks.Handle IO --- > hooks = Hooks.mkHandle $ SendMailSettings smtpServer formatMail --- > --- > formatMail :: FormatMail --- > formatMail = FormatMail --- > (\a b -> (defaultFormatFrom a b) { addressEmail = "user@host" } ) --- > defaultFormatSubject --- > defaultFormatBody --- > (\_ _ -> [Address Nothing "user@host"]) --- > --- > smtpServer :: Feed -> FeedElement -> SMTPServer --- > smtpServer _ _ = SMTPServer --- > (Just $ Authentication PLAIN "user" "password") --- > (StartTls "smtp.host" defaultSettingsSMTPSTARTTLS) -imm :: Logger.Handle IO -> Database.Handle IO FeedTable -> HTTP.Handle IO -> Hooks.Handle IO -> XML.Handle IO -> IO () -imm logger database httpClient hooks xmlParser = void $ do - options <- parseOptions - Dyre.wrap (optionDyreMode options) realMain (optionCommand options, optionLogLevel options, optionColorizeLogs options, logger, database, httpClient, hooks, xmlParser) - -realMain :: (Command, LogLevel, Bool, Logger.Handle IO, Database.Handle IO FeedTable, HTTP.Handle IO, Hooks.Handle IO, XML.Handle IO) -> IO () -realMain (command, logLevel, enableColors, logger, database, httpClient, hooks, xmlParser) = void $ do - setColorizeLogs logger enableColors - setLogLevel logger logLevel - log logger Debug . ("Dynamic reconfiguration settings:" <++>) . indent 2 =<< Dyre.describePaths - log logger Debug $ "Executing: " <> pretty command - log logger Debug . ("Using database:" <++>) . indent 2 =<< _describeDatabase database - - handleAny (log logger Error . pretty . displayException) $ case command of - Check t -> Core.check logger database httpClient xmlParser =<< resolveTarget database ByPassConfirmation t - Help -> Text.putStrLn helpString - Import -> Core.importOPML logger database Conduit.stdin - Read t -> mapM_ (Database.markAsRead logger database) =<< resolveTarget database AskConfirmation t - Run t -> Core.run logger database httpClient hooks xmlParser =<< resolveTarget database ByPassConfirmation t - Show t -> Core.showFeed logger database =<< resolveTarget database ByPassConfirmation t - ShowVersion -> Core.printVersions - Subscribe u c -> Core.subscribe logger database u c - Unread t -> mapM_ (Database.markAsUnread logger database) =<< resolveTarget database AskConfirmation t - Unsubscribe t -> Database.deleteList logger database =<< resolveTarget database AskConfirmation t - _ -> return () - - Database.commit logger database - flushLogs logger - - --- * Util - -data SafeGuard = AskConfirmation | ByPassConfirmation - deriving(Eq, Read, Show) - -data InterruptedException = InterruptedException deriving(Eq, Read, Show) -instance Exception InterruptedException where - displayException _ = "Process interrupted" - -promptConfirm :: Text -> IO () -promptConfirm s = do - Text.putStr $ s <> " Confirm [Y/n] " - hFlush stdout - x <- Text.getLine - unless (Text.null x || x == "Y") $ throwM InterruptedException - - -resolveTarget :: MonadIO m => MonadThrow m => Database.Handle m FeedTable -> SafeGuard -> Maybe Core.FeedRef -> m [FeedID] -resolveTarget database s Nothing = do - result <- Map.keys <$> Database.fetchAll database - when (s == AskConfirmation) $ liftIO $ promptConfirm $ "This will affect " <> show (length result) <> " feeds." - return result -resolveTarget database _ (Just (ByUID i)) = do - result <- fst . at (i-1) . Map.toList <$> Database.fetchAll database - -- log logger Info $ "Target(s): " <> show (pretty result) - return [result] -resolveTarget _ _ (Just (ByURI uri)) = return [FeedID uri] diff --git a/src/lib/Imm/Callback.hs b/src/lib/Imm/Callback.hs new file mode 100644 --- /dev/null +++ b/src/lib/Imm/Callback.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Imm.Callback where + +-- {{{ Imports +import Imm.Feed + +import Data.Aeson +import Data.Aeson.Types +import Data.Text.Prettyprint.Doc +import Dhall +-- }}} + +-- | External program run for each feed element. +-- +-- A `Message` is passed to this program through stdin, serialized in JSON. +data Callback = Callback + { _executable :: FilePath + , _arguments :: [Text] + } deriving (Eq, Generic, Ord, Read, Show) + +instance Interpret Callback + +instance Pretty Callback where + pretty (Callback executable arguments) = pretty executable <+> sep (pretty <$> arguments) + + +-- | All information passed to external programs about a new feed item, are stored in this structure. +data Message = Message Feed FeedElement deriving(Eq, Generic, Ord, Show) + +instance ToJSON Message where + toJSON (Message feed element) = object ["feed" .= renderFeed feed, "element" .= renderFeedElement element] + +instance FromJSON Message where + parseJSON = withObject "Message" $ \v -> Message + <$> (v .: "feed" >>= (liftEither . parseFeed)) + <*> (v .: "element" >>= (liftEither . parseFeedElement)) + where liftEither :: Either e a -> Parser a + liftEither = either (const mempty) return diff --git a/src/lib/Imm/Core.hs b/src/lib/Imm/Core.hs deleted file mode 100644 --- a/src/lib/Imm/Core.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -module Imm.Core ( --- * Types - FeedRef, --- * Actions - printVersions, - subscribe, - showFeed, - check, - run, - importOPML, -) where - --- {{{ Imports -import qualified Imm.Database as Database -import Imm.Database.FeedTable -import qualified Imm.Database.FeedTable as Database -import Imm.Feed -import Imm.Hooks as Hooks -import qualified Imm.HTTP as HTTP -import Imm.Logger as Logger -import Imm.Pretty -import Imm.XML as XML - -import Control.Exception.Safe -import Control.Monad.Time -import Data.Conduit -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Tree -import Data.Version -import qualified Paths_imm as Package -import Refined -import Streamly hiding ((<>)) -import qualified Streamly.Prelude as Stream -import System.Info -import Text.OPML.Conduit.Parse -import Text.OPML.Types as OPML -import Text.XML as XML () -import Text.XML.Stream.Parse as XML -import URI.ByteString --- }}} - - -printVersions :: (MonadBase IO m) => m () -printVersions = liftBase $ do - putStrLn $ "imm-" <> showVersion Package.version - putStrLn $ "compiled by " <> compilerName <> "-" <> showVersion compilerVersion - --- | Print database status for given feed(s) -showFeed :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> [FeedID] -> m () -showFeed logger database feedIDs = do - entries <- Database.fetchList database feedIDs - flushLogs logger - when (null entries) $ log logger Warning "No subscription" - forM_ (zip [1..] $ Map.elems entries) $ \(i, entry) -> - log logger Info $ pretty (i :: Int) <+> prettyDatabaseEntry entry - --- | Register the given feed URI in database -subscribe :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> URI -> Set Text -> m () -subscribe logger database uri = Database.register logger database (FeedID uri) - --- | Check for unread elements without processing them -check :: (MonadAsync m, MonadCatch m) - => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> XML.Handle m -> [FeedID] -> m () -check logger database httpClient xmlParser feedIDs = do - progress <- liftBase $ newTVarIO 0 - - results <- Stream.toList $ wAsyncly $ do - feedID <- Stream.fromFoldable feedIDs - result <- lift $ tryAny $ checkOne logger database httpClient xmlParser feedID - let logResult = either (red . pretty . displayException) (\n -> green (pretty n) <+> "new element(s)") result - n <- liftBase $ atomically $ do - modifyTVar' (progress :: TVar Int) (+ 1) - readTVar progress - lift $ log logger Info $ brackets (fill width (bold $ cyan $ pretty n) <+> "/" <+> pretty total) <+> "Checked" <+> magenta (pretty feedID) <+> "=>" <+> logResult - return result - - flushLogs logger - - let (failures, successes) = partitionEithers $ zipWith (\a -> bimap (a,) (a,)) feedIDs results - unless (null failures) $ log logger Error $ bold (pretty $ length failures) <+> "feeds in error" - log logger Info $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall" - - where width = length (show total :: String) - total = length feedIDs - -checkOne :: (MonadBase IO m, MonadCatch m) - => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> XML.Handle m -> FeedID -> m Int -checkOne logger database httpClient xmlParser feedID = do - feed <- getFeed logger httpClient xmlParser feedID - case feed of - Atom _ -> log logger Debug $ "Parsed Atom feed: " <> pretty feedID - Rss _ -> log logger Debug $ "Parsed RSS feed: " <> pretty feedID - - let dates = mapMaybe getDate $ getElements feed - - log logger Debug $ vsep $ map prettyElement $ getElements feed - status <- Database.getStatus database feedID - - return $ length $ filter (unread status) dates - where unread (LastUpdate t1) t2 = t2 > t1 - unread _ _ = True - - -run :: (MonadTime m, MonadAsync m, MonadCatch m) - => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> Hooks.Handle m -> XML.Handle m -> [FeedID] -> m () -run logger database httpClient hooks xmlParser feedIDs = do - progress <- liftBase $ newTVarIO 0 - - results <- Stream.toList $ wAsyncly $ do - feedID <- Stream.fromFoldable feedIDs - result <- lift $ tryAny $ runOne logger database httpClient hooks xmlParser feedID - let logResult = either (red . pretty . displayException) (\n -> green (pretty n) <+> "new element(s)") result - n <- liftBase $ atomically $ do - modifyTVar' progress (+ 1) - readTVar progress :: STM Int - lift $ log logger Info $ brackets (fill width (bold $ cyan $ pretty n) <+> "/" <+> pretty total) <+> "Processed" <+> magenta (pretty feedID) <+> "=>" <+> logResult - return $ bimap (feedID,) (feedID,) result - - flushLogs logger - - let (failures, successes) = partitionEithers results - - unless (null failures) $ log logger Error $ bold (pretty $ length failures) <+> "feeds in error" - log logger Info $ bold (pretty $ sum $ map snd successes) <+> "new element(s) overall" - - where width = length (show total :: String) - total = length feedIDs - -runOne :: (MonadTime m, MonadCatch m) - => Logger.Handle m -> Database.Handle m FeedTable -> HTTP.Handle m -> Hooks.Handle m -> XML.Handle m -> FeedID -> m Int -runOne logger database httpClient hooks xmlParser feedID = do - feed <- getFeed logger httpClient xmlParser feedID - unreadElements <- filterM (fmap not . isRead database feedID) $ getElements feed - - forM_ unreadElements $ \element -> do - onNewElement logger hooks feed element - mapM_ (Database.addReadHash logger database feedID) $ getHashes element - - Database.markAsRead logger database feedID - return $ length unreadElements - - -isRead :: MonadCatch m => Database.Handle m FeedTable -> FeedID -> FeedElement -> m Bool -isRead database feedID element = do - DatabaseEntry _ _ readHashes lastCheck <- Database.fetch database feedID - let matchHash = not $ Set.null $ Set.fromList (getHashes element) `Set.intersection` readHashes - matchDate = case (lastCheck, getDate element) of - (Nothing, _) -> False - (_, Nothing) -> False - (Just a, Just b) -> a > b - return $ matchHash || matchDate - --- | 'subscribe' to all feeds described by the OPML document provided in input -importOPML :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> ConduitT () ByteString m () -> m () -importOPML logger database input = do - opml <- runConduit $ input .| XML.parseBytes def .| force "Invalid OPML" parseOpml - forM_ (opmlOutlines opml) $ importOPML' logger database mempty - -importOPML' :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> Set Text -> Tree OpmlOutline -> m () -importOPML' logger database _ (Node (OpmlOutlineGeneric b _) sub) = mapM_ (importOPML' logger database (Set.singleton . unrefine $ OPML.text b)) sub -importOPML' logger database c (Node (OpmlOutlineSubscription _ s) _) = subscribe logger database (xmlUri s) c -importOPML' _ _ _ _ = return () - - -getFeed :: MonadCatch m => Logger.Handle m -> HTTP.Handle m -> XML.Handle m -> FeedID -> m Feed -getFeed logger httpClient xmlParser (FeedID uri) = HTTP.get logger httpClient uri >>= parseXml xmlParser uri diff --git a/src/lib/Imm/Database.hs b/src/lib/Imm/Database.hs --- a/src/lib/Imm/Database.hs +++ b/src/lib/Imm/Database.hs @@ -32,7 +32,7 @@ rep :: t data Handle m t = Handle - { _describeDatabase :: forall a . m (Doc a) + { _describeDatabase :: m (Doc AnsiStyle) , _fetchList :: [Key t] -> m (Map (Key t) (Entry t)) , _fetchAll :: m (Map (Key t) (Entry t)) , _update :: Key t -> (Entry t -> Entry t) -> m () @@ -41,6 +41,19 @@ , _purge :: m () , _commit :: m () } + +readOnly :: Monad m => Pretty (Key t) => Logger.Handle m -> Handle m t -> Handle m t +readOnly logger handle = handle + { _describeDatabase = do + output <- _describeDatabase handle + return $ output <+> yellow (brackets "read only") + , _update = \key _ -> log logger Debug $ "Not updating database for key " <> pretty key + , _insertList = \list -> log logger Debug $ "Not inserting " <> yellow (pretty $ length list) <> " entries" + , _deleteList = \list -> log logger Debug $ "Not deleting " <> yellow (pretty $ length list) <> " entries" + , _purge = log logger Debug "Not purging database" + , _commit = log logger Debug "Not committing database" + } + data DatabaseException t diff --git a/src/lib/Imm/Database/FeedTable.hs b/src/lib/Imm/Database/FeedTable.hs --- a/src/lib/Imm/Database/FeedTable.hs +++ b/src/lib/Imm/Database/FeedTable.hs @@ -1,21 +1,31 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | Feed table definitions. This is a specialization of "Imm.Database". module Imm.Database.FeedTable where -- {{{ Imports -import Imm.Aeson import Imm.Database as Database +import Imm.Feed import Imm.Logger as Logger import Imm.Pretty import Control.Exception.Safe import Control.Monad.Time import Data.Aeson -import qualified Data.Set as Set (insert) +import Data.Aeson.Types +import Data.Hashable +import Data.Map.Lazy (mapKeys) +import qualified Data.Map.Lazy as Map (insert, filter, keys) +import qualified Data.Set as Set (intersection) import Data.Time import URI.ByteString + +-- To be removed soon +import Text.Atom.Types +import Text.RSS.Types -- }}} -- * Types @@ -28,50 +38,112 @@ prettyFeedID (FeedID uri) = prettyURI uri instance FromJSON FeedID where - parseJSON = fmap FeedID . parseJsonURI + parseJSON value = FeedID . _unwrapURI <$> parseJSON value instance ToJSON FeedID where - toJSON (FeedID uri) = toJsonURI uri + toJSON (FeedID uri) = toJSON $ JsonURI uri instance Pretty FeedID where pretty (FeedID uri) = prettyURI uri +-- DEPRECATED +getHashes :: FeedElement -> [Int] +getHashes (RssElement item) = map (hash @String . show . prettyGuid) (maybeToList $ itemGuid item) + <> map (hash @String . show . withRssURI prettyURI) (maybeToList $ itemLink item) + <> [hash $ itemTitle item] + <> [hash $ itemDescription item] +getHashes (AtomElement entry) = [hash $ entryId entry, (hash :: String -> Int) $ show $ prettyAtomText $ entryTitle entry] + + +-- | Newtype wrapper to provide 'FromJSON' and 'ToJSON' instances for 'URI' +newtype JsonURI = JsonURI { _unwrapURI :: URI } + +instance FromJSON JsonURI where + parseJSON = withText "URI" $ \s -> + either (const $ fail "Invalid URI") (return . JsonURI) $ parseURI laxURIParserOptions $ encodeUtf8 s + +instance ToJSON JsonURI where + toJSON = String . decodeUtf8 . serializeURIRef' . _unwrapURI + + +-- | Newtype wrapper to provide `FromJSON` and `ToJSON` instances for 'FeedElement' +newtype JsonElement = JsonElement { unwrapElement :: FeedElement } deriving(Eq, Ord) + +instance FromJSON JsonElement where + parseJSON = withText "Feed element" $ \t -> parseFeedElement t & liftEither <&> JsonElement + where liftEither :: Either e a -> Parser a + liftEither = either (const mempty) return + +instance FromJSONKey JsonElement + +instance ToJSON JsonElement where + toJSON (JsonElement element) = String $ renderFeedElement element + +instance ToJSONKey JsonElement + + data DatabaseEntry = DatabaseEntry - { entryURI :: URI - , entryTags :: Set Text - , entryReadHashes :: Set Int - , entryLastCheck :: Maybe UTCTime + { entryURI :: URI + , entryTags :: Set Text + , entryReadHashes :: Set Int + , entryFeed :: Maybe Feed + , entryItems :: Map FeedElement Bool + , entryLastUpdate :: Maybe UTCTime } deriving(Eq, Show) -prettyDatabaseEntry :: DatabaseEntry -> Doc AnsiStyle -prettyDatabaseEntry entry = magenta feedID +prettyShortDatabaseEntry :: DatabaseEntry -> Doc AnsiStyle +prettyShortDatabaseEntry DatabaseEntry{..} = magenta feedID <++> indent 3 tags - <++> indent 3 ("Last checked:" <+> lastCheck) + <++> indent 3 ("Last update:" <+> lastUpdate) + <++> indent 3 (yellow (pretty totalItems) <+> "items," <+> yellow (pretty totalUnprocessedItems) <+> "unprocessed") - where feedID = prettyURI $ entryURI entry - tags = sep $ map ((<>) "#" . pretty) $ toList $ entryTags entry - lastCheck = format $ entryLastCheck entry - format = maybe "never" (fromString . formatTime defaultTimeLocale "%F %R") + where feedID = prettyURI entryURI + tags = sep $ map ((<>) "#" . pretty) $ toList entryTags + lastUpdate = maybe "never" prettyTime entryLastUpdate + totalItems = length entryItems + totalUnprocessedItems = length $ Map.filter not entryItems +prettyDatabaseEntry :: DatabaseEntry -> Doc AnsiStyle +prettyDatabaseEntry DatabaseEntry{..} = magenta feedID + <++> tags + <++> ("Last update:" <+> lastUpdate) + <++> (yellow (pretty $ length $ Map.filter id entryItems) <+> "processed items") + <++> indent 3 (vsep $ map displayItem $ Map.keys $ Map.filter id entryItems) + <++> (yellow (pretty $ length $ Map.filter not entryItems) <+> "unprocessed items") + <++> indent 3 (vsep $ map displayItem $ Map.keys $ Map.filter not entryItems) + where feedID = prettyURI entryURI + tags = sep $ map ((<>) "#" . pretty) $ toList entryTags + lastUpdate = maybe "never" prettyTime entryLastUpdate + displayItem item = maybe "" prettyTime (getDate item) <+> pretty (getTitle item) + instance FromJSON DatabaseEntry where - parseJSON (Object v) = DatabaseEntry <$> (parseJsonURI =<< v .: "uri") <*> v .: "tags" <*> v.: "readHashes" <*> v .: "lastCheck" + parseJSON (Object v) = DatabaseEntry + <$> (_unwrapURI <$> (v .: "uri")) + <*> v .: "tags" + <*> (v .: "readHashes" <|> pure mempty) + <*> ((v .:? "feed") >>= maybe (pure Nothing) (fmap Just . liftEither . parseFeed)) + <*> (v .:? "items" >>= maybe (pure mempty) (return . mapKeys unwrapElement)) + <*> (v .: "lastUpdate" <|> v .: "lastCheck") + where liftEither :: Either e a -> Parser a + liftEither = either (const mempty) return + parseJSON _ = mzero instance ToJSON DatabaseEntry where - toJSON entry = object - [ "uri" .= toJsonURI (entryURI entry) - , "tags" .= entryTags entry - , "readHashes" .= entryReadHashes entry - , "lastCheck" .= entryLastCheck entry - ] + toJSON DatabaseEntry{..} = object $ + [ "uri" .= JsonURI entryURI + , "tags" .= entryTags + , "items" .= mapKeys JsonElement entryItems + , "lastUpdate" .= entryLastUpdate + ] <> maybeToList (fmap (("feed" .=) . renderFeed) entryFeed) + <> if null entryReadHashes then mempty else ["readHashes" .= entryReadHashes] newDatabaseEntry :: FeedID -> Set Text -> DatabaseEntry -newDatabaseEntry (FeedID uri) tags = DatabaseEntry uri tags mempty Nothing +newDatabaseEntry (FeedID uri) tags = DatabaseEntry uri tags mempty mzero mempty Nothing -- | Singleton type to represent feeds table -data FeedTable = FeedTable - deriving(Show) +data FeedTable = FeedTable deriving(Eq, Ord, Read, Show) instance Pretty FeedTable where pretty _ = "Feeds table" @@ -103,25 +175,36 @@ getStatus :: MonadCatch m => Database.Handle m FeedTable -> FeedID -> m FeedStatus getStatus database feedID = handleAny (\_ -> return Unknown) $ do result <- fmap Just (fetch database feedID) `catchAny` (\_ -> return Nothing) - return $ maybe New LastUpdate $ entryLastCheck =<< result - -addReadHash :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> Int -> m () -addReadHash logger database feedID hash = do - log logger Debug $ "Adding read hash:" <+> pretty hash <> "..." - update database feedID f - where f a = a { entryReadHashes = Set.insert hash $ entryReadHashes a } + return $ maybe New LastUpdate $ entryLastUpdate =<< result --- | Set the last check time to now -markAsRead :: (MonadTime m, MonadThrow m) - => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m () -markAsRead logger database feedID = do - log logger Debug $ "Marking feed as read:" <+> pretty feedID <> "..." +markAsProcessed :: MonadThrow m => MonadTime m + => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> FeedElement -> m () +markAsProcessed logger database feedID element = do + log logger Debug $ "Marking as processed:" <+> pretty (PrettyKey element) <> "..." utcTime <- currentTime - update database feedID (f utcTime) - where f time a = a { entryLastCheck = Just time } + update database feedID $ \entry -> entry + { entryItems = Map.insert element True $ entryItems entry + , entryLastUpdate = Just utcTime + } --- | Unset feed's last update and remove all read hashes -markAsUnread :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m () -markAsUnread logger database feedID = do - log logger Info $ "Marking feed as unread:" <+> prettyFeedID feedID <> "..." - update database feedID $ \a -> a { entryReadHashes = mempty, entryLastCheck = Nothing } + +markAsUnprocessed :: MonadThrow m + => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m () +markAsUnprocessed logger database feedID = do + log logger Debug $ "Marking as unprocessed:" <+> pretty feedID <> "..." + update database feedID $ \entry -> entry + { entryItems = False <$ entryItems entry + , entryLastUpdate = Nothing + , entryReadHashes = mempty + } + +isRead :: MonadCatch m => Database.Handle m FeedTable -> FeedID -> FeedElement -> m Bool +isRead database feedID element = do + DatabaseEntry _ _ readHashes _ items lastUpdate <- Database.fetch database feedID + let matchHash = not $ null $ fromList (getHashes element) `Set.intersection` readHashes + matchDate = case (lastUpdate, getDate element) of + (Nothing, _) -> False + (_, Nothing) -> False + (Just a, Just b) -> a > b + matchKey = lookup element items & fromMaybe False + return $ matchHash || matchDate || matchKey diff --git a/src/lib/Imm/Database/JsonFile.hs b/src/lib/Imm/Database/JsonFile.hs deleted file mode 100644 --- a/src/lib/Imm/Database/JsonFile.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} --- | Implementation of "Imm.Database" based on a JSON file. -module Imm.Database.JsonFile - ( JsonFileDatabase - , mkJsonFileDatabase - , defaultDatabase - , mkHandle - , JsonException(..) - , module Imm.Database.FeedTable - ) where - --- {{{ Imports -import Imm.Database hiding (commit, delete, insert, - purge, update) -import Imm.Database.FeedTable -import Imm.Error -import Imm.Pretty - -import Control.Concurrent.STM.TVar (swapTVar) -import Data.Aeson -import Data.ByteString.Lazy (hPut) -import Data.ByteString.Streaming (hGetContents, toLazy_) -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Streaming.With hiding (withFile) -import System.Directory -import System.FilePath --- }}} - -data CacheStatus = Empty | Clean | Dirty - deriving(Eq, Show) - -data JsonFileDatabase t = JsonFileDatabase FilePath (Map (Key t) (Entry t)) CacheStatus - -instance Pretty (JsonFileDatabase t) where - pretty (JsonFileDatabase file _ _) = "JSON database: " <+> pretty file - -mkJsonFileDatabase :: (Table t) => FilePath -> JsonFileDatabase t -mkJsonFileDatabase file = JsonFileDatabase file mempty Empty - --- | Default database is stored in @$XDG_CONFIG_HOME\/imm\/feeds.json@ -defaultDatabase :: Table t => IO (TVar (JsonFileDatabase t)) -defaultDatabase = do - databaseFile <- getXdgDirectory XdgConfig "imm/feeds.json" - newTVarIO $ mkJsonFileDatabase databaseFile - - -data JsonException = UnableDecode - deriving(Eq, Show) - -instance Exception JsonException where - displayException _ = "Unable to parse JSON" - - -mkHandle :: (Table t, FromJSON (Key t), FromJSON (Entry t), ToJSON (Key t), ToJSON (Entry t), MonadIO m, MonadMask m) - => TVar (JsonFileDatabase t) -> Handle m t -mkHandle tvar = Handle - { _describeDatabase = pretty <$> readTVarIO tvar - , _fetchList = \keys -> loadInCache tvar >> (Map.filterWithKey (\uri _ -> Set.member uri $ Set.fromList keys) <$> getCache tvar) - , _fetchAll = loadInCache tvar >> getCache tvar - , _update = \key f -> loadInCache tvar >> atomically (modifyTVar' tvar $ updateInCache key f) - , _insertList = \list -> loadInCache tvar >> atomically (modifyTVar' tvar $ insertInCache list) - , _deleteList = \list -> loadInCache tvar >> atomically (modifyTVar' tvar $ deleteInCache list) - , _purge = loadInCache tvar >> atomically (modifyTVar' tvar purgeInCache) - , _commit = commit tvar - } - --- * Low-level implementation - -loadInCache :: (Table t, FromJSON (Key t), FromJSON (Entry t), MonadIO m, MonadMask m) => TVar (JsonFileDatabase t) -> m () -loadInCache tvar = do - JsonFileDatabase file _ status <- readTVarIO tvar - when (status == Empty) $ do - database <- loadFromDisk file - atomically $ do - JsonFileDatabase _ _ status' <- readTVar tvar - when (status' == Empty) $ writeTVar tvar database - -loadFromDisk :: (Table t, FromJSON (Key t), FromJSON (Entry t), MonadIO m, MonadMask m) => FilePath -> m (JsonFileDatabase t) -loadFromDisk file = do - liftIO $ createDirectoryIfMissing True $ takeDirectory file - fileContent <- withBinaryFile file ReadWriteMode (toLazy_ . hGetContents) - cache <- (`failWith` UnableDecode) $ fmap Map.fromList $ decode $ fromEmpty "[]" fileContent - return $ JsonFileDatabase file cache Clean - where fromEmpty x "" = x - fromEmpty _ y = y - -getCache :: MonadIO m => TVar (JsonFileDatabase t) -> m (Map (Key t) (Entry t)) -getCache tvar = do - JsonFileDatabase _ cache _ <- readTVarIO tvar - return cache - - -insertInCache :: Table t => [(Key t, Entry t)] -> JsonFileDatabase t -> JsonFileDatabase t -insertInCache rows (JsonFileDatabase file cache _) = JsonFileDatabase file (Map.union cache $ Map.fromList rows) Dirty - -updateInCache :: Table t => Key t -> (Entry t -> Entry t) -> JsonFileDatabase t -> JsonFileDatabase t -updateInCache key f (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where - newCache = Map.update (Just . f) key cache - -deleteInCache :: Table t => [Key t] -> JsonFileDatabase t -> JsonFileDatabase t -deleteInCache keys (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where - newCache = foldr Map.delete cache keys - -purgeInCache :: Table t => JsonFileDatabase t -> JsonFileDatabase t -purgeInCache (JsonFileDatabase file _ _) = JsonFileDatabase file mempty Dirty - -commit :: (ToJSON (Key t), ToJSON (Entry t), MonadIO m) - => TVar (JsonFileDatabase t) -> m () -commit tvar = do - JsonFileDatabase file cache status <- atomically $ do - database@(JsonFileDatabase file cache status) <- readTVar tvar - when (status == Dirty) $ void $ swapTVar tvar $ JsonFileDatabase file cache Clean - return database - - when (status == Dirty) $ liftIO $ withFile file WriteMode $ \h -> hPut h $ encode $ Map.toList cache diff --git a/src/lib/Imm/Dyre.hs b/src/lib/Imm/Dyre.hs deleted file mode 100644 --- a/src/lib/Imm/Dyre.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -module Imm.Dyre - ( Mode(..) - , defaultMode - , describePaths - , wrap - , recompile - ) where - --- {{{ Imports -import Imm.Pretty - -import Config.Dyre -import Config.Dyre.Compile -import Config.Dyre.Paths - -import System.IO --- }}} - --- | How dynamic reconfiguration process should behave. -data Mode = Normal | Vanilla | ForceReconfiguration | IgnoreReconfiguration - deriving(Eq, Show) - --- | Default mode is 'Normal', that is: use custom configuration file and recompile if change detected. -defaultMode :: Mode -defaultMode = Normal - - --- | Describe the paths used for dynamic reconfiguration -describePaths :: (MonadIO m) => m (Doc AnsiStyle) -describePaths = io $ do - (a, b, c, d, e) <- getPaths baseParameters - return $ vsep - [ "Current binary" <+> equals <+> magenta (fromString a) - , "Custom binary" <+> equals <+> magenta (fromString b) - , "Config file" <+> equals <+> magenta (fromString c) - , "Cache directory" <+> equals <+> magenta (fromString d) - , "Lib directory" <+> equals <+> magenta (fromString e) - ] - --- | Dynamic reconfiguration settings -parameters :: Mode -> (a -> IO ()) -> Params (Either String a) -parameters mode main = baseParameters - { configCheck = mode /= Vanilla - , realMain = main' - } - where - main' (Left e) = hPutStrLn stderr e - main' (Right x) = main x - -baseParameters :: Params (Either String a) -baseParameters = defaultParams - { projectName = "imm" - , showError = const Left - , ghcOpts = ["-threaded"] - , statusOut = hPutStrLn stderr - , includeCurrentDirectory = False - } - -wrap :: Mode -> (a -> IO ()) -> a -> IO () -wrap mode result args = wrapMain (parameters mode result) (Right args) - - --- | Launch a recompilation of the configuration file -recompile :: (MonadIO m) => m (Maybe Text) -recompile = io $ do - customCompile baseParameters - fmap fromString <$> getErrorString baseParameters diff --git a/src/lib/Imm/Error.hs b/src/lib/Imm/Error.hs deleted file mode 100644 --- a/src/lib/Imm/Error.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Imm.Error (module Imm.Error) where - --- {{{ Imports -import Control.Exception.Safe --- }}} - -liftE :: (MonadThrow m, Exception e) => Either e a -> m a -liftE (Left e) = throwM e -liftE (Right a) = return a - --- | Wrap a 'Maybe' value in 'MonadError' -failWith, () :: (MonadThrow m, Exception e) => Maybe a -> e -> m a -failWith x e = maybe (throwM e) return x -() = failWith diff --git a/src/lib/Imm/Feed.hs b/src/lib/Imm/Feed.hs --- a/src/lib/Imm/Feed.hs +++ b/src/lib/Imm/Feed.hs @@ -1,21 +1,35 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} -- | Helpers to manipulate feeds module Imm.Feed where -- {{{ Imports import Imm.Pretty -import Data.Hashable +import Conduit +import Control.Exception.Safe +import Data.Binary.Builder import Data.Text as Text (null) import Data.Time +import Data.Type.Equality import Lens.Micro +import Text.Atom.Conduit.Parse +import Text.Atom.Conduit.Render import Text.Atom.Types +import Text.RSS.Conduit.Parse +import Text.RSS.Conduit.Render import Text.RSS.Extensions.Content import Text.RSS.Extensions.DublinCore import Text.RSS.Lens import Text.RSS.Types +import Text.RSS1.Conduit.Parse +import Text.XML.Stream.Parse as XML hiding (content) +import Text.XML.Stream.Render hiding (content) import URI.ByteString -- }}} @@ -23,19 +37,81 @@ -- | Feed reference: either its URI, or its UID from database data FeedRef = ByUID Int | ByURI URI - deriving(Eq, Show) + deriving(Eq, Ord, Show) instance Pretty FeedRef where pretty (ByUID n) = "feed" <+> pretty n pretty (ByURI u) = prettyURI u data Feed = Rss (RssDocument '[ContentModule, DublinCoreModule]) | Atom AtomFeed - deriving(Eq, Show) + deriving(Eq, Ord, Show) data FeedElement = RssElement (RssItem '[ContentModule, DublinCoreModule]) | AtomElement AtomEntry - deriving(Eq, Show) + deriving(Show) +instance Pretty (PrettyKey FeedElement) where + pretty (PrettyKey element) = "element" <+> pretty (getTitle element) +instance Ord FeedElement where + compare element1 element2 = compare (getId element1) (getId element2) + <> compare (getLink element1) (getLink element2) + <> compare (getTitle element1) (getTitle element2) + <> compare (getContent element1) (getContent element2) + +instance Eq FeedElement where + element1 == element2 = compare element1 element2 == EQ + + +data FeedURI = forall a . FeedURI (URIRef a) + +deriving instance Show FeedURI +instance Eq FeedURI where + (FeedURI a) == (FeedURI b) = case sameURIType a b of + Just Refl -> a == b + _ -> False + +instance Ord FeedURI where + compare (FeedURI a) (FeedURI b) = case (a, b) of + (URI{}, URI{}) -> compare a b + (RelativeRef{}, RelativeRef{}) -> compare a b + (URI{}, RelativeRef{}) -> LT + (RelativeRef{}, URI{}) -> GT + +sameURIType :: URIRef a1 -> URIRef a2 -> Maybe (URIRef a1 :~: URIRef a2) +sameURIType a b = case (a, b) of + (URI{}, URI{}) -> Just Refl + (RelativeRef{}, RelativeRef{}) -> Just Refl + _ -> Nothing + + +withFeedURI :: (forall a . URIRef a -> b) -> FeedURI -> b +withFeedURI f (FeedURI a) = f a + + +-- * Generic parsers/renderers + +renderFeed :: Feed -> Text +renderFeed (Rss rss) = decodeUtf8 $ toLazyByteString $ runConduitPure $ renderRssDocument rss .| renderBuilder def .| foldC +renderFeed (Atom atom) = decodeUtf8 $ toLazyByteString $ runConduitPure $ renderAtomFeed atom .| renderBuilder def .| foldC + +renderFeedElement :: FeedElement -> Text +renderFeedElement (RssElement item) = decodeUtf8 $ toLazyByteString $ runConduitPure $ renderRssItem item .| renderBuilder def .| foldC +renderFeedElement (AtomElement entry) = decodeUtf8 $ toLazyByteString $ runConduitPure $ renderAtomEntry entry .| renderBuilder def .| foldC + +parseFeed :: MonadCatch m => Text -> m Feed +parseFeed text = runConduit $ parseLBS def (encodeUtf8 text) .| XML.force "Invalid feed" ((fmap Atom <$> atomFeed) `orE` (fmap Rss <$> rssDocument) `orE` (fmap Rss <$> rss1Document)) + +parseFeedElement :: MonadCatch m => Text -> m FeedElement +parseFeedElement text = runConduit $ parseLBS def (encodeUtf8 text) .| XML.force "Invalid feed element" ((fmap AtomElement <$> atomEntry) `orE` (fmap RssElement <$> rssItem) `orE` (fmap RssElement <$> rss1Item)) + + +-- * Generic mutators + +removeElements :: Feed -> Feed +removeElements (Rss rss) = Rss $ rss { channelItems = mempty } +removeElements (Atom atom) = Atom $ atom { feedEntries = mempty } + + -- * Generic getters getFeedTitle :: Feed -> Text @@ -61,14 +137,16 @@ content = show . prettyAtomContent <$> entryContent entry summary = show . prettyAtomText <$> entrySummary entry - -getHashes :: FeedElement -> [Int] -getHashes (RssElement item) = map (hash @String . show . prettyGuid) (maybeToList $ itemGuid item) - <> map ((hash :: String -> Int) . show . withRssURI prettyURI) (maybeToList $ itemLink item) - <> [hash $ itemTitle item] - <> [hash $ itemDescription item] -getHashes (AtomElement entry) = [hash $ entryId entry, (hash :: String -> Int) $ show $ prettyAtomText $ entryTitle entry] +getLink :: FeedElement -> Maybe FeedURI +getLink (RssElement item) = itemLink item <&> withRssURI FeedURI +getLink (AtomElement entry) = (alternateLink <|> defaultLink) <&> linkHref <&> withAtomURI FeedURI where + links = entryLinks entry + alternateLink = links & filter (\link -> linkRel link == "alternate") & nonEmpty <&> head + defaultLink = links & filter (Text.null . linkRel) & nonEmpty <&> head +getId :: FeedElement -> Text +getId (RssElement item) = itemGuid item <&> prettyGuid & maybe mempty show +getId (AtomElement entry) = entryId entry -- * Misc diff --git a/src/lib/Imm/HTTP/Simple.hs b/src/lib/Imm/HTTP/Simple.hs deleted file mode 100644 --- a/src/lib/Imm/HTTP/Simple.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} --- | Implementation of "Imm.HTTP" based on "Network.HTTP.Client". -module Imm.HTTP.Simple (mkHandle, defaultManager, module Reexport) where - --- {{{ Imports -import Imm.HTTP -import Imm.Pretty - -import Control.Exception.Safe -import Data.CaseInsensitive -import Network.Connection as Reexport -import Network.HTTP.Client as Reexport -import Network.HTTP.Client.TLS as Reexport -import URI.ByteString --- }}} - -mkHandle :: MonadBase IO m => Manager -> Handle m -mkHandle manager = Handle - { httpGet = liftBase . httpGet' manager - } - --- | Default manager uses TLS and no proxy -defaultManager :: IO Manager -defaultManager = newManager $ mkManagerSettings (TLSSettingsSimple False False False) Nothing - - --- | Perform an HTTP GET request and return the response body -httpGet' :: Manager -> URI -> IO LByteString -httpGet' manager uri = do - request <- makeRequest uri - responseBody <$> httpLbs request manager - -- codec' <- reader $ view (config.codec) - -- return $ response $=+ decode codec' - -parseRequest' :: MonadThrow m => URI -> m Request -parseRequest' = parseRequest . show . prettyURI - --- | Build an HTTP request for given URI -makeRequest :: URI -> IO Request -makeRequest uri = do - req <- parseRequest' uri - return $ req { requestHeaders = [ - (mk "User-Agent", "Mozilla/4.0"), - (mk "Accept", "*/*")]} diff --git a/src/lib/Imm/Hooks.hs b/src/lib/Imm/Hooks.hs deleted file mode 100644 --- a/src/lib/Imm/Hooks.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Hooks module abstracts over the main behavior of the program. --- --- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html). --- --- > import qualified Imm.Hooks as Hooks -module Imm.Hooks where - --- {{{ Imports -import Imm.Feed -import qualified Imm.Logger as Logger -import Imm.Logger hiding(Handle) -import Imm.Pretty --- }}} - --- * Types - -newtype Handle m = Handle - { processNewElement :: Feed -> FeedElement -> m () -- ^ Action triggered for each unread feed element - } - --- * Primitives - -onNewElement :: Monad m => Logger.Handle m -> Handle m -> Feed -> FeedElement -> m () -onNewElement logger handle feed element = do - log logger Debug $ "Unread element:" <+> pretty (getTitle element) - processNewElement handle feed element diff --git a/src/lib/Imm/Hooks/Dummy.hs b/src/lib/Imm/Hooks/Dummy.hs deleted file mode 100644 --- a/src/lib/Imm/Hooks/Dummy.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Implementation of "Imm.Hooks" that does nothing, --- except suggesting the user to define proper hooks. --- --- This is the default implementation of the program. -module Imm.Hooks.Dummy (module Imm.Hooks.Dummy, module Imm.Hooks) where - --- {{{ Imports -import Imm.Hooks - -import Control.Exception -import Control.Exception.Safe --- }}} - -data DummyHooks = DummyHooks - -mkHandle :: MonadThrow m => Handle m -mkHandle = Handle - { processNewElement = \_ _ -> throwM $ NoMethodError "Please define a valid Imm.Hooks.processNewElement function" - } diff --git a/src/lib/Imm/Hooks/SendMail.hs b/src/lib/Imm/Hooks/SendMail.hs deleted file mode 100644 --- a/src/lib/Imm/Hooks/SendMail.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} --- | Implementation of "Imm.Hooks" that sends a mail via a SMTP server for each new RSS/Atom element. --- You may want to check out "Network.HaskellNet.SMTP", "Network.HaskellNet.SMTP.SSL" and "Network.Mail.Mime" modules for additional information. --- --- Here is an example configuration: --- --- > sendmail :: SendMailSettings --- > sendmail = SendMailSettings smtpServer formatMail --- > --- > formatMail :: FormatMail --- > formatMail = FormatMail --- > (\a b -> (defaultFormatFrom a b) { addressEmail = "user@host" } ) --- > defaultFormatSubject --- > defaultFormatBody --- > (\_ _ -> [Address Nothing "user@host"]) --- > --- > smtpServer :: Feed -> FeedElement -> SMTPServer --- > smtpServer _ _ = SMTPServer --- > (Just $ Authentication PLAIN "user" "password") --- > (StartTls "smtp.server" defaultSettingsSMTPSTARTTLS) --- -module Imm.Hooks.SendMail (module Imm.Hooks.SendMail, module Imm.Hooks, module Reexport) where - --- {{{ Imports -import Imm.Feed -import Imm.Hooks -import Imm.Pretty - -import Data.Text as Text (intercalate) -import Data.Time -import Network.HaskellNet.SMTP as Reexport -import Network.HaskellNet.SMTP.SSL as Reexport -import Network.Mail.Mime as Reexport hiding (sendmail) -import Network.Socket -import Refined -import Text.Atom.Types -import Text.RSS.Types --- }}} - --- * Types - -type Username = String -type Password = String -type ServerName = String - --- | How to connect to the SMTP server -data ConnectionSettings = Plain ServerName PortNumber | Ssl ServerName Settings | StartTls ServerName Settings - deriving(Eq, Show) - --- | How to authenticate to the SMTP server -data Authentication = Authentication AuthType Username Password - deriving(Eq, Show) - -data SMTPServer = SMTPServer (Maybe Authentication) ConnectionSettings - deriving (Eq, Show) - --- | How to format outgoing mails from feed elements -data FormatMail = FormatMail - { formatFrom :: Feed -> FeedElement -> Address -- ^ How to write the From: header of feed mails - , formatSubject :: Feed -> FeedElement -> Text -- ^ How to write the Subject: header of feed mails - , formatBody :: Feed -> FeedElement -> Text -- ^ How to write the body of feed mails (sic!) - , formatTo :: Feed -> FeedElement -> [Address] -- ^ How to write the To: header of feed mails - } - -data SendMailSettings = SendMailSettings (Feed -> FeedElement -> SMTPServer) FormatMail - -mkHandle :: MonadBase IO m => SendMailSettings -> Handle m -mkHandle (SendMailSettings connectionSettings formatMail) = Handle - { processNewElement = \feed element -> do - timezone <- liftBase getCurrentTimeZone - currentTime <- liftBase getCurrentTime - let mail = buildMail formatMail currentTime timezone feed element - liftBase $ withSMTPConnection (connectionSettings feed element) $ sendMimeMail2 mail - } - - --- * Default behavior - --- | Fill 'addressName' with the feed title and, if available, the authors' names. --- --- This function leaves 'addressEmail' empty. You are expected to fill it adequately, because many SMTP servers enforce constraints on the From: email. -defaultFormatFrom :: Feed -> FeedElement -> Address -defaultFormatFrom (Rss doc) (RssElement item) = Address (Just $ channelTitle doc <> " (" <> itemAuthor item <> ")") "" -defaultFormatFrom (Atom feed) (AtomElement entry) = Address (Just $ title <> " (" <> authors <> ")") "" - where title = show . prettyAtomText $ feedTitle feed - authors = Text.intercalate ", " $ map (unrefine . personName) $ entryAuthors entry <> feedAuthors feed -defaultFormatFrom _ _ = Address (Just "Unknown") "" - --- | Fill mail subject with the element title -defaultFormatSubject :: Feed -> FeedElement -> Text -defaultFormatSubject _ = getTitle - --- | Fill mail body with: --- --- - a list of links associated to the element --- - the element's content or description/summary -defaultFormatBody :: Feed -> FeedElement -> Text -defaultFormatBody _ (RssElement item) = "

" <> maybe "" (withRssURI (show . prettyURI)) (itemLink item) <> "

" <> itemDescription item <> "

" -defaultFormatBody _ (AtomElement entry) = "

" <> Text.intercalate "
" links <> "

" <> fromMaybe "" (content <|> summary) <> "

" - where links = map (withAtomURI (show . prettyURI) . linkHref) $ entryLinks entry - content = show . prettyAtomContent <$> entryContent entry - summary = show . prettyAtomText <$> entrySummary entry - - --- * Low-level helpers - -authenticate_ :: SMTPConnection -> Authentication -> IO Bool -authenticate_ connection (Authentication t u p) = do - result <- authenticate t u p connection - unless result $ putStrLn "Authentication failed" - return result - -withSMTPConnection :: SMTPServer -> (SMTPConnection -> IO a) -> IO a -withSMTPConnection (SMTPServer authentication (Plain server port)) f = - doSMTPPort server port $ \connection -> do - forM_ authentication (authenticate_ connection) - f connection -withSMTPConnection (SMTPServer authentication (Ssl server settings)) f = - doSMTPSSLWithSettings server settings $ \connection -> do - forM_ authentication (authenticate_ connection) - f connection -withSMTPConnection (SMTPServer authentication (StartTls server settings)) f = - doSMTPSTARTTLSWithSettings server settings $ \connection -> do - forM_ authentication (authenticate_ connection) - f connection - --- | Build mail from a given feed -buildMail :: FormatMail -> UTCTime -> TimeZone -> Feed -> FeedElement -> Mail -buildMail format currentTime timeZone feed element = - let date = formatTime defaultTimeLocale "%a, %e %b %Y %T %z" $ utcToZonedTime timeZone $ fromMaybe currentTime $ getDate element - in Mail - { mailFrom = formatFrom format feed element - , mailTo = formatTo format feed element - , mailCc = [] - , mailBcc = [] - , mailHeaders = - [ ("Return-Path", "") - , ("Date", fromString date) - , ("Subject", formatSubject format feed element) - , ("Content-disposition", "inline") - ] - , mailParts = [[htmlPart $ fromStrict $ formatBody format feed element]] - } diff --git a/src/lib/Imm/Hooks/WriteFile.hs b/src/lib/Imm/Hooks/WriteFile.hs deleted file mode 100644 --- a/src/lib/Imm/Hooks/WriteFile.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} --- | Implementation of "Imm.Hooks" that writes a file for each new RSS/Atom item. -module Imm.Hooks.WriteFile (module Imm.Hooks.WriteFile, module Imm.Hooks) where - --- {{{ Imports -import Imm.Feed -import Imm.Hooks -import Imm.Pretty - -import Data.ByteString.Builder -import Data.ByteString.Streaming (toStreamingByteString) -import qualified Data.Text as Text (null, replace) -import Data.Time -import Streaming.With -import System.Directory (createDirectoryIfMissing) -import System.FilePath -import Text.Atom.Types -import Text.Blaze.Html.Renderer.Utf8 -import Text.Blaze.Html5 (Html, docTypeHtml, - preEscapedToHtml, (!)) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as H (charset, href) -import Text.RSS.Types -import URI.ByteString --- }}} - --- * Types - --- | Where and what to write in a file -data FileInfo = FileInfo FilePath Builder - -newtype WriteFileSettings = WriteFileSettings (Feed -> FeedElement -> FileInfo) - -mkHandle :: MonadBase IO m => MonadIO m => MonadMask m => WriteFileSettings -> Handle m -mkHandle (WriteFileSettings f) = Handle - { processNewElement = \feed element -> do - let FileInfo path content = f feed element - liftBase $ createDirectoryIfMissing True $ takeDirectory path - writeBinaryFile path $ toStreamingByteString content - } - --- * Default behavior - --- | Wrapper around 'defaultFilePath' and 'defaultFileContent' -defaultSettings :: FilePath -- ^ Root directory for 'defaultFilePath' - -> WriteFileSettings -defaultSettings root = WriteFileSettings $ \feed element -> FileInfo - (defaultFilePath root feed element) - (defaultFileContent feed element) - --- | Generate a path @//-.html@, where @@ is the first argument -defaultFilePath :: FilePath -> Feed -> FeedElement -> FilePath -defaultFilePath root feed element = makeValid $ root toString title fileName <.> "html" where - date = maybe "" (formatTime defaultTimeLocale "%F-") $ getDate element - fileName = date <> toString (sanitize $ getTitle element) - title = sanitize $ getFeedTitle feed - sanitize = appEndo (mconcat [Endo $ Text.replace (toText [s]) "_" | s <- pathSeparators]) - >>> Text.replace "." "_" - >>> Text.replace "?" "_" - >>> Text.replace "!" "_" - >>> Text.replace "#" "_" - --- | Generate an HTML page, with a title, a header and an article that contains the feed element -defaultFileContent :: Feed -> FeedElement -> Builder -defaultFileContent feed element = renderHtmlBuilder $ docTypeHtml $ do - H.head $ do - H.meta ! H.charset "utf-8" - H.title $ convertText $ getFeedTitle feed <> " | " <> getTitle element - H.body $ do - H.h1 $ convertText $ getFeedTitle feed - H.article $ do - H.header $ do - defaultArticleTitle feed element - defaultArticleAuthor feed element - defaultArticleDate feed element - defaultBody feed element - - --- * Low-level helpers - -defaultArticleTitle :: Feed -> FeedElement -> Html -defaultArticleTitle _ element@(RssElement item) = H.h2 $ maybe id (\uri -> H.a ! H.href uri) link $ convertText $ getTitle element where - link = withRssURI (convertDoc . prettyURI) <$> itemLink item -defaultArticleTitle _ element@(AtomElement _) = H.h2 $ convertText $ getTitle element - -defaultArticleAuthor :: Feed -> FeedElement -> Html -defaultArticleAuthor _ (RssElement item) = unless (Text.null author) $ H.address $ "Published by " >> convertText author where - author = itemAuthor item -defaultArticleAuthor _ (AtomElement entry) = H.address $ do - "Published by " - forM_ (entryAuthors entry) $ \author -> do - convertDoc $ prettyPerson author - ", " - -defaultArticleDate :: Feed -> FeedElement -> Html -defaultArticleDate _ element = forM_ (getDate element) $ \date -> H.p $ " on " >> H.time (convertDoc $ prettyTime date) - - --- | Generate the HTML content for a given feed element -defaultBody :: Feed -> FeedElement -> Html -defaultBody _ element@(RssElement _) = H.p $ preEscapedToHtml $ getContent element -defaultBody _ element@(AtomElement entry) = do - unless (null links) $ H.p $ do - "Related links:" - H.ul $ forM_ links $ \uri -> H.li (H.a ! withAtomURI href uri $ convertAtomURI uri) - H.p $ preEscapedToHtml $ getContent element - where links = map linkHref $ entryLinks entry - -href :: URIRef a -> H.Attribute -href = H.href . convertURI - -convertAtomURI :: (IsString t) => AtomURI -> t -convertAtomURI = withAtomURI convertURI - -convertURI :: (IsString t) => URIRef a -> t -convertURI = convertText . decodeUtf8 . serializeURIRef' - -convertText :: (IsString t) => Text -> t -convertText = fromString . toString - -convertDoc :: (IsString t) => Doc a -> t -convertDoc = show diff --git a/src/lib/Imm/Logger/Simple.hs b/src/lib/Imm/Logger/Simple.hs deleted file mode 100644 --- a/src/lib/Imm/Logger/Simple.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} --- | Implementation of "Imm.Logger" based on @fast-logger@. --- For further information, please consult "System.Log.FastLogger". -module Imm.Logger.Simple (module Imm.Logger.Simple, module Reexport) where - --- {{{ Imports -import Imm.Logger as Reexport -import Imm.Pretty - -import Data.Text.Prettyprint.Doc.Render.Terminal -import System.Log.FastLogger as Reexport --- }}} - -data LoggerSettings = LoggerSettings - { _loggerSet :: LoggerSet -- ^ 'LoggerSet' used for 'Debug', 'Info' and 'Warning' logs - , _errorLoggerSet :: LoggerSet -- ^ 'LoggerSet' used for 'Error' logs - , _logLevel :: MVar LogLevel -- ^ Discard logs that are strictly less serious than this level - , _colorizeLogs :: MVar Bool -- ^ Enable log colorisation - } - - --- | Default logger forwards error messages to stderr, and other messages to stdout. -defaultLogger :: IO LoggerSettings -defaultLogger = LoggerSettings - <$> newStdoutLoggerSet defaultBufSize - <*> newStderrLoggerSet defaultBufSize - <*> newMVar Info - <*> newMVar True - - -mkHandle :: MonadIO m => LoggerSettings -> Handle m -mkHandle settings = Handle - { log = \l t -> do - refLevel <- readMVar $ _logLevel settings - handleColor <- (\c -> if c then id else unAnnotate) <$> readMVar (_colorizeLogs settings) - let loggerSet = (if l == Error then _errorLoggerSet else _loggerSet) settings - when (l >= refLevel) $ liftIO $ pushLogStrLn loggerSet $ toLogStr $ renderLazy $ layoutPretty defaultLayoutOptions $ handleColor t - - , getLogLevel = readMVar $ _logLevel settings - , setLogLevel = void . swapMVar (_logLevel settings) - , setColorizeLogs = void . swapMVar (_colorizeLogs settings) - , flushLogs = liftIO $ do - flushLogStr $ _loggerSet settings - flushLogStr $ _errorLoggerSet settings - } diff --git a/src/lib/Imm/Options.hs b/src/lib/Imm/Options.hs deleted file mode 100644 --- a/src/lib/Imm/Options.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -module Imm.Options where - --- {{{ Imports -import Imm.Dyre as Dyre (Mode (..)) -import qualified Imm.Dyre as Dyre -import Imm.Feed -import Imm.Logger as Logger -import Imm.Pretty - -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as Text -import Options.Applicative -import Options.Applicative.Help.Core as Help -import Options.Applicative.Help.Types -import URI.ByteString --- }}} - --- | Available commands. -data Command = Check (Maybe FeedRef) - | Import - | Read (Maybe FeedRef) - | Rebuild - | Unread (Maybe FeedRef) - | Run (Maybe FeedRef) - | Show (Maybe FeedRef) - | Help - | ShowVersion - | Subscribe URI (Set Text) - | Unsubscribe (Maybe FeedRef) - -deriving instance Eq Command -deriving instance Show Command - -instance Pretty Command where - pretty (Check f) = "Check feed(s):" <+> pretty f - pretty Import = "Import feeds" - pretty (Read f) = "Mark feed(s) as read:" <+> pretty f - pretty Rebuild = "Rebuild configuration" - pretty (Unread f) = "Mark feed(s) as unread:" <+> pretty f - pretty (Run f) = "Download new entries from feed(s):" <+> pretty f - pretty (Show f) = "Show status for feed(s):" <+> pretty f - pretty Help = "Display help" - pretty ShowVersion = "Show program version" - pretty (Subscribe f _) = "Subscribe to feed:" <+> prettyURI f - pretty (Unsubscribe f) = "Unsubscribe from feed(s):" <+> pretty f - -defaultCommand :: Command -defaultCommand = Show Nothing - --- | Available commandline options. -data CliOptions = CliOptions - { optionCommand :: Command - , optionDyreMode :: Dyre.Mode - , optionLogLevel :: LogLevel - , optionColorizeLogs :: Bool - } - --- deriving instance Eq CliOptions -defaultOptions :: CliOptions -defaultOptions = CliOptions defaultCommand Dyre.defaultMode Info True - --- instance Pretty CliOptions where --- pretty opts = text "ACTION" <> equals <> $ opts^.command_ --- , ("RECONFIGURATION_MODE=" ++) . show $ opts^.dyreMode_ --- ] --- ++ catMaybes [("CONFIG=" ++) <$> opts^.configurationLabel_] - -helpString :: Text -helpString = Text.pack $ renderHelp 100 $ Help.parserHelp defaultPrefs optionsParser - -parseOptions :: (MonadIO m) => m CliOptions -parseOptions = io $ customExecParser defaultPrefs (info optionsParser $ progDesc "Fetch elements from RSS/Atom feeds and execute arbitrary actions for each of them.") - - -optionsParser :: Parser CliOptions -optionsParser = optional dyreMasterBinary *> optional dyreDebug *> cliOptions - -cliOptions :: Parser CliOptions -cliOptions = CliOptions - <$> commands - <*> (vanillaFlag <|> forceReconfFlag <|> denyReconfFlag <|> pure Dyre.defaultMode) - <*> (verboseFlag <|> quietFlag <|> logLevel <|> pure Info) - <*> (colorizeLogs <|> pure True) - - -commands :: Parser Command -commands = subparser $ mconcat - [ command "add" $ info subscribeOptions $ progDesc "Alias for subscribe." - , command "check" $ info (Check <$> optional feedRefOption) $ progDesc "Check availability and validity of all feed sources currently configured, without writing any mail." - , command "help" $ info (pure Help) $ progDesc "Display help" - , command "import" $ info (pure Import) $ progDesc "Import feeds list from an OPML descriptor (read from stdin)." - , command "read" $ info (Read <$> optional feedRefOption) $ progDesc "Mark given feed as read." - , command "rebuild" $ info (pure Rebuild) $ progDesc "Rebuild configuration file." - , command "remove" $ info unsubscribeOptions $ progDesc "Alias for unsubscribe." - , command "run" $ info (Run <$> optional feedRefOption) $ progDesc "Update list of feeds." - , command "show" $ info (Show <$> optional feedRefOption) $ progDesc "List all feed sources currently configured, along with their status." - , command "subscribe" $ info subscribeOptions $ progDesc "Subscribe to a feed." - , command "unread" $ info (Unread <$> optional feedRefOption) $ progDesc "Mark given feed as unread." - , command "unsubscribe" $ info unsubscribeOptions $ progDesc "Unsubscribe from a feed." - , command "version" $ info (pure ShowVersion) $ progDesc "Print version." - ] - - --- {{{ Dynamic reconfiguration options -vanillaFlag, forceReconfFlag, denyReconfFlag :: Parser Dyre.Mode -vanillaFlag = flag' Vanilla $ long "vanilla" <> short '1' <> help "Ignore custom configuration file." -forceReconfFlag = flag' ForceReconfiguration $ long "force-reconf" <> help "Recompile configuration file before starting the application." -denyReconfFlag = flag' IgnoreReconfiguration $ long "deny-reconf" <> help "Do not recompile configuration file even if it has changed." - -dyreDebug :: Parser Bool -dyreDebug = switch $ long "dyre-debug" <> help "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program." - -dyreMasterBinary :: Parser String -dyreMasterBinary = strOption $ long "dyre-master-binary" <> metavar "PATH" <> hidden <> internal <> help "Internal flag used for dynamic reconfiguration." --- }}} - --- {{{ Log options -verboseFlag, quietFlag, logLevel :: Parser LogLevel -verboseFlag = flag' Logger.Debug $ long "verbose" <> short 'v' <> help "Set log level to DEBUG." -quietFlag = flag' Logger.Error $ long "quiet" <> short 'q' <> help "Set log level to ERROR." -logLevel = option auto $ long "log-level" <> short 'l' <> metavar "LOG-LEVEL" <> value Info <> completeWith ["Debug", "Info", "Warning", "Error"] <> help "Set log level. Available values: Debug, Info, Warning, Error." - -colorizeLogs :: Parser Bool -colorizeLogs = flag' False $ long "nocolor" <> help "Disable log colorisation." --- }}} - --- {{{ Other options -tagOption :: Parser Text -tagOption = option auto $ long "tag" <> short 't' <> metavar "TAG" <> help "Set the given tag." - -subscribeOptions, unsubscribeOptions :: Parser Command -subscribeOptions = Subscribe <$> uriArgument "URI to subscribe to." <*> (Set.fromList <$> many tagOption) -unsubscribeOptions = Unsubscribe <$> optional feedRefOption --- }}} - --- {{{ Util -uriReader :: ReadM URI -uriReader = eitherReader $ first show . parseURI laxURIParserOptions . encodeUtf8 @Text . fromString - -feedRefOption :: Parser FeedRef -feedRefOption = argument ((ByUID <$> auto) <|> (ByURI <$> uriReader)) $ metavar "TARGET" - -uriArgument :: String -> Parser URI -uriArgument helpText = argument uriReader $ metavar "URI" <> help helpText --- }}} diff --git a/src/lib/Imm/Pretty.hs b/src/lib/Imm/Pretty.hs --- a/src/lib/Imm/Pretty.hs +++ b/src/lib/Imm/Pretty.hs @@ -5,10 +5,11 @@ module Imm.Pretty (module Imm.Pretty, module X) where -- {{{ Imports -import Data.Text as Text +import Data.Text (Text) +import qualified Data.Text as Text import Data.Time import Data.Tree - +import Data.XML.Types as XML import Text.Atom.Types as Atom -- import Text.OPML.Types as OPML hiding (text) -- import qualified Text.OPML.Types as OPML @@ -23,6 +24,10 @@ import URI.ByteString -- }}} + +-- | Newtype wrapper to prettyprint a key uniquely identifying an object +newtype PrettyKey a = PrettyKey a + -- | Infix operator for 'line' (<++>) :: Doc a -> Doc a -> Doc a x <++> y = x <> line <> y @@ -31,7 +36,7 @@ prettyTree (Node n s) = pretty n <++> indent 2 (vsep $ prettyTree <$> s) prettyTime :: UTCTime -> Doc a -prettyTime = pretty . formatTime defaultTimeLocale rfc822DateFormat +prettyTime = pretty . formatTime defaultTimeLocale "%F %T" -- instance Pretty OpmlHead where -- pretty h = hsep $ catMaybes @@ -69,9 +74,23 @@ prettyLink l = withAtomURI prettyURI $ linkHref l prettyAtomText :: AtomText -> Doc a -prettyAtomText (AtomPlainText _ t) = pretty t -prettyAtomText (AtomXHTMLText t) = pretty t +prettyAtomText (AtomPlainText _ t) = pretty t +prettyAtomText (AtomXHTMLText element) = prettyElement element +prettyElement :: Element -> Doc a +prettyElement (Element _ _ nodes) = mconcat $ map prettyNode nodes + +prettyNode :: Node -> Doc a +prettyNode (NodeElement element) = prettyElement element +prettyNode (NodeContent content) = prettyContent content +prettyNode _ = mempty + +prettyContent :: Content -> Doc a +prettyContent (ContentText t) = pretty t +prettyContent (ContentEntity "lt") = "<" +prettyContent (ContentEntity "gt") = ">" +prettyContent _ = "?" + prettyEntry :: AtomEntry -> Doc a prettyEntry e = "Entry:" <+> prettyAtomText (entryTitle e) <++> indent 4 ( "By" <+> equals <+> list (prettyPerson <$> entryAuthors e) @@ -95,10 +114,10 @@ prettyGuid (GuidUri (RssURI u)) = prettyURI u prettyAtomContent :: AtomContent -> Doc a -prettyAtomContent (AtomContentInlineText _ t) = pretty t -prettyAtomContent (AtomContentInlineXHTML t) = pretty t -prettyAtomContent (AtomContentInlineOther _ t) = pretty t -prettyAtomContent (AtomContentOutOfLine _ u) = withAtomURI prettyURI u +prettyAtomContent (AtomContentInlineText _ t) = pretty t +prettyAtomContent (AtomContentInlineXHTML element) = prettyElement element +prettyAtomContent (AtomContentInlineOther _ t) = pretty t +prettyAtomContent (AtomContentOutOfLine _ u) = withAtomURI prettyURI u magenta :: Doc AnsiStyle -> Doc AnsiStyle magenta = annotate $ color Magenta diff --git a/src/lib/Imm/XML/Conduit.hs b/src/lib/Imm/XML/Conduit.hs deleted file mode 100644 --- a/src/lib/Imm/XML/Conduit.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} --- | Implementation of "Imm.XML" based on 'Conduit'. -module Imm.XML.Conduit (module Imm.XML.Conduit, module Imm.XML) where - --- {{{ Imports -import Imm.Feed -import Imm.XML - -import Control.Exception.Safe -import Data.Conduit -import Data.XML.Types -import Text.Atom.Conduit.Parse -import Text.RSS.Conduit.Parse -import Text.RSS1.Conduit.Parse -import Text.XML.Stream.Parse as XML -import URI.ByteString --- }}} - --- | A pre-process 'Conduit' can be set to alter the raw XML before feeding it to the parser, --- depending on the feed 'URI' -newtype XmlParser = XmlParser (forall m . Monad m => URI -> ConduitT Event Event m ()) - --- | 'Conduit' based implementation -mkHandle :: MonadIO m => MonadCatch m => XmlParser -> Handle m -mkHandle (XmlParser preProcess) = Handle - { parseXml = \uri bytestring -> liftIO $ runConduit $ parseLBS def bytestring .| preProcess uri .| XML.force "Invalid feed" ((fmap Atom <$> atomFeed) `orE` (fmap Rss <$> rssDocument) `orE` (fmap Rss <$> rss1Document)) - } - --- | Forward all 'Event's without any pre-process -defaultXmlParser :: XmlParser -defaultXmlParser = XmlParser $ const $ fix $ \loop -> await >>= maybe (return ()) (yield >=> const loop) diff --git a/src/lib/Prelude.hs b/src/lib/Prelude.hs --- a/src/lib/Prelude.hs +++ b/src/lib/Prelude.hs @@ -1,8 +1,7 @@ -module Prelude (io, module Relude, module Relude.Extra.Map, module Control.Monad.Base) where +module Prelude (io, module Relude, module Relude.Extra.Map) where import Relude hiding(Handle, force) import Relude.Extra.Map (lookup) -import Control.Monad.Base io :: MonadIO m => IO a -> m a io = liftIO diff --git a/src/main/Core.hs b/src/main/Core.hs new file mode 100644 --- /dev/null +++ b/src/main/Core.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TypeFamilies #-} +module Core ( +-- * Types + FeedRef, +-- * Actions + subscribe, + listFeeds, + showFeed, + importOPML, +) where + +-- {{{ Imports +import qualified Imm.Database as Database +import Imm.Database.FeedTable +import qualified Imm.Database.FeedTable as Database +import Imm.Feed +import Imm.Logger as Logger +import Imm.Pretty + +import Control.Exception.Safe +import Data.Conduit +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Tree +import Refined +import Text.OPML.Conduit.Parse +import Text.OPML.Types as OPML +import Text.XML as XML () +import Text.XML.Stream.Parse as XML +import URI.ByteString +-- }}} + + + +-- | Print database status for given feed(s) +showFeed :: MonadThrow m => Logger.Handle m -> Database.Handle m FeedTable -> FeedID -> m () +showFeed logger database feedID = do + entry <- Database.fetch database feedID + flushLogs logger + log logger Info $ prettyDatabaseEntry entry + +-- | Register the given feed URI in database +subscribe :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> URI -> Set Text -> m () +subscribe logger database uri = Database.register logger database (FeedID uri) + +-- | List all subscribed feeds and their status +listFeeds :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> m () +listFeeds logger database = do + entries <- Database.fetchAll database + flushLogs logger + when (null entries) $ log logger Warning "No subscription" + forM_ (zip [1..] $ Map.elems entries) $ \(i, entry) -> + log logger Info $ pretty (i :: Int) <+> prettyShortDatabaseEntry entry + + +-- | 'subscribe' to all feeds described by the OPML document provided in input +importOPML :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> ConduitT () ByteString m () -> m () +importOPML logger database input = do + opml <- runConduit $ input .| XML.parseBytes def .| force "Invalid OPML" parseOpml + forM_ (opmlOutlines opml) $ importOPML' logger database mempty + +importOPML' :: MonadCatch m => Logger.Handle m -> Database.Handle m FeedTable -> Set Text -> Tree OpmlOutline -> m () +importOPML' logger database _ (Node (OpmlOutlineGeneric b _) sub) = mapM_ (importOPML' logger database (Set.singleton . unrefine $ OPML.text b)) sub +importOPML' logger database c (Node (OpmlOutlineSubscription _ s) _) = subscribe logger database (xmlUri s) c +importOPML' _ _ _ _ = return () diff --git a/src/main/Database.hs b/src/main/Database.hs new file mode 100644 --- /dev/null +++ b/src/main/Database.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +-- | Implementation of "Imm.Database" based on a JSON file. +module Database + ( JsonFileDatabase + , mkJsonFileDatabase + , defaultDatabase + , mkHandle + , JsonException(..) + , module Imm.Database.FeedTable + ) where + +-- {{{ Imports +import Imm.Database hiding (commit, delete, insert, + purge, update) +import Imm.Database.FeedTable +import Imm.Pretty + +import Control.Concurrent.STM.TVar (swapTVar) +import Control.Exception.Safe +import Data.Aeson +import Data.ByteString.Lazy (hPut) +import Data.ByteString.Streaming (hGetContents, toLazy_) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Streaming.With hiding (withFile) +import System.Directory +import System.FilePath +-- }}} + +data CacheStatus = Empty | Clean | Dirty + deriving(Eq, Ord, Read, Show) + +data JsonFileDatabase t = JsonFileDatabase FilePath (Map (Key t) (Entry t)) CacheStatus + +instance Pretty (JsonFileDatabase t) where + pretty (JsonFileDatabase file _ _) = "JSON database: " <+> pretty file + +mkJsonFileDatabase :: (Table t) => FilePath -> JsonFileDatabase t +mkJsonFileDatabase file = JsonFileDatabase file mempty Empty + +-- | Default database is stored in @$XDG_CONFIG_HOME\/imm\/feeds.json@ +defaultDatabase :: Table t => IO (TVar (JsonFileDatabase t)) +defaultDatabase = do + databaseFile <- getXdgDirectory XdgConfig "imm/feeds.json" + newTVarIO $ mkJsonFileDatabase databaseFile + + +data JsonException = UnableDecode + deriving(Eq, Show) + +instance Exception JsonException where + displayException _ = "Unable to parse JSON" + + +mkHandle :: (Table t, FromJSON (Key t), FromJSON (Entry t), ToJSON (Key t), ToJSON (Entry t), MonadIO m, MonadMask m) + => TVar (JsonFileDatabase t) -> Handle m t +mkHandle tvar = Handle + { _describeDatabase = pretty <$> readTVarIO tvar + , _fetchList = \keys -> loadInCache tvar >> (Map.filterWithKey (\uri _ -> Set.member uri $ Set.fromList keys) <$> getCache tvar) + , _fetchAll = loadInCache tvar >> getCache tvar + , _update = \key f -> loadInCache tvar >> atomically (modifyTVar' tvar $ updateInCache key f) + , _insertList = \list -> loadInCache tvar >> atomically (modifyTVar' tvar $ insertInCache list) + , _deleteList = \list -> loadInCache tvar >> atomically (modifyTVar' tvar $ deleteInCache list) + , _purge = loadInCache tvar >> atomically (modifyTVar' tvar purgeInCache) + , _commit = commit tvar + } + +-- * Low-level implementation + +loadInCache :: (Table t, FromJSON (Key t), FromJSON (Entry t), MonadIO m, MonadMask m) => TVar (JsonFileDatabase t) -> m () +loadInCache tvar = do + JsonFileDatabase file _ status <- readTVarIO tvar + when (status == Empty) $ do + database <- loadFromDisk file + atomically $ do + JsonFileDatabase _ _ status' <- readTVar tvar + when (status' == Empty) $ writeTVar tvar database + +loadFromDisk :: (Table t, FromJSON (Key t), FromJSON (Entry t), MonadIO m, MonadMask m) => FilePath -> m (JsonFileDatabase t) +loadFromDisk file = do + liftIO $ createDirectoryIfMissing True $ takeDirectory file + fileContent <- withBinaryFile file ReadWriteMode (toLazy_ . hGetContents) + cache <- (`failWith` UnableDecode) $ fmap Map.fromList $ decode $ fromEmpty "[]" fileContent + return $ JsonFileDatabase file cache Clean + where fromEmpty x "" = x + fromEmpty _ y = y + +getCache :: MonadIO m => TVar (JsonFileDatabase t) -> m (Map (Key t) (Entry t)) +getCache tvar = do + JsonFileDatabase _ cache _ <- readTVarIO tvar + return cache + + +insertInCache :: Table t => [(Key t, Entry t)] -> JsonFileDatabase t -> JsonFileDatabase t +insertInCache rows (JsonFileDatabase file cache _) = JsonFileDatabase file (Map.union cache $ Map.fromList rows) Dirty + +updateInCache :: Table t => Key t -> (Entry t -> Entry t) -> JsonFileDatabase t -> JsonFileDatabase t +updateInCache key f (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where + newCache = Map.update (Just . f) key cache + +deleteInCache :: Table t => [Key t] -> JsonFileDatabase t -> JsonFileDatabase t +deleteInCache keys (JsonFileDatabase file cache _) = JsonFileDatabase file newCache Dirty where + newCache = foldr Map.delete cache keys + +purgeInCache :: Table t => JsonFileDatabase t -> JsonFileDatabase t +purgeInCache (JsonFileDatabase file _ _) = JsonFileDatabase file mempty Dirty + +commit :: (ToJSON (Key t), ToJSON (Entry t), MonadIO m) + => TVar (JsonFileDatabase t) -> m () +commit tvar = do + JsonFileDatabase file cache status <- atomically $ do + database@(JsonFileDatabase file cache status) <- readTVar tvar + when (status == Dirty) $ void $ swapTVar tvar $ JsonFileDatabase file cache Clean + return database + + when (status == Dirty) $ liftIO $ withFile file WriteMode $ \h -> hPut h $ encode $ Map.toList cache + + +-- | Wrap a 'Maybe' value in 'MonadThrow' +failWith :: (MonadThrow m, Exception e) => Maybe a -> e -> m a +failWith x e = maybe (throwM e) return x diff --git a/src/main/HTTP.hs b/src/main/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/main/HTTP.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Implementation of "Imm.HTTP" based on "Network.HTTP.Client". +module HTTP (mkHandle, defaultManager, module Reexport) where + +-- {{{ Imports +import Imm.HTTP +import Imm.Pretty + +import Control.Exception.Safe +import Data.CaseInsensitive +import Network.Connection as Reexport +import Network.HTTP.Client as Reexport +import Network.HTTP.Client.TLS as Reexport +import URI.ByteString +-- }}} + +mkHandle :: MonadIO m => Manager -> Handle m +mkHandle manager = Handle + { httpGet = io . httpGet' manager + } + +-- | Default manager uses TLS and no proxy +defaultManager :: IO Manager +defaultManager = newManager $ mkManagerSettings (TLSSettingsSimple False False False) Nothing + + +-- | Perform an HTTP GET request and return the response body +httpGet' :: Manager -> URI -> IO LByteString +httpGet' manager uri = do + request <- makeRequest uri + responseBody <$> httpLbs request manager + -- codec' <- reader $ view (config.codec) + -- return $ response $=+ decode codec' + +parseRequest' :: MonadThrow m => URI -> m Request +parseRequest' = parseRequest . show . prettyURI + +-- | Build an HTTP request for given URI +makeRequest :: URI -> IO Request +makeRequest uri = do + req <- parseRequest' uri + return $ req { requestHeaders = [ + (mk "User-Agent", "Mozilla/4.0"), + (mk "Accept", "*/*")]} diff --git a/src/main/Logger.hs b/src/main/Logger.hs new file mode 100644 --- /dev/null +++ b/src/main/Logger.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Implementation of "Imm.Logger" based on @fast-logger@. +-- For further information, please consult "System.Log.FastLogger". +module Logger (module Logger, module Reexport) where + +-- {{{ Imports +import Imm.Logger as Reexport +import Imm.Pretty + +import Data.Text.Prettyprint.Doc.Render.Terminal +import System.Log.FastLogger as Reexport +-- }}} + +data LoggerSettings = LoggerSettings + { _loggerSet :: LoggerSet -- ^ 'LoggerSet' used for 'Debug', 'Info' and 'Warning' logs + , _errorLoggerSet :: LoggerSet -- ^ 'LoggerSet' used for 'Error' logs + , _logLevel :: MVar LogLevel -- ^ Discard logs that are strictly less serious than this level + , _colorizeLogs :: MVar Bool -- ^ Enable log colorisation + } + + +-- | Default logger forwards error messages to stderr, and other messages to stdout. +defaultLogger :: IO LoggerSettings +defaultLogger = LoggerSettings + <$> newStdoutLoggerSet defaultBufSize + <*> newStderrLoggerSet defaultBufSize + <*> newMVar Info + <*> newMVar True + + +mkHandle :: MonadIO m => LoggerSettings -> Handle m +mkHandle settings = Handle + { log = \l t -> do + refLevel <- readMVar $ _logLevel settings + handleColor <- do + keepColor <- readMVar (_colorizeLogs settings) + case (l, keepColor) of + (_, False) -> return unAnnotate + (Error, _) -> return red + (Warning, _) -> return yellow + _ -> return id + let loggerSet = (if l == Error then _errorLoggerSet else _loggerSet) settings + when (l >= refLevel) $ liftIO $ pushLogStrLn loggerSet $ toLogStr $ renderLazy $ layoutPretty defaultLayoutOptions $ handleColor t + + , getLogLevel = readMVar $ _logLevel settings + , setLogLevel = void . swapMVar (_logLevel settings) + , setColorizeLogs = void . swapMVar (_colorizeLogs settings) + , flushLogs = liftIO $ do + flushLogStr $ _loggerSet settings + flushLogStr $ _errorLoggerSet settings + } diff --git a/src/main/Main.hs b/src/main/Main.hs new file mode 100644 --- /dev/null +++ b/src/main/Main.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +-- {{{ Imports +import Imm +import Imm.Database as Database +import qualified Imm.HTTP as HTTP +import Imm.Pretty + +import qualified Core +import Database +import HTTP +import Logger +import Options +import XML + +import Control.Concurrent.Async +import Control.Concurrent.STM.TMChan +import Control.Exception.Safe +import Data.Aeson hiding (Error) +import Data.Conduit.Combinators as Conduit (stdin) +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Dhall +import Relude.Unsafe (at) +import System.Exit +import System.IO (hFlush) +import System.Process.Typed +-- }}} + + +main :: IO () +main = do + AllOptions{..} <- parseOptions + let GlobalOptions{..} = optionGlobal + + -- Setup logger + logger <- Logger.mkHandle <$> defaultLogger + setColorizeLogs logger optionColorizeLogs + setLogLevel logger optionLogLevel + log logger Debug $ "Options: " <> pretty optionCommand + + handleAny (log logger Error . pretty . displayException) $ do + -- Setup database + database <- Database.mkHandle <$> defaultDatabase + let database' = if optionReadOnlyDatabase then readOnly logger database else database + log logger Debug . ("Using database:" <++>) . indent 2 =<< _describeDatabase database' + + case optionCommand of + Import -> Core.importOPML logger database' Conduit.stdin + Subscribe u c -> Core.subscribe logger database' u c + List -> Core.listFeeds logger database' + ShowFeed feedRef -> Core.showFeed logger database =<< toFeedID database' feedRef + OnFeedRef t c -> main2 logger database' optionCallbacksFile t c + + Database.commit logger database' + + flushLogs logger + + +main2 :: Logger.Handle IO -> Database.Handle IO FeedTable -> FilePath -> Maybe FeedRef -> CommandOnFeedRef -> IO () +main2 logger database callbacksFile feedRef command = do + feedIDs <- resolveTarget database ByPassConfirmation feedRef + + case command of + Unsubscribe -> Database.deleteList logger database feedIDs + Reset -> mapM_ (Database.markAsUnprocessed logger database) feedIDs + Run callbackMode -> do + callbacks <- case callbackMode of + EnableCallbacks -> input auto $ fromString callbacksFile + _ -> return [] + main3 logger database callbacks feedIDs + + +main3 :: Logger.Handle IO -> Database.Handle IO FeedTable -> [Callback] -> [FeedID] -> IO () +main3 logger database callbacks feedIDs = do + httpClient <- HTTP.mkHandle <$> defaultManager + + targetFeedChan <- newTMChanIO + newItemsChan <- newTMChanIO + processedChan <- newTMChanIO + fetchErrorsChan <- newTMChanIO + callbackErrorsChan <- newTMChanIO + + newItemsCount <- newTVarIO (0 :: Int) + errorsCount <- newTVarIO (0 :: Int) + + -- => Feed IDs events + producer <- async $ forM_ feedIDs $ atomically . writeTMChan targetFeedChan + + -- Feed IDs events => new item events + fetchers <- replicateM 5 $ async $ fix $ \recurse -> do + target <- atomically $ readTMChan targetFeedChan + forM_ target $ \feedID@(FeedID uri) -> do + catchAny + (do + feed <- HTTP.get logger httpClient uri >>= parseXml xmlParser uri + + unreadElements <- filterM (fmap not . isRead database feedID) $ getElements feed + forM_ unreadElements $ \element -> do + log logger Info $ "New item:" <+> magenta (pretty feedID) <+> "/" <+> yellow (pretty $ getTitle element) + atomically $ do + writeTMChan newItemsChan (feedID, removeElements feed, element) + count <- readTVar newItemsCount + writeTVar newItemsCount (count + 1) ) + + (\e -> atomically $ do + writeTMChan fetchErrorsChan (feedID, e) + count <- readTVar errorsCount + writeTVar errorsCount (count + 1) ) + + recurse + + -- New items events => execute callback => processed/error events + runners <- replicateM 5 $ async $ fix $ \recurse -> do + newItem <- atomically $ readTMChan newItemsChan + forM_ newItem $ \(feedID, feed, element) -> do + results <- forM callbacks $ \callback@(Callback executable arguments) -> do + let processInput = byteStringInput $ encode $ Message feed element + processConfig = proc executable (map toString arguments) & setStdin processInput + + log logger Debug $ "Running" <+> cyan (pretty executable) <+> "on" <+> magenta (pretty feedID) <+> "/" <+> yellow (pretty $ getTitle element) + + (exitCode, output, errors) <- readProcess processConfig + case exitCode of + ExitSuccess -> return $ Right callback + ExitFailure i -> return $ Left (callback, i, output, errors) + + case lefts results of + [] -> atomically $ writeTMChan processedChan (feedID, element) + e -> atomically $ do + writeTMChan callbackErrorsChan (feedID, element, e) + count <- readTVar errorsCount + writeTVar errorsCount (count + 1) + + recurse + + -- Processed events => update database + storer <- async $ fix $ \recurse -> do + item <- atomically $ readTMChan processedChan + forM_ item $ \(feedID, element) -> do + log logger Debug $ "Updating database for" <+> pretty feedID <+> "/" <+> pretty (getTitle element) + Database.markAsProcessed logger database feedID element + recurse + + -- Wait for all async processes to complete + wait producer + atomically $ closeTMChan targetFeedChan + + mapM_ wait fetchers + atomically $ closeTMChan newItemsChan + + mapM_ wait runners + atomically $ do + closeTMChan processedChan + closeTMChan fetchErrorsChan + closeTMChan callbackErrorsChan + + wait storer + + -- Error events => log + printErrors logger fetchErrorsChan callbackErrorsChan + flushLogs logger + + readTVarIO newItemsCount <&> pretty <&> bold <&> (<+> "new items") >>= log logger Info + readTVarIO errorsCount <&> pretty <&> bold <&> (<+> "errors") >>= log logger Info + +printErrors :: (MonadIO m, Exception e, Pretty a1, Pretty a2, Pretty a3, Pretty a4, ConvertUtf8 Text b1, ConvertUtf8 Text b2) + => Logger.Handle m -> TMChan (a1, e) -> TMChan (a2, FeedElement, [(a3, a4, b1, b2)]) -> m () +printErrors logger fetchErrorsChan callbackErrorsChan = do + fix $ \recurse -> do + items <- atomically $ readTMChan fetchErrorsChan + forM_ items $ \(feedID, e) -> do + log logger Error $ bold ("Fetch error for" <+> pretty feedID) <++> indent 2 (pretty $ displayException e) + recurse + + fix $ \recurse -> do + items <- atomically $ readTMChan callbackErrorsChan + forM_ items $ \(feedID, element, errors) -> do + let prettyErrors = vsep $ do + (callback, i, stdout', stderr') <- errors + return $ "When running:" <+> pretty callback + <++> "Exit code:" <+> pretty i + <++> "Stdout:" <++> indent 2 (pretty $ decodeUtf8 @Text stdout') + <++> "Stderr:" <++> indent 2 (pretty $ decodeUtf8 @Text stderr') + log logger Error $ bold ("Callback error for" <+> pretty feedID <+> "/" <+> pretty (getTitle element)) <++> indent 2 prettyErrors + recurse + + +xmlParser :: XML.Handle IO +xmlParser = XML.mkHandle defaultXmlParser + + +-- * Util + +data SafeGuard = AskConfirmation | ByPassConfirmation + deriving(Eq, Read, Show) + +data InterruptedException = InterruptedException deriving(Eq, Read, Show) +instance Exception InterruptedException where + displayException _ = "Process interrupted" + +promptConfirm :: Text -> IO () +promptConfirm s = do + Text.putStr $ s <> " Confirm [Y/n] " + hFlush stdout + x <- Text.getLine + unless (Text.null x || x == "Y") $ throwM InterruptedException + + +resolveTarget :: MonadIO m => MonadThrow m => Database.Handle m FeedTable -> SafeGuard -> Maybe FeedRef -> m [FeedID] +resolveTarget database s Nothing = do + result <- Map.keys <$> Database.fetchAll database + when (s == AskConfirmation) $ liftIO $ promptConfirm $ "This will affect " <> show (length result) <> " feeds." + return result +resolveTarget database _ (Just feedRef) = do + result <- toFeedID database feedRef + return [result] + +toFeedID :: Monad m => Database.Handle m FeedTable -> FeedRef -> m FeedID +toFeedID database (ByUID i) = fst . at (i-1) . Map.toList <$> Database.fetchAll database +toFeedID _ (ByURI uri) = return $ FeedID uri diff --git a/src/main/Options.hs b/src/main/Options.hs new file mode 100644 --- /dev/null +++ b/src/main/Options.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +module Options where + +-- {{{ Imports +import Imm.Feed +import Imm.Logger as Logger +import Imm.Pretty +import qualified Paths_imm as Package + +import Data.List +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Version +import Options.Applicative +import System.Directory +import System.FilePath +import System.Info +import URI.ByteString +-- }}} + +-- * Types + +data AllOptions = AllOptions + { optionCommand :: Command + , optionGlobal :: GlobalOptions + } deriving(Eq, Show) + + +data GlobalOptions = GlobalOptions + { optionLogLevel :: LogLevel + , optionColorizeLogs :: Bool + , optionReadOnlyDatabase :: Bool + , optionCallbacksFile :: FilePath + } deriving(Eq, Ord, Read, Show) + + +data Command = Import | Subscribe URI (Set Text) | List | ShowFeed FeedRef | OnFeedRef (Maybe FeedRef) CommandOnFeedRef + +deriving instance Eq Command +deriving instance Ord Command +deriving instance Show Command + +instance Pretty Command where + pretty Import = "Import feeds" + pretty (Subscribe f _) = "Subscribe to feed:" <+> prettyURI f + pretty (OnFeedRef t c) = pretty c <> ":" <+> pretty t + pretty List = "List all feeds" + pretty (ShowFeed f) = "Show details of feed" <+> pretty f + + +data CallbackMode = DisableCallbacks | EnableCallbacks + deriving(Eq, Ord, Read, Show) + + +data CommandOnFeedRef = Reset | Run CallbackMode | Unsubscribe + deriving(Eq, Ord, Read, Show) + +instance Pretty CommandOnFeedRef where + pretty Reset = "Mark feed as unprocessed" + pretty (Run c) = "Download new entries from feeds" <> (if c == DisableCallbacks then space <> brackets "callbacks disabled" else mempty) + pretty Unsubscribe = "Unsubscribe from feed" + +-- * Option parsers + +parseOptions :: (MonadIO m) => m AllOptions +parseOptions = io $ do + defaultCallbacksFile <- getXdgDirectory XdgConfig $ "imm" "callbacks.dhall" + customExecParser defaultPrefs $ info (allOptions defaultCallbacksFile <**> helper <**> versionPrinter) $ progDesc description + +description :: String +description = "Execute arbitrary callbacks for each element of RSS/Atom feeds." + +allOptions :: FilePath -> Parser AllOptions +allOptions defaultCallbacksFile = AllOptions + <$> commandParser + <*> globalOptions defaultCallbacksFile + +globalOptions :: FilePath -> Parser GlobalOptions +globalOptions defaultCallbacksFile = GlobalOptions + <$> (verboseFlag <|> quietFlag <|> logLevel <|> pure Info) + <*> colorizeLogs + <*> readOnlyDatabase + <*> (callbacksFileOption <|> pure defaultCallbacksFile) + +commandParser :: Parser Command +commandParser = hsubparser $ mconcat + [ command "add" $ info subscribeOptions $ progDesc "Alias for subscribe." + , command "import" $ info (pure Import) $ progDesc "Import feeds list from an OPML descriptor (read from stdin)." + , command "subscribe" $ info subscribeOptions $ progDesc "Subscribe to a feed." + + , command "remove" $ info unsubscribeOptions $ progDesc "Alias for unsubscribe." + , command "run" $ info (OnFeedRef <$> optional feedRefOption <*> runOptions) $ progDesc "Update list of feeds." + , command "show" $ info (ShowFeed <$> feedRefOption) $ progDesc "Show details about given feed." + , command "list" $ info (pure List) $ progDesc "List all feed sources currently configured, along with their status." + , command "reset" $ info (OnFeedRef <$> optional feedRefOption <*> pure Reset) $ progDesc "Mark given feed as unprocessed." + , command "unsubscribe" $ info unsubscribeOptions $ progDesc "Unsubscribe from a feed." + ] + +-- {{{ Log options +verboseFlag, quietFlag, logLevel :: Parser LogLevel +verboseFlag = flag' Logger.Debug $ long "verbose" <> short 'v' <> help "Set log level to DEBUG." +quietFlag = flag' Logger.Error $ long "quiet" <> short 'q' <> help "Set log level to ERROR." +logLevel = option auto $ long "log-level" <> short 'l' <> metavar "LOG-LEVEL" <> value Info <> completeWith ["Debug", "Info", "Warning", "Error"] <> help "Set log level. Available values: Debug, Info, Warning, Error." + +colorizeLogs :: Parser Bool +colorizeLogs = flag True False $ long "nocolor" <> help "Disable log colorisation." +-- }}} + +-- {{{ Other options +readOnlyDatabase :: Parser Bool +readOnlyDatabase = switch $ long "read-only" <> help "Disable database writes." + +runOptions :: Parser CommandOnFeedRef +runOptions = Run <$> flag EnableCallbacks DisableCallbacks (long "no-callbacks" <> help "Disable callbacks.") + +tagOption :: Parser Text +tagOption = option auto $ long "tag" <> short 't' <> metavar "TAG" <> help "Set the given tag." + +subscribeOptions, unsubscribeOptions :: Parser Command +subscribeOptions = Subscribe <$> uriArgument "URI to subscribe to." <*> (Set.fromList <$> many tagOption) +unsubscribeOptions = OnFeedRef <$> optional feedRefOption <*> pure Unsubscribe + +callbacksFileOption :: Parser FilePath +callbacksFileOption = strOption $ long "callbacks" <> short 'c' <> metavar "FILE" <> help "Dhall configuration file for callbacks" +-- }}} + +-- {{{ Util +uriReader :: ReadM URI +uriReader = eitherReader $ first show . parseURI laxURIParserOptions . encodeUtf8 @Text . fromString + +feedRefOption :: Parser FeedRef +feedRefOption = argument ((ByUID <$> auto) <|> (ByURI <$> uriReader)) $ metavar "TARGET" + +uriArgument :: String -> Parser URI +uriArgument helpText = argument uriReader $ metavar "URI" <> help helpText + +versionPrinter :: Parser (a -> a) +versionPrinter = infoOption + (Data.List.unlines ["imm-" <> showVersion Package.version, "built with " <> compilerName <> "-" <> showVersion compilerVersion]) + (long "version" <> short 'V' <> help "Print versions.") +-- }}} diff --git a/src/main/Prelude.hs b/src/main/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/main/Prelude.hs @@ -0,0 +1,7 @@ +module Prelude (io, module Relude, module Relude.Extra.Map) where + +import Relude hiding(Handle, force) +import Relude.Extra.Map (lookup) + +io :: MonadIO m => IO a -> m a +io = liftIO diff --git a/src/main/XML.hs b/src/main/XML.hs new file mode 100644 --- /dev/null +++ b/src/main/XML.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +-- | Implementation of "Imm.XML" based on 'Conduit'. +module XML (module XML, module Imm.XML) where + +-- {{{ Imports +import Imm.Feed +import Imm.XML + +import Control.Exception.Safe +import Data.Conduit +import Data.XML.Types +import Text.Atom.Conduit.Parse +import Text.RSS.Conduit.Parse +import Text.RSS1.Conduit.Parse +import Text.XML.Stream.Parse as XML +import URI.ByteString +-- }}} + +-- | A pre-process 'Conduit' can be set to alter the raw XML before feeding it to the parser, +-- depending on the feed 'URI' +newtype XmlParser = XmlParser (forall m . Monad m => URI -> ConduitT Event Event m ()) + +-- | 'Conduit' based implementation +mkHandle :: MonadIO m => MonadCatch m => XmlParser -> Handle m +mkHandle (XmlParser preProcess) = Handle + { parseXml = \uri bytestring -> liftIO $ runConduit $ parseLBS def bytestring .| preProcess uri .| XML.force "Invalid feed" ((fmap Atom <$> atomFeed) `orE` (fmap Rss <$> rssDocument) `orE` (fmap Rss <$> rss1Document)) + } + +-- | Forward all 'Event's without any pre-process +defaultXmlParser :: XmlParser +defaultXmlParser = XmlParser $ const $ fix $ \loop -> await >>= maybe (return ()) (yield >=> const loop) diff --git a/src/send-mail/Main.hs b/src/send-mail/Main.hs new file mode 100644 --- /dev/null +++ b/src/send-mail/Main.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +-- | 'Callback' for @imm@ that sends a mail via a SMTP server the input RSS/Atom item. +-- {{{ Imports +import Imm.Callback +import Imm.Feed +import Imm.Pretty + +import Data.Aeson +import Data.ByteString (getContents) +import Data.Text as Text (intercalate) +import Data.Time +import Network.HaskellNet.SMTP +import Network.HaskellNet.SMTP.SSL +import Network.Mail.Mime hiding (sendmail) +import Network.Socket +import Options.Applicative +import Refined +import Text.Atom.Types +import Text.RSS.Types +-- }}} + +-- * Types + +type Username = String +type Password = String +type ServerName = String + +-- | How to connect to the SMTP server +data ConnectionSettings = Plain ServerName PortNumber | Encrypted ServerName Settings Bool + deriving(Eq, Generic, Ord, Show) + +-- | How to authenticate to the SMTP server +data Authentication = Authentication AuthType Username Password + deriving(Eq, Generic, Show) + +data SMTPServer = SMTPServer (Maybe Authentication) ConnectionSettings + deriving (Eq, Generic, Show) + +-- | How to format outgoing mails from feed elements +data FormatMail = FormatMail + { formatFrom :: Feed -> FeedElement -> Address -- ^ How to write the From: header of feed mails + , formatSubject :: Feed -> FeedElement -> Text -- ^ How to write the Subject: header of feed mails + , formatBody :: Feed -> FeedElement -> Text -- ^ How to write the body of feed mails (sic!) + , formatTo :: Feed -> FeedElement -> [Address] -- ^ How to write the To: header of feed mails + } + +data CliOptions = CliOptions + { _smtpServer :: SMTPServer + , _recipients :: [Address] + , _dryRun :: Bool + } deriving (Eq, Generic, Show) + + +parseOptions :: MonadIO m => m CliOptions +parseOptions = io $ customExecParser (prefs $ showHelpOnError <> showHelpOnEmpty) (info (cliOptions <**> helper) $ progDesc "Send a mail for each new RSS/Atom item.") + +cliOptions :: Parser CliOptions +cliOptions = CliOptions + <$> smtpServerParser + <*> many recipientParser + <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.") + +smtpServerParser :: Parser SMTPServer +smtpServerParser = SMTPServer + <$> ((Just <$> authenticationParser) <|> pure Nothing) + <*> (plainConnection <|> encryptedConnection) + +authenticationParser :: Parser Authentication +authenticationParser = Authentication + <$> authenticationType + <*> strOption (long "user" <> short 'u' <> help "SMTP username") + <*> strOption (long "password" <> short 'P' <> help "SMTP password") + +authenticationType :: Parser AuthType +authenticationType = flag' PLAIN (long "plain" <> help "Use plain authentication.") + <|> flag' LOGIN (long "login" <> help "Use login authentication") + <|> flag' CRAM_MD5 (long "cram-md5" <> help "Use CRAM MD5 authentication") + +plainConnection :: Parser ConnectionSettings +plainConnection = Plain + <$> strOption (long "server" <> short 's' <> help "SMTP server address.") + <*> option auto (long "port" <> short 'p' <> help "SMTP server port.") + +encryptedConnection :: Parser ConnectionSettings +encryptedConnection = Encrypted + <$> strOption (long "server" <> short 's' <> help "SMTP server address.") + <*> encryptionSettings + <*> switch (long "starttls" <> help "Use STARTTLS.") + +encryptionSettings :: Parser Settings +encryptionSettings = Settings + <$> option auto (long "ssl-port" <> short 's' <> help "SSL port.") + <*> option auto (long "max-line-length" <> short 'l' <> help "Maximum line length.") + <*> switch (long "log" <> help "Log to console.") + <*> switch (long "disable-certificate-validation" <> help "Disable certificate validation.") + +recipientParser :: Parser Address +recipientParser = strOption (long "to" <> help "Mail recipients.") + +main :: IO () +main = do + CliOptions smtpServer recipients dryRun <- parseOptions + + message <- getContents <&> fromStrict <&> eitherDecode + case message of + Left e -> putStrLn e + Right (Message feed element) -> do + timezone <- io getCurrentTimeZone + currentTime <- io getCurrentTime + let formatMail = FormatMail defaultFormatFrom defaultFormatSubject defaultFormatBody (const $ const recipients) + mail = buildMail formatMail currentTime timezone feed element + unless dryRun $ io $ withSMTPConnection smtpServer $ sendMimeMail2 mail + + return () + + +-- * Default behavior + +-- | Fill 'addressName' with the feed title and, if available, the authors' names. +-- +-- This function leaves 'addressEmail' empty. You are expected to fill it adequately, because many SMTP servers enforce constraints on the From: email. +defaultFormatFrom :: Feed -> FeedElement -> Address +defaultFormatFrom (Rss doc) (RssElement item) = Address (Just $ channelTitle doc <> " (" <> itemAuthor item <> ")") "" +defaultFormatFrom (Atom feed) (AtomElement entry) = Address (Just $ title <> " (" <> authors <> ")") "" + where title = show . prettyAtomText $ feedTitle feed + authors = Text.intercalate ", " $ map (unrefine . personName) $ entryAuthors entry <> feedAuthors feed +defaultFormatFrom _ _ = Address (Just "Unknown") "" + +-- | Fill mail subject with the element title +defaultFormatSubject :: Feed -> FeedElement -> Text +defaultFormatSubject _ = getTitle + +-- | Fill mail body with: +-- +-- - a list of links associated to the element +-- - the element's content or description/summary +defaultFormatBody :: Feed -> FeedElement -> Text +defaultFormatBody _ (RssElement item) = "

" <> maybe "" (withRssURI (show . prettyURI)) (itemLink item) <> "

" <> itemDescription item <> "

" +defaultFormatBody _ (AtomElement entry) = "

" <> Text.intercalate "
" links <> "

" <> fromMaybe "" (content <|> summary) <> "

" + where links = map (withAtomURI (show . prettyURI) . linkHref) $ entryLinks entry + content = show . prettyAtomContent <$> entryContent entry + summary = show . prettyAtomText <$> entrySummary entry + + +-- * Low-level helpers + +authenticate_ :: SMTPConnection -> Authentication -> IO Bool +authenticate_ connection (Authentication t u p) = do + result <- authenticate t u p connection + unless result $ putStrLn "Authentication failed" + return result + +withSMTPConnection :: SMTPServer -> (SMTPConnection -> IO a) -> IO a +withSMTPConnection (SMTPServer authentication (Plain server port)) f = + doSMTPPort server port $ \connection -> do + forM_ authentication (authenticate_ connection) + f connection +withSMTPConnection (SMTPServer authentication (Encrypted server settings False)) f = + doSMTPSSLWithSettings server settings $ \connection -> do + forM_ authentication (authenticate_ connection) + f connection +withSMTPConnection (SMTPServer authentication (Encrypted server settings True)) f = + doSMTPSTARTTLSWithSettings server settings $ \connection -> do + forM_ authentication (authenticate_ connection) + f connection + +-- | Build mail from a given feed +buildMail :: FormatMail -> UTCTime -> TimeZone -> Feed -> FeedElement -> Mail +buildMail format currentTime timeZone feed element = + let date = formatTime defaultTimeLocale "%a, %e %b %Y %T %z" $ utcToZonedTime timeZone $ fromMaybe currentTime $ getDate element + in Mail + { mailFrom = formatFrom format feed element + , mailTo = formatTo format feed element + , mailCc = [] + , mailBcc = [] + , mailHeaders = + [ ("Return-Path", "") + , ("Date", fromString date) + , ("Subject", formatSubject format feed element) + , ("Content-disposition", "inline") + ] + , mailParts = [[htmlPart $ fromStrict $ formatBody format feed element]] + } diff --git a/src/send-mail/Prelude.hs b/src/send-mail/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/send-mail/Prelude.hs @@ -0,0 +1,7 @@ +module Prelude (io, module Relude, module Relude.Extra.Map) where + +import Relude hiding(Handle, force) +import Relude.Extra.Map (lookup) + +io :: MonadIO m => IO a -> m a +io = liftIO diff --git a/src/write-file/Main.hs b/src/write-file/Main.hs new file mode 100644 --- /dev/null +++ b/src/write-file/Main.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Write a file from the input RSS/Atom item. +-- +-- Meant to be use as a callback for imm. +-- {{{ Imports +import Imm.Callback +import Imm.Feed +import Imm.Pretty + +import Data.Aeson +import Data.ByteString (getContents) +import Data.ByteString.Builder +import Data.ByteString.Streaming (toStreamingByteString) +import qualified Data.Text as Text (null, replace) +import Data.Time +import Options.Applicative +import Streaming.With +import System.Directory (createDirectoryIfMissing) +import System.FilePath +import Text.Atom.Types +import Text.Blaze.Html.Renderer.Utf8 +import Text.Blaze.Html5 (Html, docTypeHtml, + preEscapedToHtml, (!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as H (charset, href) +import Text.RSS.Types +import URI.ByteString +-- }}} + +data CliOptions = CliOptions + { _directory :: FilePath + , _dryRun :: Bool + } deriving (Eq, Ord, Read, Show) + +parseOptions :: MonadIO m => m CliOptions +parseOptions = io $ customExecParser defaultPrefs (info cliOptions $ progDesc "Write a file for each new RSS/Atom item. An intermediate folder will be created for each feed.") + +cliOptions :: Parser CliOptions +cliOptions = CliOptions + <$> strOption (long "directory" <> short 'd' <> metavar "PATH" <> help "Root directory where files will be created.") + <*> switch (long "dry-run" <> help "Disable all I/Os, except for logs.") + + + +main :: IO () +main = do + CliOptions directory dryRun <- parseOptions + message <- getContents <&> fromStrict <&> eitherDecode + case message of + Left e -> putStrLn e + Right (Message feed element) -> do + let content = defaultFileContent feed element + filePath = defaultFilePath directory feed element + putStrLn filePath + unless dryRun $ do + createDirectoryIfMissing True $ takeDirectory filePath + writeBinaryFile filePath $ toStreamingByteString content + return () + +-- * Default behavior + +-- | Generate a path @//-.html@, where @@ is the first argument +defaultFilePath :: FilePath -> Feed -> FeedElement -> FilePath +defaultFilePath root feed element = makeValid $ root toString title fileName <.> "html" where + date = maybe "" (formatTime defaultTimeLocale "%F-") $ getDate element + fileName = date <> toString (sanitize $ getTitle element) + title = sanitize $ getFeedTitle feed + sanitize = appEndo (mconcat [Endo $ Text.replace (toText [s]) "_" | s <- pathSeparators]) + >>> Text.replace "." "_" + >>> Text.replace "?" "_" + >>> Text.replace "!" "_" + >>> Text.replace "#" "_" + +-- | Generate an HTML page, with a title, a header and an article that contains the feed element +defaultFileContent :: Feed -> FeedElement -> Builder +defaultFileContent feed element = renderHtmlBuilder $ docTypeHtml $ do + H.head $ do + H.meta ! H.charset "utf-8" + H.title $ convertText $ getFeedTitle feed <> " | " <> getTitle element + H.body $ do + H.h1 $ convertText $ getFeedTitle feed + H.article $ do + H.header $ do + defaultArticleTitle feed element + defaultArticleAuthor feed element + defaultArticleDate feed element + defaultBody feed element + + +-- * Low-level helpers + +defaultArticleTitle :: Feed -> FeedElement -> Html +defaultArticleTitle _ element@(RssElement item) = H.h2 $ maybe id (\uri -> H.a ! H.href uri) link $ convertText $ getTitle element where + link = withRssURI (convertDoc . prettyURI) <$> itemLink item +defaultArticleTitle _ element@(AtomElement _) = H.h2 $ convertText $ getTitle element + +defaultArticleAuthor :: Feed -> FeedElement -> Html +defaultArticleAuthor _ (RssElement item) = unless (Text.null author) $ H.address $ "Published by " >> convertText author where + author = itemAuthor item +defaultArticleAuthor _ (AtomElement entry) = H.address $ do + "Published by " + forM_ (entryAuthors entry) $ \author -> do + convertDoc $ prettyPerson author + ", " + +defaultArticleDate :: Feed -> FeedElement -> Html +defaultArticleDate _ element = forM_ (getDate element) $ \date -> H.p $ " on " >> H.time (convertDoc $ prettyTime date) + + +-- | Generate the HTML content for a given feed element +defaultBody :: Feed -> FeedElement -> Html +defaultBody _ element@(RssElement _) = H.p $ preEscapedToHtml $ getContent element +defaultBody _ element@(AtomElement entry) = do + unless (null links) $ H.p $ do + "Related links:" + H.ul $ forM_ links $ \uri -> H.li (H.a ! withAtomURI href uri $ convertAtomURI uri) + H.p $ preEscapedToHtml $ getContent element + where links = map linkHref $ entryLinks entry + +href :: URIRef a -> H.Attribute +href = H.href . convertURI + +convertAtomURI :: (IsString t) => AtomURI -> t +convertAtomURI = withAtomURI convertURI + +convertURI :: (IsString t) => URIRef a -> t +convertURI = convertText . decodeUtf8 . serializeURIRef' + +convertText :: (IsString t) => Text -> t +convertText = fromString . toString + +convertDoc :: (IsString t) => Doc a -> t +convertDoc = show diff --git a/src/write-file/Prelude.hs b/src/write-file/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/write-file/Prelude.hs @@ -0,0 +1,7 @@ +module Prelude (io, module Relude, module Relude.Extra.Map) where + +import Relude hiding(Handle, force) +import Relude.Extra.Map (lookup) + +io :: MonadIO m => IO a -> m a +io = liftIO