aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorFélix Sipma <felix.sipma@no-log.org>2018-12-12 22:34:24 +0100
committerFélix Sipma <felix.sipma@no-log.org>2018-12-12 22:34:24 +0100
commitb792bff950b2ebc6ed2123cac86ad21ac95ffb35 (patch)
treebeae694b334750242bfef2703a05efd737dfa30c
parent73e3108ec8cdd69e3fc8e3f03d221720646d0488 (diff)
upgrade stackage to lts-12.22
-rw-r--r--perfeed.cabal5
-rw-r--r--src/Config/FileConfig.hs12
-rw-r--r--src/Config/InternalConfig.hs21
-rw-r--r--src/DB.hs6
-rw-r--r--src/Run.hs6
-rw-r--r--stack.yaml2
6 files changed, 23 insertions, 29 deletions
diff --git a/perfeed.cabal b/perfeed.cabal
index 72f196c..84d92fe 100644
--- a/perfeed.cabal
+++ b/perfeed.cabal
@@ -50,7 +50,7 @@ library
, pandoc >= 2.0
, path
, persistent
- , persistent-sqlite
+ , persistent-sqlite >= 2.8
, persistent-template
, process
, protolude >= 0.1.10
@@ -61,8 +61,9 @@ library
, time >= 1.5
, transformers
, unix
+ , unliftio-core
, xml-conduit >= 1.3.0
- , yaml
+ , yaml >= 0.8
default-language: Haskell2010
default-extensions: NoImplicitPrelude
if flag(dev)
diff --git a/src/Config/FileConfig.hs b/src/Config/FileConfig.hs
index c9cbf33..c268950 100644
--- a/src/Config/FileConfig.hs
+++ b/src/Config/FileConfig.hs
@@ -5,7 +5,6 @@ module Config.FileConfig
) where
import Protolude
-import GHC.Show (Show(..))
import qualified Data.Yaml as Y
import qualified Data.ByteString.Char8 as BS
import Data.Aeson
@@ -33,13 +32,6 @@ instance FromJSON FileConfig where
parseJSON _ = mzero
-data ParseConfigError = ParseConfigError FilePath
-
-instance Show ParseConfigError where
- show (ParseConfigError fp) = toS ("ParseConfigError: Could not parse config file \"" <> fp <> "\"")
-
-instance Exception ParseConfigError
-
instance ToJSON FileConfig where
toJSON (FileConfig mdb minfos mafrom mato mtlength) = object (jdb ++ jinfos ++ jafrom ++ jato ++ jtlength)
where
@@ -58,9 +50,7 @@ parseConfigFile p = fileConfigToInternalConfig <$> parseConfigFile' p
parseConfigFile' :: Path Abs File -> IO FileConfig
parseConfigFile' config = do
content <- BS.readFile fpConfig
- case (Y.decode content :: Maybe FileConfig) of
- Nothing -> throwIO (ParseConfigError fpConfig)
- Just c -> return c
+ Y.decodeThrow content
where
fpConfig = toFilePath config
diff --git a/src/Config/InternalConfig.hs b/src/Config/InternalConfig.hs
index e23fc97..8e28ef5 100644
--- a/src/Config/InternalConfig.hs
+++ b/src/Config/InternalConfig.hs
@@ -34,6 +34,17 @@ data InternalConfig = InternalConfig
, internalConfigLogLevel :: !(Maybe LogLevel)
}
+instance Semigroup InternalConfig where
+ (<>) l r = InternalConfig
+ { internalConfigFile = internalConfigFile l <|> internalConfigFile r
+ , internalConfigDatabase = internalConfigDatabase l <|> internalConfigDatabase r
+ , internalConfigFeedInfos = internalConfigFeedInfos l <|> internalConfigFeedInfos r
+ , internalConfigAddressFrom = internalConfigAddressFrom l <|> internalConfigAddressFrom r
+ , internalConfigAddressTo = internalConfigAddressTo l <|> internalConfigAddressTo r
+ , internalConfigTopicLength = internalConfigTopicLength l <|> internalConfigTopicLength r
+ , internalConfigLogLevel = internalConfigLogLevel l <|> internalConfigLogLevel r
+ }
+
instance Monoid InternalConfig where
mempty = InternalConfig
{ internalConfigFile = Nothing
@@ -44,15 +55,7 @@ instance Monoid InternalConfig where
, internalConfigTopicLength = Nothing
, internalConfigLogLevel = Nothing
}
- mappend l r = InternalConfig
- { internalConfigFile = internalConfigFile l <|> internalConfigFile r
- , internalConfigDatabase = internalConfigDatabase l <|> internalConfigDatabase r
- , internalConfigFeedInfos = internalConfigFeedInfos l <|> internalConfigFeedInfos r
- , internalConfigAddressFrom = internalConfigAddressFrom l <|> internalConfigAddressFrom r
- , internalConfigAddressTo = internalConfigAddressTo l <|> internalConfigAddressTo r
- , internalConfigTopicLength = internalConfigTopicLength l <|> internalConfigTopicLength r
- , internalConfigLogLevel = internalConfigLogLevel l <|> internalConfigLogLevel r
- }
+ mappend l r = l <> r
mkInternalConfig :: InternalConfig
mkInternalConfig = InternalConfig Nothing Nothing Nothing Nothing Nothing Nothing Nothing
diff --git a/src/DB.hs b/src/DB.hs
index 77b097d..9d72600 100644
--- a/src/DB.hs
+++ b/src/DB.hs
@@ -13,7 +13,7 @@ import Protolude
import Database.Persist.Sqlite
import Database.Persist.TH
import Data.Time.Clock ( UTCTime )
-import Control.Monad.Trans.Resource ( MonadBaseControl )
+import Control.Monad.IO.Unlift ( MonadUnliftIO )
import Control.Monad.Logger ( MonadLogger )
import Types hiding ( Feed (..) )
import Path
@@ -30,10 +30,10 @@ Feed
deriving Show
|]
-runDB :: (MonadIO m, MonadBaseControl IO m, Control.Monad.Logger.MonadLogger m) => Database -> SqlPersistT m a -> m a
+runDB :: (MonadIO m, MonadUnliftIO m, Control.Monad.Logger.MonadLogger m) => Database -> SqlPersistT m a -> m a
runDB database query = do
pool <- createSqlitePool (toS $ toFilePath database) openConnectionCount
runSqlPool query pool
-init :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => Database -> m ()
+init :: (MonadIO m, MonadUnliftIO m, MonadLogger m) => Database -> m ()
init database = runDB database $ runMigration migrateAll
diff --git a/src/Run.hs b/src/Run.hs
index 269bb20..e83a9a8 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -20,7 +20,7 @@ import Control.Monad.Logger ( MonadLogger, logError,
runStderrLoggingT,
filterLogger, logDebug
)
-import Control.Monad.Trans.Resource ( MonadBaseControl )
+import Control.Monad.IO.Unlift ( MonadUnliftIO )
import Network.HTTP.Conduit ( newManager, tlsManagerSettings, Manager )
import Types
import Config
@@ -33,12 +33,12 @@ import RSS1
import Filter
-checkFeeds :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => Maybe Database -> (Feed -> [Entry] -> m ()) -> [FeedInfo] -> m ()
+checkFeeds :: (MonadIO m, MonadUnliftIO m, MonadLogger m) => Maybe Database -> (Feed -> [Entry] -> m ()) -> [FeedInfo] -> m ()
checkFeeds mdb manageEntries infos = do
manager <- liftIO $ newManager tlsManagerSettings
mapM_ (\i -> checkFeed manager mdb manageEntries (feedInfoUrl i) (feedInfoFilter i)) infos
-checkFeed :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => Manager -> Maybe Database -> (Feed -> [Entry] -> m ()) -> Url -> [FeedFilter] -> m ()
+checkFeed :: (MonadIO m, MonadUnliftIO m, MonadLogger m) => Manager -> Maybe Database -> (Feed -> [Entry] -> m ()) -> Url -> [FeedFilter] -> m ()
checkFeed manager mdb manageEntries url filters = do
mcursor <- cursorFromUrl manager url filters
case mcursor of
diff --git a/stack.yaml b/stack.yaml
index 77fdfef..eeec6d2 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -2,4 +2,4 @@ flags: {}
packages:
- '.'
extra-deps: []
-resolver: lts-10.5
+resolver: lts-12.22