Introduce smtpPool

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

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 ${@}

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.

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

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

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)

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"