diff --git a/.gitignore b/.gitignore index c37cbe326..f744360b3 100644 --- a/.gitignore +++ b/.gitignore @@ -29,6 +29,7 @@ uniworx.nix src/Handler/Assist.bak src/Handler/Course.SnapCustom.hs *.orig +/instance .stack-work-* .directory tags diff --git a/app/DevelMain.hs b/app/DevelMain.hs index b327943d8..0a7a89562 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -33,13 +33,15 @@ module DevelMain where import Prelude import Application (getApplicationRepl, shutdownApp) -import Control.Exception (finally) +import Control.Monad.Catch (finally) import Control.Monad ((>=>)) import Control.Concurrent import Data.IORef import Foreign.Store import Network.Wai.Handler.Warp import GHC.Word +import Control.Monad.Trans.Resource +import Control.Monad.IO.Class -- | Start or restart the server. -- newStore is from foreign-store. @@ -71,13 +73,14 @@ update = do -- | Start the server in a separate thread. start :: MVar () -- ^ Written to when the thread is killed. -> IO ThreadId - start done = do - (port, site, app) <- getApplicationRepl - forkIO (finally (runSettings (setPort port defaultSettings) app) - -- Note that this implies concurrency - -- between shutdownApp and the next app that is starting. - -- Normally this should be fine - (putMVar done () >> shutdownApp site)) + start done = runResourceT $ do + (port, site, app) <- getApplicationRepl + resourceForkIO $ do + finally (liftIO $ runSettings (setPort port defaultSettings) app) + -- Note that this implies concurrency + -- between shutdownApp and the next app that is starting. + -- Normally this should be fine + (liftIO $ putMVar done () >> shutdownApp site) -- | kill the server shutdown :: IO () diff --git a/config/keter_testworx.yml b/config/keter_testworx.yml index 102573866..d719af918 100644 --- a/config/keter_testworx.yml +++ b/config/keter_testworx.yml @@ -31,9 +31,21 @@ stanzas: - DUMMY_LOGIN - DETAILED_LOGGING - LOG_ALL + - LOGLEVEL + - ALLOW_DEPRECATED - PWFILE - CRYPTOID_KEYFILE - IP_FROM_HEADER + - MAILFROM_NAME + - MAILFROM_EMAIL + - MAILOBJECT_DOMAIN + - SMTPHOST + - SMTPPORT + - SMTPSSL + - SMTPUSER + - SMTPPASS + - SMTPTIMEOUT + - SMTPLIMIT # Use the following to automatically copy your bundle upon creation via `yesod # keter`. Uses `scp` internally, so you can set it to a remote destination diff --git a/config/keter_uni2work.yml b/config/keter_uni2work.yml index aefd5a30a..d6c440632 100644 --- a/config/keter_uni2work.yml +++ b/config/keter_uni2work.yml @@ -30,9 +30,22 @@ stanzas: - LDAPTIMEOUT - DETAILED_LOGGING - LOG_ALL + - LOGLEVEL + - ALLOW_DEPRECATED - PWFILE - CRYPTOID_KEYFILE - IP_FROM_HEADER + - MAILFROM_NAME + - MAILFROM_EMAIL + - MAILOBJECT_DOMAIN + - SMTPHOST + - SMTPPORT + - SMTPSSL + - SMTPUSER + - SMTPPASS + - SMTPTIMEOUT + - SMTPLIMIT + # Use the following to automatically copy your bundle upon creation via `yesod # keter`. Uses `scp` internally, so you can set it to a remote destination diff --git a/config/settings.yml b/config/settings.yml index 75d5af052..02598c3f6 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -8,6 +8,19 @@ 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" +mail-verp: + separator: "+" + at-replacement: "=" + +job-workers: "_env:JOB_WORKERS:10" +job-flush-interval: "_env:JOB_FLUSH:30" +job-cron-interval: "_env:CRON_INTERVAL:60" +job-stale-threshold: 300 +notification-rate-limit: 3600 detailed-logging: "_env:DETAILED_LOGGING:false" should-log-all: "_env:LOG_ALL:false" @@ -44,6 +57,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:10" + user-defaults: max-favourites: 12 theme: Default @@ -53,3 +79,4 @@ user-defaults: download-files: false cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf" +instance-idfile: "_env:INSTANCEID_FILE:instance" diff --git a/db.hs b/db.hs index 3bb77bcf5..adf008619 100755 --- a/db.hs +++ b/db.hs @@ -1,11 +1,12 @@ #!/usr/bin/env stack --- stack runghc +-- stack runghc --package uniworx {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} import "uniworx" Import hiding (Option(..)) import "uniworx" Application (db, getAppDevSettings) @@ -20,6 +21,8 @@ import System.IO (hPutStrLn, stderr) import qualified Data.ByteString as BS +import Database.Persist.Sql (toSqlKey) + import Data.Time @@ -62,6 +65,8 @@ fillDb = do AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod 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 @@ -78,6 +83,8 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["en"] + , userNotificationSettings = def } fhamann <- insert User { userIdent = "felix.hamann@campus.lmu.de" @@ -92,6 +99,8 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["de"] + , userNotificationSettings = def } jost <- insert User { userIdent = "jost@tcs.ifi.lmu.de" @@ -106,6 +115,8 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["de"] + , userNotificationSettings = def } void . insert $ User { userIdent = "max@campus.lmu.de" @@ -120,6 +131,8 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["de"] + , userNotificationSettings = def } void . insert $ User { userIdent = "tester@campus.lmu.de" @@ -134,8 +147,10 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["de"] + , userNotificationSettings = def } - void . insert $ Term + void . repsert (TermKey summer2017) $ Term { termName = summer2017 , termStart = fromGregorian 2017 04 09 , termEnd = fromGregorian 2017 07 14 @@ -144,7 +159,7 @@ fillDb = 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 @@ -153,7 +168,7 @@ fillDb = 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 @@ -162,22 +177,28 @@ fillDb = 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 @@ -203,7 +224,7 @@ fillDb = do sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) insert_ $ SheetEdit gkleen now sheetkey -- EIP - eip <- insert Course + eip <- insert' Course { courseName = "Einführung in die Programmierung" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -218,10 +239,10 @@ fillDb = 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 @@ -236,10 +257,10 @@ fillDb = 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 @@ -254,10 +275,10 @@ fillDb = 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 @@ -298,7 +319,7 @@ fillDb = do void . insert $ SheetFile sh1 h103 SheetSolution void . insert $ SheetFile sh1 pdf10 SheetExercise -- datenbanksysteme - dbs <- insert Course + dbs <- insert' Course { courseName = "Datenbanksysteme" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -313,7 +334,7 @@ fillDb = 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 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/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1bd1ddd42..afbffb76e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -245,6 +245,7 @@ RatingComment: Kommentar SubmissionUsers: Studenten Rating: Korrektur RatingPoints: Punkte +RatingDone: Bewertung fertiggestellt RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein @@ -274,6 +275,7 @@ DateFormat: Datumsformat TimeFormat: Uhrzeitformat DownloadFiles: Dateien automatisch herunterladen DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden). +NotificationSettings: Erwünschte Benachrichtigungen InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren @@ -309,3 +311,47 @@ 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. +MailTestDateTime: Test der Datumsformattierung: + +German: Deutsch +GermanGermany: Deutsch (Deutschland) + +MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde korrigiert +MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde korrigiert. + +MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben +MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen. + +MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden +MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Dia Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze. + +SheetTypeBonus: Bonus +SheetTypeNormal: Normal +SheetTypePass: Bestehen +SheetTypeNotGraded: Keine Wertung + +SheetTypeBonus' maxPoints@Points: #{tshow maxPoints} Bonuspunkte +SheetTypeNormal' maxPoints@Points: #{tshow maxPoints} Punkte +SheetTypePass' maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten +SheetTypeNotGraded': Nicht gewertet + +SheetTypeMaxPoints: Maximalpunktzahl +SheetTypePassingPoints: Notwendig zum Bestehen + +SheetGroupArbitrary: Arbiträre Gruppen +SheetGroupRegisteredGroups: Registrierte Gruppen +SheetGroupNoGroups: Keine Gruppenabgabe +SheetGroupMaxGroupsize: Maximale Gruppengröße + +SheetFiles: Übungsblatt-Dateien + +NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert +NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert +NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen +NotificationTriggerSheetInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben \ No newline at end of file diff --git a/models b/models index 194a9c063..cb599b025 100644 --- a/models +++ b/models @@ -11,6 +11,8 @@ User json dateFormat DateTimeFormat "default='%d.%m.%Y'" timeFormat DateTimeFormat "default='%R'" downloadFiles Bool default=false + mailLanguages MailLanguages "default='[]'" + notificationSettings NotificationSettings UniqueAuthentication ident UniqueEmail email deriving Show @@ -221,3 +223,15 @@ Exam -- -- CONTINUE HERE: Include rating in this table or separately? -- UniqueExamUser user examId -- By default this file is used in Model.hs (which is imported by Foundation.hs) +QueuedJob + content Value + creationInstance InstanceId + creationTime UTCTime + lockInstance InstanceId Maybe + lockTime UTCTime Maybe + deriving Eq Read Show Generic Typeable +CronLastExec + job Value + time UTCTime + instance InstanceId + UniqueCronLastExec job \ No newline at end of file diff --git a/package.yaml b/package.yaml index 613489a82..c9f2e9858 100644 --- a/package.yaml +++ b/package.yaml @@ -77,6 +77,9 @@ dependencies: - parsec - uuid - exceptions +- stm +- stm-chans +- stm-conduit - lens - MonadRandom - email-validate @@ -92,6 +95,15 @@ dependencies: - universe-base - random-shuffle - th-abstraction +- HaskellNet +- HaskellNet-SSL +- network +- resource-pool +- mime-mail +- hashable +- aeson-pretty +- resourcet +- postgresql-simple # 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 9c4cb5a54..4f07f3de0 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Application ( getApplicationDev, getAppDevSettings @@ -13,6 +14,7 @@ module Application , makeFoundation , makeLogWare -- * for DevelMain + , foundationStoreNum , getApplicationRepl , shutdownApp -- * for GHCI @@ -21,7 +23,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 @@ -38,12 +40,30 @@ 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 Jobs + import qualified Data.Text.Encoding as Text import Yesod.Auth.Util.PasswordStore -import qualified Data.ByteString.Char8 as BS -import qualified Data.Yaml as Yaml +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 Control.Monad.Trans.Resource + +import System.Log.FastLogger.Date +import qualified Yesod.Core.Types as Yesod (Logger(..)) + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -69,52 +89,107 @@ mkYesodDispatch "UniWorX" resourcesUniWorX -- performs initialization and returns a foundation datatype value. This is also -- the place to put your migrate statements to have automatic database -- migrations handled by Yesod. -makeFoundation :: AppSettings -> IO UniWorX +makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX makeFoundation appSettings@(AppSettings{..}) = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. appHttpManager <- newManager - appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger - appStatic <- - (if appMutableStatic then staticDevel else static) - appStaticDir + appLogger <- liftIO $ do + tgetter <- newTimeCache "%Y-%m-%d %T %z" + loggerSet <- newStdoutLoggerSet defaultBufSize + return $ Yesod.Logger loggerSet tgetter + appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir appCryptoIDKey <- readKeyFile appCryptoIDKeyFile + appInstanceID <- liftIO $ maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile + + (appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ 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 -- 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 - -- Create the database connection pool - pool <- flip runLoggingT logFunc $ createPostgresqlPool + flip runLoggingT logFunc $ do + $logDebugS "InstanceID" $ UUID.toText appInstanceID + -- $logDebugS "Configuration" $ tshow appSettings + + smtpPool <- traverse createSmtpPool appSmtpConf + + -- Create the database connection pool + sqlPool <- createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) + + -- Perform database migration using our application's logging settings. + migrateAll `runSqlPool` sqlPool - -- Perform database migration using our application's logging settings. - runLoggingT (runSqlPool migrateAll pool) logFunc + handleJobs recvChans $ mkFoundation sqlPool smtpPool - -- Return the foundation - return $ mkFoundation pool + -- Return the foundation + return $ mkFoundation sqlPool smtpPool + +readInstanceIDFile :: MonadIO m => FilePath -> m UUID +readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS + where + parseBS :: LBS.ByteString -> IO UUID + parseBS = maybe (throwString "appInstanceIDFile does not contain an UUID encoded in network byte order") return . UUID.fromByteString + generateInstead :: IOException -> IO UUID + generateInstead e + | isDoesNotExistError e = do + createDirectoryIfMissing True $ takeDirectory idFile + instanceId <- UUID.nextRandom + LBS.writeFile idFile $ UUID.toByteString instanceId + 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 -makeApplication foundation = do +makeApplication :: MonadIO m => UniWorX -> m Application +makeApplication foundation = liftIO $ do logWare <- makeLogWare foundation -- Create the WAI application and apply middlewares appPlain <- toWaiAppPlain foundation return $ logWare $ defaultMiddlewaresNoLogging appPlain -makeLogWare :: UniWorX -> IO Middleware -makeLogWare foundation = +makeLogWare :: MonadIO m => UniWorX -> m Middleware +makeLogWare foundation = liftIO $ mkRequestLogger def { outputFormat = if appDetailedRequestLogging $ appSettings foundation @@ -143,26 +218,29 @@ warpSettings foundation = defaultSettings -- | For yesod devel, return the Warp settings and WAI Application. -getApplicationDev :: IO (Settings, Application) +getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application) getApplicationDev = do settings <- getAppDevSettings foundation <- makeFoundation settings - wsettings <- getDevSettings $ warpSettings foundation + wsettings <- liftIO . getDevSettings $ warpSettings foundation app <- makeApplication foundation return (wsettings, app) -getAppDevSettings :: IO AppSettings -getAppDevSettings = loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppDevSettings :: MonadIO m => m AppSettings +getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv -- | main function for use by yesod devel develMain :: IO () -develMain = develMainHelper getApplicationDev +develMain = runResourceT $ do + app <- getApplicationDev + liftIO . develMainHelper $ return app -- | The @main@ function for an executable running this site. -appMain :: IO () -appMain = do +appMain :: MonadResourceBase m => m () +appMain = runResourceT $ do -- Get the settings from all relevant sources - settings <- loadYamlSettingsArgs + settings <- liftIO $ + loadYamlSettingsArgs -- fall back to compile-time values, set to [] to require values at runtime [configSettingsYmlValue] @@ -176,22 +254,31 @@ appMain = do app <- makeApplication foundation -- Run the application with Warp - runSettings (warpSettings foundation) app + liftIO $ runSettings (warpSettings foundation) app -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the app from GHCi) -------------------------------------------------------------- -getApplicationRepl :: IO (Int, UniWorX, Application) +foundationStoreNum :: Word32 +foundationStoreNum = 2 + +getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) getApplicationRepl = do settings <- getAppDevSettings foundation <- makeFoundation settings - wsettings <- getDevSettings $ warpSettings foundation + wsettings <- liftIO . getDevSettings $ warpSettings foundation app1 <- makeApplication foundation + + let foundationStore = Store foundationStoreNum + liftIO $ deleteStore foundationStore + liftIO $ writeStore foundationStore foundation + return (getPort wsettings, foundation, app1) -shutdownApp :: UniWorX -> IO () -shutdownApp _ = return () +shutdownApp :: MonadIO m => UniWorX -> m () +shutdownApp UniWorX{..} = do + liftIO . atomically $ mapM_ closeTMChan appJobCtl --------------------------------------------- @@ -200,7 +287,7 @@ shutdownApp _ = return () -- | Run a handler handler :: Handler a -> IO a -handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h +handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -- | Run DB queries db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a @@ -209,7 +296,7 @@ db = handler . runDB addPWEntry :: User -> Text {-^ Password -} -> IO () -addPWEntry User{..} (Text.encodeUtf8 -> pw) = db $ do +addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength void $ insert User{..} diff --git a/src/Cron.hs b/src/Cron.hs new file mode 100644 index 000000000..a17230f15 --- /dev/null +++ b/src/Cron.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , PatternGuards + , ViewPatterns + , DeriveFunctor + , TemplateHaskell + , NamedFieldPuns + #-} + +module Cron + ( CronNextMatch(..) + , nextCronMatch + , module Cron.Types + ) where + +import ClassyPrelude +import Prelude (lcm) +import Cron.Types + +import Data.Time +import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid) +import Data.Time.Calendar.WeekDate (toWeekDate, fromWeekDate, fromWeekDateValid) +import Data.Time.Zones + +import Numeric.Natural +import Data.Ratio ((%)) + +import qualified Data.Set as Set + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty + +import Utils.Lens.TH +import Control.Lens + + +data CronDate = CronDate + { cdYear, cdWeekOfYear, cdDayOfYear + , cdMonth, cdWeekOfMonth, cdDayOfMonth + , cdDayOfWeek + , cdHour, cdMinute, cdSecond :: Natural + } deriving (Eq, Show, Read) + +makeLenses_ ''CronDate + + +evalCronMatch :: CronMatch -> Natural -> Bool +evalCronMatch CronMatchAny _ = True +evalCronMatch CronMatchNone _ = False +evalCronMatch (CronMatchSome set) x = Set.member x $ toNullable set +evalCronMatch (CronMatchStep step) x = (x `mod` step) == 0 +evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to +evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x +evalCronMatch (CronMatchUnion a b) x = evalCronMatch a x || evalCronMatch b x + +toCronDate :: LocalTime -> CronDate +toCronDate LocalTime{..} = CronDate{..} + where + (fromInteger -> cdYear, fromIntegral -> cdMonth, fromIntegral -> cdDayOfMonth) + = toGregorian localDay + (_, fromIntegral -> cdDayOfYear) + = toOrdinalDate localDay + (_, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek) + = toWeekDate localDay + cdWeekOfMonth = go 1 localDay + where + go :: Natural -> Day -> Natural + go n day + | dow /= 4 = go n $ fromWeekDate y w 4 -- According to ISO week of month is determined by Thursday + | m == m' = go (succ n) day' + | otherwise = n + where + (y, w, dow) = toWeekDate day + day' + | w /= 0 = fromWeekDate y (pred w) dow + | otherwise = fromWeekDate (pred y) 53 dow + (_, m, _) = toGregorian day + (_, m', _) = toGregorian day' + TimeOfDay + { todHour = fromIntegral -> cdHour + , todMin = fromIntegral -> cdMinute + , todSec = round -> cdSecond + } = localTimeOfDay + +consistentCronDate :: CronDate -> Bool +consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do + gDay <- fromGregorianValid (fromIntegral cdYear) (fromIntegral cdMonth) (fromIntegral cdDayOfMonth) + wDay <- fromWeekDateValid (fromIntegral cdYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek) + guard $ gDay == wDay + oDay <- fromOrdinalDateValid (fromIntegral cdYear) (fromIntegral cdDayOfYear) + guard $ wDay == oDay + guard $ ((==) `on` cdWeekOfMonth) cd (toCronDate $ LocalTime wDay (error "TimeOfDay inspected in toCronDate")) + return True + + +data CronNextMatch a = MatchAsap | MatchAt a | MatchNone + deriving (Eq, Ord, Show, Read, Functor) + +instance Applicative CronNextMatch where + pure = MatchAt + _ <*> MatchNone = MatchNone + MatchNone <*> _ = MatchNone + _ <*> MatchAsap = MatchAsap + MatchAsap <*> _ = MatchAsap + MatchAt f <*> MatchAt x = MatchAt $ f x + +instance Alternative CronNextMatch where + empty = MatchNone + x <|> MatchNone = x + MatchNone <|> x = x + _ <|> MatchAsap = MatchAsap + MatchAsap <|> _ = MatchAsap + (MatchAt a) <|> (MatchAt _) = MatchAt a + + +listToMatch :: [a] -> CronNextMatch a +listToMatch [] = MatchNone +listToMatch (t:_) = MatchAt t + +genMatch :: Int -- ^ Period + -> Bool -- ^ Modular + -> Natural -- ^ Start value + -> CronMatch + -> [Natural] +genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..] +genMatch _ _ _ CronMatchNone = [] +genMatch p m _ (CronMatchSome set) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable set +genMatch p m st (CronMatchStep step) = do + start <- [st..st + step] + guard $ (start `mod` step) == 0 + take (ceiling $ fromIntegral p % step) $ map (bool id (succ . (`mod` fromIntegral p)) m) [start,start + step..] +genMatch p m st (CronMatchContiguous from to) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) $ [max st from..to] +genMatch _ _ _ (CronMatchIntersect CronMatchNone _) = [] +genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = [] +genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other +genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other +genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2)) + = genMatch p m st . CronMatchStep $ lcm st1 st2 +genMatch p m st (CronMatchIntersect aGen bGen) + | [] <- as' = [] + | (a:as) <- as' = mergeAnd (a:as) (genMatch p m a bGen) + where + as' = genMatch p m st aGen + mergeAnd [] _ = [] + mergeAnd _ [] = [] + mergeAnd (a:as) (b:bs) + | a < b = mergeAnd as (b:bs) + | a == b = a : mergeAnd as bs + | a > b = mergeAnd (a:as) bs +genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other +genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other +genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny +genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m st CronMatchAny +genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMatch p m st bGen) + where + merge [] bs = bs + merge as [] = as + merge (a:as) (b:bs) + | a < b = a : merge as (b:bs) + | a == b = a : merge as bs + | a > b = b : merge (a:as) bs + +nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry + -> Maybe UTCTime -- ^ Time of last execution of the job + -> UTCTime -- ^ Current time, used only for `CronCalendar` + -> Cron + -> CronNextMatch UTCTime +nextCronMatch tz mPrev now c@Cron{..} + | isNothing mPrev + = execRef now False cronInitial + | Just prevT <- mPrev + = case cronRepeat of + CronRepeatOnChange + | not $ matchesCron tz Nothing prevT c + -> let + cutoffTime = addUTCTime cronRateLimit prevT + in case execRef now False cronInitial of + MatchAsap + | now < cutoffTime -> MatchAt cutoffTime + MatchAt ts + | ts < cutoffTime -> MatchAt cutoffTime + other -> other + CronRepeatScheduled cronNext + -> case cronNext of + CronAsap + | addUTCTime cronRateLimit prevT <= now + -> MatchAsap + | otherwise + -> MatchAt $ addUTCTime cronRateLimit prevT + cronNext + -> execRef (addUTCTime cronRateLimit prevT) True cronNext + _other -> MatchNone + where + execRef ref wasExecd cronAbsolute = case cronAbsolute of + CronAsap -> MatchAsap + CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts } + | ref <= ts -> MatchAt ts + | not wasExecd -> MatchAsap + | otherwise -> MatchNone + CronCalendar{..} -> listToMatch $ do + let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref + cronYear <- genMatch 400 False cdYear cronYear + cronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear + cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear + cronMonth <- genMatch 12 True cdMonth cronMonth + cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth + cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth + cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek + cronHour <- genMatch 24 True cdHour cronHour + cronMinute <- genMatch 60 True cdMinute cronMinute + cronSecond <- genMatch 60 True cdSecond cronSecond + guard $ consistentCronDate CronDate{..} + localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth) + let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond) + return $ localTimeToUTCTZ tz LocalTime{..} + +matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry + -> Maybe UTCTime -- ^ Previous execution of the job + -> UTCTime -- ^ "Current" time + -> Cron + -> Bool +-- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron` +-- specification @c@ should match @now@, under the assumption that the next +-- check will occur no earlier than @now + prec@. +matchesCron tz mPrev now cron = case nextCronMatch tz mPrev now cron of + MatchAsap -> True + MatchNone -> False + MatchAt ts -> ts <= now diff --git a/src/Cron/Types.hs b/src/Cron/Types.hs new file mode 100644 index 000000000..bb6753f73 --- /dev/null +++ b/src/Cron/Types.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoImplicitPrelude + , TemplateHaskell + , DuplicateRecordFields + #-} + +module Cron.Types + ( Cron(..), Crontab + , CronMatch(..) + , CronAbsolute(..) + , CronRepeat(..) + ) where + +import ClassyPrelude + +import Utils.Lens.TH + +import Data.Time + +import Numeric.Natural + +import Data.HashMap.Strict (HashMap) + + +data CronMatch + = CronMatchAny + | CronMatchNone + | CronMatchSome (NonNull (Set Natural)) + | CronMatchStep Natural + | CronMatchContiguous Natural Natural + | CronMatchIntersect CronMatch CronMatch + | CronMatchUnion CronMatch CronMatch + deriving (Eq, Show, Read) + +data CronAbsolute + = CronAsap + | CronTimestamp + { cronTimestamp :: LocalTime + } + | CronCalendar + { cronYear, cronWeekOfYear, cronDayOfYear + , cronMonth, cronWeekOfMonth, cronDayOfMonth + , cronDayOfWeek + , cronHour, cronMinute, cronSecond :: CronMatch + } + | CronNotScheduled + deriving (Eq, Show, Read) + +makeLenses_ ''CronAbsolute + +data CronRepeat + = CronRepeatOnChange + | CronRepeatScheduled CronAbsolute + | CronRepeatNever + deriving (Eq, Show, Read) + +data Cron = Cron + { cronInitial :: CronAbsolute + , cronRepeat :: CronRepeat + , cronRateLimit :: NominalDiffTime + } + deriving (Eq, Show) + +makeLenses_ ''Cron + +type Crontab a = HashMap a Cron diff --git a/src/Data/Universe/Instances/Reverse/Hashable.hs b/src/Data/Universe/Instances/Reverse/Hashable.hs new file mode 100644 index 000000000..e7459f613 --- /dev/null +++ b/src/Data/Universe/Instances/Reverse/Hashable.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude + , ScopedTypeVariables + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Universe.Instances.Reverse.Hashable + ( + ) where + +import ClassyPrelude + +import Data.Universe + + +instance (Hashable a, Hashable b, Finite a) => Hashable (a -> b) where + hashWithSalt s f = s `hashWithSalt` [ (k, f k) | k <- universeF ] diff --git a/src/Data/Universe/Instances/Reverse/JSON.hs b/src/Data/Universe/Instances/Reverse/JSON.hs new file mode 100644 index 000000000..60b7ba6ae --- /dev/null +++ b/src/Data/Universe/Instances/Reverse/JSON.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoImplicitPrelude + , ScopedTypeVariables + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Universe.Instances.Reverse.JSON + ( + ) where + +import ClassyPrelude + +import Data.Aeson +import Data.Aeson.Types (Parser) + +import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict ((!)) + +import Data.Universe + + +instance (Eq a, Hashable a, Finite a, ToJSON b, ToJSONKey a) => ToJSON (a -> b) where + toJSON f = toJSON $ HashMap.fromList [(k, f k) | k <- universeF] + +instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a -> b) where + parseJSON val = do + vMap <- parseJSON val :: Parser (HashMap a b) + unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $ + fail "Not all required keys found" + return $ (vMap !) diff --git a/src/Foundation.hs b/src/Foundation.hs index 105c859ab..6bef15386 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) @@ -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) @@ -67,7 +68,7 @@ import qualified Database.Esqueleto as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Trans.Reader (runReader) +import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Catch (handleAll) @@ -88,6 +89,9 @@ import qualified Data.Yaml as Yaml import Text.Shakespeare.Text (st) +import Yesod.Form.I18n.German +import qualified Yesod.Auth.Message as Auth + instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext @@ -112,11 +116,16 @@ 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 + , appInstanceID :: InstanceId + , 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 @@ -135,6 +144,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 @@ -173,7 +183,7 @@ mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de" -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. instance RenderMessage UniWorX FormMessage where - renderMessage _ _ = defaultFormMessage + renderMessage _ _ = germanFormMessage -- TODO instance RenderMessage UniWorX TermIdentifier where renderMessage foundation ls TermIdentifier{..} = case season of @@ -182,10 +192,9 @@ instance RenderMessage UniWorX TermIdentifier where where renderMessage' = renderMessage foundation ls instance RenderMessage UniWorX StudyFieldType where - renderMessage foundation ls = \case - FieldPrimary -> renderMessage' MsgFieldPrimary - FieldSecondary -> renderMessage' MsgFieldSecondary - where renderMessage' = renderMessage foundation ls + renderMessage foundation ls = renderMessage foundation ls . \case + FieldPrimary -> MsgFieldPrimary + FieldSecondary -> MsgFieldSecondary newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving (Eq, Ord, Read, Show) @@ -200,27 +209,47 @@ instance RenderMessage UniWorX String where renderMessage f ls str = renderMessage f ls $ Text.pack str instance RenderMessage UniWorX SheetFileType where - renderMessage foundation ls = \case - SheetExercise -> renderMessage' MsgSheetExercise - SheetHint -> renderMessage' MsgSheetHint - SheetSolution -> renderMessage' MsgSheetSolution - SheetMarking -> renderMessage' MsgSheetMarking - where renderMessage' = renderMessage foundation ls + renderMessage foundation ls = renderMessage foundation ls . \case + SheetExercise -> MsgSheetExercise + SheetHint -> MsgSheetHint + SheetSolution -> MsgSheetSolution + SheetMarking -> MsgSheetMarking instance RenderMessage UniWorX CorrectorState where - renderMessage foundation ls = \case - CorrectorNormal -> renderMessage' MsgCorrectorNormal - CorrectorMissing -> renderMessage' MsgCorrectorMissing - CorrectorExcused -> renderMessage' MsgCorrectorExcused - where renderMessage' = renderMessage foundation ls + renderMessage foundation ls = renderMessage foundation ls . \case + CorrectorNormal -> MsgCorrectorNormal + CorrectorMissing -> MsgCorrectorMissing + CorrectorExcused -> MsgCorrectorExcused instance RenderMessage UniWorX Load where - renderMessage foundation ls = \case - (Load {byTutorial=Nothing , byProportion=p}) -> renderMessage' $ MsgCorByProportionOnly p - (Load {byTutorial=Just True , byProportion=p}) -> renderMessage' $ MsgCorByProportionIncludingTutorial p - (Load {byTutorial=Just False, byProportion=p}) -> renderMessage' $ MsgCorByProportionExcludingTutorial p - where renderMessage' = renderMessage foundation ls + renderMessage foundation ls = renderMessage foundation ls . \case + (Load {byTutorial=Nothing , byProportion=p}) -> MsgCorByProportionOnly p + (Load {byTutorial=Just True , byProportion=p}) -> MsgCorByProportionIncludingTutorial p + (Load {byTutorial=Just False, byProportion=p}) -> MsgCorByProportionExcludingTutorial p + +instance RenderMessage UniWorX SheetType where + renderMessage foundation ls = renderMessage foundation ls . \case + Bonus{..} -> MsgSheetTypeBonus' maxPoints + Normal{..} -> MsgSheetTypeNormal' maxPoints + Pass{..} -> MsgSheetTypePass' maxPoints passingPoints + NotGraded{} -> MsgSheetTypeNotGraded' + +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 NotificationTrigger where + renderMessage foundation ls = renderMessage foundation ls . \case + NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded + NTSubmissionRated -> MsgNotificationTriggerSubmissionRated + NTSheetActive -> MsgNotificationTriggerSheetActive + NTSheetInactive -> MsgNotificationTriggerSheetInactive instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where @@ -242,6 +271,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 @@ -454,14 +499,14 @@ route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK attrsAND = map splitAND $ Set.toList $ routeAttrs r splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" -evalAccessDB :: Route UniWorX -> Bool -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise -evalAccessDB r w = case route2ap r of +evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise +evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer (APHandler p) -> lift $ p r w (APDB p) -> p r w -evalAccess :: Route UniWorX -> Bool -> Handler AuthResult -evalAccess r w = case route2ap r of +evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess r w = liftHandlerT $ case route2ap r of (APPure p) -> runReader (p r w) <$> getMsgRenderer (APHandler p) -> p r w (APDB p) -> runDB $ p r w @@ -1223,12 +1268,14 @@ instance YesodAuth UniWorX where let newUser = User - { userMaxFavourites = userDefaultMaxFavourites - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles + { userMaxFavourites = userDefaultMaxFavourites + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userNotificationSettings = def + , userMailLanguages = def , .. } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer @@ -1271,6 +1318,8 @@ instance YesodAuth UniWorX where authHttpManager = getHttpManager + renderAuthMessage _ _ = Auth.germanMessage -- TODO + instance YesodAuthPersist UniWorX -- Useful when writing code that is re-usable outside of the Handler context. @@ -1283,6 +1332,25 @@ unsafeHandler :: UniWorX -> Handler a -> IO a 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 + mailT ctx mail = defMailT ctx $ do + setMailObjectId + setDateCurrent + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + + ret <- mail + + setMailSmtpData + return ret + + instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where type MonadCryptoKey m = CryptoIDKey cryptoIDKey f = getsYesod appCryptoIDKey >>= f diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 156961629..6de79e526 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -7,11 +7,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} module Handler.Admin where import Import import Handler.Utils +import Jobs -- import Data.Time -- import qualified Data.Text as T @@ -20,6 +22,8 @@ import Handler.Utils import Web.PathPieces (showToPathPiece, readFromPathPiece) +import Database.Persist.Sql (fromSqlKey) + -- import Colonnade hiding (fromMaybe) -- import Yesod.Colonnade @@ -41,22 +45,54 @@ instance Button UniWorX CreateButton where cssClass CreateInf = BCPrimary -- END Button needed here +emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) +emailTestForm = (,) + <$> areq emailField (fslI MsgMailTestFormEmail) Nothing + <*> ( MailContext + <$> (MailLanguages <$> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing) + <*> (toMailDateTimeFormat + <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing + <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing + <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing + ) + ) + <* submitButton + where + toMailDateTimeFormat dt d t = \case + SelFormatDateTime -> dt + SelFormatDate -> d + SelFormatTime -> t -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)) -> do + jId <- runDB $ do + jId <- queueJob $ JobSendTestEmail email ls + addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] + return jId + writeJobCtl $ JobCtlPerform jId + FormMissing -> return () + (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml + + let emailWidget' = [whamlet| +
+ ^{emailWidget} + |] + + defaultLayout $ do + -- setTitle "Uni2work Admin Testpage" + $(widgetFile "adminTest") getAdminUserR :: CryptoUUIDUser -> Handler Html diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 94aab5738..5d676b63f 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiWayIf, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} {-# LANGUAGE TemplateHaskell #-} @@ -21,6 +20,7 @@ module Handler.Corrections where import Import -- import System.FilePath (takeFileName) +import Jobs import Handler.Utils import Handler.Utils.Submission import Handler.Utils.Table.Cells @@ -189,44 +189,46 @@ makeCorrectionsTable whereClause colChoices psValidator = do { dbtSQLQuery , dbtColonnade = colChoices , dbtProj - , dbtSorting = [ ( "term" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm - ) - , ( "course" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand - ) - , ( "sheet" - , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName - ) - , ( "corrector" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname - ) - , ( "rating" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints - ) - ] - , dbtFilter = [ ( "term" - , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if - | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) - ) - , ( "course" - , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if - | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs) - ) - , ( "sheet" - , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if - | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns) - ) - , ( "corrector" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if - | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails) - E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) - ) - ] + , dbtSorting = Map.fromList + [ ( "term" + , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm + ) + , ( "course" + , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand + ) + , ( "sheet" + , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName + ) + , ( "corrector" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname + ) + , ( "rating" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints + ) + ] + , dbtFilter = Map.fromList + [ ( "term" + , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if + | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) + ) + , ( "course" + , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if + | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs) + ) + , ( "sheet" + , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if + | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns) + ) + , ( "corrector" + , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if + | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails) + E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) + ) + ] , dbtStyle = def , dbtIdent = "corrections" :: Text } @@ -248,12 +250,12 @@ data ActionCorrectionsData = CorrDownloadData | CorrSetCorrectorData (Maybe UserId) | CorrAutoSetCorrectorData SheetId -correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent +correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do tableForm <- makeCorrectionsTable whereClause displayColumns psValidator ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf - (actionRes, action) <- multiAction actions + (actionRes, action) <- multiAction actions Nothing return ((,) <$> actionRes <*> selectionRes, table <> action) Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler @@ -323,16 +325,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = $(widgetFile "corrections") -type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) +type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) downloadAction :: ActionCorrections' downloadAction = ( CorrDownload - , return (pure CorrDownloadData, Nothing) + , pure CorrDownloadData ) assignAction :: Either CourseId SheetId -> ActionCorrections' assignAction selId = ( CorrSetCorrector - , over (mapped._2) Just $ do + , wFormToAForm $ do correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet @@ -346,14 +348,13 @@ assignAction selId = ( CorrSetCorrector correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey - ($ mempty) . renderAForm FormStandard . wFormToAForm $ do - cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing - fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId + cId <- wpreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing + fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId ) autoAssignAction :: SheetId -> ActionCorrections' autoAssignAction shid = ( CorrAutoSetCorrector - , return (pure $ CorrAutoSetCorrectorData shid, Nothing) + , pure $ CorrAutoSetCorrectorData shid ) getCorrectionsR, postCorrectionsR :: Handler TypedContent @@ -449,9 +450,12 @@ postCorrectionR tid ssh csh shn cid = do case results of [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) + pointsForm = case sheetType of + NotGraded -> bool Nothing (Just 0) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) + _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints) ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,) - <$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints) + <$> pointsForm <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment)) <* submitButton @@ -463,11 +467,13 @@ postCorrectionR tid ssh csh shn cid = do FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess (ratingPoints, ratingComment) -> do - runDB $ do + runDBJobs $ do uid <- liftHandlerT requireAuthId now <- liftIO getCurrentTime - let rated = isJust $ void ratingPoints <|> void ratingComment + let rated = isJust ratingPoints -- <|> void ratingComment -- Comment shouldn't cause rating + + Submission{submissionRatingTime} <- getJust sub update sub [ SubmissionRatingBy =. (uid <$ guard rated) -- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload @@ -478,6 +484,11 @@ postCorrectionR tid ssh csh shn cid = do ] addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated + + when (rated && isNothing submissionRatingTime) $ do + $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] + queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR case uploadResult of @@ -486,7 +497,7 @@ postCorrectionR tid ssh csh shn cid = do FormSuccess fileSource -> do uid <- requireAuthId - runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True + runDBJobs . runConduit $ transPipe (lift . lift) fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True addMessageI Success MsgRatingFilesUpdated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR @@ -521,7 +532,7 @@ postCorrectionsUploadR = do FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess files -> do uid <- requireAuthId - subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True + subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True if | null subs -> addMessageI Warning MsgNoCorrectionsUploaded | otherwise -> do diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 874971fec..55092ff11 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -24,6 +24,8 @@ import Utils.Lens -- import Yesod.Colonnade import Data.Monoid (Any(..)) import qualified Data.Map as Map +import Data.Map ((!)) +import qualified Data.Set as Set -- import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Esqueleto ((^.)) @@ -37,6 +39,7 @@ data SettingsForm = SettingsForm , stgDate :: DateTimeFormat , stgTime :: DateTimeFormat , stgDownloadFiles :: Bool + , stgNotificationSettings :: NotificationSettings } makeSettingForm :: Maybe SettingsForm -> Form SettingsForm @@ -53,13 +56,30 @@ makeSettingForm template = identForm FIDsettings $ \html -> do <*> areq checkBoxField (fslI MsgDownloadFiles & setTooltip MsgDownloadFilesTip ) (stgDownloadFiles <$> template) + <*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty) <* submitButton return (result, widget) -- no validation required here + where + nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt -> + areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template) + nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX]) + nsFieldView (res, fvInput) = do + mr <- getMessageRender + let fvLabel = toHtml $ mr MsgNotificationSettings + fvTooltip = mempty + fvRequired = True + fvErrors + | FormFailure (err:_) <- res = Just $ toHtml err + | otherwise = Nothing + fvId <- newIdent + return (res, pure FieldView{..}) + -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template) -getProfileR :: Handler Html -getProfileR = do +getProfileR, postProfileR :: Handler Html +getProfileR = postProfileR +postProfileR = do (uid, User{..}) <- requireAuthPair let settingsTemplate = Just $ SettingsForm { stgMaxFavourties = userMaxFavourites @@ -68,6 +88,7 @@ getProfileR = do , stgDate = userDateFormat , stgTime = userTimeFormat , stgDownloadFiles = userDownloadFiles + , stgNotificationSettings = userNotificationSettings } ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate case res of @@ -79,6 +100,7 @@ getProfileR = do , UserDateFormat =. stgDate , UserTimeFormat =. stgTime , UserDownloadFiles =. stgDownloadFiles + , UserNotificationSettings =. stgNotificationSettings ] when (stgMaxFavourties < userMaxFavourites) $ do -- prune Favourites to user-defined size @@ -135,11 +157,6 @@ getProfileR = do $(widgetFile "profile") $(widgetFile "dsgvDisclaimer") -postProfileR :: Handler Html -postProfileR = do - -- TODO - getProfileR - postProfileDataR :: Handler Html postProfileDataR = do ((btnResult,_), _) <- runFormPost $ buttonForm diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 510e92117..92aed1fab 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -57,7 +57,7 @@ import qualified Data.Map as Map import Data.Map (Map, (!), (!?)) import qualified Data.Map as Map -import Data.Monoid (Sum(..)) +import Data.Monoid (Sum(..), Any(..)) import Control.Lens -- import Utils.Lens @@ -273,14 +273,14 @@ getSShowR tid ssh csh shn = do -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat - [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype + [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName)) (\(E.Value fName,_,_) -> str2widget fName) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget ] let psValidator = def & defaultSorting [("type", SortAsc), ("path", SortAsc)] - ((), fileTable) <- dbTable psValidator $ DBTable + (Any hasFiles, fileTable) <- dbTable psValidator $ DBTable { dbtSQLQuery = fileData , dbtColonnade = colonnadeFiles , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index b64be4126..b8f80cbee 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -20,6 +20,8 @@ module Handler.Submission where import Import hiding (joinPath) +import Jobs + -- import Yesod.Form.Bootstrap3 import Handler.Utils @@ -72,7 +74,7 @@ makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ flip (renderAForm FormStandard) html $ (,) <$> fileUpload <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy - | g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile + | g <- [1..(max (fromIntegral groupNr) $ length buddies)] -- groupNr might have decreased meanwhile | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies ]) <* submitButton @@ -178,7 +180,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time return (csheet,buddies,lastEdits) ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies - mCID <- runDB $ do + mCID <- runDBJobs $ do res' <- case res of (FormMissing ) -> return $ FormMissing (FormFailure failmsgs) -> return $ FormFailure failmsgs @@ -215,7 +217,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email _other -> mempty - , case length participants `compare` maxParticipants of + , case fromIntegral (length participants) `compare` maxParticipants of LT -> mempty _ -> pure $ mr MsgTooManyParticipants ] @@ -232,8 +234,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do smid <- case (mFiles, msmid) of (Nothing, Just smid) -- no new files, existing submission partners updated -> return smid - (Just files, _) -- new files - -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False + (Just files, _) -> -- new files + runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False (Nothing, Nothing) -- new submission, no file upload requested -> insert Submission { submissionSheet = shid diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 394359b27..1b3d68334 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -25,6 +25,7 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings) import Handler.Utils.Submission as Handler.Utils import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Templates as Handler.Utils +import Handler.Utils.Mail as Handler.Utils downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 679539202..67acd6a32 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -11,6 +11,7 @@ module Handler.Utils.DateTime , formatTime, formatTime', formatTimeW , getTimeLocale, getDateTimeFormat , validDateTimeFormats, dateTimeFormatOptions + , formatTimeMail , addOneWeek ) where @@ -26,6 +27,8 @@ import qualified Data.Time.Format as Time import Data.Set (Set) import qualified Data.Set as Set +import Mail + utcToLocalTime :: UTCTime -> LocalTime utcToLocalTime = TZ.utcToLocalTimeTZ appTZ @@ -58,6 +61,9 @@ formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeForm formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget formatTimeW s t = toWidget =<< formatTime s t +formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text +formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t) + getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale getTimeLocale = getTimeLocale' <$> languages diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index a6efd53ff..1061f4256 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -25,7 +25,7 @@ import Handler.Utils.Templates import Handler.Utils.DateTime import qualified Data.Time as Time -import Import +import Import hiding (cons) import qualified Data.Char as Char import Data.String (IsString(..)) @@ -60,6 +60,10 @@ import Data.Scientific (Scientific) import Data.Ratio import Text.Read (readMaybe) +import Data.Maybe (fromJust) + +import Utils.Lens + ---------------------------- -- Buttons (new version ) -- ---------------------------- @@ -288,23 +292,122 @@ multiFileField permittedFiles' = Field{..} Right _ -> return () Left r -> yield r -sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType -sheetTypeAFormReq d Nothing = - -- TODO, offer options to choose between Normal/Bonus/Pass - (Normal . toPoints) <$> areq (natField "Punkte") d Nothing -sheetTypeAFormReq d (Just (Normal p)) = - -- TODO, offer options to choose between Normal/Bonus/Pass - (Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p) -sheetTypeAFormReq d (Just (NotGraded)) = pure NotGraded +data SheetType' = Bonus' | Normal' | Pass' | NotGraded' + deriving (Eq, Ord, Read, Show, Enum, Bounded) +instance Universe SheetType' +instance Finite SheetType' + +$(return []) + +instance PathPiece SheetType' where + toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"]) + fromPathPiece = finiteFromPathPiece + +instance RenderMessage UniWorX SheetType' where + renderMessage f ls = \case + Bonus' -> render MsgSheetTypeBonus + Normal' -> render MsgSheetTypeNormal + Pass' -> render MsgSheetTypePass + NotGraded' -> render MsgSheetTypeNotGraded + where + render = renderMessage f ls + +data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups' + deriving (Eq, Ord, Read, Show, Enum, Bounded) + +instance Universe SheetGroup' +instance Finite SheetGroup' + +$(return []) + +instance PathPiece SheetGroup' where + toPathPiece = $(nullaryToPathPiece ''SheetGroup' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"]) + fromPathPiece = finiteFromPathPiece + +instance RenderMessage UniWorX SheetGroup' where + renderMessage f ls = \case + Arbitrary' -> render MsgSheetGroupArbitrary + RegisteredGroups' -> render MsgSheetGroupRegisteredGroups + NoGroups' -> render MsgSheetGroupNoGroups + where + render = renderMessage f ls + +sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType +sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do + let + selOptions = Map.fromList + [ ( Bonus', Bonus <$> maxPointsReq ) + , ( Normal', Normal <$> maxPointsReq ) + , ( Pass', Pass + <$> maxPointsReq + <*> apreq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template) + ) + , ( NotGraded', pure NotGraded ) + ] + (res, selView) <- multiAction selOptions (classify' <$> template) + + fvId <- maybe newIdent return fsId + MsgRenderer mr <- getMsgRenderer + + return (res, + [ FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml . mr <$> fsTooltip + , fvId + , fvInput = selView + , fvErrors = case res of + FormFailure [e] -> Just $ toHtml e + _ -> Nothing + , fvRequired = True + } + ]) + + where + maxPointsReq = apreq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template) + + classify' :: SheetType -> SheetType' + classify' = \case + Bonus _ -> Bonus' + Normal _ -> Normal' + Pass _ _ -> Pass' + NotGraded -> NotGraded' sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup -sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 = - -- TODO, offer options to choose between Arbitrary/Registered/NoGroups - Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n) -sheetGroupAFormReq d _other = -- TODO - -- TODO, offer options to choose between Arbitrary/Registered/NoGroups - Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1) +sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do + let + selOptions = Map.fromList + [ ( Arbitrary', Arbitrary + <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template) + ) + , ( RegisteredGroups', pure RegisteredGroups ) + , ( NoGroups', pure NoGroups ) + ] + (res, selView) <- multiAction selOptions (classify' <$> template) + + fvId <- maybe newIdent return fsId + MsgRenderer mr <- getMsgRenderer + + return (res, + [ FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml . mr <$> fsTooltip + , fvId + , fvInput = selView + , fvErrors = case res of + FormFailure [e] -> Just $ toHtml e + _ -> Nothing + , fvRequired = True + } + ]) + + where + classify' :: SheetGroup -> SheetGroup' + classify' = \case + Arbitrary _ -> Arbitrary' + RegisteredGroups -> RegisteredGroups' + NoGroups -> NoGroups' + {- dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime @@ -416,15 +519,34 @@ aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m => Field m a -> FieldSettings site -> a -> AForm m a aforced field settings val = formToAForm $ second pure <$> mforced field settings val +apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe a -> AForm m a +-- ^ Pseudo required +apreq f fs mx = formToAForm $ do + mr <- getMessageRender + fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } ))) $ mopt f fs (Just <$> mx) + +wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a) +wpreq f fs mx = mFormToWForm $ do + mr <- getMessageRender + fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } )) $ mopt f fs (Just <$> mx) + multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) - => Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget)) + => Map action (AForm (HandlerT UniWorX IO) a) + -> Maybe action -> MForm (HandlerT UniWorX IO) (FormResult a, Widget) -multiAction acts = do +multiAction acts defAction = do mr <- getMessageRender let options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece - (actionRes, actionView) <- mreq (selectField $ return options) "" Nothing - results <- sequence acts - let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results + (actionRes, actionView) <- mreq (selectField $ return options) "" defAction + results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts + let mToWidget (_, []) = return Nothing + mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty + widgets <- mapM mToWidget results + let actionWidgets = Map.foldrWithKey accWidget [] widgets + accWidget act Nothing = id + accWidget act (Just w) = cons $(widgetFile "widgets/multiAction") actionResults = Map.map fst results return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect")) diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs new file mode 100644 index 000000000..96ef448e0 --- /dev/null +++ b/src/Handler/Utils/Mail.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE NoImplicitPrelude + , NamedFieldPuns + , TypeFamilies + , FlexibleContexts + , ViewPatterns + , LambdaCase + #-} + +module Handler.Utils.Mail + ( addRecipientsDB + , userMailT + , addFileDB + ) where + +import Import hiding ((.=)) + +import Utils.Lens hiding (snoc) + +import qualified Data.CaseInsensitive as CI + +import qualified Data.ByteString.Lazy as LBS + +import qualified Data.Conduit.List as C + +import System.FilePath (takeBaseName) +import Network.Mime (defaultMimeLookup) + +import Control.Monad.Trans.State (StateT) + + +addRecipientsDB :: ( MonadMail m + , MonadHandler m + , HandlerSite m ~ UniWorX + ) => [Filter User] -> m () +-- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user +addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient + where + addRecipient (Entity _ User{userEmail, userDisplayName}) = do + let addr = Address (Just userDisplayName) $ CI.original userEmail + _mailTo %= flip snoc addr + +userMailT :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadBaseControl IO m + , MonadLogger m + ) => UserId -> MailT m a -> m a +userMailT uid mAct = do + User + { userEmail + , userDisplayName + , userMailLanguages + , userDateTimeFormat + , userDateFormat + , userTimeFormat + } <- liftHandlerT . runDB $ getJust uid + let + addr = Address (Just userDisplayName) $ CI.original userEmail + ctx = MailContext + { mcLanguages = userMailLanguages + , mcDateTimeFormat = \case + SelFormatDateTime -> userDateTimeFormat + SelFormatDate -> userDateFormat + SelFormatTime -> userTimeFormat + } + mailT ctx $ do + _mailTo .= pure addr + mAct + +addFileDB :: ( MonadMail m + , MonadHandler m + , HandlerSite m ~ UniWorX + ) => FileId -> m MailObjectId +addFileDB fId = do + File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId + addPart $ do + _partType .= decodeUtf8 (defaultMimeLookup fileName) + _partEncoding .= Base64 + _partFilename .= Just fileName + _partContent .= LBS.fromStrict fileContent + setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 32b9e4d65..9f67bf0e0 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} module Handler.Utils.Submission @@ -25,6 +26,7 @@ module Handler.Utils.Submission ) where import Import hiding ((.=), joinPath) +import Jobs import Prelude (lcm) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) @@ -38,7 +40,7 @@ import Control.Monad.RWS.Lazy (RWST) import qualified Control.Monad.Random as Rand import qualified System.Random.Shuffle as Rand (shuffleM) -import Data.Maybe +import Data.Maybe () import qualified Data.List as List import Data.Set (Set) @@ -279,6 +281,7 @@ submissionMultiArchive (Set.toList -> ids) = do data SubmissionSinkState = SubmissionSinkState { sinkSeenRating :: Any , sinkSubmissionTouched :: Any + , sinkSubmissionNotifyRating :: Any , sinkFilenames :: Set FilePath } deriving (Show, Eq, Generic, Typeable) @@ -333,7 +336,7 @@ extractRatingsMsg = do sinkSubmission :: UserId -> Either SheetId SubmissionId -> Bool -- ^ Is this a correction - -> Sink SubmissionContent (YesodDB UniWorX) SubmissionId + -> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId -- ^ Replace the currently saved files for the given submission (either -- corrected files or original ones, depending on arguments) with the supplied -- 'SubmissionContent'. @@ -365,7 +368,7 @@ sinkSubmission userId mExists isUpdate = do sinkSubmission' :: SubmissionId -> Bool -- ^ Is this a correction - -> Sink SubmissionContent (YesodDB UniWorX) () + -> Sink SubmissionContent (YesodJobDB UniWorX) () sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case Left file@(File{..}) -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) @@ -463,18 +466,21 @@ sinkSubmission userId mExists isUpdate = do -- The check whether the new version matches the underlying file is -- more lenient, considering only filename and -content. - touchSubmission :: StateT SubmissionSinkState (YesodDB UniWorX) () + touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) () touchSubmission = do alreadyTouched <- gets $ getAny . sinkSubmissionTouched when (not alreadyTouched) $ do now <- liftIO getCurrentTime - lift $ case isUpdate of - False -> insert_ $ SubmissionEdit userId now submissionId - True -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] - -- TODO: Should submissionRatingAssigned change here if userId changes? + case isUpdate of + False -> lift . insert_ $ SubmissionEdit userId now submissionId + True -> do + Submission{submissionRatingTime} <- lift $ getJust submissionId + when (isNothing submissionRatingTime) $ tell mempty { sinkSubmissionNotifyRating = Any True } + lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] + -- TODO: Should submissionRatingAssigned change here if userId changes? tell $ mempty{ sinkSubmissionTouched = Any True } - finalize :: SubmissionSinkState -> YesodDB UniWorX () + finalize :: SubmissionSinkState -> YesodJobDB UniWorX () finalize SubmissionSinkState{..} = do missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId @@ -509,13 +515,19 @@ sinkSubmission userId mExists isUpdate = do update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ] deleteCascade fileId - when (isUpdate && not (getAny sinkSeenRating)) $ - update submissionId + if + | isUpdate + , not $ getAny sinkSeenRating + -> update submissionId [ SubmissionRatingTime =. Nothing , SubmissionRatingPoints =. Nothing , SubmissionRatingBy =. Nothing , SubmissionRatingComment =. Nothing ] + | isUpdate + , getAny sinkSubmissionNotifyRating + -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId + | otherwise -> return () data SubmissionMultiSinkException = SubmissionSinkException @@ -529,7 +541,7 @@ instance Exception SubmissionMultiSinkException sinkMultiSubmission :: UserId -> Bool {-^ Are these corrections -} - -> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId) + -> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId) -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'. -- @@ -543,8 +555,8 @@ sinkMultiSubmission userId isUpdate = do -> RWST () _ - (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) - (YesodDB UniWorX) + (Map SubmissionId (ResumableSink SubmissionContent (YesodJobDB UniWorX) SubmissionId)) + (YesodJobDB UniWorX) () feed sId val = do mSink <- gets $ Map.lookup sId @@ -593,10 +605,10 @@ sinkMultiSubmission userId isUpdate = do when (not $ null ignored) $ do mr <- (toHtml .) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) - fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do + lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do cID <- encrypt sId handle (throwM . SubmissionSinkException cID Nothing) $ - void $ closeResumableSink sink + closeResumableSink sink where handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a) handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident) 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/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 8db4ec779..fc3bdcda9 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -25,3 +25,13 @@ 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) + +import Mail as Import + +import Data.Data as Import (Data) +import Data.Typeable as Import (Typeable) +import GHC.Generics as Import (Generic) + +import Data.Hashable as Import diff --git a/src/Jobs.hs b/src/Jobs.hs new file mode 100644 index 000000000..5008b0e35 --- /dev/null +++ b/src/Jobs.hs @@ -0,0 +1,531 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , TemplateHaskell + , OverloadedStrings + , FlexibleContexts + , ViewPatterns + , TypeFamilies + , DeriveGeneric + , DeriveDataTypeable + , QuasiQuotes + , NamedFieldPuns + , MultiWayIf + , NumDecimals + #-} + +module Jobs + ( module Types + , writeJobCtl + , queueJob, queueJob' + , YesodJobDB + , runDBJobs, queueDBJob + , handleJobs + ) where + +import Import hiding ((.=), Proxy) +import Handler.Utils.Mail +import Handler.Utils.DateTime + +import Jobs.Types as Types hiding (JobCtl(JobCtlQueue)) +import Jobs.Types (JobCtl(JobCtlQueue)) + +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 qualified Data.Aeson.Types as Aeson +import Database.Persist.Sql (executeQQ, fromSqlKey, transactionSave) + +import Data.Monoid (Last(..)) +import Data.Semigroup (Max(..)) + +import Utils.Lens + +import Control.Monad.Random (evalRand, uniform, mkStdGen) + +import qualified Database.Esqueleto as E + +import qualified Data.CaseInsensitive as CI + +import Text.Shakespeare.Text +import Text.Hamlet + +import Cron +import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict (HashMap) + +import qualified Data.Set as Set + +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import qualified Data.List.NonEmpty as NonEmpty + +import Data.Foldable (foldrM) + +import Control.Monad.Trans.Reader (mapReaderT) +import Control.Monad.Trans.Writer (WriterT(..), execWriterT) +import Control.Monad.Trans.State (StateT, evalStateT, mapStateT) +import qualified Control.Monad.State.Class as State +import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Logger + +import Control.Monad.Random (MonadRandom(..), evalRand) + +import Data.Time.Clock +import Data.Time.Zones + +import Control.Concurrent.STM (retry) + +import Database.PostgreSQL.Simple (sqlErrorHint) +import Control.Monad.Catch (handleIf) + + +data JobQueueException = JInvalid QueuedJobId QueuedJob + | JLocked QueuedJobId InstanceId UTCTime + | JNonexistant QueuedJobId + deriving (Read, Show, Eq, Generic, Typeable) + +instance Exception JobQueueException + + +handleJobs :: (MonadResource m, MonadIO m) => [TMChan JobCtl] -> UniWorX -> m () +-- | 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 recvChans foundation@UniWorX{..} = do + jobCrontab <- liftIO $ newTVarIO HashMap.empty + jobConfirm <- liftIO $ newTVarIO HashMap.empty + + forM_ (zip [1..] recvChans) $ \(n, chan) -> + let + logStart = $logDebugS ("Jobs #" <> tshow n) "Starting" + logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping" + doFork = fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n + in void $ allocate (liftIO doFork) (liftIO . killThread) + + -- Start cron operation + void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread) + liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $ + writeJobCtlBlock JobCtlDetermineCrontab + + +execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) () +-- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have +-- seen, wait for the time of the next job and fire it +execCrontab = flip evalStateT HashMap.empty . forever $ do + mapStateT (liftHandlerT . runDB . setSerializable) $ do + let + merge (Entity leId CronLastExec{..}) + | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob + = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime) + | otherwise = lift $ delete leId + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge + + now <- liftIO getCurrentTime + (currentCrontab, (jobCtl, nextMatch)) <- mapStateT (mapReaderT $ liftIO . atomically) $ do + crontab <- liftBase . readTVar =<< asks jobCrontab + State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab + prevExec <- State.get + case earliestJob prevExec crontab now of + Nothing -> liftBase retry + Just (_, MatchNone) -> liftBase retry + Just x -> return (crontab, x) + + let doJob = do + mJid <- mapStateT (mapReaderT $ liftHandlerT . runDB . setSerializable) $ do + newCrontab <- lift . lift $ determineCrontab + if + | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab + -> do + now <- liftIO $ getCurrentTime + instanceID <- getsYesod appInstanceID + State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl + case jobCtl of + JobCtlQueue job -> do + lift . lift $ upsertBy + (UniqueCronLastExec $ toJSON job) + CronLastExec + { cronLastExecJob = toJSON job + , cronLastExecTime = now + , cronLastExecInstance = instanceID + } + [ CronLastExecTime =. now ] + Just <$> lift (lift $ queueJobUnsafe job) + other -> Nothing <$ writeJobCtl other + | otherwise + -> lift . fmap (const Nothing) . mapReaderT (liftIO . atomically) $ + lift . flip writeTVar newCrontab =<< asks jobCrontab + maybe (return ()) (writeJobCtl . JobCtlPerform) mJid + + case nextMatch of + MatchAsap -> doJob + MatchNone -> return () + MatchAt nextTime -> do + JobContext{jobCrontab} <- ask + nextTime' <- applyJitter jobCtl nextTime + $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|] + logFunc <- askLoggerIO + whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime') + doJob + where + acc :: NominalDiffTime + acc = 1e-3 + + applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime + applyJitter seed t = do + appInstance <- getsYesod appInstanceID + let + halfRange = truncate $ 0.5 / acc + diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed) + return $ addUTCTime diff t + + earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime) + earliestJob lastTimes crontab now = foldr go Nothing $ HashMap.toList crontab + where + go (jobCtl, cron) mbPrev + | Just (_, t') <- mbPrev + , t' < t + = mbPrev + | otherwise + = Just (jobCtl, t) + where + t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron + + waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool + waitUntil crontabTV crontab nextTime = runResourceT $ do + diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime + let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc + waitTime' + | diffT < acc = "Done" + | otherwise = tshow (realToFrac waitTime :: NominalDiffTime) + $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|] + if + | diffT < acc -> return True + | otherwise -> do + retVar <- liftIO newEmptyTMVarIO + void $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread) + let + awaitDelayThread = False <$ takeTMVar retVar + awaitCrontabChange = do + crontab' <- readTVar crontabTV + True <$ guard (crontab /= crontab') + crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread + bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged + + +handleJobs' :: Int -> Sink JobCtl (ReaderT JobContext Handler) () +handleJobs' wNum = C.mapM_ $ \jctl -> do + $logDebugS logIdent $ tshow jctl + resVars <- mapReaderT (liftIO . atomically) $ + HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm) + res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl + sentRes <- liftIO . atomically $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars) + case res of + Just err + | not sentRes -> $logErrorS logIdent $ tshow err + _other -> return () + where + logIdent = "Jobs #" <> tshow wNum + + handleQueueException :: MonadLogger m => JobQueueException -> m () + handleQueueException (JInvalid jId j) = $logWarnS logIdent $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j + handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId) + handleQueueException (JLocked jId lInstance lTime) = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime) + + handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform) + handleCmd (JobCtlQueue job) = lift $ queueJob' job + handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do + content <- case fromJSON queuedJobContent of + Aeson.Success c -> return c + Aeson.Error t -> do + $logErrorS logIdent $ "Aeson decoding error: " <> pack t + throwM $ JInvalid jId j + + $logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content + + performJob content + + -- `performJob` is expected to throw an exception if it detects that the job was not done + runDB $ delete jId + handleCmd JobCtlDetermineCrontab = do + newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab + -- $logDebugS logIdent $ tshow newCTab + mapReaderT (liftIO . atomically) $ + lift . flip writeTVar newCTab =<< asks jobCrontab + +jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a +jLocked jId act = do + hasLock <- liftIO $ newTVarIO False + + let + lock = runDB . setSerializable $ do + qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId + instanceID <- getsYesod appInstanceID + threshold <- getsYesod $ appJobStaleThreshold . appSettings + now <- liftIO getCurrentTime + hadStale <- maybeT (return False) $ do + lockTime <- MaybeT $ return queuedJobLockTime + lockInstance <- MaybeT $ return queuedJobLockInstance + if + | lockInstance == instanceID + , diffUTCTime now lockTime >= threshold + -> return True + | otherwise + -> throwM $ JLocked jId lockInstance lockTime + when hadStale . + $logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj + val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID + , QueuedJobLockTime =. Just now + ] + liftIO . atomically $ writeTVar hasLock True + return val + + unlock = whenM (liftIO . atomically $ readTVar hasLock) $ + runDB . setSerializable $ + update jId [ QueuedJobLockInstance =. Nothing + , QueuedJobLockTime =. Nothing + ] + + bracket lock (const unlock) act + +writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () +writeJobCtl cmd = do + tid <- liftIO myThreadId + chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl + liftIO . atomically $ writeTMChan chan cmd + +writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m () +writeJobCtlBlock cmd = do + getResVar <- asks jobConfirm + resVar <- liftIO . atomically $ do + var <- newEmptyTMVar + modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var) + return var + lift $ writeJobCtl cmd + let + removeResVar = HashMap.update (nonEmpty . NonEmpty.filter (/= resVar)) cmd + mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar + maybe (return ()) throwM mExc + +queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId +queueJobUnsafe job = do + now <- liftIO getCurrentTime + self <- getsYesod appInstanceID + insert QueuedJob + { queuedJobContent = toJSON job + , queuedJobCreationInstance = self + , queuedJobCreationTime = now + , queuedJobLockInstance = Nothing + , queuedJobLockTime = Nothing + } + -- We should not immediately notify a worker; instead wait for the transaction to finish first + -- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something) + -- return jId + +queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId +queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe + +queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m () +-- ^ `queueJob` followed by `JobCtlPerform` +queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform + +type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO)) + +queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) () +queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton + +runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a +runDBJobs act = do + (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act + forM_ jIds $ writeJobCtl . JobCtlPerform + return ret + +setSerializable :: DB a -> DB a +setSerializable act = setSerializable' (0 :: Integer) + where + act' = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act + + setSerializable' (min 10 -> logBackoff) = + handleIf + (\e -> sqlErrorHint e == "The transaction might succeed if retried.") + (\e -> $logWarnS "SQL" (tshow e) *> threadDelay (1e3 * 2 ^ logBackoff) *> setSerializable' (succ logBackoff)) + act' + +pruneLastExecs :: Crontab JobCtl -> DB () +pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab + where + ensureCrontab (Entity leId CronLastExec{..}) + | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob + , HashMap.member (JobCtlQueue job) crontab + = return () + | otherwise = delete leId + + +determineCrontab :: DB (Crontab JobCtl) +-- ^ Extract all future jobs from the database (sheet deadlines, ...) +determineCrontab = (\ct -> ct <$ pruneLastExecs ct) <=< execWriterT $ do + AppSettings{..} <- getsYesod appSettings + + case appJobFlushInterval of + Just interval -> tell $ HashMap.singleton + JobCtlFlush + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = interval + } + Nothing -> return () + + now <- liftIO getCurrentTime + tell $ HashMap.singleton + JobCtlDetermineCrontab + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = appJobCronInterval + } + + let + sheetJobs (Entity nSheet Sheet{..}) = do + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..}) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom + , cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour + , cronRateLimit = appNotificationRateLimit + } + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..}) + Cron + { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appNotificationRateLimit + } + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs + + +determineNotificationCandidates :: Notification -> DB [Entity User] +determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do + E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission + return user +determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse + E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.where_ $ sheet E.^. SheetId E.==. E.val nSheet + return user +determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse + E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.where_ $ sheet E.^. SheetId E.==. E.val nSheet + return user + +classifyNotification :: Notification -> DB NotificationTrigger +classifyNotification NotificationSubmissionRated{..} = do + Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission + return $ case sheetType of + NotGraded -> NTSubmissionRated + _other -> NTSubmissionRatedGraded +classifyNotification NotificationSheetActive{} = return NTSheetActive +classifyNotification NotificationSheetInactive{} = return NTSheetInactive + + +performJob :: Job -> HandlerT UniWorX IO () +performJob JobQueueNotification{jNotification} = do + jIds <- runDB. setSerializable $ do + candidates <- determineNotificationCandidates jNotification + nClass <- classifyNotification jNotification + mapM (queueJobUnsafe . flip JobSendNotification jNotification) $ do + Entity uid User{userNotificationSettings} <- candidates + guard $ notificationAllowed userNotificationSettings nClass + return uid + forM_ jIds $ writeJobCtl . JobCtlPerform +performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, jRecipient } = userMailT jRecipient $ do + (Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do + submission@Submission{submissionRatingBy} <- getJust nSubmission + sheet <- belongsToJust submissionSheet submission + course <- belongsToJust sheetCourse sheet + corrector <- traverse getJust submissionRatingBy + return (course, sheet, submission, corrector) + setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand + + csid <- encrypt nSubmission + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime + let tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + -- TODO: provide convienience template-haskell for `addAlternatives` + addAlternatives $ do + provideAlternative $ Aeson.object + [ "submission" Aeson..= ciphertext csid + , "submission-rating-points" Aeson..= (guard (sheetType /= NotGraded) *> submissionRatingPoints) + , "submission-rating-comment" Aeson..= submissionRatingComment + , "submission-rating-time" Aeson..= submissionRatingTime + , "submission-rating-by" Aeson..= (userDisplayName <$> corrector) + , "submission-rating-passed" Aeson..= ((>=) <$> submissionRatingPoints <*> preview _passingPoints sheetType) + , "sheet-name" Aeson..= sheetName + , "sheet-type" Aeson..= sheetType + , "course-name" Aeson..= courseName + , "course-shorthand" Aeson..= courseShorthand + , "course-term" Aeson..= courseTerm + , "course-school" Aeson..= courseSchool + ] + -- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements + providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) +performJob JobSendNotification{ jNotification = NotificationSheetActive{..}, jRecipient } = userMailT jRecipient $ do + (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do + sheet <- getJust nSheet + course <- belongsToJust sheetCourse sheet + return (course, sheet) + setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName + + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + addAlternatives $ do + providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) +performJob JobSendNotification{ jNotification = NotificationSheetInactive{..}, jRecipient } = userMailT jRecipient $ do + (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do + sheet <- getJust nSheet + course <- belongsToJust sheetCourse sheet + return (course, sheet) + setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName + + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + addAlternatives $ do + providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) +performJob JobSendTestEmail{..} = mailT jMailContext $ do + _mailTo .= [Address Nothing jEmail] + setSubjectI MsgMailTestSubject + now <- liftIO getCurrentTime + nDT <- formatTimeMail SelFormatDateTime now + nD <- formatTimeMail SelFormatDate now + nT <- formatTimeMail SelFormatTime now + addPart $ \(MsgRenderer mr) -> ([text| + #{mr MsgMailTestContent} + + #{mr MsgMailTestDateTime} + * #{nDT} + * #{nD} + * #{nT} + |] :: TextUrl (Route UniWorX)) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs new file mode 100644 index 000000000..59ad06e2f --- /dev/null +++ b/src/Jobs/Types.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE TemplateHaskell + , NoImplicitPrelude + , DeriveGeneric + , DeriveDataTypeable + #-} + +module Jobs.Types + ( Job(..), Notification(..) + , JobCtl(..) + , JobContext(..) + ) where + +import Import.NoFoundation + +import Data.Aeson (defaultOptions, Options(..), SumEncoding(..)) +import Data.Aeson.TH (deriveJSON) + +import Data.List.NonEmpty (NonEmpty) + + +data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } + | JobSendTestEmail { jEmail :: Text, jMailContext :: MailContext } + | JobQueueNotification { jNotification :: Notification } + deriving (Eq, Ord, Show, Read, Generic, Typeable) +data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } + | NotificationSheetActive { nSheet :: SheetId } + | NotificationSheetInactive { nSheet :: SheetId } + deriving (Eq, Ord, Show, Read, Generic, Typeable) + +instance Hashable Job +instance Hashable Notification + +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 + | JobCtlDetermineCrontab + | JobCtlQueue Job + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Hashable JobCtl + + +data JobContext = JobContext + { jobCrontab :: TVar (Crontab JobCtl) + , jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException)))) + } diff --git a/src/Mail.hs b/src/Mail.hs new file mode 100644 index 000000000..a035cc6ad --- /dev/null +++ b/src/Mail.hs @@ -0,0 +1,479 @@ +{-# LANGUAGE NoImplicitPrelude + , GeneralizedNewtypeDeriving + , DerivingStrategies + , FlexibleInstances + , MultiParamTypeClasses + , UndecidableInstances + , DeriveGeneric + , TemplateHaskell + , OverloadedStrings + , RecordWildCards + , FlexibleContexts + , TypeFamilies + , ViewPatterns + , NamedFieldPuns + , MultiWayIf + , QuasiQuotes + , RankNTypes + , ScopedTypeVariables + , DeriveDataTypeable + #-} + +module Mail + ( -- * Structured MIME emails + module Network.Mail.Mime + -- * MailT + , MailT, defMailT + , MailSmtpData(..), MailContext(..), MailLanguages(..) + , MonadMail(..) + , getMailMessageRender, getMailMsgRenderer + -- * YesodMail + , VerpMode(..) + , YesodMail(..) + , MailException(..) + -- * Monadically constructing Mail + , PrioritisedAlternatives + , ToMailPart(..) + , addAlternatives, provideAlternative, providePreferredAlternative + , addPart + , MonadHeader(..) + , MailHeader + , MailObjectId + , replaceMailHeader, addMailHeader, removeMailHeader + , replaceMailHeaderI, addMailHeaderI + , setSubjectI, setMailObjectId, setMailObjectId' + , setDateCurrent + , setMailSmtpData + , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts + , _partType, _partEncoding, _partFilename, _partHeaders, _partContent + ) 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, mapStateT) +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 Data.Data (Data) + +import Data.Set (Set) +import qualified Data.Set as Set + +import qualified Data.Text as Text + +import qualified Data.Foldable as Foldable + +import Data.Hashable + +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as LTB +import qualified Data.ByteString.Lazy as LBS + +import Utils (MsgRendererS(..)) +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) + +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 Hamlet (Translate) +import qualified Text.Shakespeare as Shakespeare (RenderUrl) + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as Aeson +import Data.Aeson (Options(..)) +import Data.Aeson.TH +import Utils (MsgRendererS(..)) +import Utils.PathPiece (splitCamel) +import Utils.DateTime + +import Data.Universe.Instances.Reverse () +import Data.Universe.Instances.Reverse.JSON () +import Data.Universe.Instances.Reverse.Hashable () + +makeLenses_ ''Mail +makeLenses_ ''Part + + +newtype MailT m a = MailT { unMailT :: RWST MailContext MailSmtpData Mail m a } + deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus + , MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b + , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailContext + ) + +instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where + type MonadCryptoKey (MailT m) = CryptoIDKey + cryptoIDKey f = lift (cryptoIDKey return) >>= f + +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, Generic, Typeable) + deriving newtype (FromJSON, ToJSON) + +instance Default MailLanguages where + def = MailLanguages [] + +instance Hashable MailLanguages + +data MailContext = MailContext + { mcLanguages :: MailLanguages + , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''MailContext + +instance Hashable MailContext + +makeLenses_ ''MailContext + +class (MonadHandler m, MonadState Mail m) => MonadMail m where + askMailLanguages :: m MailLanguages + askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat + tellMailSmtpData :: MailSmtpData -> m () + +instance MonadHandler m => MonadMail (MailT m) where + askMailLanguages = view _mcLanguages + askMailDateTimeFormat = (view _mcDateTimeFormat ??) + 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 + +getMailMessageRender :: ( MonadMail m + , HandlerSite m ~ site + , RenderMessage site msg + ) => m (msg -> Text) +getMailMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages) + +getMailMsgRenderer :: forall site m. + ( MonadMail m + , HandlerSite m ~ site + ) => m (MsgRendererS site) +getMailMsgRenderer = do + mr <- getMailMessageRender + return $ MsgRenderer (mr . SomeMessage :: RenderMessage site msg => msg -> Text) + + +data MailException = MailNotAvailable + | MailNoSenderSpecified + | MailNoRecipientsSpecified + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Exception MailException + + +class Yesod site => 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 + + 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 + , HandlerSite m ~ site + , MonadBaseControl IO m + , MonadLogger m + ) => MailContext -> MailT m a -> m a + mailT = defMailT + + defaultMailLayout :: ( MonadHandler m + , HandlerSite m ~ site + ) => WidgetT site IO () -> m Html + defaultMailLayout wgt = do + PageContent{..} <- liftHandlerT $ widgetToPageContent wgt + msgs <- getMessages + withUrlRenderer [hamlet| + $newline never + $doctype 5 + + + #{pageTitle} + ^{pageHead} + <body> + $forall (status, msg) <- msgs + <p class="message #{status}">#{msg} + ^{pageBody} + |] + +defMailT :: ( MonadHandler m + , YesodMail (HandlerSite m) + , MonadBaseControl IO m + , MonadLogger m + ) => MailContext + -> MailT m a + -> m a +defMailT ls (MailT mail) = do + fromAddress <- defaultFromAddress + (ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress) + mail' <- liftIO $ LBS.toStrict <$> renderMail' mail + $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 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 $ \conn -> do + $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData + liftIO $ SMTP.sendMail + returnPath + recipients + mail' + conn + + +data PrioritisedAlternatives m = PrioritisedAlternatives + { preferredAlternative :: Last (m Part) + , otherAlternatives :: Seq (m Part) + } deriving (Generic) + +instance Monoid (PrioritisedAlternatives m) where + mempty = memptydefault + mappend = mappenddefault + +class YesodMail site => ToMailPart site a where + type MailPartReturn site a :: * + type MailPartReturn site a = () + toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a) + +instance YesodMail site => ToMailPart site (StateT Part (HandlerT site IO) a) where + type MailPartReturn site (StateT Part (HandlerT site IO) a) = a + toMailPart = mapStateT liftHandlerT + +instance YesodMail site => ToMailPart site LT.Text where + toMailPart text = do + _partType .= "text/plain; charset=utf-8" + _partEncoding .= QuotedPrintableText + _partContent .= encodeUtf8 text + +instance YesodMail site => ToMailPart site Text where + toMailPart = toMailPart . LT.fromStrict + +instance YesodMail site => ToMailPart site LTB.Builder where + toMailPart = toMailPart . LTB.toLazyText + +instance YesodMail site => ToMailPart site Html where + toMailPart html = do + _partType .= "text/html; charset=utf-8" + _partEncoding .= QuotedPrintableText + _partContent .= renderMarkup html + +instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where + type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a + toMailPart act = do + mr <- lift getMailMessageRender + toMailPart $ act (toHtml . mr) + +instance (ToMailPart site a, site ~ site') => ToMailPart site (MsgRendererS site' -> a) where + type MailPartReturn site (MsgRendererS site' -> a) = MailPartReturn site a + toMailPart act = do + mr <- lift getMailMsgRenderer + toMailPart $ act mr + +instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site) -> a) where + type MailPartReturn site (Shakespeare.RenderUrl (Route site) -> a) = MailPartReturn site a + toMailPart act = do + ur <- getUrlRenderParams + toMailPart $ act ur + +instance YesodMail site => ToMailPart site Aeson.Value where + toMailPart val = do + _partType .= "application/json; charset=utf-8" + _partEncoding .= QuotedPrintableText + _partContent .= Aeson.encodePretty val + + +addAlternatives :: (MonadMail m) + => Writer (PrioritisedAlternatives m) () + -> m () +addAlternatives provided = do + let PrioritisedAlternatives{..} = execWriter provided + alternatives <- sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives + modify $ Mime.addPart alternatives + +provideAlternative, providePreferredAlternative + :: (MonadMail m, HandlerSite m ~ site, ToMailPart site a) + => a + -> Writer (PrioritisedAlternatives m) () +provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart } +providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart } + +addPart :: ( MonadMail m + , HandlerSite m ~ site + , ToMailPart site a + ) => a -> m (MailPartReturn site a) +addPart part = do + (ret, part') <- runStateT (toMailPart part) initialPart + modify . Mime.addPart $ pure part' + return ret + +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 =<< (getMailMessageRender <*> pure msg) + + +setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m () +setSubjectI = replaceMailHeaderI "Subject" + +setMailObjectUUID :: ( MonadHeader m + , YesodMail (HandlerSite m) + ) => UUID -> m MailObjectId +setMailObjectUUID uuid = do + domain <- mailObjectIdDomain + oidHeader <- objectIdHeader + let objectId = UUID.toText uuid <> "@" <> domain + replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">" + return objectId + +setMailObjectId :: ( MonadHeader m + , YesodMail (HandlerSite m) + ) => m MailObjectId +setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom + +setMailObjectId' :: ( MonadHeader m + , YesodMail (HandlerSite m) + , MonadCrypto m + , HasCryptoUUID plain m + , MonadCryptoKey m ~ CryptoIDKey + , KnownSymbol (CryptoIDNamespace UUID plain) + , Binary plain + ) => plain -> 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 + + +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/Model.hs b/src/Model.hs index f57f39a7c..5d3b51e3f 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -7,6 +7,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} @@ -14,6 +16,7 @@ module Model ( module Model , module Model.Types + , module Cron.Types ) where import ClassyPrelude.Yesod @@ -21,7 +24,10 @@ import Database.Persist.Quasi -- import Data.Time -- import Data.ByteString import Model.Types -import Data.Aeson.TH +import Cron.Types + +import Data.Aeson (Value) +import Data.Aeson.TH (deriveJSON, defaultOptions) import Data.CaseInsensitive (CI) import Data.CaseInsensitive.Instances () @@ -35,7 +41,7 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only deriving instance Eq (Unique Course) - + data PWEntry = PWEntry { pwUser :: User , pwHash :: Text diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 54ec40156..bd6be6098 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -189,6 +189,13 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"'; |] ) + , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|] + , whenM (tableExists "user") $ do + [executeQQ| + ALTER TABLE "user" ADD COLUMN "notification_settings" json DEFAULT null; + UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null; + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 4f406a148..87d6d579d 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -5,16 +5,23 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingStrategies #-} {-- # LANGUAGE ExistentialQuantification #-} -- for DA type {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) -module Model.Types where +module Model.Types + ( module Model.Types + , module Numeric.Natural + , module Mail + , module Utils.DateTime + ) where import ClassyPrelude import Utils import Control.Lens +import Utils.Lens.TH import Data.Set (Set) import qualified Data.Set as Set @@ -26,6 +33,8 @@ import Data.Universe import Data.Universe.Helpers import Data.UUID.Types +import Data.Default + import Text.Read (readMaybe) import Database.Persist.TH hiding (derivePersistFieldJSON) @@ -40,20 +49,32 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lens as Text +import qualified Data.HashMap.Strict as HashMap + import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.CaseInsensitive.Instances () import Yesod.Core.Dispatch (PathPiece(..)) -import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value()) +import Data.Aeson.Types (toJSONKeyText) import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) import GHC.Generics (Generic) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Data.Typeable (Typeable) +import Data.Universe.Instances.Reverse () + import qualified Yesod.Auth.Util.PasswordStore as PWStore +import Mail (MailLanguages(..)) +import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..)) + +import Numeric.Natural + instance PathPiece UUID where fromPathPiece = Data.UUID.Types.fromString . unpack @@ -108,6 +129,8 @@ instance DisplayAble SheetType where deriveJSON defaultOptions ''SheetType derivePersistFieldJSON ''SheetType +makeLenses_ ''SheetType + data SheetTypeSummary = SheetTypeSummary { sumBonusPoints :: Sum Points , sumNormalPoints :: Sum Points @@ -130,13 +153,15 @@ sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 } data SheetGroup - = Arbitrary { maxParticipants :: Int } + = Arbitrary { maxParticipants :: Natural } | RegisteredGroups | NoGroups deriving (Show, Read, Eq) deriveJSON defaultOptions ''SheetGroup derivePersistFieldJSON ''SheetGroup +makeLenses_ ''SheetGroup + data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking deriving (Show, Read, Eq, Ord, Enum, Bounded) derivePersistField "SheetFileType" @@ -332,7 +357,7 @@ instance PathPiece TermIdentifier where toPathPiece = termToText instance ToJSON TermIdentifier where - toJSON = String . termToText + toJSON = Aeson.String . termToText instance FromJSON TermIdentifier where parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText @@ -355,6 +380,16 @@ data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded) derivePersistField "StudyFieldType" +instance PersistField UUID where + toPersistValue = PersistDbSpecific . toASCIIBytes + fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ fromText t + fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs + fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs + fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x + +instance PersistFieldSql UUID where + sqlType _ = SqlOther "uuid" + instance DisplayAble StudyFieldType data Theme @@ -391,12 +426,6 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip" toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName -newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } - deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString) - -data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime - deriving (Eq, Ord, Read, Show, Enum, Bounded) - data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused deriving (Eq, Ord, Read, Show, Enum, Bounded) @@ -429,14 +458,76 @@ deriveJSON defaultOptions derivePersistFieldJSON ''AuthenticationMode - + +derivePersistFieldJSON ''Value + + +-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ +-- +-- Could maybe be replaced with `Structure Notification` in the long term +data NotificationTrigger = NTSubmissionRatedGraded + | NTSubmissionRated + | NTSheetActive + | NTSheetInactive + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe NotificationTrigger +instance Finite NotificationTrigger + +instance Hashable NotificationTrigger + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''NotificationTrigger + +instance ToJSONKey NotificationTrigger where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey NotificationTrigger where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + + +newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } + deriving (Generic, Typeable) + deriving newtype (Eq, Ord, Read, Show) + +instance Default NotificationSettings where + def = NotificationSettings $ \case + NTSubmissionRatedGraded -> True + NTSubmissionRated -> False + NTSheetActive -> True + NTSheetInactive -> True + +instance ToJSON NotificationSettings where + toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF + +instance FromJSON NotificationSettings where + parseJSON = withObject "NotificationSettings" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) + return . NotificationSettings $ \n -> case HashMap.lookup n o' of + Nothing -> notificationAllowed def n + Just b -> b + +derivePersistFieldJSON ''NotificationSettings + + +instance ToBackendKey SqlBackend record => Hashable (Key record) where + hashWithSalt s key = s `hashWithSalt` fromSqlKey key + + +derivePersistFieldJSON ''MailLanguages + + -- 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/Model/Types/JSON.hs b/src/Model/Types/JSON.hs index 655c95294..dc5a5eec6 100644 --- a/src/Model/Types/JSON.hs +++ b/src/Model/Types/JSON.hs @@ -50,7 +50,7 @@ derivePersistFieldJSON n = do ] , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t) [ funD (mkName "sqlType") - [ clause [wildP] (normalB [e|SqlOther "json"|]) [] + [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) [] ] ] ] diff --git a/src/Settings.hs b/src/Settings.hs index 4649c76f4..79a3a8be4 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,13 @@ 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 Network.Mail.Mime (Address) + +import Mail (VerpMode) + import Model -- | Runtime settings to configure this application. These settings can be @@ -51,6 +67,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. @@ -61,6 +79,14 @@ 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 + , appMailVerp :: VerpMode + , appJobWorkers :: Int + , appJobFlushInterval :: Maybe NominalDiffTime + , appJobCronInterval :: NominalDiffTime + , appJobStaleThreshold :: NominalDiffTime + , appNotificationRateLimit :: NominalDiffTime , appDetailedRequestLogging :: Bool -- ^ Use detailed request logging system @@ -82,20 +108,24 @@ data AppSettings = AppSettings , appAuthPWHash :: PWHashConf , appCryptoIDKeyFile :: FilePath - } + , appInstanceIDFile :: Maybe FilePath + } deriving (Show) data UserDefaultConf = UserDefaultConf { userDefaultTheme :: Theme , userDefaultMaxFavourites :: Int , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat , userDefaultDownloadFiles :: Bool - } + } deriving (Show) data PWHashConf = PWHashConf { pwHashAlgorithm :: PWHashAlgorithm , pwHashStrength :: Int } +instance Show PWHashConf where + show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }" + instance FromJSON PWHashConf where parseJSON = withObject "PWHashConf" $ \o -> do pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text) @@ -113,8 +143,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 @@ -139,6 +192,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" @@ -146,6 +205,52 @@ 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 of plausible size to denote port" + +deriveFromJSON + defaultOptions + { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack + , allNullaryToStringTag = True + } + ''HaskellNet.AuthType + +instance FromJSON SmtpConf where + parseJSON = withObject "SmtpConf" $ \o -> do + smtpHost <- o .: "host" + smtpPort <- o .: "port" + smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth" + smtpSsl <- o .: "ssl" + smtpPool <- o .: "pool" + return 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 + +deriveFromJSON + defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } + ''Address + + + instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do let defaultDev = @@ -160,11 +265,22 @@ 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" appIpFromHeader <- o .: "ip-from-header" + appMailFrom <- o .: "mail-from" + appMailObjectDomain <- o .: "mail-object-domain" + appMailVerp <- o .: "mail-verp" + + appJobWorkers <- o .: "job-workers" + appJobFlushInterval <- o .:? "job-flush-interval" + appJobCronInterval <- o .: "job-cron-interval" + appJobStaleThreshold <- o .: "job-stale-threshold" + appNotificationRateLimit <- o .: "notification-rate-limit" + appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev appShouldLogAll <- o .:? "should-log-all" .!= defaultDev appMinimumLogLevel <- o .: "minimum-log-level" @@ -178,6 +294,7 @@ instance FromJSON AppSettings where appAuthPWHash <- o .: "auth-pw-hash" appCryptoIDKeyFile <- o .: "cryptoid-keyfile" + appInstanceIDFile <- o .:? "instance-idfile" return AppSettings {..} diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 1b82dbe12..90a4059f6 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -2,7 +2,12 @@ , TemplateHaskell , QuasiQuotes , StandaloneDeriving + , DerivingStrategies , DeriveLift + , DeriveDataTypeable + , DeriveGeneric + , GeneralizedNewtypeDeriving + , OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -10,6 +15,8 @@ module Utils.DateTime ( timeLocaleMap , TimeLocale(..) , currentYear + , DateTimeFormat(..) + , SelDateTimeFormat(..) , module Data.Time.Zones , module Data.Time.Zones.TH ) where @@ -25,6 +32,18 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) import Instances.TH.Lift () +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.Universe + +import Database.Persist.Sql (PersistField, PersistFieldSql) + +import Data.Aeson.Types (toJSONKeyText) +import Data.Aeson +import Data.Aeson.TH + +import Utils.PathPiece + deriving instance Lift TimeZone deriving instance Lift TimeLocale @@ -63,3 +82,26 @@ currentYear = do now <- runIO getCurrentTime let (year, _, _) = toGregorian $ utctDay now [e|year|] + + +newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } + deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + deriving newtype (ToJSON, FromJSON, PersistField, PersistFieldSql, IsString) + +instance Hashable DateTimeFormat + +data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime + deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable) + +instance Universe SelDateTimeFormat +instance Finite SelDateTimeFormat +instance Hashable SelDateTimeFormat + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel + } ''SelDateTimeFormat + +instance ToJSONKey SelDateTimeFormat where + toJSONKey = toJSONKeyText $ \v -> let String txt = toJSON v in txt +instance FromJSONKey SelDateTimeFormat where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . String diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 939169e9b..0ccc1da6f 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 ------------------- @@ -135,6 +143,9 @@ addDatalist field mValues = field |] } +noValidate :: FieldSettings site -> FieldSettings site +noValidate = addAttr "formnovalidate" "" + ------------------------------------------------ -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ @@ -216,3 +227,36 @@ 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 + , 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 optList = Field{..} + where + fieldEnctype = UrlEncoded + fieldParse [] _ = return $ Right Nothing + fieldParse optlist _ = do + OptionList{..} <- liftHandlerT optList + let + olNum = fromIntegral $ length olOptions + selOptions = 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/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 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 diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet index 651d6b6e0..0693ea1cc 100644 --- a/templates/adminTest.hamlet +++ b/templates/adminTest.hamlet @@ -34,3 +34,5 @@ Modals: ^{modal "Klick mich für Ajax-Test" (Left UsersR)} ^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")} + <li> + ^{modal "Email-Test" (Right emailWidget')} diff --git a/templates/correction-user.cassius b/templates/correction-user.cassius new file mode 100644 index 000000000..2b7b13b7a --- /dev/null +++ b/templates/correction-user.cassius @@ -0,0 +1,3 @@ +.comment + white-space: pre-wrap + font-family: monospace \ No newline at end of file diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index d0b8976e2..a3036193f 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -36,4 +36,4 @@ $maybe comment <- ratingComment <tr .table__row> <th .table__th>_{MsgRatingComment} - <td .table__td style="white-space: pre;">#{comment} + <td .table__td .comment>#{comment} diff --git a/templates/correction.hamlet b/templates/correction.hamlet index e26dbe7c4..9c5c0ed39 100644 --- a/templates/correction.hamlet +++ b/templates/correction.hamlet @@ -1,11 +1,10 @@ -^{userCorrection} +<section> + ^{userCorrection} -<hr> - -<form method=post enctype=#{corrEncoding}> - ^{corrForm} +<section> + <form method=post enctype=#{corrEncoding}> + ^{corrForm} -<hr> - -<form method=post enctype=#{uploadEncoding}> - ^{uploadForm} +<section> + <form method=post enctype=#{uploadEncoding}> + ^{uploadForm} diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 97968130e..5e682fba2 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -185,6 +185,10 @@ h4 { p { margin: 10px 0; } + + p:last-child { + margin: 10px 0 0; + } } .logged-in { @@ -309,6 +313,10 @@ input[type="button"].btn-info:hover, width: 100%; } +.table:only-child { + margin: 0; +} + .table--striped { .table__row:not(.no-stripe):nth-child(even) { @@ -502,3 +510,17 @@ input[type="button"].btn-info:hover, padding-right: 15px; } } + +section { + padding: 0 0 12px; + margin: 0 0 12px; + border-bottom: 1px solid #d3d3d3; + +} + +section:last-of-type { + padding: 0; + margin: 0; + border-bottom: none; +} + diff --git a/templates/mail/sheetActive.hamlet b/templates/mail/sheetActive.hamlet new file mode 100644 index 000000000..aecc4c458 --- /dev/null +++ b/templates/mail/sheetActive.hamlet @@ -0,0 +1,17 @@ +$newline never +\<!doctype html> +<html> + <head> + <meta charset="UTF-8"> + <style> + h1 { + font-size: 1.25em; + font-variant: small-caps; + font-weight: normal; + } + <body> + <h1> + _{MsgMailSheetActiveIntro (CI.original courseName) termDesc sheetName} + <p> + <a href=@{CSheetR tid ssh csh shn SShowR}> + #{sheetName} diff --git a/templates/mail/sheetInactive.hamlet b/templates/mail/sheetInactive.hamlet new file mode 100644 index 000000000..3b0664eb5 --- /dev/null +++ b/templates/mail/sheetInactive.hamlet @@ -0,0 +1,17 @@ +$newline never +\<!doctype html> +<html> + <head> + <meta charset="UTF-8"> + <style> + h1 { + font-size: 1.25em; + font-variant: small-caps; + font-weight: normal; + } + <body> + <h1> + _{MsgMailSheetInactiveIntro (CI.original courseName) termDesc sheetName} + <p> + <a href=@{CSheetR tid ssh csh shn SShowR}> + #{sheetName} diff --git a/templates/mail/submissionRated.hamlet b/templates/mail/submissionRated.hamlet new file mode 100644 index 000000000..8e016dc0b --- /dev/null +++ b/templates/mail/submissionRated.hamlet @@ -0,0 +1,65 @@ +$newline never +\<!doctype html> +<html> + <head> + <meta charset="UTF-8"> + <style> + h1 { + font-size: 1.25em; + font-variant: small-caps; + font-weight: normal; + } + + .comment { + white-space: pre-wrap; + font-family: monospace; + } + <body> + <h1> + _{MsgMailSubmissionRatedIntro (CI.original courseName) termDesc} + <dl> + <dt> + _{MsgSubmission} + <dd> + <a href=@{CSubmissionR tid ssh csh shn csid SubShowR}> + #{display csid} + $maybe User{..} <- corrector + <dt> + _{MsgRatingBy} + <dd> + #{display userDisplayName} + $maybe time <- submissionRatingTime' + <dt> + _{MsgRatingTime} + <dd> + #{time} + $maybe points <- submissionRatingPoints + $case sheetType + $of Bonus{..} + <dt> + _{MsgAchievedBonusPoints} + <dd> + _{MsgAchievedOf points maxPoints} + $of Normal{..} + <dt> + _{MsgAchievedNormalPoints} + <dd> + _{MsgAchievedOf points maxPoints} + $of Pass{..} + <dt> + _{MsgPassedResult} + <dd> + $if points >= passingPoints + _{MsgPassed} + $else + _{MsgNotPassed} + <dt> + _{MsgAchievedPassPoints} + <dd> + _{MsgPassAchievedOf points passingPoints maxPoints} + $of NotGraded + $maybe comment <- submissionRatingComment + <dt> + _{MsgRatingComment} + <dd .comment> + #{comment} diff --git a/templates/mail/submissionRated.txt b/templates/mail/submissionRated.txt new file mode 100644 index 000000000..1fa13f16f --- /dev/null +++ b/templates/mail/submissionRated.txt @@ -0,0 +1 @@ +#{mr (MsgMailSubmissionRatedIntro (CI.original courseName) termDesc)} diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 012ada784..47e2014b9 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -1,33 +1,32 @@ -<div .container> - $maybe descr <- sheetDescription sheet - <h2 #description>Hinweise - <p> #{descr} +$newline never +$maybe descr <- sheetDescription sheet + <section> + <h2 #description>_{MsgSheetDescription} + <p> + #{descr} - <h3>Bewertung - <p> - #{display $ sheetType sheet} - - $maybe marking <- sheetMarkingText sheet +$maybe marking <- sheetMarkingText sheet + <section> + <h2>_{MsgSheetMarking} <p> #{marking} - <p> - Download und Abgabe freigeschaltet ab - #{sheetFrom} +<section> + <dl .deflist> + <dt .deflist__dt>_{MsgSheetActiveFrom} + <dd .deflist__dd>#{sheetFrom} + <dt .deflist__dt>_{MsgSheetActiveTo} + <dd .deflist__dd>#{sheetTo} + $maybe hints <- hintsFrom <* guard hasHints + <dt .deflist__dt>_{MsgSheetHintFrom} + <dd .deflist__dd>#{hints} + $maybe solution <- solutionFrom <* guard hasSolution + <dt .deflist__dt>_{MsgSheetSolutionFrom} + <dd .deflist__dd>#{solution} + <dt .deflist__dt>_{MsgSheetType} + <dd .deflist__dd>_{sheetType sheet} - <p> - Abgabe bis - #{sheetTo} - - $maybe hints <- hintsFrom <* guard hasHints - <p> - Hinweise ab - #{hints} - - $maybe solution <- solutionFrom <* guard hasSolution - <p> - Lösung ab - #{solution} - - <h2>Dateien - ^{fileTable} +$if hasFiles + <section> + <h2>_{MsgSheetFiles} + ^{fileTable} diff --git a/templates/widgets/form.julius b/templates/widgets/form.julius index b36ea327b..90a1f53b1 100644 --- a/templates/widgets/form.julius +++ b/templates/widgets/form.julius @@ -36,7 +36,6 @@ }; window.utils.interactiveFieldset = function(form, fieldSets) { - var fields = fieldSets.map(function(fs) { return { fieldSet: fs, diff --git a/templates/widgets/form.lucius b/templates/widgets/form.lucius index 094758416..d4e06f591 100644 --- a/templates/widgets/form.lucius +++ b/templates/widgets/form.lucius @@ -1,10 +1,3 @@ -.hidden { - visibility: hidden; - height: 0; - opacity: 0; -} - - fieldset { border: 0; margin: 20px 0 30px; @@ -13,3 +6,14 @@ fieldset { display: none; } } + +.form-group__input > fieldset { + margin-bottom: 0; +} + +.hidden { + visibility: hidden; + height: 0; + opacity: 0; + margin: 0; +} 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 +<ul ##{theId}> + $forall (n, selId) <- nums + <li> + <select ##{selId} name=#{name} :isReq:required *{attrs}> + $forall opt <- olOptions + <option value=#{withNum (optionExternalValue opt) n} :isSel n opt:selected>#{optionDisplay opt} diff --git a/templates/widgets/permutation.lucius b/templates/widgets/permutation.lucius new file mode 100644 index 000000000..0ae9d74e5 --- /dev/null +++ b/templates/widgets/permutation.lucius @@ -0,0 +1,3 @@ +##{theId} { + list-style-type: none; +} diff --git a/test.sh b/test.sh new file mode 100755 index 000000000..9e3db3ebe --- /dev/null +++ b/test.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash + +move-back() { + mv -v .stack-work .stack-work-test + [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work +} + +if [[ -d .stack-work-test ]]; then + [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run + mv -v .stack-work-test .stack-work + trap move-back EXIT +fi + +stack test --flag uniworx:dev --flag uniworx:library-only ${@} diff --git a/test/CronSpec.hs b/test/CronSpec.hs new file mode 100644 index 000000000..af942ea77 --- /dev/null +++ b/test/CronSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module CronSpec where + +import TestImport + +import Cron +import Numeric.Natural + +import Data.Time +import Data.Time.Clock.System +import Data.Time.Zones + +import Data.List (iterate) + + +baseTime :: UTCTime +baseTime = UTCTime (addDays 58400 systemEpochDay) 50000 + + +sampleCron :: Natural -> Cron -> [UTCTime] +sampleCron n = go n baseTime Nothing + where + go 0 _ _ _ = [] + go n t mPrev cron = case nextCronMatch utcTZ mPrev t cron of + MatchAsap -> t : go (pred n) t (Just t) cron + MatchAt t' -> t' : go (pred n) t' (Just t') cron + MatchNone -> [] + + +spec :: Spec +spec = do + describe "Cron" $ do + it "generates correct example series" . mapM_ seriesExample $ + [ (Cron CronAsap Nothing CronScheduleBefore, [baseTime]) + , (Cron CronAsap (Just $ CronPeriod 10 CronAsap) CronScheduleBefore, iterate (addUTCTime 10) baseTime) + ] + +seriesExample :: (Cron, [UTCTime]) -> Expectation +seriesExample (cron, res) = example $ sampleCron 10 cron `shouldBe` take 10 res diff --git a/test/Handler/ProfileSpec.hs b/test/Handler/ProfileSpec.hs index dff41b58b..e0f8ed5c2 100644 --- a/test/Handler/ProfileSpec.hs +++ b/test/Handler/ProfileSpec.hs @@ -4,6 +4,8 @@ module Handler.ProfileSpec (spec) where import TestImport +import qualified Data.CaseInsensitive as CI + spec :: Spec spec = withApp $ do @@ -13,16 +15,16 @@ spec = withApp $ do statusIs 403 it "asserts access to my-account for authenticated users" $ do - userEntity <- createUser "dummy" "foo" + userEntity <- createUser "foo" authenticateAs userEntity get ProfileR statusIs 200 it "asserts user's information is shown" $ do - userEntity <- createUser "dummy" "bar" + userEntity <- createUser "bar" authenticateAs userEntity get ProfileR let (Entity _ user) = userEntity - htmlAnyContain ".username" . unpack $ userIdent user + htmlAnyContain ".username" . unpack . CI.original $ userIdent user diff --git a/test/TestImport.hs b/test/TestImport.hs index 29f09bdc6..bf7f56729 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -25,6 +25,13 @@ import Test.QuickCheck.Gen as X import Data.Default as X import Test.QuickCheck.Instances as X + +import Settings + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + + runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do app <- getTestYesod @@ -79,12 +86,24 @@ authenticateAs :: Entity User -> YesodExample UniWorX () authenticateAs (Entity _ User{..}) = do request $ do setMethod "POST" - addPostParam "ident" $ userPlugin <> ":" <> userIdent + addPostParam "ident" $ CI.original userIdent setUrl $ AuthR $ PluginR "dummy" [] -- | Create a user. The dummy email entry helps to confirm that foreign-key -- checking is switched off in wipeDB for those database backends which need it. -createUser :: Text -> Text -> YesodExample UniWorX (Entity User) -createUser userPlugin userIdent = runDB $ insertEntity User{..} - where - userMatrikelnummer = "DummyMatrikelnummer" +createUser :: CI Text -> YesodExample UniWorX (Entity User) +createUser userIdent = do + UserDefaultConf{..} <- appUserDefaults . appSettings <$> getTestYesod + let + userMatrikelnummer = Nothing + userAuthentication = AuthLDAP + userEmail = "dummy@example.invalid" + userDisplayName = "Dummy Example" + userSurname = "Example" + userTheme = userDefaultTheme + userMaxFavourites = userDefaultMaxFavourites + userDateTimeFormat = userDefaultDateTimeFormat + userDateFormat = userDefaultDateFormat + userTimeFormat = userDefaultTimeFormat + userDownloadFiles = userDefaultDownloadFiles + runDB $ insertEntity User{..}