imm 1.1.0.0 → 1.2.0.0

raw patch · 17 files changed

+220/−107 lines, 17 filesdep +xml-typesdep ~rss-conduitdep ~xml-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: xml-types

Dependency ranges changed: rss-conduit, xml-conduit

API changes (from Hackage documentation)

Files

• imm.cabal +5/−3
• src/bin/Executable.hs +7/−7
• src/lib/Imm/Boot.hs +24/−13
• src/lib/Imm/Core.hs +35/−31
• src/lib/Imm/Database.hs +11/−11
• src/lib/Imm/Database/FeedTable.hs +5/−5
• src/lib/Imm/Database/JsonFile.hs +2/−2
• src/lib/Imm/Feed.hs +7/−1
• src/lib/Imm/HTTP.hs +1/−1
• src/lib/Imm/Hooks.hs +1/−1
• src/lib/Imm/Hooks/WriteFile.hs +24/−17
• src/lib/Imm/Logger.hs +6/−6
• src/lib/Imm/Options.hs +1/−1
• src/lib/Imm/Prelude.hs +7/−7
• src/lib/Imm/Pretty.hs +2/−1
• src/lib/Imm/XML.hs +45/−0
• src/lib/Imm/XML/Simple.hs +37/−0

@@ -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 <koral@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

@@ -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)

@@ -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

@@ -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]

@@ -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

@@ -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) <> "..."

@@ -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

@@ -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

@@ -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

@@ -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 ()

@@ -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

@@ -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

@@ -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  

@@ -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 >:+(+:) :: 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 *:*+(*:) :: (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

@@ -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

@@ -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

@@ -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)