diff --git a/imm.cabal b/imm.cabal --- a/imm.cabal +++ b/imm.cabal @@ -1,5 +1,5 @@ name: imm -version: 1.4.0.0 +version: 1.5.0.0 synopsis: Execute arbitrary actions for each unread element of RSS/Atom feeds description: Cf README file homepage: https://github.com/k0ral/imm @@ -33,7 +33,6 @@ Imm.HTTP.Simple Imm.Logger Imm.Logger.Simple - Imm.Prelude Imm.XML Imm.XML.Conduit other-modules: @@ -43,10 +42,11 @@ Imm.Options Imm.Pretty Paths_imm + Prelude build-depends: aeson, - atom-conduit >= 0.4, - base == 4.*, + atom-conduit >= 0.6, + base-noprelude == 4.*, blaze-html, blaze-markup, bytestring, @@ -64,19 +64,18 @@ http-client >= 0.4.30, http-client-tls, http-types, - lifted-base, microlens, mime-mail, - monad-control, monad-time, monoid-subclasses, - mono-traversable >= 1, mtl, network, - opml-conduit >= 0.6, + opml-conduit >= 0.7, optparse-applicative, prettyprinter, prettyprinter-ansi-terminal, + refined, + relude, rss-conduit >= 0.4.1, safe-exceptions, stm, diff --git a/src/bin/Executable.hs b/src/bin/Executable.hs --- a/src/bin/Executable.hs +++ b/src/bin/Executable.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} ---module Executable where +-- module Executable where -- {{{ Imports import Imm @@ -7,7 +6,6 @@ import Imm.Hooks.Dummy as Hooks import Imm.HTTP.Simple as HTTP import Imm.Logger.Simple as Logger -import Imm.Prelude import Imm.XML.Conduit as XML -- }}} diff --git a/src/lib/Imm/Aeson.hs b/src/lib/Imm/Aeson.hs --- a/src/lib/Imm/Aeson.hs +++ b/src/lib/Imm/Aeson.hs @@ -1,10 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} module Imm.Aeson where -- {{{ Imports -import Imm.Prelude - import Data.Aeson import URI.ByteString diff --git a/src/lib/Imm/Boot.hs b/src/lib/Imm/Boot.hs --- a/src/lib/Imm/Boot.hs +++ b/src/lib/Imm/Boot.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -- | @@ -22,21 +21,25 @@ 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 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.Prelude +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 Imm.XML as XML -import Data.Conduit.Combinators (stdin) -import System.IO (hFlush) +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. @@ -91,8 +94,8 @@ handleAny (log logger Error . pretty . displayException) $ case command of Check t -> Core.check logger database httpClient xmlParser =<< resolveTarget database ByPassConfirmation t - Help -> liftBase $ putStrLn helpString - Import -> Core.importOPML logger database stdin + 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 @@ -117,19 +120,19 @@ promptConfirm :: Text -> IO () promptConfirm s = do - putStr $ s <> " Confirm [Y/n] " + Text.putStr $ s <> " Confirm [Y/n] " hFlush stdout - x <- getLine - unless (null x || x == ("Y" :: Text)) $ throwM InterruptedException + x <- Text.getLine + unless (Text.null x || x == "Y") $ throwM InterruptedException -resolveTarget :: MonadBase IO m => MonadThrow m => Database.Handle m FeedTable -> SafeGuard -> Maybe Core.FeedRef -> m [FeedID] +resolveTarget :: MonadIO m => MonadThrow m => Database.Handle m FeedTable -> SafeGuard -> Maybe Core.FeedRef -> m [FeedID] resolveTarget database s Nothing = do - result <- keys <$> Database.fetchAll database - when (s == AskConfirmation) $ liftBase $ promptConfirm $ "This will affect " <> show (length result) <> " feeds." + 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 . (!! (i-1)) . mapToList <$> Database.fetchAll database + result <- fst . at (i-1) . Map.toList <$> Database.fetchAll database -- log logger Info $ "Target(s): " <> show (pretty result) - return $ singleton result + return [result] resolveTarget _ _ (Just (ByURI uri)) = return [FeedID uri] 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,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TupleSections #-} @@ -18,44 +17,41 @@ ) where -- {{{ Imports -import qualified Imm.Database as Database +import qualified Imm.Database as Database import Imm.Database.FeedTable -import qualified Imm.Database.FeedTable as Database +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.Prelude +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 Imm.XML as XML -import Control.Concurrent.STM (STM, atomically) -import Control.Concurrent.STM.TVar +import Control.Exception.Safe import Control.Monad.Time import Data.Conduit -import qualified Data.Map as Map -import Data.NonNull -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as Text +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 Streamly hiding ((<>)) -import qualified Streamly.Prelude as Stream +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 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-" <> Text.pack (showVersion Package.version) - putStrLn $ "compiled by " <> Text.pack compilerName <> "-" <> Text.pack (showVersion compilerVersion) + 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 () @@ -81,7 +77,7 @@ 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) + 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 @@ -123,7 +119,7 @@ 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) + 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 @@ -155,7 +151,7 @@ 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 $ null $ (setFromList (getHashes element) :: Set Int) `intersection` readHashes + let matchHash = not $ Set.null $ Set.fromList (getHashes element) `Set.intersection` readHashes matchDate = case (lastCheck, getDate element) of (Nothing, _) -> False (_, Nothing) -> False @@ -169,7 +165,7 @@ 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 . toNullable $ OPML.text b)) sub +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/lib/Imm/Database.hs b/src/lib/Imm/Database.hs --- a/src/lib/Imm/Database.hs +++ b/src/lib/Imm/Database.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} @@ -15,12 +14,12 @@ module Imm.Database where -- {{{ Imports -import qualified Imm.Logger as Logger -import Imm.Logger hiding(Handle) -import Imm.Prelude +import Imm.Logger hiding (Handle) +import qualified Imm.Logger as Logger import Imm.Pretty -import Data.Map (Map) +import Control.Exception.Safe hiding (handle) +import Data.Map (Map) -- }}} -- * Types @@ -34,13 +33,13 @@ data Handle m t = Handle { _describeDatabase :: forall a . m (Doc a) - , _fetchList :: [Key t] -> m (Map (Key t) (Entry t)) - , _fetchAll :: m (Map (Key t) (Entry t)) - , _update :: Key t -> (Entry t -> Entry t) -> m () - , _insertList :: [(Key t, Entry t)] -> m () - , _deleteList :: [Key t] -> m () - , _purge :: m () - , _commit :: m () + , _fetchList :: [Key t] -> m (Map (Key t) (Entry t)) + , _fetchAll :: m (Map (Key t) (Entry t)) + , _update :: Key t -> (Entry t -> Entry t) -> m () + , _insertList :: [(Key t, Entry t)] -> m () + , _deleteList :: [Key t] -> m () + , _purge :: m () + , _commit :: m () } 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,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -- | Feed table definitions. This is a specialization of "Imm.Database". @@ -7,14 +6,14 @@ -- {{{ Imports import Imm.Aeson -import Imm.Database as Database -import Imm.Logger as Logger -import Imm.Prelude +import Imm.Database as Database +import Imm.Logger as Logger import Imm.Pretty +import Control.Exception.Safe import Control.Monad.Time import Data.Aeson -import Data.Set (Set) +import qualified Data.Set as Set (insert) import Data.Time import URI.ByteString -- }}} @@ -110,7 +109,7 @@ addReadHash logger database feedID hash = do log logger Debug $ "Adding read hash:" <+> pretty hash <> "..." update database feedID f - where f a = a { entryReadHashes = insertSet hash $ entryReadHashes a } + where f a = a { entryReadHashes = Set.insert hash $ entryReadHashes a } -- | Set the last check time to now markAsRead :: (MonadTime m, MonadThrow m) diff --git a/src/lib/Imm/Database/JsonFile.hs b/src/lib/Imm/Database/JsonFile.hs --- a/src/lib/Imm/Database/JsonFile.hs +++ b/src/lib/Imm/Database/JsonFile.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} @@ -16,21 +15,20 @@ ) where -- {{{ Imports -import Imm.Database hiding (commit, delete, insert, - purge, update) +import Imm.Database hiding (commit, delete, insert, + purge, update) import Imm.Database.FeedTable import Imm.Error -import Imm.Prelude hiding (delete, keys) import Imm.Pretty -import Control.Concurrent.MVar.Lifted +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 +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 -- }}} @@ -47,10 +45,10 @@ mkJsonFileDatabase file = JsonFileDatabase file mempty Empty -- | Default database is stored in @$XDG_CONFIG_HOME\/imm\/feeds.json@ -defaultDatabase :: Table t => IO (MVar (JsonFileDatabase t)) +defaultDatabase :: Table t => IO (TVar (JsonFileDatabase t)) defaultDatabase = do databaseFile <- getXdgDirectory XdgConfig "imm/feeds.json" - newMVar $ mkJsonFileDatabase databaseFile + newTVarIO $ mkJsonFileDatabase databaseFile data JsonException = UnableDecode @@ -60,73 +58,65 @@ displayException _ = "Unable to parse JSON" -mkHandle :: (Table t, FromJSON (Key t), FromJSON (Entry t), ToJSON (Key t), ToJSON (Entry t), MonadBase IO m) - => MVar (JsonFileDatabase t) -> Handle m t -mkHandle mvar = Handle - { _describeDatabase = pretty <$> readMVar mvar - , _fetchList = \keys -> Map.filterWithKey (\uri _ -> member uri $ Set.fromList keys) <$> fetchAll_ - , _fetchAll = fetchAll_ - , _update = \key f -> liftBase $ modifyMVar_ mvar (\a -> update a key f) - , _insertList = liftBase . modifyMVar_ mvar . insert - , _deleteList = liftBase . modifyMVar_ mvar . delete - , _purge = liftBase $ modifyMVar_ mvar purge - , _commit = liftBase $ modifyMVar_ mvar commit +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 } - where fetchAll_ = liftBase $ modifyMVar mvar $ \database -> do - a@(JsonFileDatabase _ cache _) <- loadInCache database - return (a, cache) - -- * Low-level implementation -loadInCache :: (Table t, FromJSON (Key t), FromJSON (Entry t)) - => JsonFileDatabase t -> IO (JsonFileDatabase t) -loadInCache t@(JsonFileDatabase file _ status) = case status of - Empty -> do - createDirectoryIfMissing True $ takeDirectory file - fileContent <- withBinaryFile file ReadWriteMode (toLazy_ . hGetContents) - cache <- (`failWith` UnableDecode) $ fmap Map.fromList $ decode $ fromEmpty "[]" fileContent - return $ JsonFileDatabase file cache Clean - _ -> return t +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 -insert :: (Table t, FromJSON (Key t), FromJSON (Entry t)) - => [(Key t, Entry t)] -> JsonFileDatabase t -> IO (JsonFileDatabase t) -insert rows t = insertInCache rows <$> loadInCache t 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 - -update :: (Table t, FromJSON (Key t), FromJSON (Entry t)) - => JsonFileDatabase t -> Key t -> (Entry t -> Entry t) -> IO (JsonFileDatabase t) -update t key f = updateInCache key f <$> loadInCache t - 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 -delete :: (Table t, FromJSON (Key t), FromJSON (Entry t)) - => [Key t] -> JsonFileDatabase t -> IO (JsonFileDatabase t) -delete keys t = deleteInCache keys <$> loadInCache t - 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 -purge :: (Table t, FromJSON (Key t), FromJSON (Entry t)) - => JsonFileDatabase t -> IO (JsonFileDatabase t) -purge t = purgeInCache <$> loadInCache t - purgeInCache :: Table t => JsonFileDatabase t -> JsonFileDatabase t purgeInCache (JsonFileDatabase file _ _) = JsonFileDatabase file mempty Dirty -commit :: (ToJSON (Key t), ToJSON (Entry t)) - => JsonFileDatabase t -> IO (JsonFileDatabase t) -commit t@(JsonFileDatabase file cache status) = case status of - Dirty -> do - withFile file WriteMode $ \h -> hPut h $ encode $ Map.toList cache - return $ JsonFileDatabase file cache Clean - _ -> return t +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 --- a/src/lib/Imm/Dyre.hs +++ b/src/lib/Imm/Dyre.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -12,7 +11,6 @@ ) where -- {{{ Imports -import Imm.Prelude import Imm.Pretty import Config.Dyre diff --git a/src/lib/Imm/Error.hs b/src/lib/Imm/Error.hs --- a/src/lib/Imm/Error.hs +++ b/src/lib/Imm/Error.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} module Imm.Error (module Imm.Error) where -- {{{ Imports -import Imm.Prelude +import Control.Exception.Safe -- }}} liftE :: (MonadThrow m, Exception e) => Either e a -> m a 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,15 +1,14 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -- | Helpers to manipulate feeds module Imm.Feed where -- {{{ Imports -import Imm.Prelude import Imm.Pretty import Data.Hashable +import Data.Text as Text (null) import Data.Time import Lens.Micro import Text.Atom.Types @@ -56,7 +55,7 @@ getTitle (AtomElement entry) = show $ prettyAtomText $ entryTitle entry getContent :: FeedElement -> Text -getContent (RssElement item) = if not (null content) then content else itemDescription item where +getContent (RssElement item) = if not (Text.null content) then content else itemDescription item where ContentItem content = item ^. itemExtensionL getContent (AtomElement entry) = fromMaybe "" $ content <|> summary where content = show . prettyAtomContent <$> entryContent entry 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 @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | HTTP module abstracts over HTTP requests to the external world. -- @@ -12,7 +11,6 @@ -- {{{ Imports import qualified Imm.Logger as Logger import Imm.Logger hiding(Handle) -import Imm.Prelude import Imm.Pretty import URI.ByteString diff --git a/src/lib/Imm/HTTP/Simple.hs b/src/lib/Imm/HTTP/Simple.hs --- a/src/lib/Imm/HTTP/Simple.hs +++ b/src/lib/Imm/HTTP/Simple.hs @@ -1,15 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# 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.Prelude import Imm.Pretty +import Control.Exception.Safe import Data.CaseInsensitive import Network.Connection as Reexport import Network.HTTP.Client as Reexport diff --git a/src/lib/Imm/Hooks.hs b/src/lib/Imm/Hooks.hs --- a/src/lib/Imm/Hooks.hs +++ b/src/lib/Imm/Hooks.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Hooks module abstracts over the main behavior of the program. -- @@ -11,7 +10,6 @@ import Imm.Feed import qualified Imm.Logger as Logger import Imm.Logger hiding(Handle) -import Imm.Prelude import Imm.Pretty -- }}} diff --git a/src/lib/Imm/Hooks/Dummy.hs b/src/lib/Imm/Hooks/Dummy.hs --- a/src/lib/Imm/Hooks/Dummy.hs +++ b/src/lib/Imm/Hooks/Dummy.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Implementation of "Imm.Hooks" that does nothing, -- except suggesting the user to define proper hooks. @@ -8,9 +7,9 @@ -- {{{ Imports import Imm.Hooks -import Imm.Prelude import Control.Exception +import Control.Exception.Safe -- }}} data DummyHooks = DummyHooks diff --git a/src/lib/Imm/Hooks/SendMail.hs b/src/lib/Imm/Hooks/SendMail.hs --- a/src/lib/Imm/Hooks/SendMail.hs +++ b/src/lib/Imm/Hooks/SendMail.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# 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. @@ -21,20 +20,20 @@ -- > (Just $ Authentication PLAIN "user" "password") -- > (StartTls "smtp.server" defaultSettingsSMTPSTARTTLS) -- -module Imm.Hooks.SendMail (module Imm.Hooks.SendMail, module Reexport) where +module Imm.Hooks.SendMail (module Imm.Hooks.SendMail, module Imm.Hooks, module Reexport) where -- {{{ Imports import Imm.Feed import Imm.Hooks -import Imm.Prelude import Imm.Pretty -import Data.NonNull +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 -- }}} @@ -85,7 +84,7 @@ 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 = intercalate ", " $ map (toNullable . personName) $ entryAuthors entry <> feedAuthors feed + authors = Text.intercalate ", " $ map (unrefine . personName) $ entryAuthors entry <> feedAuthors feed defaultFormatFrom _ _ = Address (Just "Unknown") "" -- | Fill mail subject with the element title @@ -98,7 +97,7 @@ -- - 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) = "

" <> intercalate "
" links <> "

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

" +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 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 @@ -1,19 +1,16 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Implementation of "Imm.Hooks" that writes a file for each new RSS/Atom item. -module Imm.Hooks.WriteFile where +module Imm.Hooks.WriteFile (module Imm.Hooks.WriteFile, module Imm.Hooks) where -- {{{ Imports import Imm.Feed import Imm.Hooks -import Imm.Prelude import Imm.Pretty -import Control.Arrow import Data.ByteString.Builder import Data.ByteString.Streaming (toStreamingByteString) -import Data.Monoid.Textual hiding (elem, map) +import qualified Data.Text as Text (null, replace) import Data.Time import Streaming.With import System.Directory (createDirectoryIfMissing) @@ -23,7 +20,7 @@ import Text.Blaze.Html5 (Html, docTypeHtml, preEscapedToHtml, (!)) import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes as H (charset, href) +import qualified Text.Blaze.Html5.Attributes as H (charset, href) import Text.RSS.Types import URI.ByteString -- }}} @@ -54,14 +51,15 @@ -- | Generate a path @//-.html@, where @@ is the first argument defaultFilePath :: FilePath -> Feed -> FeedElement -> FilePath -defaultFilePath root feed element = makeValid $ root title fileName <.> "html" where +defaultFilePath root feed element = makeValid $ root toString title fileName <.> "html" where date = maybe "" (formatTime defaultTimeLocale "%F-") $ getDate element - fileName = date <> sanitize (convertText $ getTitle element) - title = sanitize $ convertText $ getFeedTitle feed - sanitize = replaceIf isPathSeparator '-' >>> replaceAny ".?!#" '_' - replaceAny :: String -> Char -> String -> String - replaceAny list = replaceIf (`elem` list) - replaceIf f b = map (\c -> if f c then b else c) + 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 @@ -87,7 +85,7 @@ 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 +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 " @@ -105,10 +103,12 @@ 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.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 @@ -117,7 +117,7 @@ convertURI = convertText . decodeUtf8 . serializeURIRef' convertText :: (IsString t) => Text -> t -convertText = fromString . toString (const "?") +convertText = fromString . toString convertDoc :: (IsString t) => Doc a -> t convertDoc = show diff --git a/src/lib/Imm/Logger.hs b/src/lib/Imm/Logger.hs --- a/src/lib/Imm/Logger.hs +++ b/src/lib/Imm/Logger.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Logger module abstracts over logging data. -- @@ -12,7 +11,6 @@ module Imm.Logger where -- {{{ Imports -import Imm.Prelude import Imm.Pretty -- }}} diff --git a/src/lib/Imm/Logger/Simple.hs b/src/lib/Imm/Logger/Simple.hs --- a/src/lib/Imm/Logger/Simple.hs +++ b/src/lib/Imm/Logger/Simple.hs @@ -1,52 +1,46 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -- | 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.Prelude import Imm.Pretty -import Control.Concurrent.MVar.Lifted -import Control.Monad.Trans.Control 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 :: LogLevel -- ^ Discard logs that are strictly less serious than this level - , _colorizeLogs :: Bool -- ^ Enable log colorisation + { _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 (MVar LoggerSettings) -defaultLogger = newMVar =<< LoggerSettings +defaultLogger :: IO LoggerSettings +defaultLogger = LoggerSettings <$> newStdoutLoggerSet defaultBufSize <*> newStderrLoggerSet defaultBufSize - <*> pure Info - <*> pure True + <*> newMVar Info + <*> newMVar True -mkHandle :: MonadBaseControl IO m => MVar LoggerSettings -> Handle m +mkHandle :: MonadIO m => LoggerSettings -> Handle m mkHandle settings = Handle { log = \l t -> do - s <- readMVar settings - let loggerSet = (if l == Error then _errorLoggerSet else _loggerSet) s - handleColor = (\c -> if c then id else unAnnotate) $ _colorizeLogs s - refLevel = _logLevel s - when (l >= refLevel) $ liftBase $ pushLogStrLn loggerSet $ toLogStr $ renderLazy $ layoutPretty defaultLayoutOptions $ handleColor t + 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 = _logLevel <$> readMVar settings - , setLogLevel = \level -> modifyMVar_ settings $ \s -> return (s { _logLevel = level }) - , setColorizeLogs = \value -> modifyMVar_ settings $ \s -> return (s { _colorizeLogs = value }) - , flushLogs = do - s <- readMVar settings - liftBase $ flushLogStr $ _loggerSet s - liftBase $ flushLogStr $ _errorLoggerSet s + , 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 --- a/src/lib/Imm/Options.hs +++ b/src/lib/Imm/Options.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} module Imm.Options where -- {{{ Imports @@ -9,7 +9,6 @@ import qualified Imm.Dyre as Dyre import Imm.Feed import Imm.Logger as Logger -import Imm.Prelude import Imm.Pretty import Data.Set (Set) @@ -141,7 +140,7 @@ -- {{{ Util uriReader :: ReadM URI -uriReader = eitherReader $ first show . parseURI laxURIParserOptions . encodeUtf8 . fromString +uriReader = eitherReader $ first show . parseURI laxURIParserOptions . encodeUtf8 @Text . fromString feedRefOption :: Parser FeedRef feedRefOption = argument ((ByUID <$> auto) <|> (ByURI <$> uriReader)) $ metavar "TARGET" diff --git a/src/lib/Imm/Prelude.hs b/src/lib/Imm/Prelude.hs deleted file mode 100644 --- a/src/lib/Imm/Prelude.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Imm.Prelude (module Imm.Prelude, module X) where - --- {{{ Imports -import Control.Applicative as X -import Control.Exception.Safe as X hiding(handle) -import Control.Monad as X (MonadPlus (..), unless, - void, when) -import Control.Monad.Base as X -import Control.Monad.IO.Class as X -import Control.Monad.Trans as X (lift) -import Data.Bifunctor as X -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_) -import Data.Maybe as X hiding (catMaybes) -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 qualified Data.Text as T (Text) -import Data.Text.IO as X (getLine, putStr, - putStrLn) -import qualified Data.Text.Lazy as LT (Text) -import Data.Traversable as X (for, forM) -import qualified GHC.Show as Show -import Prelude as X hiding (all, and, any, - break, concat, concatMap, - drop, dropWhile, elem, - filter, foldMap, foldr, - getLine, length, lines, - log, lookup, notElem, - null, or, product, - putStr, putStrLn, - readFile, replicate, - reverse, sequence_, show, - span, splitAt, sum, take, - takeWhile, unlines, - unwords, words, - writeFile) -import System.IO as X (IOMode (..), stderr, - stdout) --- }}} - --- * Shortcuts - -type LByteString = LB.ByteString -type ByteString = B.ByteString -type LText = LT.Text -type Text = T.Text - --- | Shortcut to 'liftIO' -io :: MonadIO m => IO a -> m a -io = liftIO - --- * Generalisation - --- | Generic 'Show.show' -show :: (Show a, IsString b) => a -> b -show = fromString . Show.show 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 @@ -1,13 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Imm.Pretty (module Imm.Pretty, module X) where -- {{{ Imports -import Imm.Prelude - -import Data.NonNull +import Data.Text as Text import Data.Time import Data.Tree @@ -20,6 +18,7 @@ import Data.Text.Prettyprint.Doc.Render.Terminal as X (AnsiStyle) import Data.Text.Prettyprint.Doc.Render.Terminal import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty +import Refined import Text.RSS.Types as RSS import URI.ByteString -- }}} @@ -61,8 +60,8 @@ -- pretty o = text "OPML" <+> pretty (opmlVersion o) <++> indent 2 (pretty (opmlHead o) <++> (vsep . map pretty $ opmlOutlines o)) prettyPerson :: AtomPerson -> Doc a -prettyPerson p = pretty (toNullable $ personName p) <> email where - email = if null $ personEmail p +prettyPerson p = pretty (unrefine $ personName p) <> email where + email = if Text.null $ personEmail p then mempty else space <> angles (pretty $ personEmail p) @@ -89,7 +88,7 @@ ) prettyURI :: URIRef a -> Doc b -prettyURI uri = pretty $ decodeUtf8 $ serializeURIRef' uri +prettyURI uri = pretty @Text $ decodeUtf8 $ serializeURIRef' uri prettyGuid :: RssGuid -> Doc a prettyGuid (GuidText t) = pretty t diff --git a/src/lib/Imm/XML.hs b/src/lib/Imm/XML.hs --- a/src/lib/Imm/XML.hs +++ b/src/lib/Imm/XML.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -- | XML module abstracts over the parsing of RSS/Atom feeds. -- -- This module follows the [Handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html). @@ -8,7 +7,6 @@ -- {{{ Imports import Imm.Feed -import Imm.Prelude import URI.ByteString -- }}} diff --git a/src/lib/Imm/XML/Conduit.hs b/src/lib/Imm/XML/Conduit.hs --- a/src/lib/Imm/XML/Conduit.hs +++ b/src/lib/Imm/XML/Conduit.hs @@ -1,22 +1,19 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# 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.Prelude import Imm.XML -import Control.Monad -import Control.Monad.Fix +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 +import Text.XML.Stream.Parse as XML import URI.ByteString -- }}} @@ -27,7 +24,7 @@ -- | '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 .| force "Invalid feed" ((fmap Atom <$> atomFeed) `orE` (fmap Rss <$> rssDocument) `orE` (fmap Rss <$> rss1Document)) + { 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 diff --git a/src/lib/Prelude.hs b/src/lib/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/lib/Prelude.hs @@ -0,0 +1,8 @@ +module Prelude (io, module Relude, module Relude.Extra.Map, module Control.Monad.Base) where + +import Relude hiding(Handle, force) +import Relude.Extra.Map (lookup) +import Control.Monad.Base + +io :: MonadIO m => IO a -> m a +io = liftIO