Hello community,
here is the log from the commit of package ghc-imm for openSUSE:Factory checked
in at 2017-08-31 20:56:32
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-imm (Old)
and /work/SRC/openSUSE:Factory/.ghc-imm.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-imm"
Thu Aug 31 20:56:32 2017 rev:2 rq:513399 version:1.2.0.0
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-imm/ghc-imm.changes 2017-05-17
10:51:04.022572947 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-imm.new/ghc-imm.changes 2017-08-31
20:56:32.714727365 +0200
@@ -1,0 +2,5 @@
+Thu Jul 27 14:07:10 UTC 2017 - psim...@suse.com
+
+- Update to version 1.2.0.0.
+
+-------------------------------------------------------------------
Old:
----
imm-1.1.0.0.tar.gz
New:
----
imm-1.2.0.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-imm.spec ++++++
--- /var/tmp/diff_new_pack.6Y5Bf8/_old 2017-08-31 20:56:33.570607111 +0200
+++ /var/tmp/diff_new_pack.6Y5Bf8/_new 2017-08-31 20:56:33.582605426 +0200
@@ -18,7 +18,7 @@
%global pkg_name imm
Name: ghc-%{pkg_name}
-Version: 1.1.0.0
+Version: 1.2.0.0
Release: 0
Summary: Execute arbitrary actions for each unread element of RSS/Atom
feeds
License: WTFPL
@@ -71,6 +71,7 @@
BuildRequires: ghc-uri-bytestring-devel
BuildRequires: ghc-xml-conduit-devel
BuildRequires: ghc-xml-devel
+BuildRequires: ghc-xml-types-devel
BuildRoot: %{_tmppath}/%{name}-%{version}-build
%description
++++++ imm-1.1.0.0.tar.gz -> imm-1.2.0.0.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/imm.cabal new/imm-1.2.0.0/imm.cabal
--- old/imm-1.1.0.0/imm.cabal 2016-10-24 22:15:11.000000000 +0200
+++ new/imm-1.2.0.0/imm.cabal 2017-03-19 10:26:16.000000000 +0100
@@ -1,9 +1,9 @@
name: imm
-version: 1.1.0.0
+version: 1.2.0.0
synopsis: Execute arbitrary actions for each unread element of
RSS/Atom feeds
description: Cf README file
homepage: https://github.com/k0ral/imm
-license: OtherLicense
+license: PublicDomain
license-file: LICENSE
author: kamaradclimber, koral
maintainer: koral <ko...@mailoo.org>
@@ -33,6 +33,8 @@
Imm.Logger
Imm.Logger.Simple
Imm.Prelude
+ Imm.XML
+ Imm.XML.Simple
other-modules:
Imm.Aeson
Imm.Dyre
@@ -40,7 +42,7 @@
Imm.Options
Imm.Pretty
Paths_imm
- build-depends: aeson, 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, safe-exceptions,
tagged, text, transformers, time, timerep >= 2.0.0.0, tls, uri-bytestring, xml,
xml-conduit, ansi-wl-pprint
+ 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-tools:
hs-source-dirs: src/lib
ghc-options: -Wall -fno-warn-unused-do-bind
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/bin/Executable.hs
new/imm-1.2.0.0/src/bin/Executable.hs
--- old/imm-1.1.0.0/src/bin/Executable.hs 2016-08-23 12:03:21.000000000
+0200
+++ new/imm-1.2.0.0/src/bin/Executable.hs 2017-03-19 10:26:16.000000000
+0100
@@ -5,19 +5,19 @@
-- {{{ 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
+import Imm.XML.Simple
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 +26,4 @@
manager <- defaultManager
database <- defaultDatabase
- imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger)
(WriteFile.mkCoHooks, WriteFile.defaultSettings "/home/koral/feeds")
+ imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger, logger)
(mkDummyCoHooks, ()) (mkCoXmlParser, defaultPreProcess)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Boot.hs
new/imm-1.2.0.0/src/lib/Imm/Boot.hs
--- old/imm-1.1.0.0/src/lib/Imm/Boot.hs 2016-10-24 22:08:58.000000000 +0200
+++ new/imm-1.2.0.0/src/lib/Imm/Boot.hs 2017-03-19 10:26:16.000000000 +0100
@@ -37,6 +37,7 @@
import Imm.Options as Options hiding(logLevel)
import Imm.Prelude
import Imm.Pretty
+import Imm.XML
import Control.Comonad.Cofree
import Control.Monad.Trans.Free
@@ -58,6 +59,7 @@
-- > import Imm.Hooks.SendMail
-- > import Imm.HTTP.Simple
-- > import Imm.Logger.Simple
+-- > import Imm.XML.Simple
-- >
-- > main :: IO ()
-- > main = do
@@ -65,7 +67,7 @@
-- > manager <- defaultManager
-- > database <- defaultDatabase
-- >
--- > imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger,
logger) (mkCoHooks, sendmail)
+-- > imm (mkCoHttpClient, manager) (mkCoDatabase, database) (mkCoLogger,
logger) (mkCoHooks, sendmail) (mkCoXmlParser, defaultPreProcess)
-- >
-- > sendmail :: SendMailSettings
-- > sendmail = SendMailSettings smtpServer formatMail
@@ -82,14 +84,15 @@
-- > (Just $ Authentication PLAIN "user" "password")
-- > (StartTls "smtp.host" defaultSettingsSMTPSTARTTLS)
imm :: (a -> CoHttpClientF IO a, a) -- ^ HTTP client interpreter (cf
"Imm.HTTP")
- -> (b -> CoDatabaseF' IO b, b) -- ^ Database interpreter (cf
"Imm.Database")
- -> (c -> CoLoggerF IO c, c) -- ^ Logger interpreter (cf "Imm.Logger")
- -> (d -> CoHooksF IO d, d) -- ^ Hooks interpreter (cf "Imm.Hooks")
+ -> (b -> CoDatabaseF' IO b, b) -- ^ Database interpreter (cf
"Imm.Database")
+ -> (c -> CoLoggerF IO c, c) -- ^ Logger interpreter (cf "Imm.Logger")
+ -> (d -> CoHooksF IO d, d) -- ^ Hooks interpreter (cf "Imm.Hooks")
+ -> (e -> CoXmlParserF IO e, e) -- ^ XML parsing interpreter (cf
"Imm.XML")
-> IO ()
-imm coHttpClient coDatabase coLogger coHooks = void $ do
+imm coHttpClient coDatabase coLogger coHooks coXmlParser = void $ do
options <- parseOptions
Dyre.wrap (optionDyreMode options) realMain (optionCommand options,
optionLogLevel options, optionColorizeLogs options, coiter next start)
- where (next, start) = mkCoImm coHttpClient coDatabase coLogger coHooks
+ where (next, start) = mkCoImm coHttpClient coDatabase coLogger coHooks
coXmlParser
realMain :: (MonadIO m, PairingM (CoImmF m) ImmF m, MonadCatch m)
=> (Command, LogLevel, Bool, Cofree (CoImmF m) a) -> m ()
@@ -117,14 +120,22 @@
-- * DSL/interpreter model
-type CoImmF m = Product (CoHttpClientF m) (Product (CoDatabaseF' m) (Product
(CoLoggerF m) (CoHooksF m)))
-type ImmF = Sum HttpClientF (Sum DatabaseF' (Sum LoggerF HooksF))
+type CoImmF m = Product (CoHttpClientF m)
+ (Product (CoDatabaseF' m)
+ (Product (CoLoggerF m)
+ (Product (CoHooksF m) (CoXmlParserF m)
+ )))
+type ImmF = Sum HttpClientF (Sum DatabaseF' (Sum LoggerF (Sum HooksF
XmlParserF)))
mkCoImm :: (Functor m)
- => (a -> CoHttpClientF m a, a) -> (b -> CoDatabaseF' m b, b) -> (c ->
CoLoggerF m c, c) -> (d -> CoHooksF m d, d)
- -> ((a ::: b ::: c ::: d) -> CoImmF m (a ::: b ::: c ::: d), a ::: b
::: c ::: d)
-mkCoImm (coHttpClient, a) (coDatabase, b) (coLogger, c) (coHooks, d) =
- (coHttpClient *:* coDatabase *:* coLogger *:* coHooks, a >: b >: c >: d)
+ => (a -> CoHttpClientF m a, a)
+ -> (b -> CoDatabaseF' m b, b)
+ -> (c -> CoLoggerF m c, c)
+ -> (d -> CoHooksF m d, d)
+ -> (e -> CoXmlParserF m e, e)
+ -> ((a ::: b ::: c ::: d ::: e) -> CoImmF m (a ::: b ::: c ::: d :::
e), a ::: b ::: c ::: d ::: e)
+mkCoImm (coHttpClient, a) (coDatabase, b) (coLogger, c) (coHooks, d)
(coXmlParser, e) =
+ (coHttpClient *: coDatabase *: coLogger *: coHooks *: coXmlParser, a +: b +:
c +: d +: e)
-- * Util
@@ -144,7 +155,7 @@
unless (null x || x == ("Y" :: Text)) $ throwM InterruptedException
-resolveTarget :: (MonadIO m, MonadThrow m, Functor f, MonadFree f m,
DatabaseF' :<: f)
+resolveTarget :: (MonadIO m, MonadThrow m, MonadFree f m, DatabaseF' :<: f)
=> SafeGuard -> Maybe Core.FeedRef -> m [FeedID]
resolveTarget s Nothing = do
result <- keys <$> Database.fetchAll FeedTable
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Core.hs
new/imm-1.2.0.0/src/lib/Imm/Core.hs
--- old/imm-1.1.0.0/src/lib/Imm/Core.hs 2016-09-28 00:05:51.000000000 +0200
+++ new/imm-1.2.0.0/src/lib/Imm/Core.hs 2017-03-19 10:26:16.000000000 +0100
@@ -29,6 +29,7 @@
import Imm.Logger
import Imm.Prelude
import Imm.Pretty
+import Imm.XML
-- import Control.Concurrent.Async.Lifted (Async, async, mapConcurrently,
waitAny)
-- import Control.Concurrent.Async.Pool
@@ -51,12 +52,8 @@
import System.Info
-import Text.Atom.Conduit.Parse
-import Text.Atom.Types
import Text.OPML.Conduit.Parse
import Text.OPML.Types as OPML
-import Text.RSS.Conduit.Parse
-import Text.RSS.Types
import Text.XML as XML ()
import Text.XML.Stream.Parse as XML
@@ -70,7 +67,7 @@
putStrLn $ "compiled by " ++ compilerName ++ "-" ++ showVersion
compilerVersion
-- | Print database status for given feed(s)
-showFeed :: (MonadIO m, LoggerF :<: f, MonadThrow m, Functor f, MonadFree f m,
DatabaseF' :<: f)
+showFeed :: (MonadIO m, LoggerF :<: f, MonadThrow m, MonadFree f m, DatabaseF'
:<: f)
=> [FeedID] -> m ()
showFeed feedIDs = do
feeds <- Database.fetchList FeedTable feedIDs
@@ -78,38 +75,41 @@
if null feeds then logWarning "No subscription" else putBox $
entryTableToBox feeds
-- | Register the given feed URI in database
-subscribe :: (LoggerF :<: f, Functor f, MonadFree f m, DatabaseF' :<: f,
MonadCatch m)
+subscribe :: (LoggerF :<: f, MonadFree f m, DatabaseF' :<: f, MonadCatch m)
=> URI -> Maybe Text -> m ()
subscribe uri category = Database.register (FeedID uri) $ fromMaybe "default"
category
-- | Check for unread elements without processing them
-check :: (MonadIO m, MonadCatch m, LoggerF :<: f, Functor f, MonadFree f m,
DatabaseF' :<: f, HttpClientF :<: f)
+check :: (MonadIO m, MonadCatch m, LoggerF :<: f, MonadFree f m, DatabaseF'
:<: f, HttpClientF :<: f, XmlParserF :<: f)
=> [FeedID] -> m ()
check feedIDs = do
- results <- forM (zip ([1..] :: [Int]) feedIDs) $ \(i, feedID) -> do
+ results <- for (zip ([1..] :: [Int]) feedIDs) $ \(i, feedID) -> do
logInfo $ brackets (fill width (bold $ cyan $ pretty i) <+> "/" <+> pretty
total) <+> "Checking" <+> magenta (pretty feedID) <> "..."
try $ checkOne feedID
+ flushLogs
+
putBox $ statusTableToBox $ mapFromList $ zip feedIDs results
+
+ let (failures, successes) = partitionEithers $ zipWith (\a -> bimap (a,)
(a,)) feedIDs results
+ unless (null failures) $ logError $ bold (pretty $ length failures) <+>
"feeds in error"
+ forM_ failures $ \(feedID, e) ->
+ logError $ indent 2 (pretty feedID <++> indent 2 (pretty $
displayException e))
+
where width = length (show total :: String)
total = length feedIDs
-checkOne :: (MonadIO m, MonadCatch m, LoggerF :<: f, Functor f, MonadFree f m,
DatabaseF' :<: f, HttpClientF :<: f)
+checkOne :: (MonadIO m, MonadCatch m, LoggerF :<: f, MonadFree f m, DatabaseF'
:<: f, HttpClientF :<: f, XmlParserF :<: f)
=> FeedID -> m Int
-checkOne feedID@(FeedID uri) = do
- body <- HTTP.get uri
- feed <- runConduit $ parseLBS def body =$= force "Invalid feed" ((fmap Left
<$> atomFeed) `orE` (fmap Right <$> rssDocument))
-
+checkOne feedID = do
+ feed <- getFeed feedID
case feed of
- Left _ -> logDebug $ "Parsed Atom feed: " <> pretty feedID
- Right _ -> logDebug $ "Parsed RSS feed: " <> pretty feedID
+ Atom _ -> logDebug $ "Parsed Atom feed: " <> pretty feedID
+ Rss _ -> logDebug $ "Parsed RSS feed: " <> pretty feedID
- let dates = either
- (map entryUpdated . feedEntries)
- (mapMaybe itemPubDate . channelItems)
- feed
+ let dates = mapMaybe getDate $ getElements feed
- logDebug $ vsep $ either (map prettyEntry . feedEntries) (map prettyItem .
channelItems) feed
+ logDebug $ vsep $ map prettyElement $ getElements feed
status <- Database.getStatus feedID
return $ length $ filter (unread status) dates
@@ -117,10 +117,10 @@
unread _ _ = True
-run :: (MonadIO m, MonadCatch m, HooksF :<: f, LoggerF :<: f, Functor f,
MonadFree f m, DatabaseF' :<: f, HttpClientF :<: f)
+run :: (MonadIO m, MonadCatch m, HooksF :<: f, LoggerF :<: f, MonadFree f m,
DatabaseF' :<: f, HttpClientF :<: f, XmlParserF :<: f)
=> [FeedID] -> m ()
run feedIDs = do
- results <- forM (zip ([1..] :: [Int]) feedIDs) $ \(i, feedID) -> do
+ results <- for (zip ([1..] :: [Int]) feedIDs) $ \(i, feedID) -> do
logInfo $ brackets (fill width (bold $ cyan $ pretty i) <+> "/" <+> pretty
total) <+> "Processing" <+> magenta (pretty feedID) <> "..."
result <- tryAny $ runOne feedID
return $ bimap (feedID,) (feedID,) result
@@ -136,14 +136,13 @@
where width = length (show total :: String)
total = length feedIDs
-runOne :: (MonadIO m, MonadCatch m, HooksF :<: f, LoggerF :<: f, Functor f,
MonadFree f m, DatabaseF' :<: f, HttpClientF :<: f)
+runOne :: (MonadIO m, MonadCatch m, HooksF :<: f, LoggerF :<: f, MonadFree f
m, DatabaseF' :<: f, HttpClientF :<: f, XmlParserF :<: f)
=> FeedID -> m ()
-runOne feedID@(FeedID uri) = do
- body <- HTTP.get uri
- feed <- runConduit $ parseLBS def body =$= force "Invalid feed" ((fmap Atom
<$> atomFeed) `orE` (fmap Rss <$> rssDocument))
+runOne feedID = do
+ feed <- getFeed feedID
unreadElements <- filterM (fmap not . isRead feedID) $ getElements feed
- unless (null unreadElements) $ logInfo $ indent 2 $ green (pretty $ length
unreadElements) <+> "unread element(s)"
+ unless (null unreadElements) $ logInfo $ indent 2 $ green (pretty $ length
unreadElements) <+> "new element(s)"
forM_ unreadElements $ \element -> do
onNewElement feed element
@@ -152,7 +151,7 @@
Database.markAsRead feedID
-isRead :: (Functor f, MonadCatch m, DatabaseF' :<: f, MonadFree f m) => FeedID
-> FeedElement -> m Bool
+isRead :: (MonadCatch m, DatabaseF' :<: f, MonadFree f m) => FeedID ->
FeedElement -> m Bool
isRead feedID element = do
DatabaseEntry _ _ readHashes lastCheck <- Database.fetch FeedTable feedID
let matchHash = not $ null $ (setFromList (getHashes element) :: Set Int)
`intersection` readHashes
@@ -163,18 +162,23 @@
return $ matchHash || matchDate
-- | 'subscribe' to all feeds described by the OPML document provided in input
(stdin)
-importOPML :: (MonadIO m, LoggerF :<: f, Functor f, MonadFree f m, DatabaseF'
:<: f, MonadCatch m) => m ()
+importOPML :: (MonadIO m, LoggerF :<: f, MonadFree f m, DatabaseF' :<: f,
MonadCatch m) => m ()
importOPML = do
opml <- runConduit $ Conduit.stdin =$= XML.parseBytes def =$= force "Invalid
OPML" parseOpml
forM_ (opmlOutlines opml) $ importOPML' mempty
-importOPML' :: (MonadIO m, LoggerF :<: f, Functor f, MonadFree f m, DatabaseF'
:<: f, MonadCatch m)
+importOPML' :: (MonadIO m, LoggerF :<: f, MonadFree f m, DatabaseF' :<: f,
MonadCatch m)
=> Maybe Text -> Tree OpmlOutline -> m ()
importOPML' _ (Node (OpmlOutlineGeneric b _) sub) = mapM_ (importOPML' (Just .
toNullable $ OPML.text b)) sub
importOPML' c (Node (OpmlOutlineSubscription _ s) _) = subscribe (xmlUri s) c
importOPML' _ _ = return ()
+getFeed :: (MonadIO m, MonadCatch m, MonadFree f m, HttpClientF :<: f, LoggerF
:<: f, XmlParserF :<: f)
+ => FeedID -> m Feed
+getFeed (FeedID uri) = HTTP.get uri >>= parseXml uri
+
+
-- * Boxes
putBox :: (Orientation a, MonadIO m) => Box a -> m ()
@@ -202,6 +206,6 @@
statusTableToBox t = tableByColumns $ Rainbox.intersperse sep $ fromList
[col1, col2, col3] where
result = sortBy (comparing fst) $ Map.toList t
col1 = fromList $ cell "# UNREAD" : map (cell . either (const "?") show .
snd) result
- col2 = fromList $ cell "STATUS" : map (cell . either (fromString .
displayException) (const "OK") . snd) result
+ col2 = fromList $ cell "STATUS" : map (cell . either (const "ERROR") (const
"OK") . snd) result
col3 = fromList $ cell "FEED" : map (cell . show . pretty . fst) result
sep = fromList [separator mempty 2]
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Database/FeedTable.hs
new/imm-1.2.0.0/src/lib/Imm/Database/FeedTable.hs
--- old/imm-1.1.0.0/src/lib/Imm/Database/FeedTable.hs 2016-10-01
00:18:43.000000000 +0200
+++ new/imm-1.2.0.0/src/lib/Imm/Database/FeedTable.hs 2017-03-19
10:26:16.000000000 +0100
@@ -95,19 +95,19 @@
-- * Primitives
-register :: (MonadThrow m, LoggerF :<: f, DatabaseF' :<: f, Functor f,
MonadFree f m)
+register :: (MonadThrow m, LoggerF :<: f, DatabaseF' :<: f, MonadFree f m)
=> FeedID -> Text -> m ()
register feedID category = do
logInfo $ "Registering feed " <> magenta (pretty feedID) <> "..."
insert FeedTable feedID $ newDatabaseEntry feedID category
-getStatus :: (DatabaseF' :<: f, Functor f, MonadFree f m, MonadCatch m)
+getStatus :: (DatabaseF' :<: f, MonadFree f m, MonadCatch m)
=> FeedID -> m FeedStatus
getStatus feedID = handleAny (\_ -> return Unknown) $ do
result <- fmap Just (fetch FeedTable feedID) `catchAny` (\_ -> return
Nothing)
return $ maybe New LastUpdate $ entryLastCheck =<< result
-addReadHash :: (DatabaseF' :<: f, Functor f, MonadFree f m, MonadThrow m,
LoggerF :<: f)
+addReadHash :: (DatabaseF' :<: f, MonadFree f m, MonadThrow m, LoggerF :<: f)
=> FeedID -> Int -> m ()
addReadHash feedID hash = do
logDebug $ "Adding read hash: " <> pretty hash <> "..."
@@ -115,7 +115,7 @@
where f a = a { entryReadHashes = insertSet hash $ entryReadHashes a }
-- | Set the last check time to now
-markAsRead :: (MonadIO m, DatabaseF' :<: f, Functor f, MonadFree f m,
MonadThrow m, LoggerF :<: f)
+markAsRead :: (MonadIO m, DatabaseF' :<: f, MonadFree f m, MonadThrow m,
LoggerF :<: f)
=> FeedID -> m ()
markAsRead feedID = do
logDebug $ "Marking feed as read: " <> pretty feedID <> "..."
@@ -124,7 +124,7 @@
where f time a = a { entryLastCheck = Just time }
-- | Unset feed's last update and remove all read hashes
-markAsUnread :: (DatabaseF' :<: f, Functor f, MonadFree f m, MonadThrow m,
LoggerF :<: f)
+markAsUnread :: (DatabaseF' :<: f, MonadFree f m, MonadThrow m, LoggerF :<: f)
=> FeedID -> m ()
markAsUnread feedID = do
logInfo $ "Marking feed as unread: " <> show (pretty feedID) <> "..."
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Database/JsonFile.hs
new/imm-1.2.0.0/src/lib/Imm/Database/JsonFile.hs
--- old/imm-1.1.0.0/src/lib/Imm/Database/JsonFile.hs 2016-08-22
15:15:42.000000000 +0200
+++ new/imm-1.2.0.0/src/lib/Imm/Database/JsonFile.hs 2017-03-19
10:26:16.000000000 +0100
@@ -39,9 +39,9 @@
mkJsonFileDatabase :: (Table t) => FilePath -> JsonFileDatabase t
mkJsonFileDatabase file = JsonFileDatabase file mempty Empty
--- | Default database is stored in @$XDG_DATA_HOME\/imm\/feeds.json@
+-- | Default database is stored in @$XDG_CONFIG_HOME\/imm\/feeds.json@
defaultDatabase :: Table t => IO (JsonFileDatabase t)
-defaultDatabase = mkJsonFileDatabase <$> getXdgDirectory XdgData
"imm/feeds.json"
+defaultDatabase = mkJsonFileDatabase <$> getXdgDirectory XdgConfig
"imm/feeds.json"
data JsonException = UnableDecode
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Database.hs
new/imm-1.2.0.0/src/lib/Imm/Database.hs
--- old/imm-1.1.0.0/src/lib/Imm/Database.hs 2016-09-27 23:01:07.000000000
+0200
+++ new/imm-1.2.0.0/src/lib/Imm/Database.hs 2017-03-19 10:26:16.000000000
+0100
@@ -111,62 +111,62 @@
-- * Primitives
-describeDatabase :: (Functor f, MonadFree f m, DatabaseF t :<: f)
+describeDatabase :: (MonadFree f m, DatabaseF t :<: f)
=> t -> m Doc
describeDatabase t = liftF . inj $ Describe t id
-fetch :: (Functor f, MonadFree f m, DatabaseF t :<: f, Table t, MonadThrow m)
+fetch :: (MonadFree f m, DatabaseF t :<: f, Table t, MonadThrow m)
=> t -> Key t -> m (Entry t)
fetch t k = do
results <- liftF . inj $ FetchList t [k] id
result <- lookup k <$> liftE results
maybe (throwM $ NotFound t [k]) return result
-fetchList :: (Functor f, MonadFree f m, DatabaseF t :<: f, MonadThrow m)
+fetchList :: (MonadFree f m, DatabaseF t :<: f, MonadThrow m)
=> t -> [Key t] -> m (Map (Key t) (Entry t))
fetchList t k = do
result <- liftF . inj $ FetchList t k id
liftE result
-fetchAll :: (MonadThrow m, Functor f, MonadFree f m, DatabaseF t :<: f) => t
-> m (Map (Key t) (Entry t))
+fetchAll :: (MonadThrow m, MonadFree f m, DatabaseF t :<: f) => t -> m (Map
(Key t) (Entry t))
fetchAll t = do
result <- liftF . inj $ FetchAll t id
liftE result
-update :: (Functor f, MonadFree f m, DatabaseF t :<: f, MonadThrow m)
+update :: (MonadFree f m, DatabaseF t :<: f, MonadThrow m)
=> t -> Key t -> (Entry t -> Entry t) -> m ()
update t k f = do
result <- liftF . inj $ Update t k f id
liftE result
-insert :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f, DatabaseF t
:<: f)
+insert :: (MonadThrow m, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f)
=> t -> Key t -> Entry t -> m ()
insert t k v = insertList t [(k, v)]
-insertList :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f,
DatabaseF t :<: f)
+insertList :: (MonadThrow m, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f)
=> t -> [(Key t, Entry t)] -> m ()
insertList t i = do
logInfo $ "Inserting " <> yellow (pretty $ length i) <> " entries..."
result <- liftF . inj $ InsertList t i id
liftE result
-delete :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f, DatabaseF t
:<: f) => t -> Key t -> m ()
+delete :: (MonadThrow m, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f) => t
-> Key t -> m ()
delete t k = deleteList t [k]
-deleteList :: (MonadThrow m, Functor f, MonadFree f m, LoggerF :<: f,
DatabaseF t :<: f)
+deleteList :: (MonadThrow m, MonadFree f m, LoggerF :<: f, DatabaseF t :<: f)
=> t -> [Key t] -> m ()
deleteList t k = do
logInfo $ "Deleting " <> yellow (pretty $ length k) <> " entries..."
result <- liftF . inj $ DeleteList t k id
liftE result
-purge :: (MonadThrow m, Functor f, MonadFree f m, DatabaseF t :<: f, LoggerF
:<: f) => t -> m ()
+purge :: (MonadThrow m, MonadFree f m, DatabaseF t :<: f, LoggerF :<: f) => t
-> m ()
purge t = do
logInfo "Purging database..."
result <- liftF . inj $ Purge t id
liftE result
-commit :: (MonadThrow m, Functor f, MonadFree f m, DatabaseF t :<: f, LoggerF
:<: f) => t -> m ()
+commit :: (MonadThrow m, MonadFree f m, DatabaseF t :<: f, LoggerF :<: f) => t
-> m ()
commit t = do
logDebug "Committing database transaction..."
result <- liftF . inj $ Commit t id
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Feed.hs
new/imm-1.2.0.0/src/lib/Imm/Feed.hs
--- old/imm-1.1.0.0/src/lib/Imm/Feed.hs 2016-10-09 14:19:07.000000000 +0200
+++ new/imm-1.2.0.0/src/lib/Imm/Feed.hs 2017-03-19 10:26:16.000000000 +0100
@@ -7,7 +7,6 @@
import Imm.Pretty
import Data.Hashable
-import Data.NonNull
import Data.Time
import Text.Atom.Types
@@ -57,3 +56,10 @@
<> [hash $ itemTitle item]
<> [hash $ itemDescription item]
getHashes (AtomElement entry) = [hash $ entryId entry, (hash :: String -> Int)
$ show $ prettyAtomText $ entryTitle entry]
+
+
+-- * Misc
+
+prettyElement :: FeedElement -> Doc
+prettyElement (RssElement item) = prettyItem item
+prettyElement (AtomElement entry) = prettyEntry entry
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/HTTP.hs
new/imm-1.2.0.0/src/lib/Imm/HTTP.hs
--- old/imm-1.1.0.0/src/lib/Imm/HTTP.hs 2016-09-27 23:51:58.000000000 +0200
+++ new/imm-1.2.0.0/src/lib/Imm/HTTP.hs 2017-03-19 10:26:16.000000000 +0100
@@ -40,7 +40,7 @@
-- * Primitives
-- | Perform an HTTP GET request
-get :: (MonadFree f m, Functor f, HttpClientF :<: f, LoggerF :<: f, MonadThrow
m)
+get :: (MonadFree f m, HttpClientF :<: f, LoggerF :<: f, MonadThrow m)
=> URI -> m LByteString
get uri = do
logDebug $ "Fetching " <> prettyURI uri
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Hooks/WriteFile.hs
new/imm-1.2.0.0/src/lib/Imm/Hooks/WriteFile.hs
--- old/imm-1.1.0.0/src/lib/Imm/Hooks/WriteFile.hs 2016-10-16
22:24:40.000000000 +0200
+++ new/imm-1.2.0.0/src/lib/Imm/Hooks/WriteFile.hs 2017-03-19
10:26:16.000000000 +0100
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -11,7 +12,9 @@
import Imm.Prelude
import Imm.Pretty
-import Data.Monoid.Textual hiding (map)
+import Control.Arrow
+
+import Data.Monoid.Textual hiding (elem, map)
import qualified Data.Text.Lazy as Text
import Data.Time
@@ -19,9 +22,10 @@
import System.FilePath
import Text.Atom.Types
-import qualified Text.Blaze as Blaze
import Text.Blaze.Html.Renderer.Text
-import Text.Blaze.Html5 as H hiding (map)
+import Text.Blaze.Html5 (Html, docTypeHtml,
+ preEscapedToHtml, (!))
+import qualified Text.Blaze.Html5 as H hiding (map)
import Text.Blaze.Html5.Attributes as H (charset, href)
import Text.RSS.Types
@@ -57,9 +61,12 @@
defaultFilePath :: FilePath -> Feed -> FeedElement -> FilePath
defaultFilePath root feed element = makeValid $ root </> feedTitle </>
fileName <.> "html" where
date = maybe "" (formatTime defaultTimeLocale "%F-") $ getDate element
- fileName = date <> convertText (sanitizePath $ getTitle element)
- feedTitle = convertText $ sanitizePath $ getFeedTitle feed
- sanitizePath = intercalate "-" . split isPathSeparator
+ fileName = date <> sanitize (convertText $ getTitle element)
+ feedTitle = sanitize $ convertText $ getFeedTitle feed
+ sanitize = replaceIf isPathSeparator '-' >>> replaceAny ".?!#" '_'
+ replaceAny :: [Char] -> Char -> String -> String
+ replaceAny list = replaceIf (`elem` list)
+ replaceIf f b = map (\c -> if f c then b else c)
-- | Generate an HTML page, with a title, a header and an article that
contains the feed element
defaultFileContent :: Feed -> FeedElement -> ByteString
@@ -67,9 +74,9 @@
H.head $ do
H.meta ! H.charset "utf-8"
H.title $ convertText $ getFeedTitle feed <> " | " <> getTitle element
- body $ do
+ H.body $ do
H.h1 $ convertText $ getFeedTitle feed
- article $ do
+ H.article $ do
defaultHeader feed element
defaultBody feed element
@@ -78,29 +85,29 @@
-- | Generate an HTML @<header>@ for a given feed element
defaultHeader :: Feed -> FeedElement -> Html
-defaultHeader _ element@(RssElement item) = header $ do
+defaultHeader _ element@(RssElement item) = H.header $ do
H.h2 $ maybe id (\uri -> H.a ! H.href uri) link $ convertText $ getTitle
element
- unless (null author) $ address $ "Published by " >> convertText author
- forM_ (itemPubDate item) $ \date -> p $ " on " >> time (convertDoc $
prettyTime date)
+ 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) = header $ do
+defaultHeader _ element@(AtomElement entry) = H.header $ do
H.h2 $ convertText $ getTitle element
- address $ do
+ H.address $ do
"Published by "
forM_ (entryAuthors entry) $ \author -> do
convertDoc $ prettyPerson author
", "
- p $ "on " >> time (convertDoc $ prettyTime $ entryUpdated entry)
+ H.p $ "on " >> H.time (convertDoc $ prettyTime $ entryUpdated entry)
-- | Generate the HTML content for a given feed element
defaultBody :: Feed -> FeedElement -> Html
-defaultBody _ (RssElement item) = p $ preEscapedToHtml $ itemDescription item
+defaultBody _ (RssElement item) = H.p $ preEscapedToHtml $ itemDescription item
defaultBody _ (AtomElement entry) = do
- unless (null links) $ p $ do
+ unless (null links) $ H.p $ do
"Related links:"
H.ul $ forM_ links $ \uri -> H.li (H.a ! H.href (convertAtomURI uri) $
convertAtomURI uri)
- p $ preEscapedToHtml $ fromMaybe "<empty>" $ content <|> summary
+ H.p $ preEscapedToHtml $ fromMaybe "<empty>" $ content <|> summary
where links = map linkHref $ entryLinks entry
content = show . prettyAtomContent <$> entryContent entry :: Maybe Text
summary = show . prettyAtomText <$> entrySummary entry :: Maybe Text
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Hooks.hs
new/imm-1.2.0.0/src/lib/Imm/Hooks.hs
--- old/imm-1.1.0.0/src/lib/Imm/Hooks.hs 2016-08-21 10:48:44.000000000
+0200
+++ new/imm-1.2.0.0/src/lib/Imm/Hooks.hs 2017-03-19 10:26:16.000000000
+0100
@@ -37,7 +37,7 @@
-- * Primitives
-onNewElement :: (Functor f, MonadFree f m, LoggerF :<: f, HooksF :<: f) =>
Feed -> FeedElement -> m ()
+onNewElement :: (MonadFree f m, LoggerF :<: f, HooksF :<: f) => Feed ->
FeedElement -> m ()
onNewElement feed element = do
logDebug $ "Unread element:" <+> textual (getTitle element)
liftF . inj $ OnNewElement feed element ()
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Logger.hs
new/imm-1.2.0.0/src/lib/Imm/Logger.hs
--- old/imm-1.1.0.0/src/lib/Imm/Logger.hs 2016-10-23 17:50:25.000000000
+0200
+++ new/imm-1.2.0.0/src/lib/Imm/Logger.hs 2017-03-19 10:26:16.000000000
+0100
@@ -64,24 +64,24 @@
-- * Primitives
-log :: (Functor f, MonadFree f m, LoggerF :<: f) => LogLevel -> Doc -> m ()
+log :: (MonadFree f m, LoggerF :<: f) => LogLevel -> Doc -> m ()
log level message = liftF . inj $ Log level message ()
-getLogLevel :: (Functor f, MonadFree f m, LoggerF :<: f) => m LogLevel
+getLogLevel :: (MonadFree f m, LoggerF :<: f) => m LogLevel
getLogLevel = liftF . inj $ GetLevel id
-setLogLevel :: (Functor f, MonadFree f m, LoggerF :<: f) => LogLevel -> m ()
+setLogLevel :: (MonadFree f m, LoggerF :<: f) => LogLevel -> m ()
setLogLevel level = liftF . inj $ SetLevel level ()
-setColorizeLogs :: (Functor f, MonadFree f m, LoggerF :<: f) => Bool -> m ()
+setColorizeLogs :: (MonadFree f m, LoggerF :<: f) => Bool -> m ()
setColorizeLogs colorize = liftF . inj $ SetColorize colorize ()
-flushLogs :: (Functor f, MonadFree f m, LoggerF :<: f) => m ()
+flushLogs :: (MonadFree f m, LoggerF :<: f) => m ()
flushLogs = liftF . inj $ Flush ()
-- * Helpers
-logDebug, logInfo, logWarning, logError :: (Functor f, MonadFree f m, LoggerF
:<: f) => Doc -> m ()
+logDebug, logInfo, logWarning, logError :: (MonadFree f m, LoggerF :<: f) =>
Doc -> m ()
logDebug = log Debug
logInfo = log Info
logWarning = log Warning
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Options.hs
new/imm-1.2.0.0/src/lib/Imm/Options.hs
--- old/imm-1.1.0.0/src/lib/Imm/Options.hs 2016-10-12 20:21:56.000000000
+0200
+++ new/imm-1.2.0.0/src/lib/Imm/Options.hs 2017-03-19 10:26:16.000000000
+0100
@@ -68,7 +68,7 @@
-- ++ catMaybes [("CONFIG=" ++) <$> opts^.configurationLabel_]
parseOptions :: (MonadIO m) => m CliOptions
-parseOptions = io $ customExecParser (defaultPrefs {- noBacktrack -} ) (info
parser $ progDesc "Fetch elements from RSS/Atom feeds and execute arbitrary
actions for each of them.")
+parseOptions = io $ customExecParser (prefs noBacktrack) (info parser $
progDesc "Convert items from RSS/Atom feeds to mails.")
where parser = helper <*> optional dyreMasterBinary *> optional dyreDebug *>
cliOptions
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Prelude.hs
new/imm-1.2.0.0/src/lib/Imm/Prelude.hs
--- old/imm-1.1.0.0/src/lib/Imm/Prelude.hs 2016-10-23 19:10:49.000000000
+0200
+++ new/imm-1.2.0.0/src/lib/Imm/Prelude.hs 2017-03-19 10:26:16.000000000
+0100
@@ -45,7 +45,7 @@
import Data.Tagged
import qualified Data.Text as T (Text ())
import qualified Data.Text.Lazy as LT (Text ())
-import Data.Traversable as X (forM)
+import Data.Traversable as X (for, forM)
import Data.Typeable as X
import qualified GHC.Show as Show
@@ -81,13 +81,13 @@
infixr 0 :::
-- | Right-associative tuple data-constructor
-(>:) :: a -> b -> (a,b)
-(>:) a b = (a, b)
-infixr 0 >:
-
-(*:*) :: (Functor f, Functor g) => (a -> f a) -> (b -> g b) -> (a, b) ->
Product f g (a, b)
-(*:*) f g (a,b) = Pair ((,b) <$> f a) ((a,) <$> g b)
-infixr 0 *:*
+(+:) :: a -> b -> (a,b)
+(+:) a b = (a, b)
+infixr 0 +:
+
+(*:) :: (Functor f, Functor g) => (a -> f a) -> (b -> g b) -> (a, b) ->
Product f g (a, b)
+(*:) f g (a,b) = Pair ((,b) <$> f a) ((a,) <$> g b)
+infixr 0 *:
data HLeft
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/Pretty.hs
new/imm-1.2.0.0/src/lib/Imm/Pretty.hs
--- old/imm-1.1.0.0/src/lib/Imm/Pretty.hs 2016-08-23 01:04:31.000000000
+0200
+++ new/imm-1.2.0.0/src/lib/Imm/Pretty.hs 2017-03-19 10:26:16.000000000
+0100
@@ -16,7 +16,8 @@
import Text.Atom.Types as Atom
-- import Text.OPML.Types as OPML hiding (text)
-- import qualified Text.OPML.Types as OPML
-import Text.PrettyPrint.ANSI.Leijen as X hiding ((<$>), (</>), (<>))
+import Text.PrettyPrint.ANSI.Leijen as X hiding (sep, width, (<$>),
+ (</>), (<>))
import Text.RSS.Types as RSS
import URI.ByteString
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/XML/Simple.hs
new/imm-1.2.0.0/src/lib/Imm/XML/Simple.hs
--- old/imm-1.1.0.0/src/lib/Imm/XML/Simple.hs 1970-01-01 01:00:00.000000000
+0100
+++ new/imm-1.2.0.0/src/lib/Imm/XML/Simple.hs 2017-03-19 10:26:16.000000000
+0100
@@ -0,0 +1,37 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Simple interpreter to parse XML into 'Feed', based on 'Conduit'.
+module Imm.XML.Simple where
+
+-- {{{ Imports
+import Imm.Feed
+import Imm.Prelude
+import Imm.XML
+
+import Control.Monad
+import Control.Monad.Fix
+
+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
+
+import URI.ByteString
+-- }}}
+
+-- | A 'Conduit' to alter the raw XML before feeding it to the parser,
depending on the feed 'URI'
+type PreProcess m = URI -> Conduit Event m Event
+
+-- | Interpreter for 'XmlParserF'
+mkCoXmlParser :: (MonadIO m, MonadCatch m) => PreProcess m -> CoXmlParserF m
(PreProcess m)
+mkCoXmlParser preProcess = CoXmlParserF coParse where
+ coParse uri bytestring = handleAny (\e -> return (Left e, preProcess)) $ do
+ result <- runConduit $ parseLBS def bytestring =$= preProcess uri =$=
force "Invalid feed" ((fmap Atom <$> atomFeed) `orE` (fmap Rss <$> rssDocument)
`orE` (fmap Rss <$> rss1Document))
+ return (Right result, preProcess)
+
+-- | Default pre-process always forwards all 'Event's
+defaultPreProcess :: Monad m => PreProcess m
+defaultPreProcess _ = fix $ \loop -> await >>= maybe (return ()) (yield >=>
const loop)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/imm-1.1.0.0/src/lib/Imm/XML.hs
new/imm-1.2.0.0/src/lib/Imm/XML.hs
--- old/imm-1.1.0.0/src/lib/Imm/XML.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/imm-1.2.0.0/src/lib/Imm/XML.hs 2017-03-19 10:26:16.000000000 +0100
@@ -0,0 +1,45 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TypeOperators #-}
+-- | DSL/interpreter model for parsing XML into a 'Feed'
+module Imm.XML where
+
+-- {{{ Imports
+import Imm.Error
+import Imm.Feed
+import Imm.Prelude
+
+import Control.Monad.Trans.Free
+
+import URI.ByteString
+-- }}}
+
+-- * Types
+
+-- | XML parsing DSL
+data XmlParserF next
+ = ParseXml URI LByteString (Either SomeException Feed -> next)
+ deriving(Functor)
+
+-- | XML parsing interpreter
+newtype CoXmlParserF m a = CoXmlParserF
+ { parseXmlH :: URI -> LByteString -> m (Either SomeException Feed, a)
+ } deriving(Functor)
+
+instance Monad m => PairingM (CoXmlParserF m) XmlParserF m where
+ -- pairM :: (a -> b -> m r) -> f a -> g b -> m r
+ pairM f (CoXmlParserF p) (ParseXml uri bytestring next) = do
+ (result, a) <- p uri bytestring
+ f a $ next result
+
+-- * Primitives
+
+-- | Parse XML into a 'Feed'
+parseXml :: (MonadFree f m, XmlParserF :<: f, MonadThrow m)
+ => URI -> LByteString -> m Feed
+parseXml uri bytestring = do
+ result <- liftF . inj $ ParseXml uri bytestring id
+ liftE result
