From 68ddceb5f11ad952572fed58deec3980d5b90d72 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 2 Oct 2018 16:00:04 +0200 Subject: [PATCH] Introduce smtpPool --- config/settings.yml | 13 +++++ ghci.sh | 2 +- package.yaml | 4 ++ src/Application.hs | 57 +++++++++++++++++----- src/Foundation.hs | 3 ++ src/Import/NoFoundation.hs | 2 + src/Settings.hs | 99 ++++++++++++++++++++++++++++++++++---- 7 files changed, 158 insertions(+), 22 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 84708ced3..46676454e 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -44,6 +44,19 @@ ldap: scope: "_env:LDAPSCOPE:WholeSubtree" timeout: "_env:LDAPTIMEOUT:5" +smtp: + host: "_env:SMTPHOST:" + port: "_env:SMTPPORT:25" + ssl: "_env:SMTPSSL:starttls" + auth: + type: "login" + user: "_env:SMTPUSER:" + pass: "_env:SMTPPASS:" + pool: + stripes: "_env:SMTPSTRIPES:1" + timeout: "_env:SMTPTIMEOUT:20" + limit: "_env:SMTPLIMIT:1" + user-defaults: max-favourites: 12 theme: Default diff --git a/ghci.sh b/ghci.sh index 5139c7c72..825a936f0 100755 --- a/ghci.sh +++ b/ghci.sh @@ -16,4 +16,4 @@ if [[ -d .stack-work-ghci ]]; then trap move-back EXIT fi -stack ghci --flag uniworx:dev --flag uniworx:library-only +stack ghci --flag uniworx:dev --flag uniworx:library-only ${@} diff --git a/package.yaml b/package.yaml index 6b28933e1..9311ef57d 100644 --- a/package.yaml +++ b/package.yaml @@ -95,6 +95,10 @@ dependencies: - universe-base - random-shuffle - th-abstraction +- HaskellNet +- HaskellNet-SSL +- network +- resource-pool # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Application.hs b/src/Application.hs index 931f53e3c..b15f11aab 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -22,7 +22,7 @@ module Application , addPWEntry ) where -import Control.Monad.Logger (liftLoc, runLoggingT) +import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..)) import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool) import Import @@ -54,6 +54,10 @@ import Yesod.Auth.Util.PasswordStore import qualified Data.ByteString.Lazy as LBS +import Network.HaskellNet.SSL hiding (Settings) +import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings) +import Data.Pool + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -102,27 +106,30 @@ makeFoundation appSettings@(AppSettings{..}) = do -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool = UniWorX {..} + let mkFoundation appConnPool appSmtpPool = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html - tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" + tempFoundation = mkFoundation (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation") logFunc = messageLoggerSource tempFoundation appLogger - flip runLoggingT logFunc . $(logDebugS) "InstanceID" $ UUID.toText appInstanceID + flip runLoggingT logFunc $ do + smtpPool <- traverse createSmtpPool appSmtpConf + + $logDebugS "InstanceID" $ UUID.toText appInstanceID - -- Create the database connection pool - pool <- flip runLoggingT logFunc $ createPostgresqlPool + -- Create the database connection pool + sqlPool <- createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) - -- Perform database migration using our application's logging settings. - flip runLoggingT logFunc $ runSqlPool migrateAll pool - - void . fork . handleJobs $ (mkFoundation pool) { appJobCtl = recvChan } + -- Perform database migration using our application's logging settings. + migrateAll `runSqlPool` sqlPool - -- Return the foundation - return $ mkFoundation pool + liftIO . void . fork . handleJobs $ (mkFoundation sqlPool smtpPool) { appJobCtl = recvChan } + + -- Return the foundation + return $ mkFoundation sqlPool smtpPool readInstanceIDFile :: FilePath -> IO UUID readInstanceIDFile idFile = handle generateInstead $ LBS.readFile idFile >>= parseBS @@ -138,6 +145,32 @@ readInstanceIDFile idFile = handle generateInstead $ LBS.readFile idFile >>= par return instanceId | otherwise = throw e +createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool +createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do + logFunc <- askLoggerIO + let + withLogging :: LoggingT IO a -> IO a + withLogging = flip runLoggingT logFunc + + mkConnection = withLogging $ do + $logInfoS "SMTP" "Opening new connection" + liftIO mkConnection' + mkConnection' + | SmtpSslNone <- smtpSsl = connectSMTPPort smtpHost smtpPort + | SmtpSslSmtps <- smtpSsl = connectSMTPSSLWithSettings smtpHost $ defaultSettingsWithPort smtpPort + | SmtpSslStarttls <- smtpSsl = connectSMTPSTARTTLSWithSettings smtpHost $ defaultSettingsWithPort smtpPort + reapConnection conn = withLogging $ do + $logDebugS "SMTP" "Closing connection" + liftIO $ closeSMTP conn + applyAuth :: SmtpAuthConf -> SMTPConnection -> IO SMTPConnection + applyAuth SmtpAuthConf{..} conn = withLogging $ do + $logDebugS "SMTP" "Doing authentication" + authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn + when (not authSuccess) $ do + fail "SMTP authentication failed" + return conn + liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit + -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. makeApplication :: UniWorX -> IO Application diff --git a/src/Foundation.hs b/src/Foundation.hs index fc6816487..6326a8d90 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -112,6 +112,7 @@ data UniWorX = UniWorX { appSettings :: AppSettings , appStatic :: Static -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appSmtpPool :: Maybe SMTPPool , appHttpManager :: Manager , appLogger :: Logger , appCryptoIDKey :: CryptoIDKey @@ -119,6 +120,8 @@ data UniWorX = UniWorX , appJobCtl :: TMChan JobCtl } +type SMTPPool = Pool SMTPConnection + -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://www.yesodweb.com/book/routing-and-handlers diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 8db4ec779..bef1d3ac9 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -25,3 +25,5 @@ import Text.Lucius as Import import Text.Shakespeare.Text as Import hiding (text, stext) import Data.Universe as Import +import Data.Pool as Import (Pool) +import Network.HaskellNet.SMTP as Import (SMTPConnection) diff --git a/src/Settings.hs b/src/Settings.hs index 0fa14a225..02421732f 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,9 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. @@ -15,7 +18,7 @@ module Settings where import ClassyPrelude.Yesod import qualified Control.Exception as Exception import Data.Aeson (Result (..), fromJSON, withObject, - (.!=), (.:?)) + (.!=), (.:?), withScientific) import qualified Data.Aeson.Types as Aeson import Data.Aeson.TH import Data.FileEmbed (embedFile) @@ -29,6 +32,12 @@ import Yesod.Default.Util (WidgetFileSettings, widgetFileReload) import qualified Yesod.Auth.Util.PasswordStore as PWStore +import Data.Time (NominalDiffTime) + +import Data.Scientific (toBoundedInteger) +import Data.Word (Word16) + +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Ldap.Client as Ldap @@ -39,6 +48,9 @@ import Control.Lens import Data.Maybe (fromJust) import qualified Data.Char as Char +import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..)) +import qualified Network.Socket as HaskellNet (PortNumber(..), HostName) + import Model -- | Runtime settings to configure this application. These settings can be @@ -51,6 +63,8 @@ data AppSettings = AppSettings -- ^ Configuration settings for accessing the database. , appLdapConf :: Maybe LdapConf -- ^ Configuration settings for accessing the LDAP-directory + , appSmtpConf :: Maybe SmtpConf + -- ^ Configuration settings for accessing a SMTP Mailserver , appRoot :: Maybe Text -- ^ Base for all generated URLs. If @Nothing@, determined -- from the request headers. @@ -90,7 +104,7 @@ data UserDefaultConf = UserDefaultConf , userDefaultMaxFavourites :: Int , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat , userDefaultDownloadFiles :: Bool - } + } deriving (Show) data PWHashConf = PWHashConf { pwHashAlgorithm :: PWHashAlgorithm @@ -114,8 +128,31 @@ data LdapConf = LdapConf , ldapBase :: Ldap.Dn , ldapScope :: Ldap.Scope , ldapTimeout :: Int32 - } + } deriving (Show) +data SmtpConf = SmtpConf + { smtpHost :: HaskellNet.HostName + , smtpPort :: HaskellNet.PortNumber + , smtpAuth :: Maybe SmtpAuthConf + , smtpSsl :: SmtpSslMode + , smtpPool :: ResourcePoolConf + } deriving (Show) + +data ResourcePoolConf = ResourcePoolConf + { poolStripes :: Int + , poolTimeout :: NominalDiffTime + , poolLimit :: Int + } deriving (Show) + +data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls + deriving (Show) + +data SmtpAuthConf = SmtpAuthConf + { smtpAuthType :: HaskellNet.AuthType + , smtpAuthUsername :: HaskellNet.UserName + , smtpAuthPassword :: HaskellNet.Password + } deriving (Show) + deriveFromJSON defaultOptions ''Ldap.Scope deriveFromJSON defaultOptions { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel @@ -140,6 +177,12 @@ instance FromJSON LdapConf where ldapTimeout <- o .: "timeout" return LdapConf{..} +deriveFromJSON + defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } + ''ResourcePoolConf + deriveFromJSON defaultOptions { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level" @@ -147,6 +190,43 @@ deriveFromJSON } ''LogLevel +instance FromJSON HaskellNet.PortNumber where + parseJSON = withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of + Just int -> return $ fromIntegral (int :: Word16) + Nothing -> fail "Expected whole number to denote port" + +deriveFromJSON + defaultOptions + { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack + , allNullaryToStringTag = True + } + ''HaskellNet.AuthType + +deriveFromJSON + defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } + ''SmtpConf + +deriveFromJSON + defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel + , allNullaryToStringTag = True + } + ''SmtpSslMode + +deriveFromJSON + defaultOptions + { fieldLabelModifier = let + nameMap "username" = "user" + nameMap "password" = "pass" + nameMap x = x + in nameMap . intercalate "-" . map toLower . drop 2 . splitCamel + } + ''SmtpAuthConf + + + instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do let defaultDev = @@ -161,6 +241,7 @@ instance FromJSON AppSettings where Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap" + appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" appRoot <- o .:? "approot" appHost <- fromString <$> o .: "host" appPort <- o .: "port"