From 93c96ae6206c17beccbd487fc5a4fb11cedccc06 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 19 Feb 2018 11:12:43 +0100 Subject: [PATCH 01/39] Framework for Notifications --- .gitignore | 1 + config/settings.yml | 1 + models | 7 ++++ package.yaml | 1 + src/Application.hs | 50 ++++++++++++++++++++++++++-- src/Foundation.hs | 5 +++ src/Model.hs | 9 ++++- src/Model/Types.hs | 15 ++++++++- src/Notifications.hs | 78 ++++++++++++++++++++++++++++++++++++++++++++ src/Settings.hs | 2 ++ 10 files changed, 164 insertions(+), 5 deletions(-) create mode 100644 src/Notifications.hs diff --git a/.gitignore b/.gitignore index 9abd44d27..ecf10c096 100644 --- a/.gitignore +++ b/.gitignore @@ -29,3 +29,4 @@ uniworx.nix src/Handler/Assist.bak src/Handler/Course.SnapCustom.hs *.orig +/instance diff --git a/config/settings.yml b/config/settings.yml index 735afe776..3c2ef80c3 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -41,6 +41,7 @@ ldap: userDefaultFavourites: 12 cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf" +instance-idfile: "_env:INSTANCEID_FILE:instance" copyright: ©Institute for Informatics, LMU Munich #analytics: UA-YOURCODE diff --git a/models b/models index de3c17b88..0d4793d28 100644 --- a/models +++ b/models @@ -212,3 +212,10 @@ Exam -- -- CONTINUE HERE: Include rating in this table or separately? -- UniqueExamUser userId examId -- By default this file is used in Model.hs (which is imported by Foundation.hs) +QueuedNotification + recipient UserId + content Value + created UTCTime + lockInstance UUID Maybe + lockTime UTCTime Maybe + deriving Eq Read Show Generic Typeable diff --git a/package.yaml b/package.yaml index fb495c5a8..dc63b7a45 100644 --- a/package.yaml +++ b/package.yaml @@ -79,6 +79,7 @@ dependencies: - parsec - uuid - exceptions +- stm-conduit # 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 33a3fd07b..9a0e7883c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -13,6 +13,7 @@ module Application , makeFoundation , makeLogWare -- * for DevelMain + , foundationStoreNum , getApplicationRepl , shutdownApp -- * for GHCI @@ -37,6 +38,16 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger), import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr) +import Foreign.Store + +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID + +import System.Directory +import System.FilePath + +import Notifications + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -70,6 +81,12 @@ makeFoundation appSettings@(AppSettings{..}) = do appStaticDir appCryptoIDKey <- readKeyFile appCryptoIDKeyFile + appInstanceID <- maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile + + (appNotificationCtl, recvChan) <- atomically $ do + chan <- newBroadcastTMChan + recvChan <- dupTMChan chan + return (chan, recvChan) -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a @@ -83,17 +100,35 @@ makeFoundation appSettings@(AppSettings{..}) = do tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" logFunc = messageLoggerSource tempFoundation appLogger + flip runLoggingT logFunc . $(logDebugS) "InstanceID" $ UUID.toText appInstanceID + -- Create the database connection pool pool <- flip runLoggingT logFunc $ createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) - + -- Perform database migration using our application's logging settings. - runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc + flip runLoggingT logFunc $ runSqlPool (runMigration migrateAll) pool + + void . fork . handleNotifications $ (mkFoundation pool) { appNotificationCtl = recvChan } -- Return the foundation return $ mkFoundation pool +readInstanceIDFile :: FilePath -> IO UUID +readInstanceIDFile idFile = handle generateInstead $ readFileUtf8 idFile >>= parseText + where + parseText :: Text -> IO UUID + parseText = maybe (throwString "appInstanceIDFile does not contain an UUID") return . UUID.fromText + generateInstead :: IOException -> IO UUID + generateInstead e + | isDoesNotExistError e = do + createDirectoryIfMissing True $ takeDirectory idFile + instanceId <- UUID.nextRandom + writeFileUtf8 idFile $ UUID.toText instanceId + return instanceId + | otherwise = throw e + -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. makeApplication :: UniWorX -> IO Application @@ -172,16 +207,25 @@ appMain = do -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the app from GHCi) -------------------------------------------------------------- +foundationStoreNum :: Word32 +foundationStoreNum = 2 + getApplicationRepl :: IO (Int, UniWorX, Application) getApplicationRepl = do settings <- getAppDevSettings foundation <- makeFoundation settings wsettings <- getDevSettings $ warpSettings foundation app1 <- makeApplication foundation + + let foundationStore = Store foundationStoreNum + deleteStore foundationStore + writeStore foundationStore foundation + return (getPort wsettings, foundation, app1) shutdownApp :: UniWorX -> IO () -shutdownApp _ = return () +shutdownApp UniWorX{..} = do + atomically $ closeTMChan appNotificationCtl --------------------------------------------- diff --git a/src/Foundation.hs b/src/Foundation.hs index 314229d96..38de1681c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -73,8 +73,13 @@ data UniWorX = UniWorX , appHttpManager :: Manager , appLogger :: Logger , appCryptoIDKey :: CryptoIDKey + , appInstanceID :: UUID + , appNotificationCtl :: TMChan NotificationCtl } +data NotificationCtl = NCtlFlush + | NCtlSend QueuedNotificationId + -- 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/Model.hs b/src/Model.hs index a08615827..0bcc47ec9 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -7,6 +7,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} module Model ( module Model , module Model.Types @@ -17,6 +19,9 @@ import Database.Persist.Quasi -- import Data.Time -- import Data.ByteString import Model.Types +import Data.UUID +import Data.Aeson (Value) +import Data.Aeson.TH (deriveJSON, defaultOptions) -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities @@ -25,5 +30,7 @@ import Model.Types share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"] $(persistFileWith lowerCaseSettings "models") - +data Notification = SubmissionRated SubmissionId UTCTime + deriving (Eq, Ord, Show, Read) +deriveJSON defaultOptions ''Notification diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 9aac70705..b54eb4601 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -28,8 +28,10 @@ import Text.Read (readMaybe) -- import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.UUID + import Yesod.Core.Dispatch (PathPiece(..)) -import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..)) +import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..), encode, eitherDecode) import Data.Aeson.TH (deriveJSON, defaultOptions) import GHC.Generics (Generic) @@ -158,3 +160,14 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded) derivePersistField "StudyFieldType" + +derivePersistField "UUID" + +instance PersistField Value where + toPersistValue = PersistDbSpecific . toStrict . encode + + fromPersistValue (PersistDbSpecific t) = first pack . eitherDecode $ fromStrict t + fromPersistValue _ = Left "JSON values must be converted from PersistDbSpecific" + +instance PersistFieldSql Value where + sqlType _ = SqlOther "json" diff --git a/src/Notifications.hs b/src/Notifications.hs new file mode 100644 index 000000000..003b0f4a8 --- /dev/null +++ b/src/Notifications.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , TemplateHaskell + , OverloadedStrings + , FlexibleContexts + , ViewPatterns + , TypeFamilies + , DeriveGeneric + , DeriveDataTypeable + #-} + +module Notifications + ( handleNotifications + ) where + +import Import + +import Data.Conduit.TMChan +import qualified Data.Conduit.List as C + +import Data.Aeson (fromJSON, Result(..)) +import Database.Persist.Sql (rawExecute, fromSqlKey) + + +data NotificationQueueException = QNInvalid QueuedNotification + | QNLocked QueuedNotificationId UUID UTCTime + | QNNonexistant QueuedNotificationId + deriving (Read, Show, Eq, Generic, Typeable) + +instance Exception NotificationQueueException + + +handleNotifications :: UniWorX -> IO () +handleNotifications foundation@UniWorX{..} = unsafeHandler foundation . bracket_ logStart logStop . runConduit $ sourceTMChan appNotificationCtl .| handleNotifications' + where + logStart = $(logDebugS) "Notifications" "Started" + logStop = $(logDebugS) "Notifications" "Shutting down" + +handleNotifications' :: Sink NotificationCtl Handler () +handleNotifications' = C.mapM_ $ void . handleAny ($(logErrorS) "Notifications" . tshow) . handleCmd + where + handleQueueException :: MonadLogger m => NotificationQueueException -> m () + handleQueueException (QNInvalid qn) = $(logWarnS) "Notifications" $ "Invalid QueuedNotification: " ++ tshow qn + handleQueueException (QNNonexistant qnId) = $(logInfoS) "Notifications" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey qnId) + handleQueueException (QNLocked qnId lInstance lTime) = $(logDebugS) "Notifications" $ "Saw locked QueuedNotification: " ++ tshow (qnId, lInstance, lTime) + + handleCmd NCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedNotificationCreated ] .| C.mapM_ cmdSend + handleCmd (NCtlSend qnId) = handle handleQueueException $ do + qn@QueuedNotification{..} <- qnLock qnId + + let + content :: Notification + Success content = fromJSON queuedNotificationContent + + $(logDebugS) "Notifications" $ "Would send: " <> tshow (queuedNotificationRecipient, content) -- FIXME + + runDB $ delete qnId + + + +qnLock :: QueuedNotificationId -> Handler QueuedNotification +qnLock qnId = runDB $ do + rawExecute "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE" [] + qn@QueuedNotification{..} <- maybe (throwM $ QNNonexistant qnId) return =<< get qnId + maybe (return ()) throwM $ QNLocked <$> pure qnId <*> queuedNotificationLockInstance <*> queuedNotificationLockTime + unless ((fromJSON queuedNotificationContent :: Result Notification) /= mempty) . throwM $ QNInvalid qn + instanceID <- getsYesod appInstanceID + now <- liftIO getCurrentTime + updateGet qnId [ QueuedNotificationLockInstance =. Just instanceID + , QueuedNotificationLockTime =. Just now + ] + +cmdSend :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) => QueuedNotificationId -> m () +cmdSend (NCtlSend -> cmd) = do + chan <- getsYesod appNotificationCtl + liftIO . atomically $ writeTMChan chan cmd diff --git a/src/Settings.hs b/src/Settings.hs index d63b447b2..97d582904 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -68,6 +68,7 @@ data AppSettings = AppSettings , appAnalytics :: Maybe Text -- ^ Google Analytics code , appCryptoIDKeyFile :: FilePath + , appInstanceIDFile :: Maybe FilePath , appAuthDummyLogin :: Bool -- ^ Indicate if auth dummy login should be enabled. @@ -102,6 +103,7 @@ instance FromJSON AppSettings where appCopyright <- o .: "copyright" appAnalytics <- o .:? "analytics" appCryptoIDKeyFile <- o .: "cryptoid-keyfile" + appInstanceIDFile <- o .:? "instance-idfile" appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev From 544eadca85e343d62b26eda17b1e2561233f5ea3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 19 Feb 2018 12:54:43 +0100 Subject: [PATCH 02/39] Fix DB interaction --- fill-db.hs | 101 ++++++++++++++++++++++++------------------- ghci.sh | 2 +- models | 1 + src/Model/Types.hs | 3 +- src/Notifications.hs | 10 +++-- 5 files changed, 67 insertions(+), 50 deletions(-) diff --git a/fill-db.hs b/fill-db.hs index 4cc894464..66118aba6 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -1,13 +1,16 @@ #!/usr/bin/env stack --- stack runghc +-- stack runghc --package uniworx {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} import "uniworx" Import import "uniworx" Application (db) +import Database.Persist.Sql (toSqlKey) + import Data.Time main :: IO () @@ -15,10 +18,12 @@ main = db $ do defaultFavourites <- getsYesod $ appDefaultFavourites . appSettings now <- liftIO getCurrentTime let + insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r) + insert' = fmap (either entityKey id) . insertBy summer2017 = TermIdentifier 2017 Summer winter2017 = TermIdentifier 2017 Winter summer2018 = TermIdentifier 2018 Summer - gkleen <- insert User + gkleen <- insert' User { userPlugin = "LDAP" , userIdent = "G.Kleen@campus.lmu.de" , userMatrikelnummer = Nothing @@ -26,7 +31,7 @@ main = db $ do , userDisplayName = "Gregor Kleen" , userMaxFavourites = 6 } - fhamann <- insert User + fhamann <- insert' User { userPlugin = "LDAP" , userIdent = "felix.hamann@campus.lmu.de" , userMatrikelnummer = Nothing @@ -34,7 +39,7 @@ main = db $ do , userDisplayName = "Felix Hamann" , userMaxFavourites = defaultFavourites } - jost <- insert User + jost <- insert' User { userPlugin = "LDAP" , userIdent = "jost@tcs.ifi.lmu.de" , userMatrikelnummer = Nothing @@ -42,7 +47,7 @@ main = db $ do , userDisplayName = "Steffen Jost" , userMaxFavourites = 14 } - void . insert $ Term + void . repsert (TermKey summer2017) $ Term { termName = summer2017 , termStart = fromGregorian 2017 04 09 , termEnd = fromGregorian 2017 07 14 @@ -51,7 +56,7 @@ main = db $ do , termLectureEnd = fromGregorian 2018 07 14 , termActive = False } - void . insert $ Term + void . repsert (TermKey winter2017) $ Term { termName = winter2017 , termStart = fromGregorian 2017 10 16 , termEnd = fromGregorian 2018 02 10 @@ -60,7 +65,7 @@ main = db $ do , termLectureEnd = fromGregorian 2018 02 10 , termActive = True } - void . insert $ Term + void . repsert (TermKey summer2018) $ Term { termName = summer2018 , termStart = fromGregorian 2018 04 09 , termEnd = fromGregorian 2018 07 14 @@ -69,22 +74,28 @@ main = db $ do , termLectureEnd = fromGregorian 2018 07 14 , termActive = True } - ifi <- insert $ School "Institut für Informatik" "IfI" - mi <- insert $ School "Institut für Mathematik" "MI" - void . insert $ UserAdmin gkleen ifi - void . insert $ UserAdmin gkleen mi - void . insert $ UserAdmin fhamann ifi - void . insert $ UserAdmin jost ifi - void . insert $ UserAdmin jost mi - void . insert $ UserLecturer gkleen ifi - void . insert $ UserLecturer fhamann ifi - void . insert $ UserLecturer jost ifi - sdBsc <- insert $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) - sdMst <- insert $ StudyDegree 88 (Just "MSc") (Just "Master" ) - sdInf <- insert $ StudyTerms 79 (Just "Inf") (Just "Informatik") - sdMath <- insert $ StudyTerms 105 (Just "M" ) (Just "Mathematik") + ifi <- insert' $ School "Institut für Informatik" "IfI" + mi <- insert' $ School "Institut für Mathematik" "MI" + void . insert' $ UserAdmin gkleen ifi + void . insert' $ UserAdmin gkleen mi + void . insert' $ UserAdmin fhamann ifi + void . insert' $ UserAdmin jost ifi + void . insert' $ UserAdmin jost mi + void . insert' $ UserLecturer gkleen ifi + void . insert' $ UserLecturer fhamann ifi + void . insert' $ UserLecturer jost ifi + let + sdBsc = StudyDegreeKey' 82 + sdMst = StudyDegreeKey' 88 + repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) + repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" ) + let + sdInf = StudyTermsKey' 79 + sdMath = StudyTermsKey' 105 + repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatik") + repsert sdMath $ StudyTerms 105 (Just "M" ) (Just "Mathematik") -- FFP - ffp <- insert Course + ffp <- insert' Course { courseName = "Fortgeschrittene Funktionale Programmierung" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -100,15 +111,15 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit jost now ffp - void . insert $ DegreeCourse ffp sdBsc sdInf - void . insert $ DegreeCourse ffp sdMst sdInf - void . insert $ Lecturer jost ffp - void . insert $ Lecturer gkleen ffp - insert_ $ Corrector gkleen ffp (ByProportion 1) - sheetkey <- insert $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing + void . insert' $ DegreeCourse ffp sdBsc sdInf + void . insert' $ DegreeCourse ffp sdMst sdInf + void . insert' $ Lecturer jost ffp + void . insert' $ Lecturer gkleen ffp + void . insert' $ Corrector gkleen ffp (ByProportion 1) + sheetkey <- insert' $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing insert_ $ SheetEdit gkleen now sheetkey -- EIP - eip <- insert Course + eip <- insert' Course { courseName = "Einführung in die Programmierung" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -124,10 +135,10 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit fhamann now eip - void . insert $ DegreeCourse eip sdBsc sdInf - void . insert $ Lecturer fhamann eip + void . insert' $ DegreeCourse eip sdBsc sdInf + void . insert' $ Lecturer fhamann eip -- interaction design - ixd <- insert Course + ixd <- insert' Course { courseName = "Interaction Design (User Experience Design I & II)" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -143,10 +154,10 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit fhamann now ixd - void . insert $ DegreeCourse ixd sdBsc sdInf - void . insert $ Lecturer fhamann ixd + void . insert' $ DegreeCourse ixd sdBsc sdInf + void . insert' $ Lecturer fhamann ixd -- concept development - ux3 <- insert Course + ux3 <- insert' Course { courseName = "Concept Development (User Experience Design III)" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -162,10 +173,10 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit fhamann now ux3 - void . insert $ DegreeCourse ux3 sdBsc sdInf - void . insert $ Lecturer fhamann ux3 + void . insert' $ DegreeCourse ux3 sdBsc sdInf + void . insert' $ Lecturer fhamann ux3 -- promo - pmo <- insert Course + pmo <- insert' Course { courseName = "Programmierung und Modellierung" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -181,10 +192,10 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit jost now pmo - void . insert $ DegreeCourse pmo sdBsc sdInf - void . insert $ Lecturer jost pmo + void . insert' $ DegreeCourse pmo sdBsc sdInf + void . insert' $ Lecturer jost pmo -- datenbanksysteme - dbs <- insert Course + dbs <- insert' Course { courseName = "Datenbanksysteme" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -200,7 +211,7 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit gkleen now dbs - void . insert $ DegreeCourse dbs sdBsc sdInf - void . insert $ DegreeCourse dbs sdBsc sdMath - void . insert $ Lecturer gkleen dbs - void . insert $ Lecturer jost dbs + void . insert' $ DegreeCourse dbs sdBsc sdInf + void . insert' $ DegreeCourse dbs sdBsc sdMath + void . insert' $ Lecturer gkleen dbs + void . insert' $ Lecturer jost dbs diff --git a/ghci.sh b/ghci.sh index 64adc58eb..1c0ac289f 100755 --- a/ghci.sh +++ b/ghci.sh @@ -5,4 +5,4 @@ export DETAILED_LOGGING=true export LOG_ALL=true export DUMMY_LOGIN=true -exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only +exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only uniworx diff --git a/models b/models index 0d4793d28..708d933f8 100644 --- a/models +++ b/models @@ -9,6 +9,7 @@ User UserAdmin user UserId school SchoolId + UniqueUserAdmin school user UserLecturer user UserId school SchoolId diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b54eb4601..ca925fafb 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -167,7 +167,8 @@ instance PersistField Value where toPersistValue = PersistDbSpecific . toStrict . encode fromPersistValue (PersistDbSpecific t) = first pack . eitherDecode $ fromStrict t - fromPersistValue _ = Left "JSON values must be converted from PersistDbSpecific" + fromPersistValue (PersistByteString t) = first pack . eitherDecode $ fromStrict t + fromPersistValue v = Left $ "JSON values must be converted from PersistDbSpecific (got: " ++ tshow v ++ ")" instance PersistFieldSql Value where sqlType _ = SqlOther "json" diff --git a/src/Notifications.hs b/src/Notifications.hs index 003b0f4a8..7dd63ad3f 100644 --- a/src/Notifications.hs +++ b/src/Notifications.hs @@ -45,7 +45,7 @@ handleNotifications' = C.mapM_ $ void . handleAny ($(logErrorS) "Notifications" handleQueueException (QNLocked qnId lInstance lTime) = $(logDebugS) "Notifications" $ "Saw locked QueuedNotification: " ++ tshow (qnId, lInstance, lTime) handleCmd NCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedNotificationCreated ] .| C.mapM_ cmdSend - handleCmd (NCtlSend qnId) = handle handleQueueException $ do + handleCmd (NCtlSend qnId) = handle handleQueueException . (`finally` qnUnlock qnId) $ do qn@QueuedNotification{..} <- qnLock qnId let @@ -56,8 +56,6 @@ handleNotifications' = C.mapM_ $ void . handleAny ($(logErrorS) "Notifications" runDB $ delete qnId - - qnLock :: QueuedNotificationId -> Handler QueuedNotification qnLock qnId = runDB $ do rawExecute "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE" [] @@ -70,6 +68,12 @@ qnLock qnId = runDB $ do , QueuedNotificationLockTime =. Just now ] +qnUnlock :: QueuedNotificationId -> Handler () +qnUnlock qnId = runDB $ update qnId [ QueuedNotificationLockInstance =. Nothing + , QueuedNotificationLockTime =. Nothing + ] + + cmdSend :: ( MonadHandler m , HandlerSite m ~ UniWorX ) => QueuedNotificationId -> m () From fb52db33a1330534359c809daf3017af09766663 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 1 Oct 2018 19:21:45 +0200 Subject: [PATCH 03/39] Cleanup --- models | 5 +- package.yaml | 2 + src/Foundation.hs | 10 ++-- src/Import.hs | 1 - src/Jobs.hs | 115 ++++++++++++++++++++++++------------------- src/Jobs/Types.hs | 38 ++++++++++++++ src/Model.hs | 1 - src/Model/Types.hs | 1 + src/Utils/Message.hs | 3 +- src/Utils/TH.hs | 2 + 10 files changed, 114 insertions(+), 64 deletions(-) create mode 100644 src/Jobs/Types.hs diff --git a/models b/models index b36d6f93e..d5b82b764 100644 --- a/models +++ b/models @@ -223,7 +223,8 @@ Exam -- By default this file is used in Model.hs (which is imported by Foundation.hs) QueuedJob content Value - created UTCTime - lockInstance UUID Maybe + creationInstance InstanceId + creationTime UTCTime + lockInstance InstanceId Maybe lockTime UTCTime Maybe deriving Eq Read Show Generic Typeable diff --git a/package.yaml b/package.yaml index 3b5db7a49..6b28933e1 100644 --- a/package.yaml +++ b/package.yaml @@ -77,6 +77,8 @@ dependencies: - parsec - uuid - exceptions +- stm +- stm-chans - stm-conduit - lens - MonadRandom diff --git a/src/Foundation.hs b/src/Foundation.hs index 86e90471b..fc6816487 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -20,12 +20,12 @@ import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) import Text.Jasmine (minifym) --- Used only when in "auth-dummy-login" setting is enabled. import Yesod.Auth.Message import Yesod.Auth.Dummy import Auth.LDAP import Auth.PWHash import Auth.Dummy +import Jobs.Types import qualified Network.Wai as W (requestMethod, pathInfo) @@ -115,14 +115,10 @@ data UniWorX = UniWorX , appHttpManager :: Manager , appLogger :: Logger , appCryptoIDKey :: CryptoIDKey - , appInstanceID :: UUID - , appJobCtl :: TMChan JobCtl + , appInstanceID :: InstanceId + , appJobCtl :: TMChan JobCtl } -data JobCtl = NCtlFlush - | NCtlPerform QueuedJobId - deriving (Eq, Ord, Read, Show) - -- 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.hs b/src/Import.hs index cdb0ec16f..a10200156 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -4,4 +4,3 @@ module Import import Foundation as Import import Import.NoFoundation as Import - diff --git a/src/Jobs.hs b/src/Jobs.hs index e82ad1060..494b83c2f 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -7,50 +7,41 @@ , TypeFamilies , DeriveGeneric , DeriveDataTypeable + , QuasiQuotes #-} module Jobs - ( handleJobs - , Job(..), Notification(..) + ( module Jobs.Types + , writeJobCtl + , queueJob + , handleJobs ) where import Import +import Jobs.Types + import Data.Conduit.TMChan import qualified Data.Conduit.List as C -import Data.Aeson (fromJSON, Result(..), defaultOptions, Options(..)) +import Data.Aeson (fromJSON, toJSON) import qualified Data.Aeson as Aeson -import Data.Aeson.TH (deriveJSON) -import Database.Persist.Sql (rawExecute, fromSqlKey) +import Database.Persist.Sql (executeQQ, fromSqlKey) -data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } - deriving (Eq, Ord, Show, Read) -data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId, nTimestamp :: UTCTime } - deriving (Eq, Ord, Show, Read) - -deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , tagSingleConstructors = True - } ''Job - -deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , tagSingleConstructors = True - } ''Notification - -data JobQueueException = JInvalid QueuedJob - | JLocked QueuedJobId UUID UTCTime +data JobQueueException = JInvalid QueuedJobId QueuedJob + | JLocked QueuedJobId InstanceId UTCTime | JNonexistant QueuedJobId deriving (Read, Show, Eq, Generic, Typeable) instance Exception JobQueueException - + handleJobs :: UniWorX -> IO () +-- | Read control commands from `appJobCtl` and address them as they come in +-- +-- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders. +-- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ... handleJobs foundation@UniWorX{..} = unsafeHandler foundation . bracket_ logStart logStop . runConduit $ sourceTMChan appJobCtl .| handleJobs' where logStart = $(logDebugS) "Jobs" "Started" @@ -60,14 +51,12 @@ handleJobs' :: Sink JobCtl Handler () handleJobs' = C.mapM_ $ void . handleAny ($(logErrorS) "Jobs" . tshow) . handleCmd where handleQueueException :: MonadLogger m => JobQueueException -> m () - handleQueueException (JInvalid j) = $(logWarnS) "Jobs" $ "Invalid QueuedJob: " ++ tshow j + handleQueueException (JInvalid jId j) = $(logWarnS) "Jobs" $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j handleQueueException (JNonexistant jId) = $(logInfoS) "Jobs" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId) - handleQueueException (JLocked jId lInstance lTime) = $(logDebugS) "Jobs" $ "Saw locked QueuedJob: " ++ tshow (jId, lInstance, lTime) + handleQueueException (JLocked jId lInstance lTime) = $(logDebugS) "Jobs" $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime) - handleCmd NCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreated ] .| C.mapM_ cmdPerform - handleCmd (NCtlPerform jId) = handle handleQueueException . (`finally` jUnlock jId) $ do - j@QueuedJob{..} <- jLock jId - + handleCmd JobCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform) + handleCmd (JobCtlPerform jId) = handle handleQueueException . jLocked jId $ \QueuedJob{..} -> do let content :: Job Aeson.Success content = fromJSON queuedJobContent @@ -76,29 +65,51 @@ handleJobs' = C.mapM_ $ void . handleAny ($(logErrorS) "Jobs" . tshow) . handleC runDB $ delete jId -jLock :: QueuedJobId -> Handler QueuedJob -jLock jId = runDB $ do - rawExecute "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE" [] - j@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId - maybe (return ()) throwM $ JLocked <$> pure jId <*> queuedJobLockInstance <*> queuedJobLockTime - let isSuccess (Aeson.Success _) = True - isSuccess _ = False - unless (isSuccess (fromJSON queuedJobContent :: Result Job)) . throwM $ JInvalid j - instanceID <- getsYesod appInstanceID - now <- liftIO getCurrentTime - updateGet jId [ QueuedJobLockInstance =. Just instanceID - , QueuedJobLockTime =. Just now - ] - -jUnlock :: QueuedJobId -> Handler () -jUnlock jId = runDB $ update jId [ QueuedJobLockInstance =. Nothing +jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a +jLocked jId act = do + hasLock <- liftIO $ newTVarIO False + val <- runDB $ do + [executeQQ| + SET TRANSACTION ISOLATION LEVEL SERIALIZABLE + |] + j@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId + maybe (return ()) throwM $ JLocked <$> pure jId <*> queuedJobLockInstance <*> queuedJobLockTime + case fromJSON queuedJobContent :: Aeson.Result Job of + Aeson.Success _ -> return () + Aeson.Error t -> do + $logErrorS "Jobs" $ "Aeson decoding error: " <> pack t + throwM $ JInvalid jId j + instanceID <- getsYesod appInstanceID + now <- liftIO getCurrentTime + val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID + , QueuedJobLockTime =. Just now + ] + liftIO . atomically $ writeTVar hasLock True + return val + act val `finally` whenM (liftIO . atomically $ readTVar hasLock) jUnlock + where + jUnlock :: Handler () + jUnlock = runDB $ update jId [ QueuedJobLockInstance =. Nothing , QueuedJobLockTime =. Nothing ] -cmdPerform :: ( MonadHandler m - , HandlerSite m ~ UniWorX - ) => QueuedJobId -> m () -cmdPerform (NCtlPerform -> cmd) = do - chan <- getsYesod appJobCtl +writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () +writeJobCtl cmd = do + chan <- getsYesod appJobCtl liftIO . atomically $ writeTMChan chan cmd + +queueJob :: Job -> YesodDB UniWorX QueuedJobId +queueJob job = do + now <- liftIO getCurrentTime + self <- getsYesod appInstanceID + jId <- insert QueuedJob + { queuedJobContent = toJSON job + , queuedJobCreationInstance = self + , queuedJobCreationTime = now + , queuedJobLockInstance = Nothing + , queuedJobLockTime = Nothing + } + writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something) + return jId + diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs new file mode 100644 index 000000000..00621ae0a --- /dev/null +++ b/src/Jobs/Types.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell + , NoImplicitPrelude + #-} + +module Jobs.Types + ( Job(..), Notification(..) + , JobCtl(..) + ) where + +import Import.NoFoundation + +import Data.Aeson (defaultOptions, Options(..), SumEncoding(..)) +import Data.Aeson.TH (deriveJSON) + + +data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } + deriving (Eq, Ord, Show, Read) +data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId, nTimestamp :: UTCTime } + deriving (Eq, Ord, Show, Read) + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , tagSingleConstructors = True + , sumEncoding = TaggedObject "job" "data" + } ''Job + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , tagSingleConstructors = True + , sumEncoding = TaggedObject "notification" "data" + } ''Notification + + +data JobCtl = JobCtlFlush + | JobCtlPerform QueuedJobId + deriving (Eq, Ord, Read, Show) diff --git a/src/Model.hs b/src/Model.hs index 55fcfb78c..a6d297443 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -24,7 +24,6 @@ import Database.Persist.Quasi -- import Data.ByteString import Model.Types -import Data.UUID import Data.Aeson (Value) import Data.Aeson.TH (deriveJSON, defaultOptions) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 8acb5c58b..cc4861626 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -453,3 +453,4 @@ type SheetName = CI Text type UserEmail = CI Text type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString +type InstanceId = UUID diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 438d21932..c6a518fae 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} module Utils.Message @@ -13,7 +14,7 @@ import Data.Universe import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece) import qualified ClassyPrelude.Yesod (addMessage, addMessageI) -import ClassyPrelude.Yesod (PathPiece(..),MonadHandler,HandlerSite,RenderMessage,Html) +import ClassyPrelude.Yesod hiding (addMessage, addMessageI) data MessageClass = Error | Warning | Info | Success diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 45bc84c7e..3f5579269 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -1,11 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} module Utils.TH where -- Common Utility Functions that require TemplateHaskell -- import Data.Char +import Prelude import Language.Haskell.TH -- import Control.Monad -- import Control.Monad.Trans.Class From 5869cb226b600e5205f643db711f7fb208a8c3a8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 1 Oct 2018 20:39:13 +0200 Subject: [PATCH 04/39] more serializition --- src/Jobs.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Jobs.hs b/src/Jobs.hs index 494b83c2f..423411dc3 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -69,9 +69,7 @@ jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a jLocked jId act = do hasLock <- liftIO $ newTVarIO False val <- runDB $ do - [executeQQ| - SET TRANSACTION ISOLATION LEVEL SERIALIZABLE - |] + setSerializable j@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId maybe (return ()) throwM $ JLocked <$> pure jId <*> queuedJobLockInstance <*> queuedJobLockTime case fromJSON queuedJobContent :: Aeson.Result Job of @@ -89,9 +87,15 @@ jLocked jId act = do act val `finally` whenM (liftIO . atomically $ readTVar hasLock) jUnlock where jUnlock :: Handler () - jUnlock = runDB $ update jId [ QueuedJobLockInstance =. Nothing - , QueuedJobLockTime =. Nothing - ] + jUnlock = runDB $ do + setSerializable + update jId [ QueuedJobLockInstance =. Nothing + , QueuedJobLockTime =. Nothing + ] + + setSerializable = [executeQQ| + SET TRANSACTION ISOLATION LEVEL SERIALIZABLE + |] writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () From 68ddceb5f11ad952572fed58deec3980d5b90d72 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 2 Oct 2018 16:00:04 +0200 Subject: [PATCH 05/39] 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" From 35c653160a169d1e079a9227472ee68497527a08 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 2 Oct 2018 18:17:48 +0200 Subject: [PATCH 06/39] better error message on invalid portnumber --- src/Settings.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Settings.hs b/src/Settings.hs index 02421732f..c9fbcd7e3 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -193,7 +193,7 @@ deriveFromJSON 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" + Nothing -> fail "Expected whole number of plausible size to denote port" deriveFromJSON defaultOptions From b7771137a598eb21a068c21fa0caf1cd36062ede Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 3 Oct 2018 17:27:31 +0200 Subject: [PATCH 07/39] Monadic construction of mime emails --- config/settings.yml | 4 + package.yaml | 1 + src/Foundation.hs | 6 + src/Import/NoFoundation.hs | 2 + src/Jobs.hs | 36 ++++-- src/Mail.hs | 244 +++++++++++++++++++++++++++++++++++++ src/Model/Types.hs | 10 ++ src/Settings.hs | 13 ++ src/index.md | 10 ++ 9 files changed, 313 insertions(+), 13 deletions(-) create mode 100644 src/Mail.hs diff --git a/config/settings.yml b/config/settings.yml index 46676454e..8c34e8265 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -8,6 +8,10 @@ host: "_env:HOST:*4" # any IPv4 host port: "_env:PORT:3000" ip-from-header: "_env:IP_FROM_HEADER:false" approot: "_env:APPROOT:http://localhost:3000" +mail-from: + name: "_env:MAILFROM_NAME:Uni2Work" + email: "_env:MAILFROM_EMAIL:uniworx@localhost" +mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost" detailed-logging: "_env:DETAILED_LOGGING:false" should-log-all: "_env:LOG_ALL:false" diff --git a/package.yaml b/package.yaml index 9311ef57d..d620d3fc7 100644 --- a/package.yaml +++ b/package.yaml @@ -99,6 +99,7 @@ dependencies: - HaskellNet-SSL - network - resource-pool +- mime-mail # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Foundation.hs b/src/Foundation.hs index 6326a8d90..b8b3d2e7e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -140,6 +140,7 @@ mkYesodData "UniWorX" $(parseRoutesFile "routes") type DB a = YesodDB UniWorX a type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) type MsgRenderer = MsgRendererS UniWorX -- see Utils +type MailM a = MailT (HandlerT UniWorX IO) a -- Pattern Synonyms for convenience pattern CSheetR tid ssh csh shn ptn @@ -1288,6 +1289,11 @@ unsafeHandler :: UniWorX -> Handler a -> IO a unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger +instance YesodMail UniWorX where + defaultFromAddress = getsYesod $ appMailFrom . appSettings + mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings + + instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where type MonadCryptoKey m = CryptoIDKey cryptoIDKey f = getsYesod appCryptoIDKey >>= f diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index bef1d3ac9..e1d2dfe37 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -27,3 +27,5 @@ 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) + +import Mail as Import diff --git a/src/Jobs.hs b/src/Jobs.hs index 423411dc3..f9681be10 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -24,10 +24,15 @@ import Jobs.Types import Data.Conduit.TMChan import qualified Data.Conduit.List as C +import qualified Data.Text.Lazy as LT + import Data.Aeson (fromJSON, toJSON) import qualified Data.Aeson as Aeson import Database.Persist.Sql (executeQQ, fromSqlKey) +import Data.Monoid (Last(..)) +import Control.Monad.Trans.Writer (WriterT(..), execWriterT) + data JobQueueException = JInvalid QueuedJobId QueuedJob | JLocked QueuedJobId InstanceId UTCTime @@ -44,26 +49,29 @@ handleJobs :: UniWorX -> IO () -- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ... handleJobs foundation@UniWorX{..} = unsafeHandler foundation . bracket_ logStart logStop . runConduit $ sourceTMChan appJobCtl .| handleJobs' where - logStart = $(logDebugS) "Jobs" "Started" - logStop = $(logDebugS) "Jobs" "Shutting down" + logStart = $logDebugS "Jobs" "Started" + logStop = $logDebugS "Jobs" "Shutting down" handleJobs' :: Sink JobCtl Handler () -handleJobs' = C.mapM_ $ void . handleAny ($(logErrorS) "Jobs" . tshow) . handleCmd +handleJobs' = C.mapM_ $ void . handleAny ($logErrorS "Jobs" . tshow) . handleCmd where handleQueueException :: MonadLogger m => JobQueueException -> m () - handleQueueException (JInvalid jId j) = $(logWarnS) "Jobs" $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j - handleQueueException (JNonexistant jId) = $(logInfoS) "Jobs" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId) - handleQueueException (JLocked jId lInstance lTime) = $(logDebugS) "Jobs" $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime) + handleQueueException (JInvalid jId j) = $logWarnS "Jobs" $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j + handleQueueException (JNonexistant jId) = $logInfoS "Jobs" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId) + handleQueueException (JLocked jId lInstance lTime) = $logDebugS "Jobs" $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime) - handleCmd JobCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform) + handleCmd JobCtlFlush = void . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform) handleCmd (JobCtlPerform jId) = handle handleQueueException . jLocked jId $ \QueuedJob{..} -> do let content :: Job - Aeson.Success content = fromJSON queuedJobContent + Aeson.Success content = fromJSON queuedJobContent -- `jLocked` ensures that `queuedJobContent` parses - $(logDebugS) "Jobs" $ "Would do: " <> tshow content -- FIXME + $logDebugS "Jobs" . LT.toStrict . decodeUtf8 $ Aeson.encode content - runDB $ delete jId + Last jobDone <- execWriterT $ performJob content + + when (fromMaybe False jobDone) $ + runDB $ delete jId jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a jLocked jId act = do @@ -93,9 +101,7 @@ jLocked jId act = do , QueuedJobLockTime =. Nothing ] - setSerializable = [executeQQ| - SET TRANSACTION ISOLATION LEVEL SERIALIZABLE - |] + setSerializable = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () @@ -117,3 +123,7 @@ queueJob job = do writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something) return jId + +performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) () +performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do + $logDebugS "Jobs" "NotificationSubmissionRated" -- FIXME diff --git a/src/Mail.hs b/src/Mail.hs new file mode 100644 index 000000000..1d803d5f6 --- /dev/null +++ b/src/Mail.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE NoImplicitPrelude + , GeneralizedNewtypeDeriving + , DerivingStrategies + , FlexibleInstances + , MultiParamTypeClasses + , UndecidableInstances + , DeriveGeneric + , TemplateHaskell + , OverloadedStrings + , RecordWildCards + , FlexibleContexts + , TypeFamilies + #-} + +module Mail + ( -- * Structured MIME emails + module Network.Mail.Mime + -- * MailT + , MailT, mailT + , MonadMail(..) + -- * YesodMail + , YesodMail(..) + -- * Monadically constructing Mail + , MonadState(..) + , PrioritisedAlternatives + , ToMailPart(..) + , addAlternatives, provideAlternative, providePreferredAlternative + , addPart + , MonadHeader(..) + , MailHeader + , MailObjectId + , replaceMailHeader, addMailHeader, removeMailHeader + , replaceMailHeaderI, addMailHeaderI + , setSubjectI, setMailObjectId, setMailObjectId' + , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts + , _partType, _partEncoding, _partFilename, _partHeaders, _partContent + ) where + +import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender) + +import Network.Mail.Mime hiding (addPart, addAttachment) +import qualified Network.Mail.Mime as Mime (addPart) + +import Data.Monoid (Last(..)) +import Control.Monad.Trans.RWS (RWST(..), execRWST) +import Control.Monad.Trans.State (StateT(..), execStateT, State) +import Control.Monad.Trans.Writer (execWriter, Writer) +import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify) +import Control.Monad.Fail + +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) + +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq + +import qualified Data.Foldable as Foldable + +import qualified Data.Text.Lazy as LT + +import Utils.Lens.TH +import Control.Lens + +import Text.Blaze.Renderer.Utf8 + +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID +import Data.UUID.Cryptographic.ImplicitNamespace + +import Data.Binary (Binary) + +import GHC.TypeLits (KnownSymbol) + +import Network.BSD (getHostName) + + +makeLenses_ ''Mail +makeLenses_ ''Part + + +newtype MailT m a = MailT { unMailT :: RWST [Text] () Mail m a } + deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus + , MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b + , MonadState Mail + ) + +instance (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where + type MonadCryptoKey (MailT m) = CryptoIDKey + cryptoIDKey f = lift (cryptoIDKey return) >>= f + +class MonadHandler m => MonadMail m where + mailLanguages :: m [Text] + +instance MonadHandler m => MonadMail (MailT m) where + mailLanguages = MailT ask + +getMessageRender :: ( MonadMail m + , HandlerSite m ~ site + , RenderMessage site msg + ) => m (msg -> Text) +getMessageRender = renderMessage <$> getYesod <*> mailLanguages + + +class YesodMail site where + defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address + defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName + + mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text + mailObjectIdDomain = pack <$> liftIO getHostName + +mailT :: ( MonadHandler m + , YesodMail (HandlerSite m) + ) => [Text] -- ^ Languages in priority order + -> MailT m a + -> m Mail +mailT ls (MailT mail) = do + fromAddress <- defaultFromAddress + fst <$> execRWST mail ls (emptyMail fromAddress) + + +data PrioritisedAlternatives m = PrioritisedAlternatives + { preferredAlternative :: Last (m Part) + , otherAlternatives :: Seq (m Part) + } deriving (Generic) + +instance Monoid (PrioritisedAlternatives m) where + mempty = memptydefault + mappend = mappenddefault + +class ToMailPart a where + toMailPart :: a -> State Part () + +instance ToMailPart LT.Text where + toMailPart text = do + _partType .= "text/plain" + _partEncoding .= QuotedPrintableText + _partContent .= encodeUtf8 text + +instance ToMailPart Text where + toMailPart = toMailPart . LT.fromStrict + +instance ToMailPart Html where + toMailPart html = do + _partType .= "text/html" + _partEncoding .= QuotedPrintableText + _partContent .= renderMarkup html + + +addAlternatives :: Monad m + => Writer (PrioritisedAlternatives m) () + -> MailT m () +addAlternatives provided = MailT $ do + let PrioritisedAlternatives{..} = execWriter provided + alternatives <- lift . sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives + modify $ Mime.addPart alternatives + +provideAlternative, providePreferredAlternative + :: Monad m + => StateT Part m () + -> Writer (PrioritisedAlternatives m) () +provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT part initialPart } +providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT part initialPart } + +addPart :: Monad m => StateT Part m () -> MailT m () +addPart part = MailT $ do + part' <- lift $ execStateT part initialPart + modify . Mime.addPart $ pure part' + +initialPart :: Part +initialPart = Part + { partType = "text/plain" + , partEncoding = None + , partFilename = Nothing + , partHeaders = [] + , partContent = mempty + } + + +class MonadHandler m => MonadHeader m where + modifyHeaders :: (Headers -> Headers) -> m () + objectIdHeader :: m MailHeader + +instance MonadHandler m => MonadHeader (MailT m) where + modifyHeaders f = MailT . modify $ over _mailHeaders f + objectIdHeader = return "Message-ID" + +instance MonadHandler m => MonadHeader (StateT Part m) where + modifyHeaders f = _partHeaders %= f + objectIdHeader = return "Content-ID" + + +type MailHeader = ByteString +type MailObjectId = Text + + +replaceMailHeader :: MonadHeader m => MailHeader -> Maybe Text -> m () +replaceMailHeader header mC = removeMailHeader header >> maybe (return ()) (addMailHeader header) mC + +addMailHeader :: MonadHeader m => MailHeader -> Text -> m () +addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (header, c) + +removeMailHeader :: MonadHeader m => MailHeader -> m () +removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders + + +replaceMailHeaderI :: ( RenderMessage site msg + , MonadMail m + , HandlerSite m ~ site + , MonadHeader m + ) => MailHeader -> msg -> m () +replaceMailHeaderI header msg = removeMailHeader header >> addMailHeaderI header msg + +addMailHeaderI :: ( RenderMessage site msg + , MonadMail m + , HandlerSite m ~ site + , MonadHeader m + ) => MailHeader -> msg -> m () +addMailHeaderI header msg = addMailHeader header =<< (getMessageRender <*> pure msg) + + +setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m () +setSubjectI = replaceMailHeaderI "Subject" + +setMailObjectUUID :: (MonadHandler m, YesodMail (HandlerSite m)) => UUID -> MailT m MailObjectId +setMailObjectUUID uuid = do + domain <- mailObjectIdDomain + oidHeader <- objectIdHeader + let objectId = UUID.toText uuid <> "@" <> domain + replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">" + return objectId + +setMailObjectId :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m MailObjectId +setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom + +setMailObjectId' :: ( MonadHandler m + , YesodMail (HandlerSite m) + , MonadCrypto m + , HasCryptoUUID plain m + , MonadCryptoKey m ~ CryptoIDKey + , KnownSymbol (CryptoIDNamespace UUID plain) + , Binary plain + ) => plain -> MailT m MailObjectId +setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid diff --git a/src/Model/Types.hs b/src/Model/Types.hs index cc4861626..cd76390cb 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -442,6 +442,16 @@ derivePersistFieldJSON ''AuthenticationMode derivePersistFieldJSON ''Value + +data NotificationSettings = NotificationSettings + { + } deriving (Eq, Ord, Read, Show) + +deriveJSON defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''NotificationSettings +derivePersistFieldJSON ''NotificationSettings + -- Type synonyms diff --git a/src/Settings.hs b/src/Settings.hs index c9fbcd7e3..33de49dcc 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -51,6 +51,8 @@ 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 Network.Mail.Mime (Address) + import Model -- | Runtime settings to configure this application. These settings can be @@ -75,6 +77,8 @@ data AppSettings = AppSettings , appIpFromHeader :: Bool -- ^ Get the IP address from the header when logging. Useful when sitting -- behind a reverse proxy. + , appMailFrom :: Address + , appMailObjectDomain :: Text , appDetailedRequestLogging :: Bool -- ^ Use detailed request logging system @@ -225,6 +229,12 @@ deriveFromJSON } ''SmtpAuthConf +deriveFromJSON + defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } + ''Address + instance FromJSON AppSettings where @@ -247,6 +257,9 @@ instance FromJSON AppSettings where appPort <- o .: "port" appIpFromHeader <- o .: "ip-from-header" + appMailFrom <- o .: "mail-from" + appMailObjectDomain <- o .: "mail-object-domain" + appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev appShouldLogAll <- o .:? "should-log-all" .!= defaultDev appMinimumLogLevel <- o .: "minimum-log-level" diff --git a/src/index.md b/src/index.md index a1c616b17..1a81b627c 100644 --- a/src/index.md +++ b/src/index.md @@ -96,3 +96,13 @@ CryptoID Model.Migration : Manuelle Datenbank-Migration + +Jobs + : `handleJobs` worker thread handling background jobs + `JobQueueException` + +Jobs.Types + : `Job`, `Notification`, `JobCtl` Types of Jobs + +Mail + : Monadically constructing MIME emails From e650d5c2c018c230df3de0d129539703b8c6fef6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 3 Oct 2018 17:28:57 +0200 Subject: [PATCH 08/39] fix exports --- src/Mail.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Mail.hs b/src/Mail.hs index 1d803d5f6..0275c1ac2 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -21,7 +21,6 @@ module Mail -- * YesodMail , YesodMail(..) -- * Monadically constructing Mail - , MonadState(..) , PrioritisedAlternatives , ToMailPart(..) , addAlternatives, provideAlternative, providePreferredAlternative From 7553182cf968410fe33664a9f4d75f85fedcefb9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 3 Oct 2018 18:40:06 +0200 Subject: [PATCH 09/39] Dates in emails --- src/Foundation.hs | 1 + src/Mail.hs | 16 ++++++++++++++++ 2 files changed, 17 insertions(+) diff --git a/src/Foundation.hs b/src/Foundation.hs index b8b3d2e7e..c8ed085f6 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1292,6 +1292,7 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger instance YesodMail UniWorX where defaultFromAddress = getsYesod $ appMailFrom . appSettings mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings + mailDateTZ = return appTZ instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where diff --git a/src/Mail.hs b/src/Mail.hs index 0275c1ac2..d289f1ac9 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -31,6 +31,7 @@ module Mail , replaceMailHeader, addMailHeader, removeMailHeader , replaceMailHeaderI, addMailHeaderI , setSubjectI, setMailObjectId, setMailObjectId' + , setDateCurrent , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts , _partType, _partEncoding, _partFilename, _partHeaders, _partContent ) where @@ -73,6 +74,10 @@ import GHC.TypeLits (KnownSymbol) import Network.BSD (getHostName) +import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime) +import Data.Time.LocalTime (ZonedTime(..)) +import Data.Time.Format + makeLenses_ ''Mail makeLenses_ ''Part @@ -108,6 +113,9 @@ class YesodMail site where mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text mailObjectIdDomain = pack <$> liftIO getHostName + mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ + mailDateTZ = return utcTZ + mailT :: ( MonadHandler m , YesodMail (HandlerSite m) ) => [Text] -- ^ Languages in priority order @@ -241,3 +249,11 @@ setMailObjectId' :: ( MonadHandler m , Binary plain ) => plain -> MailT m MailObjectId setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid + + +setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m () +setDateCurrent = do + now <- liftIO getCurrentTime + tz <- mailDateTZ + let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz now) (timeZoneForUTCTime tz now) + replaceMailHeader "Date" . Just $ pack timeStr From 74222dbcc8491e996875c86f2273e0338506f346 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 4 Oct 2018 14:53:36 +0200 Subject: [PATCH 10/39] Framework for email-test --- config/settings.yml | 3 + messages/uniworx/de.msg | 9 +++ src/Foundation.hs | 29 +++++++++ src/Handler/Admin.hs | 6 ++ src/Jobs.hs | 10 ++- src/Jobs/Types.hs | 1 + src/Mail.hs | 138 ++++++++++++++++++++++++++++++++++------ src/Model/Types.hs | 4 +- src/Settings.hs | 4 ++ src/Utils/Form.hs | 7 ++ 10 files changed, 188 insertions(+), 23 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 8c34e8265..cd68a3261 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -12,6 +12,9 @@ mail-from: name: "_env:MAILFROM_NAME:Uni2Work" email: "_env:MAILFROM_EMAIL:uniworx@localhost" mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost" +mail-verp: + separator: "+" + at-replacement: "=" detailed-logging: "_env:DETAILED_LOGGING:false" should-log-all: "_env:LOG_ALL:false" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c1b8fcca7..d4559a612 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -308,3 +308,12 @@ SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. FieldPrimary: Hauptfach FieldSecondary: Nebenfach + +MailTestFormEmail: Email-Addresse +MailTestFormLanguages: Spracheinstellungen + +MailTestSubject: Uni2Work Test-Email +MailTestContent: Dies ist eine Test-Email versandt von Uni2Work. Von Ihrer Seite ist keine Handlung notwendig. + +German: Deutsch +GermanGermany: Deutsch (Deutschland) \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index c8ed085f6..cc238e7ff 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -59,6 +59,7 @@ import qualified Data.Map as Map import Data.Monoid (Any(..)) +import Data.Pool import Data.Conduit (($$)) import Data.Conduit.List (sourceList) @@ -228,6 +229,15 @@ instance RenderMessage UniWorX Load where (Load {byTutorial=Just False, byProportion=p}) -> renderMessage' $ MsgCorByProportionExcludingTutorial p where renderMessage' = renderMessage foundation ls +newtype MsgLanguage = MsgLanguage Lang + deriving (Eq, Ord, Show, Read) +instance RenderMessage UniWorX MsgLanguage where + renderMessage foundation ls (MsgLanguage lang) + | lang == "de-DE" = mr MsgGermanGermany + | "de" `isPrefixOf` lang = mr MsgGerman + where + mr = renderMessage foundation ls + instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) @@ -248,6 +258,22 @@ getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")]) appTZ :: TZ appTZ = $(includeSystemTZ "Europe/Berlin") +appLanguages :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) => m (OptionList Lang) +-- ^ Authoritive list of supported Languages +appLanguages = do + mr <- getsYesod renderMessage + let mkOption l = Option + { optionDisplay = mr (l : filter (/= l) (optionInternalValue <$> langOptions)) (MsgLanguage l) + , optionInternalValue = l + , optionExternalValue = l + } + langOptions = map mkOption + [ "de-DE" + ] + return $ mkOptionList langOptions + -- Access Control data AccessPredicate @@ -1293,6 +1319,9 @@ instance YesodMail UniWorX where defaultFromAddress = getsYesod $ appMailFrom . appSettings mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings mailDateTZ = return appTZ + mailSmtp act = do + pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool + withResource pool act instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 156961629..619687daa 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -41,6 +41,12 @@ instance Button UniWorX CreateButton where cssClass CreateInf = BCPrimary -- END Button needed here +emailTestForm :: AForm (HandlerT UniWorX IO) (Email, [Lang]) +emailTestForm = (,) + <$> areq emailField (fslI MsgMailTestFormEmail) Nothing + <*> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing + <* submitButton + getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! getAdminTestR = do diff --git a/src/Jobs.hs b/src/Jobs.hs index f9681be10..bc18a700a 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -17,7 +17,7 @@ module Jobs , handleJobs ) where -import Import +import Import hiding ((.=)) import Jobs.Types @@ -33,6 +33,8 @@ import Database.Persist.Sql (executeQQ, fromSqlKey) import Data.Monoid (Last(..)) import Control.Monad.Trans.Writer (WriterT(..), execWriterT) +import Utils.Lens + data JobQueueException = JInvalid QueuedJobId QueuedJob | JLocked QueuedJobId InstanceId UTCTime @@ -127,3 +129,9 @@ queueJob job = do performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) () performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do $logDebugS "Jobs" "NotificationSubmissionRated" -- FIXME +performJob JobSendTestEmail{..} = do + $logInfoS "Jobs" $ "Sending test-email to " <> jEmail + mailT jLanguages $ do + _mailTo .= [Address Nothing jEmail] + setSubjectI MsgMailTestSubject + addPart (($ MsgMailTestContent) :: (UniWorXMessage -> Text) -> Text) -- FIXME diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 00621ae0a..552d37211 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -14,6 +14,7 @@ import Data.Aeson.TH (deriveJSON) data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } + | JobSendTestEmail { jEmail :: Text, jLanguages :: MailLanguages } deriving (Eq, Ord, Show, Read) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId, nTimestamp :: UTCTime } deriving (Eq, Ord, Show, Read) diff --git a/src/Mail.hs b/src/Mail.hs index d289f1ac9..2a1388934 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -10,6 +10,8 @@ , RecordWildCards , FlexibleContexts , TypeFamilies + , ViewPatterns + , NamedFieldPuns #-} module Mail @@ -17,9 +19,12 @@ module Mail module Network.Mail.Mime -- * MailT , MailT, mailT + , MailSmtpData(..), MailLanguages(..) , MonadMail(..) -- * YesodMail + , VerpMode(..) , YesodMail(..) + , MailException(..) -- * Monadically constructing Mail , PrioritisedAlternatives , ToMailPart(..) @@ -37,13 +42,14 @@ module Mail ) where import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender) +import qualified ClassyPrelude.Yesod as Yesod (getMessageRender) import Network.Mail.Mime hiding (addPart, addAttachment) import qualified Network.Mail.Mime as Mime (addPart) import Data.Monoid (Last(..)) import Control.Monad.Trans.RWS (RWST(..), execRWST) -import Control.Monad.Trans.State (StateT(..), execStateT, State) +import Control.Monad.Trans.State (StateT(..), execStateT, State, mapStateT) import Control.Monad.Trans.Writer (execWriter, Writer) import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify) import Control.Monad.Fail @@ -54,9 +60,13 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Data.Sequence (Seq) import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set + import qualified Data.Foldable as Foldable import qualified Data.Text.Lazy as LT +import qualified Data.ByteString.Lazy as LBS import Utils.Lens.TH import Control.Lens @@ -78,32 +88,77 @@ import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime) import Data.Time.LocalTime (ZonedTime(..)) import Data.Time.Format +import Network.HaskellNet.SMTP (SMTPConnection) +import qualified Network.HaskellNet.SMTP as SMTP + +import qualified Text.Hamlet as Shakespeare (Translate, Render) + +import Data.Aeson (Options(..)) +import Data.Aeson.TH +import Utils.PathPiece (splitCamel) + makeLenses_ ''Mail makeLenses_ ''Part -newtype MailT m a = MailT { unMailT :: RWST [Text] () Mail m a } +newtype MailT m a = MailT { unMailT :: RWST MailLanguages MailSmtpData Mail m a } deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus , MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b - , MonadState Mail + , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailLanguages ) instance (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where type MonadCryptoKey (MailT m) = CryptoIDKey cryptoIDKey f = lift (cryptoIDKey return) >>= f -class MonadHandler m => MonadMail m where - mailLanguages :: m [Text] +data MailSmtpData = MailSmtpData + { smtpEnvelopeFrom :: Last Text + , smtpRecipients :: Set Text + } deriving (Eq, Ord, Show, Read, Generic) + +instance Monoid (MailSmtpData) where + mempty = memptydefault + mappend = mappenddefault + +newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] } + deriving (Eq, Ord, Show, Read) + deriving newtype (FromJSON, ToJSON) + +instance Default MailLanguages where + def = MailLanguages [] + +class (MonadHandler m, MonadState Mail m) => MonadMail m where + askMailLanguages :: m MailLanguages + tellMailSmtpData :: MailSmtpData -> m () instance MonadHandler m => MonadMail (MailT m) where - mailLanguages = MailT ask + askMailLanguages = ask + tellMailSmtpData = tell + +data VerpMode = VerpNone + | Verp { verpSeparator, verpAtReplacement :: Char } + deriving (Eq, Show, Read) + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , sumEncoding = UntaggedValue + } ''VerpMode getMessageRender :: ( MonadMail m , HandlerSite m ~ site , RenderMessage site msg ) => m (msg -> Text) -getMessageRender = renderMessage <$> getYesod <*> mailLanguages +getMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages) + + +data MailException = MailNotAvailable + | MailNoSenderSpecified + | MailNoRecipientsSpecified + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Exception MailException class YesodMail site where @@ -116,14 +171,37 @@ class YesodMail site where mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ mailDateTZ = return utcTZ + mailSmtp :: ( MonadHandler m + , HandlerSite m ~ site + , MonadBaseControl IO m + ) => (SMTPConnection -> m a) -> m a + mailSmtp _ = throwM MailNotAvailable + + mailVERP :: ( MonadHandler m + , HandlerSite m ~ site + ) => m VerpMode + mailVERP = return VerpNone + mailT :: ( MonadHandler m , YesodMail (HandlerSite m) - ) => [Text] -- ^ Languages in priority order + , MonadBaseControl IO m + ) => MailLanguages -- ^ Languages in priority order -> MailT m a - -> m Mail + -> m a mailT ls (MailT mail) = do fromAddress <- defaultFromAddress - fst <$> execRWST mail ls (emptyMail fromAddress) + (ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress) + mail' <- liftIO $ LBS.toStrict <$> renderMail' mail + ret <$ case smtpData of + MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified + MailSmtpData{ smtpRecipients } + | Set.null smtpRecipients -> throwM MailNoRecipientsSpecified + MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath)) + , smtpRecipients = (map unpack . toList -> recipients) + } -> mailSmtp $ liftIO . SMTP.sendMail + returnPath + recipients + mail' data PrioritisedAlternatives m = PrioritisedAlternatives @@ -135,24 +213,42 @@ instance Monoid (PrioritisedAlternatives m) where mempty = memptydefault mappend = mappenddefault -class ToMailPart a where - toMailPart :: a -> State Part () +class ToMailPart site a where + toMailPart :: (MonadHandler m, HandlerSite m ~ site) => a -> StateT Part m () -instance ToMailPart LT.Text where +instance ToMailPart site (StateT Part (HandlerT site IO) ()) where + toMailPart = mapStateT liftHandlerT + +instance ToMailPart site LT.Text where toMailPart text = do _partType .= "text/plain" _partEncoding .= QuotedPrintableText _partContent .= encodeUtf8 text -instance ToMailPart Text where +instance ToMailPart site Text where toMailPart = toMailPart . LT.fromStrict -instance ToMailPart Html where +instance ToMailPart site Html where toMailPart html = do _partType .= "text/html" _partEncoding .= QuotedPrintableText _partContent .= renderMarkup html +instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Shakespeare.Translate msg -> a) where + toMailPart act = do + mr <- Yesod.getMessageRender + toMailPart $ act (toHtml . mr) + +instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site ((msg -> Text) -> a) where + toMailPart act = do + mr <- Yesod.getMessageRender + toMailPart $ act mr + +instance ToMailPart site a => ToMailPart site (Shakespeare.Render (Route site) -> a) where + toMailPart act = do + ur <- getUrlRenderParams + toMailPart $ act ur + addAlternatives :: Monad m => Writer (PrioritisedAlternatives m) () @@ -163,15 +259,15 @@ addAlternatives provided = MailT $ do modify $ Mime.addPart alternatives provideAlternative, providePreferredAlternative - :: Monad m - => StateT Part m () + :: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a) + => a -> Writer (PrioritisedAlternatives m) () -provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT part initialPart } -providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT part initialPart } +provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart } +providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart } -addPart :: Monad m => StateT Part m () -> MailT m () +addPart :: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a) => a -> MailT m () addPart part = MailT $ do - part' <- lift $ execStateT part initialPart + part' <- lift $ execStateT (toMailPart part) initialPart modify . Mime.addPart $ pure part' initialPart :: Part diff --git a/src/Model/Types.hs b/src/Model/Types.hs index cd76390cb..701659dff 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -455,12 +455,14 @@ derivePersistFieldJSON ''NotificationSettings -- Type synonyms +type Email = Text + type SchoolName = CI Text type SchoolShorthand = CI Text type CourseName = CI Text type CourseShorthand = CI Text type SheetName = CI Text -type UserEmail = CI Text +type UserEmail = CI Email type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type InstanceId = UUID diff --git a/src/Settings.hs b/src/Settings.hs index 33de49dcc..2e3ac1eec 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -53,6 +53,8 @@ import qualified Network.Socket as HaskellNet (PortNumber(..), HostName) import Network.Mail.Mime (Address) +import Mail (VerpMode) + import Model -- | Runtime settings to configure this application. These settings can be @@ -79,6 +81,7 @@ data AppSettings = AppSettings -- behind a reverse proxy. , appMailFrom :: Address , appMailObjectDomain :: Text + , appMailVerp :: VerpMode , appDetailedRequestLogging :: Bool -- ^ Use detailed request logging system @@ -259,6 +262,7 @@ instance FromJSON AppSettings where appMailFrom <- o .: "mail-from" appMailObjectDomain <- o .: "mail-object-domain" + appMailVerp <- o .: "mail-verp" appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev appShouldLogAll <- o .:? "should-log-all" .!= defaultDev diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 939169e9b..a1c3fd573 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -216,3 +216,10 @@ ciField :: ( Textual t , RenderMessage (HandlerSite m) FormMessage ) => Field m (CI t) ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField + +reorderField :: ( MonadHandler m + , HandlerSite m ~ site + , Eq a + ) => HandlerT site IO (OptionList a) -> Field m [a] +-- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result) +reorderField = undefined From 1beeea5aa6a0c4c733b10f13b1aba8dec21f9275 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 4 Oct 2018 19:48:07 +0200 Subject: [PATCH 11/39] Working mail test --- src/Foundation.hs | 9 +++++++ src/Handler/Admin.hs | 33 +++++++++++++++---------- src/Jobs.hs | 9 +++---- src/Mail.hs | 36 ++++++++++++++++++++++++++-- src/Utils/Form.hs | 36 +++++++++++++++++++++++++++- templates/adminTest.hamlet | 3 +++ templates/widgets/permutation.hamlet | 7 ++++++ templates/widgets/permutation.lucius | 3 +++ 8 files changed, 117 insertions(+), 19 deletions(-) create mode 100644 templates/widgets/permutation.hamlet create mode 100644 templates/widgets/permutation.lucius diff --git a/src/Foundation.hs b/src/Foundation.hs index cc238e7ff..f9b9e8825 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1318,10 +1318,19 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger instance YesodMail UniWorX where defaultFromAddress = getsYesod $ appMailFrom . appSettings mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings + mailVerp = getsYesod $ appMailVerp . appSettings mailDateTZ = return appTZ mailSmtp act = do pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act + defaultMailAction ls mail = mailT ls $ do + setMailObjectId + setDateCurrent + + ret <- mail + + setMailSmtpData + return ret instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 619687daa..f73d95348 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -12,6 +12,7 @@ module Handler.Admin where import Import import Handler.Utils +import Jobs -- import Data.Time -- import qualified Data.Text as T @@ -20,6 +21,8 @@ import Handler.Utils import Web.PathPieces (showToPathPiece, readFromPathPiece) +import Database.Persist.Sql (fromSqlKey) + -- import Colonnade hiding (fromMaybe) -- import Yesod.Colonnade @@ -41,28 +44,34 @@ instance Button UniWorX CreateButton where cssClass CreateInf = BCPrimary -- END Button needed here -emailTestForm :: AForm (HandlerT UniWorX IO) (Email, [Lang]) +emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailLanguages) emailTestForm = (,) <$> areq emailField (fslI MsgMailTestFormEmail) Nothing - <*> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing + <*> (MailLanguages <$> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing) <* submitButton -getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! -getAdminTestR = do - (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton) - defaultLayout $ do - -- setTitle "Uni2work Admin Testpage" - $(widgetFile "adminTest") - -postAdminTestR :: Handler Html +getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! +getAdminTestR = postAdminTestR postAdminTestR = do - ((btnResult,_), _) <- runFormPost $ buttonForm + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form CreateButton) case btnResult of (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" + FormMissing -> return () _other -> addMessage Warning "KEIN Knopf erkannt" - getAdminTestR + + ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm + case emailResult of + (FormSuccess (email, ls)) -> runDB $ do + (fromSqlKey -> jId) <- queueJob $ JobSendTestEmail email ls + addMessage Success [shamlet|Email-test gestartet (Job ##{tshow jId})|] + FormMissing -> return () + (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml + + defaultLayout $ do + -- setTitle "Uni2work Admin Testpage" + $(widgetFile "adminTest") getAdminUserR :: CryptoUUIDUser -> Handler Html diff --git a/src/Jobs.hs b/src/Jobs.hs index bc18a700a..bba0261d4 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -103,9 +103,6 @@ jLocked jId act = do , QueuedJobLockTime =. Nothing ] - setSerializable = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] - - writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () writeJobCtl cmd = do chan <- getsYesod appJobCtl @@ -113,6 +110,7 @@ writeJobCtl cmd = do queueJob :: Job -> YesodDB UniWorX QueuedJobId queueJob job = do + setSerializable now <- liftIO getCurrentTime self <- getsYesod appInstanceID jId <- insert QueuedJob @@ -125,13 +123,16 @@ queueJob job = do writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something) return jId +setSerializable :: DB () +setSerializable = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] + performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) () performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do $logDebugS "Jobs" "NotificationSubmissionRated" -- FIXME performJob JobSendTestEmail{..} = do $logInfoS "Jobs" $ "Sending test-email to " <> jEmail - mailT jLanguages $ do + defaultMailAction jLanguages $ do _mailTo .= [Address Nothing jEmail] setSubjectI MsgMailTestSubject addPart (($ MsgMailTestContent) :: (UniWorXMessage -> Text) -> Text) -- FIXME diff --git a/src/Mail.hs b/src/Mail.hs index 2a1388934..b618061ec 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -12,6 +12,7 @@ , TypeFamilies , ViewPatterns , NamedFieldPuns + , MultiWayIf #-} module Mail @@ -37,6 +38,7 @@ module Mail , replaceMailHeaderI, addMailHeaderI , setSubjectI, setMailObjectId, setMailObjectId' , setDateCurrent + , setMailSmtpData , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts , _partType, _partEncoding, _partFilename, _partHeaders, _partContent ) where @@ -63,6 +65,8 @@ import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Text as Text + import qualified Data.Foldable as Foldable import qualified Data.Text.Lazy as LT @@ -177,10 +181,16 @@ class YesodMail site where ) => (SMTPConnection -> m a) -> m a mailSmtp _ = throwM MailNotAvailable - mailVERP :: ( MonadHandler m + mailVerp :: ( MonadHandler m , HandlerSite m ~ site ) => m VerpMode - mailVERP = return VerpNone + mailVerp = return VerpNone + + defaultMailAction :: ( MonadHandler m + , HandlerSite m ~ site + , MonadBaseControl IO m + ) => MailLanguages -> MailT m a -> m a + defaultMailAction = mailT mailT :: ( MonadHandler m , YesodMail (HandlerSite m) @@ -353,3 +363,25 @@ setDateCurrent = do tz <- mailDateTZ let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz now) (timeZoneForUTCTime tz now) replaceMailHeader "Date" . Just $ pack timeStr + + +setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m () +setMailSmtpData = do + Address _ from <- use _mailFrom + recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use + + tell $ mempty { smtpRecipients = recps } + + verpMode <- mailVerp + if + | Verp{..} <- verpMode + , [recp] <- Set.toList recps + -> let doVerp (Text.breakOn "@" -> (user, domain)) recp = mconcat + [ user + , Text.singleton verpSeparator + , Text.replace "@" (Text.singleton verpAtReplacement) recp + , domain + ] + in tell $ mempty { smtpEnvelopeFrom = Last . Just $ doVerp from recp } + | otherwise + -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from } diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a1c3fd573..ed359d3cf 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -9,6 +9,8 @@ , FlexibleContexts , NamedFieldPuns , ScopedTypeVariables + , MultiWayIf + , RecordWildCards #-} module Utils.Form where @@ -23,6 +25,12 @@ import qualified Data.Char as Char import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.Map.Lazy ((!)) +import qualified Data.Map.Lazy as Map +import qualified Data.Set as Set + +import Data.List ((!!)) + import Web.PathPieces ------------------- @@ -220,6 +228,32 @@ ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) reorderField :: ( MonadHandler m , HandlerSite m ~ site , Eq a + , Show a ) => HandlerT site IO (OptionList a) -> Field m [a] -- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result) -reorderField = undefined +reorderField optList = Field{..} + where + fieldEnctype = UrlEncoded + fieldParse [] _ = return $ Right Nothing + fieldParse optlist _ = do + OptionList{..} <- liftHandlerT optList + let + olNum = fromIntegral $ length olOptions + selOptions = traceShowId . Map.fromList $ do + i <- [1..olNum] + (readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist + guard $ i == n + Just val <- return . olReadExternal $ pack extVal + return (i, val) + return $ if + | Map.keysSet selOptions == Set.fromList [1..olNum] + -> Right . Just $ map (selOptions !) [1..fromIntegral olNum] + | otherwise + -> Left "Not a valid permutation" + fieldView theId name attrs val isReq = do + OptionList{..} <- liftHandlerT optList + let + isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue + nums = map (id &&& withNum theId) [1..length olOptions] + withNum t n = tshow n <> "." <> t + $(widgetFile "widgets/permutation") diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet index ea27a3906..5b9947314 100644 --- a/templates/adminTest.hamlet +++ b/templates/adminTest.hamlet @@ -39,3 +39,6 @@ ^{modal ".toggler2" (Just "Test Inhalt für Modal")}
Klick mich für Content-Test +
  • +
    + ^{emailWidget} diff --git a/templates/widgets/permutation.hamlet b/templates/widgets/permutation.hamlet new file mode 100644 index 000000000..ac5ee008a --- /dev/null +++ b/templates/widgets/permutation.hamlet @@ -0,0 +1,7 @@ +$newline never +
      + $forall (n, selId) <- nums +
    • +