aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--app/Devel.hs22
-rw-r--r--app/Main.hs23
-rw-r--r--perfeed.cabal6
-rw-r--r--src/Atom.hs21
-rw-r--r--src/Config.hs5
-rw-r--r--src/Config/CmdConfig.hs1
-rw-r--r--src/Config/FileConfig.hs6
-rw-r--r--src/Config/InternalConfig.hs2
-rw-r--r--src/Convert.hs65
-rw-r--r--src/DB.hs7
-rw-r--r--src/Date.hs29
-rw-r--r--src/Email.hs31
-rw-r--r--src/Filter.hs40
-rw-r--r--src/Parse.hs36
-rw-r--r--src/RSS.hs21
-rw-r--r--src/RSS1.hs19
-rw-r--r--src/Run.hs41
-rw-r--r--src/Types.hs29
18 files changed, 197 insertions, 207 deletions
diff --git a/app/Devel.hs b/app/Devel.hs
index ecd2550..75903dd 100644
--- a/app/Devel.hs
+++ b/app/Devel.hs
@@ -1,23 +1,7 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE OverloadedStrings #-}
module Main where
-import Control.Monad.Logger ( runStderrLoggingT, filterLogger
- , logDebug )
-import Email
-import Run
-import Config
-import Types
+import Run (develMain)
+
main :: IO ()
-main = do
- config <- getConfig
- initDirs config
- let from = getConfigAddressFrom config
- to = getConfigAddressTo config
- infos = getConfigFeedInfos config
- tlength = getConfigTopicLength config
- level = LevelDebug
- runStderrLoggingT $ filterLogger (\_ level' -> level' >= level) $ do
- $logDebug "DEBUG"
- checkFeeds Nothing (printFeedEntries from to tlength) infos
+main = develMain
diff --git a/app/Main.hs b/app/Main.hs
index 3b9c3c9..b279fa7 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,22 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Main where
+module Main (module Run) where
-import Control.Monad.Logger ( runStderrLoggingT, filterLogger )
-import Email
-import Run
-import qualified DB
-import Config
-
-main :: IO ()
-main = do
- config <- getConfig
- initDirs config
- let db = getConfigDatabase config
- from = getConfigAddressFrom config
- to = getConfigAddressTo config
- infos = getConfigFeedInfos config
- tlength = getConfigTopicLength config
- level = getConfigLogLevel config
- runStderrLoggingT $ filterLogger (\_ level' -> level' >= level) $ do
- DB.init db
- checkFeeds (Just db) (sendFeedEntries from to tlength) infos
+import Run (main)
diff --git a/perfeed.cabal b/perfeed.cabal
index ee00cbc..3dd06c9 100644
--- a/perfeed.cabal
+++ b/perfeed.cabal
@@ -53,6 +53,7 @@ library
, persistent-sqlite
, persistent-template
, process
+ , protolude >= 0.1.10
, resourcet
, template-haskell
, text
@@ -63,6 +64,7 @@ library
, xml-conduit >= 1.3.0
, yaml
default-language: Haskell2010
+ default-extensions: NoImplicitPrelude
if flag(dev)
cpp-options: -DDEVELOPMENT
ghc-options: -Wall -fwarn-tabs
@@ -74,10 +76,8 @@ executable perfeed
else
main-is: Main.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
+ build-depends: base >= 4.8 && < 5
, perfeed
- , monad-logger
- , text
default-language: Haskell2010
test-suite perfeed-test
diff --git a/src/Atom.hs b/src/Atom.hs
index a8424d7..611f265 100644
--- a/src/Atom.hs
+++ b/src/Atom.hs
@@ -4,13 +4,12 @@ module Atom
( parseAtomFeed
) where
+import Protolude
import Text.XML.Cursor
import Text.XML ( Name (..) )
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as B
+import qualified Data.Text.Lazy as TL
import Data.Maybe ( catMaybes, listToMaybe, isNothing )
import Data.Time.Clock ( UTCTime )
-import Control.Monad ( msum, when )
import Control.Monad.Logger ( MonadLogger, logWarn, logError )
import Text.Blaze ( toMarkup )
import Text.Blaze.Renderer.Text ( renderMarkup )
@@ -19,18 +18,18 @@ import Types
import Parse
-localNameFilter :: T.Text -> Axis
+localNameFilter :: Text -> Axis
localNameFilter ln = checkName (\name -> nameLocalName name == ln)
-parseFieldContent :: T.Text -> Cursor -> [T.Text]
+parseFieldContent :: Text -> Cursor -> [Text]
parseFieldContent field c = c $/ localNameFilter field &// content
-- | "id" is a required element
-parseId :: Cursor -> T.Text
+parseId :: Cursor -> Text
parseId = mconcat . parseFieldContent "id"
-- | "title" is a required element
-parseTitle :: Cursor -> T.Text
+parseTitle :: Cursor -> Text
parseTitle = mconcat . parseFieldContent "title"
-- | "updated" is a required element
@@ -67,14 +66,14 @@ parseContent' :: Cursor -> Maybe Content
parseContent' c = parseType (mconcat $ c $| attribute "type")
where
parseType t
- | t == "text" = Just $ TextContent $ B.fromChunks $ c $// content
+ | t == "text" = Just $ TextContent $ TL.fromChunks $ c $// content
| t == "html"
|| t == "xhtml"
|| t == "" = case c $/ xhtmlFilter of
- [] -> Just . HtmlContent . B.fromChunks $ c $/ content
- xs -> Just . HtmlContent $ foldr (B.append . managechildren . child) "" xs
+ [] -> Just . HtmlContent . TL.fromChunks $ c $/ content
+ xs -> Just . HtmlContent $ foldr ((<>) . managechildren . child) "" xs
| otherwise = Nothing
- managechildren = foldr (B.append . renderMarkup . toMarkup . node) ""
+ managechildren = foldr ((<>) . renderMarkup . toMarkup . node) ""
xhtmlFilter :: Axis
xhtmlFilter = checkName (\name -> nameNamespace name == Just "http://www.w3.org/1999/xhtml")
diff --git a/src/Config.hs b/src/Config.hs
index e06739c..241d37f 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -12,17 +12,16 @@ module Config
, getConfig
) where
+import Protolude
import Path
import System.Environment ( lookupEnv )
import Data.Maybe ( fromMaybe )
-import Control.Monad ( when )
import System.Directory ( doesFileExist
, doesDirectoryExist
, createDirectoryIfMissing
, getHomeDirectory
)
import System.Posix.User
-import qualified Data.Text as T
import Types
import Config.CmdConfig
import Config.FileConfig
@@ -108,7 +107,7 @@ defaultAddressFrom :: IO ConfigAddress
defaultAddressFrom = do
uid <- getRealUserID
uentry <- getUserEntryForID uid
- return $ ConfigAddress Nothing $ T.pack $ userName uentry ++ "@localhost"
+ return $ ConfigAddress Nothing $ toS (userName uentry) <> "@localhost"
defaultAddressTo :: IO ConfigAddress
defaultAddressTo = defaultAddressFrom
diff --git a/src/Config/CmdConfig.hs b/src/Config/CmdConfig.hs
index f58412a..d7f430f 100644
--- a/src/Config/CmdConfig.hs
+++ b/src/Config/CmdConfig.hs
@@ -4,6 +4,7 @@ module Config.CmdConfig
, cmdConfigToInternalConfig
) where
+import Protolude hiding ((<>))
import Options.Applicative
import Path
import Config.InternalConfig
diff --git a/src/Config/FileConfig.hs b/src/Config/FileConfig.hs
index e2e242f..c9cbf33 100644
--- a/src/Config/FileConfig.hs
+++ b/src/Config/FileConfig.hs
@@ -4,12 +4,12 @@ module Config.FileConfig
, writeInternalConfig
) where
-import Control.Exception (throwIO, Exception)
+import Protolude
+import GHC.Show (Show(..))
import qualified Data.Yaml as Y
import qualified Data.ByteString.Char8 as BS
import Data.Aeson
import Path
-import Control.Monad ( mzero )
import Config.InternalConfig
import Types
import Filter
@@ -36,7 +36,7 @@ instance FromJSON FileConfig where
data ParseConfigError = ParseConfigError FilePath
instance Show ParseConfigError where
- show (ParseConfigError fp) = "ParseConfigError: Could not parse config file \"" ++ fp ++ "\""
+ show (ParseConfigError fp) = toS ("ParseConfigError: Could not parse config file \"" <> fp <> "\"")
instance Exception ParseConfigError
diff --git a/src/Config/InternalConfig.hs b/src/Config/InternalConfig.hs
index 601997b..e23fc97 100644
--- a/src/Config/InternalConfig.hs
+++ b/src/Config/InternalConfig.hs
@@ -18,7 +18,7 @@ module Config.InternalConfig
, setLogLevel
) where
-import Control.Applicative ( (<|>) )
+import Protolude
import Path
import Types
import Filter
diff --git a/src/Convert.hs b/src/Convert.hs
index 6046f1c..3c12c9f 100644
--- a/src/Convert.hs
+++ b/src/Convert.hs
@@ -7,8 +7,7 @@ module Convert
, formatRichContent
) where
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as B
+import Protolude
import Text.Pandoc ( writeMarkdown, readHtml, def)
import Lucid
import Control.Monad.Logger ( MonadLogger, logError )
@@ -19,30 +18,30 @@ import Types ( Entry (..)
)
-htmlToText :: MonadLogger m => B.Text -> m B.Text
-htmlToText html = case readHtml def (B.unpack html) of
+htmlToText :: MonadLogger m => LText -> m LText
+htmlToText html = case readHtml def (toS html) of
Left err -> do
- $logError . T.pack $ show err
+ $logError (show err)
return ""
- Right p -> return . B.pack $ writeMarkdown def p
+ Right p -> return $ toS (writeMarkdown def p)
-contentToTextAsText :: MonadLogger m => Content -> m B.Text
+contentToTextAsText :: MonadLogger m => Content -> m LText
contentToTextAsText (TextContent t) = return t
contentToTextAsText (HtmlContent h) = htmlToText h
-contentToTextAsHtml:: Content -> B.Text
+contentToTextAsHtml:: Content -> LText
contentToTextAsHtml (TextContent t) = t
contentToTextAsHtml (HtmlContent h) = h
formatRichContent :: Entry -> Maybe Content -> Content
formatRichContent e (Just (HtmlContent c)) = HtmlContent $
- flip B.append c $ renderText $ do
+ flip (<>) c $ renderText $ do
formatId (entryId e)
formatAuthors (entryAuthors e)
formatLinks (entryLinks e)
where
- formatId :: T.Text -> Html ()
- formatId id' = h3_ $ toHtml $ "Id: " `T.append` id'
+ formatId :: Text -> Html ()
+ formatId id' = h3_ $ toHtml $ "Id: " <> id'
formatLinks :: [Link] -> Html ()
formatLinks = mapM_ formatLink
@@ -64,38 +63,38 @@ formatRichContent e (Just (HtmlContent c)) = HtmlContent $
maybe (toHtml $ personName p) withURI (personURI p)
maybe (return ()) withEmail (personEmail p)
where
- withEmail :: T.Text -> Html ()
- withEmail email = a_ [href_ $ "mailto:" `T.append` email] $
- toHtml $ "<" `T.append` email `T.append` ">"
+ withEmail :: Text -> Html ()
+ withEmail email = a_ [href_ $ "mailto:" <> email] $
+ toHtml $ "<" <> email <> ">"
- withURI :: T.Text -> Html ()
+ withURI :: Text -> Html ()
withURI uri = a_ [href_ uri] $ toHtml $ personName p
formatRichContent e (Just (TextContent c)) = TextContent $
- formatId (entryId e)
- `B.append` formatLinks (entryLinks e)
- `B.append` formatAuthors (entryAuthors e)
- `B.append` c
+ formatId (entryId e)
+ <> formatLinks (entryLinks e)
+ <> formatAuthors (entryAuthors e)
+ <> c
where
- formatId :: T.Text -> B.Text
- formatId id' = "Id: " `B.append` B.fromStrict id' `B.append` "\n"
+ formatId :: Text -> LText
+ formatId id' = "Id: " <> toS id' <> "\n"
- formatLinks :: [Link] -> B.Text
- formatLinks = foldr (flip B.append . formatLink) ""
+ formatLinks :: [Link] -> LText
+ formatLinks = foldr (flip (<>) . formatLink) ""
- formatLink :: Link -> B.Text
+ formatLink :: Link -> LText
formatLink l = "Link"
- `B.append` maybe "" (\r -> " (" `B.append` B.fromStrict r `B.append` ")") (linkRel l)
- `B.append` ": <" `B.append` B.fromStrict (linkHref l) `B.append` ">\n"
+ <> maybe "" (\r -> " (" <> toS r <> ")") (linkRel l)
+ <> ": <" <> toS (linkHref l) <> ">\n"
- formatAuthors :: [Person] -> B.Text
- formatAuthors = foldr (flip B.append . formatAuthor) ""
+ formatAuthors :: [Person] -> LText
+ formatAuthors = foldr (flip (<>) . formatAuthor) ""
- formatAuthor :: Person -> B.Text
+ formatAuthor :: Person -> LText
formatAuthor p = "Author: "
- `B.append` B.fromStrict (personName p)
- `B.append` maybe "" (\r -> " <" `B.append` B.fromStrict r `B.append` ">") (personEmail p)
- `B.append` maybe "" (B.append " @ " . B.fromStrict) (personURI p)
- `B.append` "\n"
+ <> toS (personName p)
+ <> maybe "" (\r -> " <" <> toS r <> ">") (personEmail p)
+ <> maybe "" ((<>) " @ " . toS) (personURI p)
+ <> "\n"
formatRichContent e Nothing = formatRichContent e (Just $ TextContent "")
diff --git a/src/DB.hs b/src/DB.hs
index 8f3bbdb..77b097d 100644
--- a/src/DB.hs
+++ b/src/DB.hs
@@ -9,11 +9,10 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module DB where
+import Protolude
import Database.Persist.Sqlite
import Database.Persist.TH
import Data.Time.Clock ( UTCTime )
-import Data.Text as T
-import Control.Monad.IO.Class ( MonadIO )
import Control.Monad.Trans.Resource ( MonadBaseControl )
import Control.Monad.Logger ( MonadLogger )
import Types hiding ( Feed (..) )
@@ -25,7 +24,7 @@ openConnectionCount = 10
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Feed
- ident T.Text
+ ident Text
updated UTCTime
UniqueFeed ident
deriving Show
@@ -33,7 +32,7 @@ Feed
runDB :: (MonadIO m, MonadBaseControl IO m, Control.Monad.Logger.MonadLogger m) => Database -> SqlPersistT m a -> m a
runDB database query = do
- pool <- createSqlitePool (T.pack $ toFilePath database) openConnectionCount
+ pool <- createSqlitePool (toS $ toFilePath database) openConnectionCount
runSqlPool query pool
init :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => Database -> m ()
diff --git a/src/Date.hs b/src/Date.hs
index f73aecb..509c536 100644
--- a/src/Date.hs
+++ b/src/Date.hs
@@ -10,39 +10,38 @@ module Date
, formatRfc822
) where
-import qualified Data.Text as T
+import Protolude
import Data.Time.Format
import Data.Time.Clock ( UTCTime )
-import Control.Applicative ( (<|>) )
import Control.Monad.Logger ( MonadLogger, logError )
-parseRfc822 :: T.Text -> Maybe UTCTime
-parseRfc822 = parseTimeM True defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" . T.unpack
+parseRfc822 :: Text -> Maybe UTCTime
+parseRfc822 = parseTimeM True defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" . toS
-parseRfc822' :: T.Text -> Maybe UTCTime
-parseRfc822' = parseTimeM True defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" . T.unpack
+parseRfc822' :: Text -> Maybe UTCTime
+parseRfc822' = parseTimeM True defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" . toS
-parseW3 :: T.Text -> Maybe UTCTime
+parseW3 :: Text -> Maybe UTCTime
parseW3 t = parseTimeM True defaultTimeLocale "%FT%X%z" s
<|> parseTimeM True defaultTimeLocale "%FT%X%Z" s
where
- s = T.unpack t
+ s = toS t
-parseW3Rfc822' :: T.Text -> Maybe UTCTime
+parseW3Rfc822' :: Text -> Maybe UTCTime
parseW3Rfc822' t = parseW3 t <|> parseRfc822 t <|> parseRfc822' t
-parseW3Rfc822 :: MonadLogger m => T.Text -> m (Maybe UTCTime)
+parseW3Rfc822 :: MonadLogger m => Text -> m (Maybe UTCTime)
parseW3Rfc822 t = case parseW3Rfc822' t of
Nothing -> do
- $logError $ "Can't parse date: " `T.append` t
+ $logError $ "Can't parse date: " <> t
return Nothing
Just d -> return $ Just d
-- | Format a 'UTCTime' in W3 format.
-formatW3 :: UTCTime -> T.Text
-formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"
+formatW3 :: UTCTime -> Text
+formatW3 = toS . formatTime defaultTimeLocale "%FT%X-00:00"
-- | Format as per RFC 822.
-formatRfc822 :: UTCTime -> T.Text
-formatRfc822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
+formatRfc822 :: UTCTime -> Text
+formatRfc822 = toS . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
diff --git a/src/Email.hs b/src/Email.hs
index a0b9174..89e361f 100644
--- a/src/Email.hs
+++ b/src/Email.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Email
@@ -9,12 +10,10 @@ module Email
, printFeedEntries
) where
+import Protolude
import Network.Mail.Mime
-import qualified Data.ByteString.Lazy as B
import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
import Data.Text.Manipulate ( toPascal, toTrain )
-import Control.Monad.IO.Class ( MonadIO, liftIO )
import Control.Monad.Logger ( MonadLogger, logWarn )
import Types
import Date
@@ -25,11 +24,11 @@ configAddressToAddress :: ConfigAddress -> Address
configAddressToAddress (ConfigAddress name email) = Address name email
entryToMail :: MonadLogger m => ConfigAddress -> ConfigAddress -> Int -> Feed -> Entry -> m Mail
-entryToMail from to tlength f e = do
+entryToMail from' to' tlength f e = do
ps <- parts (entryContent e)
return Mail
- { mailFrom = configAddressToAddress from
- , mailTo = [configAddressToAddress to]
+ { mailFrom = configAddressToAddress from'
+ , mailTo = [configAddressToAddress to']
, mailCc = []
, mailBcc = []
, mailHeaders =
@@ -49,17 +48,17 @@ entryToMail from to tlength f e = do
, formatFieldContent $ linkHref l
)
where
- formatFieldName mrel = TE.encodeUtf8 $
- "X-Perfeed-EntryLink" `T.append` maybe "" (\r -> "-" `T.append` toPascal r) mrel
- formatFieldContent l = "<" `T.append` l `T.append` ">"
+ formatFieldName mrel = toS $
+ "X-Perfeed-EntryLink" <> maybe "" (\r -> "-" <> toPascal r) mrel
+ formatFieldContent l = "<" <> l <> ">"
authorHeaders = map $ \a ->
( "X-Perfeed-EntryAuthor"
- , escapeHeader $ personName a `T.append` formatEmail (personEmail a) `T.append` formatURI (personURI a)
+ , escapeHeader $ personName a <> formatEmail (personEmail a) <> formatURI (personURI a)
)
where
- formatEmail = maybe "" (\u -> " <" `T.append` u `T.append` ">")
- formatURI = maybe "" (\u -> " [" `T.append` u `T.append` "]")
+ formatEmail = maybe "" (\u -> " <" <> u <> ">")
+ formatURI = maybe "" (\u -> " [" <> u <> "]")
parts Nothing = do
-- work around Network.Mime.Mail error with empty parts
@@ -75,13 +74,13 @@ entryToMail from to tlength f e = do
parts (Just (TextContent content)) = return [ [ plainPart content ] ]
topic _ "" s = s
- topic l t s = "[" `T.append` short t `T.append` "] " `T.append` s
+ topic l t s = "[" <> short t <> "] " <> s
where
short t'
| T.length t <= l = t'
- | otherwise = T.take (l - 1) t' `T.append` "…"
+ | otherwise = T.take (l - 1) t' <> "…"
-escapeHeader :: T.Text -> T.Text
+escapeHeader :: Text -> Text
escapeHeader = T.strip . T.intercalate " - " . T.lines
mapFeedEntries :: MonadLogger m => ConfigAddress -> ConfigAddress -> Int -> Feed -> (Mail -> m ()) -> [Entry] -> m ()
@@ -101,4 +100,4 @@ sendMail :: MonadIO m => Mail -> m ()
sendMail = liftIO . renderSendMail
printMail :: MonadIO m => Mail -> m ()
-printMail m = liftIO $ B.putStr =<< renderMail' m
+printMail m = liftIO $ putStr =<< renderMail' m
diff --git a/src/Filter.hs b/src/Filter.hs
index f854a45..a7f48eb 100644
--- a/src/Filter.hs
+++ b/src/Filter.hs
@@ -11,17 +11,16 @@ module Filter
, isCursorFilter
) where
-import Control.Applicative ( (<|>) )
+import Protolude
import Data.Aeson
-import Control.Monad ( mzero, void, foldM, unless )
+import Data.String ( words, unwords )
import Text.XML.Cursor ( Cursor )
-import qualified Data.Text as T
import qualified Control.Exception as E
import System.Process ( createProcess, proc, std_in, std_out, std_err, StdStream (..), waitForProcess )
import System.IO ( hClose )
import Control.Concurrent ( forkIO, putMVar, takeMVar, newEmptyMVar )
-import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString as B
import System.Exit ( ExitCode (..) )
import Data.List ( partition )
import Control.Monad.IO.Class ( MonadIO, liftIO )
@@ -29,13 +28,14 @@ import Control.Monad.Logger ( MonadLogger, logError )
import Types
-getCursorFilter :: T.Text -> FeedFilter
-getCursorFilter "id" = CursorFilter "id" id
-getCursorFilter s = error $ "UnKnown filter: " ++ T.unpack s
+getCursorFilter :: Text -> FeedFilter
+getCursorFilter "id" = CursorFilter "id" identity
+getCursorFilter s = error $ "UnKnown filter: i" <> s
+-- ^ TODO: remove error
data FeedFilter
- = CursorFilter T.Text (Cursor -> Cursor)
- | ExternalFilter FilePath [String]
+ = CursorFilter Text (Cursor -> Cursor)
+ | ExternalFilter FilePath [[Char]]
instance FromJSON FeedFilter where
parseJSON (Object o) =
@@ -43,7 +43,7 @@ instance FromJSON FeedFilter where
<|> parseExternalFilter <$> o .: "external"
parseJSON _ = mzero
-parseExternalFilter :: String -> FeedFilter
+parseExternalFilter :: [Char] -> FeedFilter
parseExternalFilter s = case words s of
[] -> ExternalFilter "" []
(c : opts) -> ExternalFilter (c :: FilePath) opts
@@ -85,13 +85,13 @@ applyCursorFilters fs c = foldr applyCursorFilter c fs
applyCursorFilter (CursorFilter _ f) c' = f c'
applyCursorFilter _ c' = c'
-applyExternalFilters :: (MonadIO m, MonadLogger m) => [FeedFilter] -> L.ByteString -> m (Maybe L.ByteString)
+applyExternalFilters :: (MonadIO m, MonadLogger m) => [FeedFilter] -> LBS.ByteString -> m (Maybe LBS.ByteString)
applyExternalFilters fs lbs = foldM (\ms f -> maybe (return Nothing) (applyExternalFilter f) ms) (Just lbs) fs
where
applyExternalFilter (ExternalFilter fp opts) lbs' = applyExternalFilter' fp opts lbs'
applyExternalFilter (CursorFilter _ _) lbs' = return $ Just lbs'
-applyExternalFilter' :: (MonadIO m, MonadLogger m) => FilePath -> [String] -> L.ByteString -> m (Maybe L.ByteString)
+applyExternalFilter' :: (MonadIO m, MonadLogger m) => FilePath -> [[Char]] -> LBS.ByteString -> m (Maybe LBS.ByteString)
applyExternalFilter' fp opts lbs = do
(Just hin, mHOut, mHErr, phandle) <- liftIO $ createProcess (proc fp opts)
{ std_in = CreatePipe
@@ -101,26 +101,26 @@ applyExternalFilter' fp opts lbs = do
errMVar <- liftIO newEmptyMVar
outMVar <- liftIO newEmptyMVar
eresult <- liftIO $
- (Right <$> L.hPut hin lbs) `E.catch` \(ex :: E.IOException) -> return $ Left ex
+ (Right <$> LBS.hPut hin lbs) `E.catch` \(ex :: E.IOException) -> return $ Left ex
case eresult of
Right _ -> return ()
- Left ex -> $logError $ "external filter \"" `T.append` T.pack fp `T.append` T.pack (unwords opts) `T.append` "\" failed: " `T.append` T.pack (show ex)
+ Left ex -> $logError $ "external filter \"" <> toS fp <> toS (unwords opts) <> "\" failed: " <> show ex
liftIO $ hClose hin
case (mHOut, mHErr) of
(Nothing, Nothing) -> return ()
(Just hOut, Just hErr) -> do
- void . liftIO . forkIO $ S.hGetContents hOut >>= putMVar outMVar
- void . liftIO . forkIO $ S.hGetContents hErr >>= putMVar errMVar
+ void . liftIO . forkIO $ B.hGetContents hOut >>= putMVar outMVar
+ void . liftIO . forkIO $ B.hGetContents hErr >>= putMVar errMVar
_ -> $logError "error in applyExternalFilter: missing a handle"
exitCode <- liftIO $ waitForProcess phandle
errOutput <- liftIO $ takeMVar errMVar
case exitCode of
ExitSuccess -> do
outOutput <- liftIO $ takeMVar outMVar
- unless (S.null errOutput) ($logWarnB errOutput)
- return $ Just (L.fromStrict outOutput)
+ unless (B.null errOutput) ($logWarnB errOutput)
+ return $ Just (toS outOutput)
_ -> do
- $logError $ T.pack ("external filter \"" ++ fp ++ "\" exited with error code " ++ show exitCode)
+ $logError $ "external filter \"" <> toS fp <> "\" exited with error code " <> show exitCode
$logErrorB errOutput
return Nothing
diff --git a/src/Parse.hs b/src/Parse.hs
index 9efcdb1..72df6ae 100644
--- a/src/Parse.hs
+++ b/src/Parse.hs
@@ -11,7 +11,7 @@ module Parse
, formatParseFeedUpdatedError
) where
-import Prelude hiding ( readFile )
+import Protolude hiding ( readFile )
import Control.Monad.IO.Class ( MonadIO, liftIO )
import Text.XML
import Text.XML.Cursor
@@ -24,10 +24,10 @@ import Types
import Filter
-escapeHref :: T.Text -> T.Text
+escapeHref :: Text -> Text
escapeHref = T.strip . T.intercalate "" . T.lines
-cursorFromFile :: (MonadIO m, MonadLogger m) => FilePath -> m Cursor
+cursorFromFile :: MonadIO m => FilePath -> m Cursor
cursorFromFile file = do
doc <- liftIO $ readFile parseSettings file
return $ fromDocument doc
@@ -35,14 +35,14 @@ cursorFromFile file = do
cursorFromUrl :: (MonadIO m, MonadLogger m) => Manager -> Url -> [FeedFilter] -> m (Maybe Cursor)
cursorFromUrl manager u filters = do
let (cursorfilters, externalfilters) = partitionFilters filters
- request <- liftIO $ parseRequest $ T.unpack u
+ request <- liftIO $ parseRequest $ toS u
eresponse <- liftIO $ try (httpLbs request manager)
case eresponse of
Right res -> do
mbody <- applyExternalFilters externalfilters (responseBody res)
maybe eFilterError (eFilterSuccess cursorfilters) mbody
Left (e :: HttpException) -> do
- $logError $ formatHttpError u (T.pack (show e))
+ $logError $ formatHttpError u (show e)
-- ^ TODO: store failed feed and do not log again if failing again
return Nothing
where
@@ -51,28 +51,28 @@ cursorFromUrl manager u filters = do
return Nothing
eFilterSuccess cfilters body = case parseLBS parseSettings body of
Left exception -> do
- $logError $ formatParseXmlError u (T.pack (show exception))
+ $logError $ formatParseXmlError u (show exception)
return Nothing
Right doc -> return $ Just (applyCursorFilters cfilters (fromDocument doc))
parseSettings :: ParseSettings
parseSettings = def { psDecodeEntities = decodeHtmlEntities, psRetainNamespaces = False }
-formatFilterError :: T.Text -> T.Text
-formatFilterError url = "cannot apply external filters for url \"" `T.append` url `T.append` "\""
+formatFilterError :: Text -> Text
+formatFilterError url = "cannot apply external filters for url \"" <> url <> "\""
-formatParseXmlError :: T.Text -> T.Text -> T.Text
-formatParseXmlError url exception = "cannot get an XML structure from page \"" `T.append` url `T.append` "\": " `T.append` exception
+formatParseXmlError :: Text -> Text -> Text
+formatParseXmlError url exception = "cannot get an XML structure from page \"" <> url <> "\": " <> exception
-formatHttpError :: T.Text -> T.Text -> T.Text
-formatHttpError url exception = "HTTP error while fetching \"" `T.append` url `T.append` "\": " `T.append` exception
+formatHttpError :: Text -> Text -> Text
+formatHttpError url exception = "HTTP error while fetching \"" <> url <> "\": " <> exception
-- ^ TODO: improve formatting (use getResponseStatusCode, ...)
-formatContentEmptyError :: T.Text -> T.Text -> T.Text
-formatContentEmptyError id' title = "empty content for entry \"" `T.append` title `T.append` "\" (" `T.append` id' `T.append` ")"
+formatContentEmptyError :: Text -> Text -> Text
+formatContentEmptyError id' title = "empty content for entry \"" <> title <> "\" (" <> id' <> ")"
-formatParseEntryUpdatedError :: T.Text -> T.Text -> T.Text
-formatParseEntryUpdatedError id' title = "parse updated field failed for entry \"" `T.append` title `T.append` "\" (" `T.append` id' `T.append` ")"
+formatParseEntryUpdatedError :: Text -> Text -> Text
+formatParseEntryUpdatedError id' title = "parse updated field failed for entry \"" <> title <> "\" (" <> id' <> ")"
-formatParseFeedUpdatedError :: T.Text -> T.Text -> T.Text
-formatParseFeedUpdatedError id' title = "parse updated field failed for feed \"" `T.append` title `T.append` "\" (" `T.append` id' `T.append` ")"
+formatParseFeedUpdatedError :: Text -> Text -> Text
+formatParseFeedUpdatedError id' title = "parse updated field failed for feed \"" <> title <> "\" (" <> id' <> ")"
diff --git a/src/RSS.hs b/src/RSS.hs
index 131b640..a7f242c 100644
--- a/src/RSS.hs
+++ b/src/RSS.hs
@@ -4,29 +4,29 @@ module RSS
( parseRSSFeed
) where
+import Protolude
import Text.XML.Cursor
import Text.XML ( Name (..) )
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as B
+import qualified Data.Text.Lazy as TL
import Data.Maybe ( catMaybes, listToMaybe, isNothing )
-import Data.Time.Clock ( UTCTime )
-import Control.Monad ( msum, when )
+import Data.Time.Clock ( UTCTime (..) )
+import Data.Time.Format ( ParseTime (..), defaultTimeLocale )
import Control.Monad.Logger ( MonadLogger, logWarn, logError )
import Date
import Types
import Parse
-localNameFilter :: T.Text -> Axis
+localNameFilter :: Text -> Axis
localNameFilter ln = checkName (\name -> nameLocalName name == ln)
-parseFieldContent :: T.Text -> Cursor -> [T.Text]
+parseFieldContent :: Text -> Cursor -> [Text]
parseFieldContent field c = c $/ localNameFilter field &// content
-parseId :: Cursor -> T.Text
+parseId :: Cursor -> Text
parseId = mconcat . parseFieldContent "guid"
-parseTitle :: Cursor -> T.Text
+parseTitle :: Cursor -> Text
parseTitle c =
mconcat (parseFieldContent "title" c)
`mappend` mconcat (c $/ element "{http://purl.org/dc/elements/1.1/}subject" &// content)
@@ -34,7 +34,8 @@ parseTitle c =
parseUpdated :: MonadLogger m => [Entry] -> Cursor -> m (Maybe UTCTime)
parseUpdated e c = case mconcat $ parseFieldContent "lastBuildDate" c of
"" -> case e of
- [] -> return (Just $ read "1970-01-01 00:00:00 UTC")
+ [] -> return (buildTime defaultTimeLocale [])
+ -- ^ Just 1970-01-01 00:00:00 UTC
_ -> case map entryUpdated e of
[] -> return Nothing
us -> return (Just $ maximum us)
@@ -70,7 +71,7 @@ parseEntryAuthors c =
`mappend` (c $/ element "{http://purl.org/dc/elements/1.1/}creator" &| parsePerson)
parseContent' :: Cursor -> Maybe Content
-parseContent' c = Just . HtmlContent . B.fromChunks $ c $// content
+parseContent' c = Just . HtmlContent . TL.fromChunks $ c $// content
parseContent :: Cursor -> Maybe Content
parseContent c = msum $
diff --git a/src/RSS1.hs b/src/RSS1.hs
index 27e0254..7974b7c 100644
--- a/src/RSS1.hs
+++ b/src/RSS1.hs
@@ -4,29 +4,29 @@ module RSS1
( parseRSS1Feed
) where
+import Protolude
import Text.XML.Cursor
import Text.XML ( Name (..) )
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as B
+import qualified Data.Text.Lazy as TL
import Data.Maybe ( catMaybes, listToMaybe, isNothing )
import Data.Time.Clock ( UTCTime )
-import Control.Monad ( msum, when )
+import Data.Time.Format ( ParseTime (..), defaultTimeLocale )
import Control.Monad.Logger ( MonadLogger, logWarn, logError )
import Date
import Types
import Parse
-localNameFilter :: T.Text -> Axis
+localNameFilter :: Text -> Axis
localNameFilter ln = checkName (\name -> nameLocalName name == ln)
-parseFieldContent :: T.Text -> Cursor -> [T.Text]
+parseFieldContent :: Text -> Cursor -> [Text]
parseFieldContent field c = c $/ localNameFilter field &// content
-parseId :: Cursor -> T.Text
+parseId :: Cursor -> Text
parseId = mconcat . parseFieldContent "guid"
-parseTitle :: Cursor -> T.Text
+parseTitle :: Cursor -> Text
parseTitle c =
mconcat (parseFieldContent "title" c)
`mappend` mconcat (c $/ element "{http://purl.org/dc/elements/1.1/}subject" &// content)
@@ -34,7 +34,8 @@ parseTitle c =
parseUpdated :: MonadLogger m => [Entry] -> Cursor -> m (Maybe UTCTime)
parseUpdated e c = case mconcat $ parseFieldContent "lastBuildDate" c of
"" -> case e of
- [] -> return (Just $ read "1970-01-01 00:00:00 UTC")
+ [] -> return (buildTime defaultTimeLocale [])
+ -- ^ Just 1970-01-01 00:00:00 UTC
_ -> case map entryUpdated e of
[] -> return Nothing
us -> return (Just $ maximum us)
@@ -70,7 +71,7 @@ parseEntryAuthors c =
`mappend` (c $/ element "{http://purl.org/dc/elements/1.1/}creator" &| parsePerson)
parseContent' :: Cursor -> Maybe Content
-parseContent' c = Just . HtmlContent . B.fromChunks $ c $// content
+parseContent' c = Just . HtmlContent . TL.fromChunks $ c $// content
parseContent :: Cursor -> Maybe Content
parseContent c = msum $
diff --git a/src/Run.hs b/src/Run.hs
index e8188dd..269bb20 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -5,24 +5,28 @@ module Run
( checkFeed
, checkFeeds
, initDirs
+ , main
+ , develMain
) where
-import qualified Data.Text as T
+import Protolude
import Database.Persist
-import Control.Monad ( when, void, msum )
import Path
import System.Directory ( doesFileExist
, doesDirectoryExist
, createDirectoryIfMissing
)
-import Control.Monad.Logger ( MonadLogger, logError )
+import Control.Monad.Logger ( MonadLogger, logError,
+ runStderrLoggingT,
+ filterLogger, logDebug
+ )
import Control.Monad.Trans.Resource ( MonadBaseControl )
-import Control.Monad.IO.Class ( MonadIO, liftIO )
import Network.HTTP.Conduit ( newManager, tlsManagerSettings, Manager )
import Types
import Config
import Parse
import qualified DB
+import Email
import Atom
import RSS
import RSS1
@@ -46,7 +50,7 @@ checkFeed manager mdb manageEntries url filters = do
Just database -> maybe noFeed (yesFeed database) mfeed
where
noFeed = do
- $logError $ "cannot parse feed from url " `T.append` url
+ $logError $ "cannot parse feed from url " <> url
return ()
yesFeed database feed = do
mfeedDB <- DB.runDB database $ getBy $ DB.UniqueFeed $ feedId feed
@@ -74,3 +78,30 @@ initDirs config = do
configfile = toFilePath pconfigfile
configdir = toFilePath $ parent pconfigfile
datadir = toFilePath $ parent $ getConfigDatabase config
+
+main :: IO ()
+main = do
+ config <- getConfig
+ initDirs config
+ let db = getConfigDatabase config
+ from' = getConfigAddressFrom config
+ to' = getConfigAddressTo config
+ infos = getConfigFeedInfos config
+ tlength = getConfigTopicLength config
+ level = getConfigLogLevel config
+ runStderrLoggingT $ filterLogger (\_ level' -> level' >= level) $ do
+ DB.init db
+ checkFeeds (Just db) (sendFeedEntries from' to' tlength) infos
+
+develMain :: IO ()
+develMain = do
+ config <- getConfig
+ initDirs config
+ let from' = getConfigAddressFrom config
+ to' = getConfigAddressTo config
+ infos = getConfigFeedInfos config
+ tlength = getConfigTopicLength config
+ level = LevelDebug
+ runStderrLoggingT $ filterLogger (\_ level' -> level' >= level) $ do
+ $logDebug "DEBUG"
+ checkFeeds Nothing (printFeedEntries from' to' tlength) infos
diff --git a/src/Types.hs b/src/Types.hs
index 07b3791..709ae79 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -16,12 +16,10 @@ module Types
, logDebugB
) where
-import qualified Data.Text as T
+import Protolude hiding ( lift )
import Path
import Data.Aeson
-import Control.Monad ( mzero )
import Data.Time.Clock ( UTCTime )
-import qualified Data.Text.Lazy as B
import Control.Monad.Logger ( LogLevel (..)
, monadLoggerLog
, liftLoc
@@ -29,13 +27,12 @@ import Control.Monad.Logger ( LogLevel (..)
import Language.Haskell.TH.Syntax ( Lift (lift), Q, Exp
, qLocation
)
-import qualified Data.ByteString as S
data Feed
= Feed
- { feedId :: !T.Text
- , feedTitle :: !T.Text
+ { feedId :: !Text
+ , feedTitle :: !Text
, feedUpdated :: !UTCTime
, feedAuthors :: ![Person]
, feedLinks :: ![Link]
@@ -45,8 +42,8 @@ data Feed
data Entry
= Entry
- { entryId :: !T.Text
- , entryTitle :: !T.Text
+ { entryId :: !Text
+ , entryTitle :: !Text
, entryUpdated :: !UTCTime
, entryAuthors :: ![Person]
, entryContent :: !(Maybe Content)
@@ -57,34 +54,34 @@ data Entry
data Link
= Link
{ linkHref :: !Url
- , linkRel :: !(Maybe T.Text)
+ , linkRel :: !(Maybe Text)
}
deriving (Show)
data Person
= Person
- { personName :: !T.Text
+ { personName :: !Text
, personURI :: !(Maybe Url)
, personEmail :: !(Maybe Email)
}
deriving (Show)
data Content
- = TextContent B.Text
- | HtmlContent B.Text
+ = TextContent LText
+ | HtmlContent LText
deriving (Show)
-- TODO: use data
-type Url = T.Text
+type Url = Text
-- TODO: use data
-type Email = T.Text
+type Email = Text
-- TODO: use data
type Database = Path Abs File
data ConfigAddress = ConfigAddress
- { _name :: !(Maybe T.Text)
+ { _name :: !(Maybe Text)
, _email :: !Email
}
deriving (Show)
@@ -104,7 +101,7 @@ instance ToJSON ConfigAddress where
logTHB :: LogLevel -> Q Exp
logTHB level =
- [|monadLoggerLog $(qLocation >>= liftLoc) "" $(lift level) . (id :: S.ByteString -> S.ByteString)|]
+ [|monadLoggerLog $(qLocation >>= liftLoc) "" $(lift level) . identity|]
logErrorB :: Q Exp
logErrorB = logTHB LevelError