diff --git a/imm.cabal b/imm.cabal --- a/imm.cabal +++ b/imm.cabal @@ -1,5 +1,5 @@ name: imm -version: 1.2.0.0 +version: 1.2.1.0 synopsis: Execute arbitrary actions for each unread element of RSS/Atom feeds description: Cf README file homepage: https://github.com/k0ral/imm @@ -42,7 +42,7 @@ Imm.Options Imm.Pretty Paths_imm - build-depends: aeson, ansi-wl-pprint, atom-conduit >= 0.4, base == 4.*, blaze-html, blaze-markup, bytestring, case-insensitive, chunked-data >= 0.3.0, comonad, conduit, conduit-combinators, connection, containers, directory >= 1.2.3.0, dyre, fast-logger, filepath, free, hashable, HaskellNet, HaskellNet-SSL >= 0.3.3.0, http-client >= 0.4.30, http-client-tls, http-types, mime-mail, monoid-subclasses, mono-traversable >= 1.0.0, network, opml-conduit >= 0.6, optparse-applicative, rainbow, rainbox, rss-conduit >= 0.3.1, safe-exceptions, tagged, text, transformers, time, timerep >= 2.0.0.0, tls, uri-bytestring, xml, xml-conduit >= 1.5, xml-types + build-depends: aeson, ansi-wl-pprint, atom-conduit >= 0.4, base == 4.*, blaze-html, blaze-markup, bytestring, case-insensitive, chunked-data >= 0.3.0, comonad, conduit, conduit-combinators, connection, containers, directory >= 1.2.3.0, dyre, fast-logger, filepath, free, hashable, HaskellNet, HaskellNet-SSL >= 0.3.3.0, http-client >= 0.4.30, http-client-tls, http-types, mime-mail, monoid-subclasses, microlens, mono-traversable >= 1, network, opml-conduit >= 0.6, optparse-applicative, rainbow, rainbox, rss-conduit >= 0.4.1, safe-exceptions, tagged, text, transformers, 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 diff --git a/src/bin/Executable.hs b/src/bin/Executable.hs --- a/src/bin/Executable.hs +++ b/src/bin/Executable.hs @@ -5,6 +5,7 @@ -- {{{ Imports import Imm import Imm.Database.JsonFile +import qualified Imm.Hooks.WriteFile as WriteFile import Imm.HTTP.Simple import Imm.Logger.Simple import Imm.Prelude @@ -13,11 +14,11 @@ import System.Exit -- }}} -mkDummyCoHooks :: (MonadIO m, MonadThrow m) => () -> CoHooksF m () -mkDummyCoHooks _ = CoHooksF coOnNewElement where - coOnNewElement _ _ = do - io $ putStrLn "No hook defined." - throwM $ ExitFailure 1 +-- mkDummyCoHooks :: (MonadIO m, MonadThrow m) => () -> CoHooksF m () +-- mkDummyCoHooks _ = CoHooksF coOnNewElement where +-- coOnNewElement _ _ = do +-- io $ putStrLn "No hook defined." +-- throwM $ ExitFailure 1 main :: IO () @@ -26,4 +27,5 @@ manager <- defaultManager database <- defaultDatabase - imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (mkDummyCoHooks, ()) (mkCoXmlParser, defaultPreProcess) + -- imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (mkDummyCoHooks, ()) (mkCoXmlParser, defaultPreProcess) + imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger) (WriteFile.mkCoHooks, WriteFile.defaultSettings "/home/koral/feeds") (mkCoXmlParser, defaultPreProcess) diff --git a/src/lib/Imm/Core.hs b/src/lib/Imm/Core.hs --- a/src/lib/Imm/Core.hs +++ b/src/lib/Imm/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} 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,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} -- | Helpers to manipulate feeds module Imm.Feed where @@ -8,10 +10,12 @@ import Data.Hashable import Data.Time - +import Lens.Micro import Text.Atom.Types +import Text.RSS.Extensions.Content +import Text.RSS.Extensions.DublinCore +import Text.RSS.Lens import Text.RSS.Types - import URI.ByteString -- }}} @@ -25,10 +29,10 @@ pretty (ByUID n) = text "feed" <+> text (show n) pretty (ByURI u) = prettyURI u -data Feed = Rss RssDocument | Atom AtomFeed +data Feed = Rss (RssDocument '[ContentModule, DublinCoreModule]) | Atom AtomFeed deriving(Eq, Show) -data FeedElement = RssElement RssItem | AtomElement AtomEntry +data FeedElement = RssElement (RssItem '[ContentModule, DublinCoreModule]) | AtomElement AtomEntry deriving(Eq, Show) @@ -43,12 +47,20 @@ getElements (Atom feed) = map AtomElement $ feedEntries feed getDate :: FeedElement -> Maybe UTCTime -getDate (RssElement item) = itemPubDate item +getDate (RssElement item) = itemPubDate item <|> (elementDate $ itemDcMetaData (item ^. itemExtensionL)) getDate (AtomElement entry) = Just $ entryUpdated entry getTitle :: FeedElement -> Text getTitle (RssElement item) = itemTitle item getTitle (AtomElement entry) = show $ prettyAtomText $ entryTitle entry + +getContent :: FeedElement -> Text +getContent (RssElement item) = if not (null content) then content else itemDescription item where + ContentItem content = item ^. itemExtensionL +getContent (AtomElement entry) = fromMaybe "" $ content <|> summary where + content = show . prettyAtomContent <$> entryContent entry + summary = show . prettyAtomText <$> entrySummary entry + getHashes :: FeedElement -> [Int] getHashes (RssElement item) = map (hash . (show :: Doc -> String) . prettyGuid) (maybeToList $ itemGuid item) diff --git a/src/lib/Imm/HTTP.hs b/src/lib/Imm/HTTP.hs --- a/src/lib/Imm/HTTP.hs +++ b/src/lib/Imm/HTTP.hs @@ -27,7 +27,7 @@ deriving(Functor) -- | HTTP client interpreter -data CoHttpClientF m a = CoHttpClientF +newtype CoHttpClientF m a = CoHttpClientF { getH :: URI -> m (Either SomeException LByteString, a) } deriving(Functor) diff --git a/src/lib/Imm/Hooks/WriteFile.hs b/src/lib/Imm/Hooks/WriteFile.hs --- a/src/lib/Imm/Hooks/WriteFile.hs +++ b/src/lib/Imm/Hooks/WriteFile.hs @@ -13,14 +13,11 @@ import Imm.Pretty import Control.Arrow - import Data.Monoid.Textual hiding (elem, map) import qualified Data.Text.Lazy as Text import Data.Time - import System.Directory (createDirectoryIfMissing) import System.FilePath - import Text.Atom.Types import Text.Blaze.Html.Renderer.Text import Text.Blaze.Html5 (Html, docTypeHtml, @@ -28,7 +25,6 @@ import qualified Text.Blaze.Html5 as H hiding (map) import Text.Blaze.Html5.Attributes as H (charset, href) import Text.RSS.Types - import URI.ByteString -- }}} @@ -42,7 +38,7 @@ -- * Interpreter -- | Interpreter for 'HooksF' -mkCoHooks :: (MonadIO m) => WriteFileSettings -> CoHooksF m WriteFileSettings +mkCoHooks :: MonadIO m => WriteFileSettings -> CoHooksF m WriteFileSettings mkCoHooks a@(WriteFileSettings f) = CoHooksF coOnNewElement where coOnNewElement feed element = do let FileInfo path content = f feed element @@ -77,40 +73,42 @@ H.body $ do H.h1 $ convertText $ getFeedTitle feed H.article $ do - defaultHeader feed element + H.header $ do + defaultArticleTitle feed element + defaultArticleAuthor feed element + defaultArticleDate feed element defaultBody feed element -- * Low-level helpers --- | Generate an HTML @
@ for a given feed element -defaultHeader :: Feed -> FeedElement -> Html -defaultHeader _ element@(RssElement item) = H.header $ do - H.h2 $ maybe id (\uri -> H.a ! H.href uri) link $ convertText $ getTitle element - unless (null author) $ H.address $ "Published by " >> convertText author - forM_ (itemPubDate item) $ \date -> H.p $ " on " >> H.time (convertDoc $ prettyTime date) - where link = withRssURI (convertDoc . prettyURI) <$> itemLink item - author = itemAuthor item -defaultHeader _ element@(AtomElement entry) = H.header $ do - H.h2 $ convertText $ getTitle element - H.address $ do - "Published by " - forM_ (entryAuthors entry) $ \author -> do - convertDoc $ prettyPerson author - ", " - H.p $ "on " >> H.time (convertDoc $ prettyTime $ entryUpdated entry) +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 (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 _ (RssElement item) = H.p $ preEscapedToHtml $ itemDescription item -defaultBody _ (AtomElement entry) = do +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 ! H.href (convertAtomURI uri) $ convertAtomURI uri) - H.p $ preEscapedToHtml $ fromMaybe "" $ content <|> summary + H.p $ preEscapedToHtml $ getContent element where links = map linkHref $ entryLinks entry - content = show . prettyAtomContent <$> entryContent entry :: Maybe Text - summary = show . prettyAtomText <$> entrySummary entry :: Maybe Text convertAtomURI :: (IsString t) => AtomURI -> t diff --git a/src/lib/Imm/Options.hs b/src/lib/Imm/Options.hs --- a/src/lib/Imm/Options.hs +++ b/src/lib/Imm/Options.hs @@ -68,7 +68,7 @@ -- ++ catMaybes [("CONFIG=" ++) <$> opts^.configurationLabel_] parseOptions :: (MonadIO m) => m CliOptions -parseOptions = io $ customExecParser (prefs noBacktrack) (info parser $ progDesc "Convert items from RSS/Atom feeds to mails.") +parseOptions = io $ customExecParser (defaultPrefs {- noBacktrack -} ) (info parser $ progDesc "Fetch elements from RSS/Atom feeds and execute arbitrary actions for each of them.") where parser = helper <*> optional dyreMasterBinary *> optional dyreDebug *> cliOptions diff --git a/src/lib/Imm/Prelude.hs b/src/lib/Imm/Prelude.hs --- a/src/lib/Imm/Prelude.hs +++ b/src/lib/Imm/Prelude.hs @@ -22,10 +22,9 @@ void, when) import Control.Monad.IO.Class as X import Control.Monad.Trans.Free (FreeF (..), FreeT (..)) - import Data.Bifunctor as X -import qualified Data.ByteString as B (ByteString ()) -import qualified Data.ByteString.Lazy as LB (ByteString ()) +import qualified Data.ByteString as B (ByteString) +import qualified Data.ByteString.Lazy as LB (ByteString) import Data.Containers as X import Data.Either as X import Data.Foldable as X (forM_) @@ -36,20 +35,17 @@ import Data.Map as X (Map) import Data.Maybe as X hiding (catMaybes) import Data.Monoid as X hiding (Product, Sum) -import Data.Monoid.Textual as X (TextualMonoid (), - fromText) +import Data.Monoid.Textual as X (TextualMonoid, fromText) import Data.MonoTraversable.Unprefixed as X hiding (forM_, mapM_) import Data.Ord as X import Data.Sequences as X import Data.String as X (IsString (..)) import Data.Tagged -import qualified Data.Text as T (Text ()) -import qualified Data.Text.Lazy as LT (Text ()) +import qualified Data.Text as T (Text) +import qualified Data.Text.Lazy as LT (Text) import Data.Traversable as X (for, forM) import Data.Typeable as X - import qualified GHC.Show as Show - import Prelude as X hiding (all, and, any, break, concat, concatMap, drop, dropWhile, elem, @@ -63,14 +59,11 @@ takeWhile, unlines, unwords, words, writeFile) - import System.IO as X (stderr, stdout) - import Text.PrettyPrint.ANSI.Leijen as X (Doc, Pretty (..), angles, brackets, equals, hsep, indent, space, text, vsep, (<+>)) - import Text.PrettyPrint.ANSI.Leijen (line) -- }}} @@ -123,6 +116,7 @@ inj = proxy inj' (Proxy :: Proxy (Contains f g)) +-- | Functors @f@ and @g@ are paired when they can annihilate each other class (Monad m, Functor f, Functor g) => PairingM f g m | f -> g where pairM :: (a -> b -> m r) -> f a -> g b -> m r 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 @@ -80,7 +80,7 @@ -- , " Item Body: " ++ (Imm.Mail.getItemContent item), ) -prettyItem :: RssItem -> Doc +prettyItem :: RssItem e -> Doc prettyItem i = "Item:" <+> text (fromText $ itemTitle i) <++> indent 4 ( "By" <+> equals <+> text (fromText $ itemAuthor i) <++> "Updated" <+> equals <+> fromMaybe "" (prettyTime <$> itemPubDate i)