From 3e784534a02e41a0b6ba7cb23d6c6911be52dcaf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Oct 2018 14:59:28 +0200 Subject: [PATCH 1/7] Framework for dynamic log settings & major jobs cleanup --- config/settings.yml | 9 +- package.yaml | 1 + src/Application.hs | 55 ++-- src/Foundation.hs | 6 +- src/Import/NoFoundation.hs | 4 +- src/Jobs.hs | 282 ++---------------- src/Jobs/Crontab.hs | 63 ++++ src/Jobs/Handler/HelpRequest.hs | 40 +++ src/Jobs/Handler/QueueNotification.hs | 54 ++++ src/Jobs/Handler/SendNotification.hs | 21 ++ .../Handler/SendNotification/SheetActive.hs | 36 +++ .../Handler/SendNotification/SheetInactive.hs | 36 +++ .../SendNotification/SubmissionRated.hs | 58 ++++ src/Jobs/Handler/SendTestEmail.hs | 34 +++ src/Jobs/Handler/SetLogSettings.hs | 15 + src/Jobs/Queue.hs | 81 +++++ src/Jobs/TH.hs | 29 ++ src/Jobs/Types.hs | 1 + src/Settings.hs | 30 +- src/Utils/Sql.hs | 1 + src/Utils/SystemMessage.hs | 1 - start.sh | 1 + templates/mail/support.hamlet | 2 +- 23 files changed, 566 insertions(+), 294 deletions(-) create mode 100644 src/Jobs/Crontab.hs create mode 100644 src/Jobs/Handler/HelpRequest.hs create mode 100644 src/Jobs/Handler/QueueNotification.hs create mode 100644 src/Jobs/Handler/SendNotification.hs create mode 100644 src/Jobs/Handler/SendNotification/SheetActive.hs create mode 100644 src/Jobs/Handler/SendNotification/SheetInactive.hs create mode 100644 src/Jobs/Handler/SendNotification/SubmissionRated.hs create mode 100644 src/Jobs/Handler/SendTestEmail.hs create mode 100644 src/Jobs/Handler/SetLogSettings.hs create mode 100644 src/Jobs/Queue.hs create mode 100644 src/Jobs/TH.hs diff --git a/config/settings.yml b/config/settings.yml index 0d6855fa5..96e378b69 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -25,9 +25,12 @@ 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" -minimum-log-level: "_env:LOGLEVEL:warn" +log-settings: + log-detailed: "_env:DETAILED_LOGGING:false" + log-all: "_env:LOG_ALL:false" + log-minimum-level: "_env:LOGLEVEL:warn" + +# Debugging auth-dummy-login: "_env:DUMMY_LOGIN:false" allow-deprecated: "_env:ALLOW_DEPRECATED:false" diff --git a/package.yaml b/package.yaml index 656ac5902..4a48ee43d 100644 --- a/package.yaml +++ b/package.yaml @@ -106,6 +106,7 @@ dependencies: - resourcet - postgresql-simple - word24 +- mmorph # 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 c0a92d695..9ffcf2106 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -63,6 +63,10 @@ import Control.Monad.Trans.Resource import System.Log.FastLogger.Date import qualified Yesod.Core.Types as Yesod (Logger(..)) + +import qualified Data.HashMap.Strict as HashMap + +import Control.Lens ((&)) -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) @@ -109,6 +113,8 @@ makeFoundation appSettings@(AppSettings{..}) = do recvChan <- dupTMChan chan return (chan, recvChan) + appLogSettings <- liftIO $ newTVarIO appInitialLogSettings + -- 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 @@ -190,25 +196,38 @@ makeApplication foundation = liftIO $ do return $ logWare $ defaultMiddlewaresNoLogging appPlain makeLogWare :: MonadIO m => UniWorX -> m Middleware -makeLogWare foundation = liftIO $ - mkRequestLogger def - { outputFormat = - if appDetailedRequestLogging $ appSettings foundation - then Detailed True - else Apache - (if appIpFromHeader $ appSettings foundation - then FromFallback - else FromSocket) - , destination = Logger $ loggerSet $ appLogger foundation - } +makeLogWare app = do + logWareMap <- liftIO $ newTVarIO HashMap.empty + let + mkLogWare ls@LogSettings{..} = do + logWare <- mkRequestLogger def + { outputFormat = bool + (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app) + (Detailed True) + logDetailed + , destination = Logger . loggerSet $ appLogger app + } + atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare + return logWare + + void. liftIO $ + mkLogWare =<< readTVarIO (appLogSettings app) + + return $ \wai req fin -> do + lookupRes <- atomically $ do + ls <- readTVar $ appLogSettings app + existing <- HashMap.lookup ls <$> readTVar logWareMap + return $ maybe (Left ls) Right existing + logWare <- either mkLogWare return lookupRes + logWare wai req fin -- | Warp settings for the given foundation value. warpSettings :: UniWorX -> Settings -warpSettings foundation = - setPort (appPort $ appSettings foundation) - $ setHost (appHost $ appSettings foundation) - $ setOnException (\_req e -> +warpSettings foundation = defaultSettings + & setPort (appPort $ appSettings foundation) + & setHost (appHost $ appSettings foundation) + & setOnException (\_req e -> when (defaultShouldDisplayException e) $ messageLoggerSource foundation (appLogger foundation) @@ -216,7 +235,6 @@ warpSettings foundation = "yesod" LevelError (toLogStr $ "Exception from Warp: " ++ show e)) - defaultSettings -- | For yesod devel, return the Warp settings and WAI Application. getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application) @@ -232,9 +250,8 @@ getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSetting -- | main function for use by yesod devel develMain :: IO () -develMain = runResourceT $ do - app <- getApplicationDev - liftIO . develMainHelper $ return app +develMain = runResourceT $ + liftIO . develMainHelper . return =<< getApplicationDev -- | The @main@ function for an executable running this site. appMain :: MonadResourceBase m => m () diff --git a/src/Foundation.hs b/src/Foundation.hs index fd28bd230..9d875c34a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -123,6 +123,7 @@ data UniWorX = UniWorX , appSmtpPool :: Maybe SMTPPool , appHttpManager :: Manager , appLogger :: Logger + , appLogSettings :: TVar LogSettings , appCryptoIDKey :: CryptoIDKey , appInstanceID :: InstanceId , appJobCtl :: [TMChan JobCtl] @@ -751,7 +752,10 @@ instance Yesod UniWorX where -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app) + shouldLog _ _ _ = error "Must use shouldLogIO" + shouldLogIO app _source level = do + LogSettings{..} <- readTVarIO $ appLogSettings app + return $ logAll || level >= logMinimumLevel makeLogger = return . appLogger diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9268563f8..55fc73870 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -3,7 +3,7 @@ module Import.NoFoundation ( module Import ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=)) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import @@ -37,3 +37,5 @@ import GHC.Generics as Import (Generic) import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..)) + +import Control.Monad.Morph as Import (MFunctor(..)) diff --git a/src/Jobs.hs b/src/Jobs.hs index 9f2d8bd23..f89265009 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -14,19 +14,17 @@ module Jobs ( module Types - , writeJobCtl - , queueJob, queueJob' - , YesodJobDB - , runDBJobs, queueDBJob + , module Jobs.Queue , handleJobs ) where -import Import hiding ((.=), Proxy) -import Handler.Utils.Mail -import Handler.Utils.DateTime +import Import hiding (Proxy) import Jobs.Types as Types hiding (JobCtl(JobCtlQueue)) import Jobs.Types (JobCtl(JobCtlQueue)) +import Jobs.Queue +import Jobs.TH +import Jobs.Crontab import Data.Conduit.TMChan import qualified Data.Conduit.List as C @@ -36,40 +34,25 @@ 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 Database.Persist.Sql (fromSqlKey) -import Data.Monoid (Last(..)) import Data.Semigroup (Max(..)) -import Data.Bitraversable -import Utils.Lens import Utils.Sql -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 Control.Monad.Random (evalRand, mkStdGen) 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(..)) @@ -82,6 +65,13 @@ import Data.Time.Zones import Control.Concurrent.STM (retry) + +import Jobs.Handler.SendNotification +import Jobs.Handler.SendTestEmail +import Jobs.Handler.QueueNotification +import Jobs.Handler.HelpRequest +import Jobs.Handler.SetLogSettings + data JobQueueException = JInvalid QueuedJobId QueuedJob | JLocked QueuedJobId InstanceId UTCTime @@ -105,7 +95,7 @@ handleJobs recvChans foundation@UniWorX{..} = do 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) + in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan) -- Start cron operation void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread) @@ -135,9 +125,8 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do Just (_, MatchNone) -> liftBase retry Just x -> return (crontab, x) - let doJob = do - mJid <- mapStateT (mapReaderT $ liftHandlerT . runDB . setSerializable) $ do - newCrontab <- lift . lift $ determineCrontab + let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do + newCrontab <- lift . lift . hoist lift $ determineCrontab' if | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab -> do @@ -154,12 +143,11 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do , cronLastExecInstance = instanceID } [ CronLastExecTime =. now ] - Just <$> lift (lift $ queueJobUnsafe job) - other -> Nothing <$ writeJobCtl other + lift . lift $ queueDBJob job + other -> writeJobCtl other | otherwise - -> lift . fmap (const Nothing) . mapReaderT (liftIO . atomically) $ + -> lift . mapReaderT (liftIO . atomically) $ lift . flip writeTVar newCrontab =<< asks jobCrontab - maybe (return ()) (writeJobCtl . JobCtlPerform) mJid case nextMatch of MatchAsap -> doJob @@ -252,7 +240,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do -- `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 + newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab' -- $logDebugS logIdent $ tshow newCTab mapReaderT (liftIO . atomically) $ lift . flip writeTVar newCTab =<< asks jobCrontab @@ -292,57 +280,6 @@ jLocked jId act = do 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 pruneLastExecs :: Crontab JobCtl -> DB () pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab @@ -352,181 +289,10 @@ pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCronta , 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 +determineCrontab' :: DB (Crontab JobCtl) +determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab 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)) -performJob JobHelpRequest{..} = do - supportAddress <- getsYesod $ appMailSupport . appSettings - userInfo <- bitraverse return (runDB . getEntity) jSender - let userAddress = either (fmap $ Address Nothing) - (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail)) - userInfo - mailT def $ do - _mailTo .= [supportAddress] - whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress - setSubjectI MsgMailSubjectSupport - setDate jRequestTime - rtime <- formatTimeMail SelFormatDateTime jRequestTime - addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) - +performJob = $(dispatchTH ''Job) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs new file mode 100644 index 000000000..955c09ee4 --- /dev/null +++ b/src/Jobs/Crontab.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , FlexibleContexts + #-} + +module Jobs.Crontab + ( determineCrontab + ) where + +import Import + +import qualified Data.HashMap.Strict as HashMap +import Jobs.Types + +import Data.Time +import Data.Time.Zones + +import Control.Monad.Trans.Writer (execWriterT) +import Control.Monad.Writer.Class (MonadWriter(..)) + +import qualified Data.Conduit.List as C + + +determineCrontab :: DB (Crontab JobCtl) +-- ^ Extract all future jobs from the database (sheet deadlines, ...) +determineCrontab = execWriterT $ do + AppSettings{..} <- getsYesod appSettings + + case appJobFlushInterval of + Just interval -> tell $ HashMap.singleton + JobCtlFlush + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = interval + } + Nothing -> return () + + 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 diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs new file mode 100644 index 000000000..ba466d700 --- /dev/null +++ b/src/Jobs/Handler/HelpRequest.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude + , TemplateHaskell + , RecordWildCards + , OverloadedStrings + #-} + +module Jobs.Handler.HelpRequest + ( dispatchJobHelpRequest + ) where + +import Import hiding ((.=)) + +import Text.Hamlet +import qualified Data.CaseInsensitive as CI + +import Handler.Utils.DateTime + +import Utils.Lens + +import Data.Bitraversable + + +dispatchJobHelpRequest :: Either (Maybe Email) UserId + -> UTCTime + -> Text -- ^ Help Request + -> Maybe Text -- ^ Referer + -> Handler () +dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do + supportAddress <- getsYesod $ appMailSupport . appSettings + userInfo <- bitraverse return (runDB . getEntity) jSender + let userAddress = either (fmap $ Address Nothing) + (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail)) + userInfo + mailT def $ do + _mailTo .= [supportAddress] + whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress + setSubjectI MsgMailSubjectSupport + setDate jRequestTime + rtime <- formatTimeMail SelFormatDateTime jRequestTime + addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs new file mode 100644 index 000000000..1767f7133 --- /dev/null +++ b/src/Jobs/Handler/QueueNotification.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + #-} + +module Jobs.Handler.QueueNotification + ( dispatchJobQueueNotification + ) where + +import Import + +import Jobs.Types + +import qualified Database.Esqueleto as E +import Utils.Sql +import Jobs.Queue + + +dispatchJobQueueNotification :: Notification -> Handler () +dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do + candidates <- hoist lift $ determineNotificationCandidates jNotification + nClass <- hoist lift $ classifyNotification jNotification + mapM_ (queueDBJob . flip JobSendNotification jNotification) $ do + Entity uid User{userNotificationSettings} <- candidates + guard $ notificationAllowed userNotificationSettings nClass + return uid + + +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 + + diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs new file mode 100644 index 000000000..39598368b --- /dev/null +++ b/src/Jobs/Handler/SendNotification.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE NoImplicitPrelude + , TemplateHaskell + #-} + +module Jobs.Handler.SendNotification + ( dispatchJobSendNotification + ) where + +import Import + +import Jobs.TH +import Jobs.Types + + +import Jobs.Handler.SendNotification.SubmissionRated +import Jobs.Handler.SendNotification.SheetActive +import Jobs.Handler.SendNotification.SheetInactive + + +dispatchJobSendNotification :: UserId -> Notification -> Handler () +dispatchJobSendNotification jRecipient jNotification = $(dispatchTH ''Notification) jNotification jRecipient diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs new file mode 100644 index 000000000..c25962a7e --- /dev/null +++ b/src/Jobs/Handler/SendNotification/SheetActive.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + , TemplateHaskell + , OverloadedStrings + #-} + +module Jobs.Handler.SendNotification.SheetActive + ( dispatchNotificationSheetActive + ) where + +import Import + +import Utils.Lens +import Handler.Utils.Mail + +import Text.Hamlet +import qualified Data.CaseInsensitive as CI + +dispatchNotificationSheetActive :: SheetId -> UserId -> Handler () +dispatchNotificationSheetActive nSheet 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)) diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs new file mode 100644 index 000000000..5caf09e0a --- /dev/null +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + , TemplateHaskell + , OverloadedStrings + #-} + +module Jobs.Handler.SendNotification.SheetInactive + ( dispatchNotificationSheetInactive + ) where + +import Import + +import Utils.Lens +import Handler.Utils.Mail + +import Text.Hamlet +import qualified Data.CaseInsensitive as CI + +dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler () +dispatchNotificationSheetInactive nSheet 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)) diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs new file mode 100644 index 000000000..91d983265 --- /dev/null +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + , TemplateHaskell + , OverloadedStrings + #-} + +module Jobs.Handler.SendNotification.SubmissionRated + ( dispatchNotificationSubmissionRated + ) where + +import Import + +import Utils.Lens +import Handler.Utils.DateTime +import Handler.Utils.Mail + +import Text.Hamlet +import qualified Data.Aeson as Aeson +import qualified Data.CaseInsensitive as CI + +dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler () +dispatchNotificationSubmissionRated nSubmission 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)) diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs new file mode 100644 index 000000000..4b2865fdd --- /dev/null +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + , QuasiQuotes + #-} + +module Jobs.Handler.SendTestEmail + ( dispatchJobSendTestEmail + ) where + +import Import hiding ((.=)) + +import Handler.Utils.DateTime + +import Text.Shakespeare.Text + +import Utils.Lens + +dispatchJobSendTestEmail :: Email -> MailContext -> Handler () +dispatchJobSendTestEmail jEmail jMailContext = 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/Handler/SetLogSettings.hs b/src/Jobs/Handler/SetLogSettings.hs new file mode 100644 index 000000000..01c8d618f --- /dev/null +++ b/src/Jobs/Handler/SetLogSettings.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude + #-} + +module Jobs.Handler.SetLogSettings + ( dispatchJobSetLogSettings + ) where + +import Import + +dispatchJobSetLogSettings :: InstanceId -> LogSettings -> Handler () +dispatchJobSetLogSettings jInstance jLogSettings = do + instanceId <- getsYesod appInstanceID + unless (instanceId == jInstance) $ fail "Incorrect instance" + lSettings <- getsYesod appLogSettings + atomically $ writeTVar lSettings jLogSettings diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs new file mode 100644 index 000000000..d72734aeb --- /dev/null +++ b/src/Jobs/Queue.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE NoImplicitPrelude + , TypeFamilies + #-} + +module Jobs.Queue + ( writeJobCtl, writeJobCtlBlock + , queueJob, queueJob' + , YesodJobDB + , runDBJobs, queueDBJob + ) where + +import Import + +import Utils.Sql +import Jobs.Types + +import Control.Monad.Trans.Writer (WriterT, runWriterT) +import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Trans.Reader (ReaderT, mapReaderT) + +import qualified Data.Set as Set +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.HashMap.Strict as HashMap + +import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen, uniform) + + +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 . 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 + + + diff --git a/src/Jobs/TH.hs b/src/Jobs/TH.hs new file mode 100644 index 000000000..47e69f62d --- /dev/null +++ b/src/Jobs/TH.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoImplicitPrelude + , TemplateHaskell + , QuasiQuotes + , RecordWildCards + #-} + +module Jobs.TH + ( dispatchTH + ) where + +import ClassyPrelude + +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +import Data.List (foldl) + + +dispatchTH :: Name -- ^ Datatype to pattern match + -> ExpQ +dispatchTH dType = do + DatatypeInfo{..} <- reifyDatatype dType + let + matches = map mkMatch datatypeCons + mkMatch ConstructorInfo{..} = do + pats <- forM constructorFields $ \_ -> newName "x" + let fName = mkName $ "dispatch" <> nameBase constructorName + match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) [] + lamCaseE matches diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 9cb800c4d..4d3bbb85f 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -24,6 +24,7 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica | JobHelpRequest { jSender :: Either (Maybe Email) UserId , jRequestTime :: UTCTime , jHelpRequest :: Text, jReferer :: Maybe Text } + | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings } deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } diff --git a/src/Settings.hs b/src/Settings.hs index 455839b13..9ba5e40ca 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Settings are centralized, as much as possible, into this file. This @@ -89,10 +90,8 @@ data AppSettings = AppSettings , appJobStaleThreshold :: NominalDiffTime , appNotificationRateLimit :: NominalDiffTime - , appDetailedRequestLogging :: Bool - -- ^ Use detailed request logging system - , appShouldLogAll :: Bool - -- ^ Should all log messages be displayed? + , appInitialLogSettings :: LogSettings + , appReloadTemplates :: Bool -- ^ Use the reload version of templates , appMutableStatic :: Bool @@ -103,7 +102,6 @@ data AppSettings = AppSettings -- ^ Indicate if auth dummy login should be enabled. , appAllowDeprecated :: Bool -- ^ Indicate if deprecated routes are accessible for everyone - , appMinimumLogLevel :: LogLevel , appUserDefaults :: UserDefaultConf , appAuthPWHash :: PWHashConf @@ -111,7 +109,16 @@ data AppSettings = AppSettings , appCryptoIDKeyFile :: FilePath , appInstanceIDFile :: Maybe FilePath } deriving (Show) - + +data LogSettings = LogSettings + { logAll, logDetailed :: Bool + , logMinimumLevel :: LogLevel + } deriving (Show, Read, Generic, Eq, Ord) + +deriving instance Generic LogLevel +instance Hashable LogLevel +instance Hashable LogSettings + data UserDefaultConf = UserDefaultConf { userDefaultTheme :: Theme , userDefaultMaxFavourites :: Int @@ -169,6 +176,10 @@ data SmtpAuthConf = SmtpAuthConf , smtpAuthPassword :: HaskellNet.Password } deriving (Show) +deriveJSON defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . splitCamel + } ''LogSettings + deriveFromJSON defaultOptions ''Ldap.Scope deriveFromJSON defaultOptions { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel @@ -199,7 +210,7 @@ deriveFromJSON } ''ResourcePoolConf -deriveFromJSON +deriveJSON defaultOptions { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level" , sumEncoding = UntaggedValue @@ -283,15 +294,14 @@ instance FromJSON AppSettings where 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" appReloadTemplates <- o .:? "reload-templates" .!= defaultDev appMutableStatic <- o .:? "mutable-static" .!= defaultDev appSkipCombining <- o .:? "skip-combining" .!= defaultDev appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev + appInitialLogSettings <- o .: "log-settings" + appUserDefaults <- o .: "user-defaults" appAuthPWHash <- o .: "auth-pw-hash" diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index 6cdb0a144..ef2d2c6ea 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -32,6 +32,7 @@ setSerializable act = setSerializable' (0 :: Integer) delay :: NominalDiffTime delay = 1e-3 * 2 ^ logBackoff $logWarnS "Sql" $ tshow (delay, e) + transactionUndo threadDelay . round $ delay * 1e6 setSerializable' (succ logBackoff) ) diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs index 163722a66..80a7b7e00 100644 --- a/src/Utils/SystemMessage.hs +++ b/src/Utils/SystemMessage.hs @@ -5,7 +5,6 @@ module Utils.SystemMessage where import Import.NoFoundation -import Utils import qualified Data.List.NonEmpty as NonEmpty import Data.List (findIndex) diff --git a/start.sh b/start.sh index da7e422d4..7f0a48c4e 100755 --- a/start.sh +++ b/start.sh @@ -3,6 +3,7 @@ unset HOST export DETAILED_LOGGING=true export LOG_ALL=true +export LOGLEVEL=info export DUMMY_LOGIN=true export ALLOW_DEPRECATED=true export PWFILE=users.yml diff --git a/templates/mail/support.hamlet b/templates/mail/support.hamlet index d37ca5a8d..e8ba2fb77 100644 --- a/templates/mail/support.hamlet +++ b/templates/mail/support.hamlet @@ -25,5 +25,5 @@ $newline never
#{lang}
Zeit
#{rtime} -

+

#{jHelpRequest} From 1aa08cdb825d1231a95059f402de5c145b8cd8ae Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Oct 2018 20:51:33 +0200 Subject: [PATCH 2/7] Cleanup --- messages/uniworx/de.msg | 12 +++++------- src/index.md | 37 +++++++++++++++++++++++++++++++++++++ templates/help.hamlet | 3 +-- 3 files changed, 43 insertions(+), 9 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 741370d07..2835d3210 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -388,12 +388,10 @@ SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben: UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht! -HelpAnswer: Anfrage von -HelpUser: Benutzeraccount Uni2Work -HelpAnonymous: Anonym (Keine Antwort möglich) -HelpEMail: E-Mail (ohne Login) +HelpAnswer: Antworten an +HelpUser: Meinen Benutzeraccount +HelpAnonymous: Keine Antwort (Anonym) +HelpEMail: E-Mail HelpRequest: Supportanfrage / Verbesserungsvorschlag HelpProblemPage: Problematische Seite - - -Dummy: TODO Message not defined! +HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten. \ No newline at end of file diff --git a/src/index.md b/src/index.md index 1a81b627c..2fcfbeaa6 100644 --- a/src/index.md +++ b/src/index.md @@ -103,6 +103,43 @@ Jobs Jobs.Types : `Job`, `Notification`, `JobCtl` Types of Jobs + +Cron.Types + : Datentypen zur Spezifikation von Intervallen zu denen Jobs ausgeführt werden + können: + + `Cron`, `CronMatch`, `CronAbsolute`, `CronRepeat`, `Crontab` + +Cron + : Seiteneffektfreie Berechnungen auf Typen aus `Cron.Types`: `nextCronMatch` + +Jobs.Queue + : Funktionen zum _anstoßen_ von Jobs und zur Kommunikation mit den + Worker-Threads + + `writeJobCtl` schickt Nachricht an einen pseudo-Zufälligen worker-thread der + lokalen Instanz + + `queueJob` und `queueJob'` schreiben neue Jobs in die Instanz-übergreifende + Job-Queue, `queueJob'` stößt außerdem einen lokalen worker-thread an sich + des Jobs anzunehmen + + `runDBJobs` ersetzt `runDB` und erlaubt `queueDBJob` zu + benutzen. `queueDBJob` schreibt einen Job in die Queue; am Ende stößt + `runDBJobs` lokale worker-threads für alle mit `queueDBJobs` eingetragenen + Jobs an. + +Jobs.TH + : Templatehaskell für den dispatch mechanismus für `Jobs` + +Jobs.Crontab + : Generiert `Crontab JobCtl` aus der Datenbank (sammelt alle in den Daten aus + der Datenbank impliziten Jobs (notifications zu bestimmten zeiten, + aufräumaktionen, ...) ein) + +Jobs.Handler.** + : Via `Jobs.TH` delegiert `Jobs` das Interpretieren und Ausführen eines Werts + aus `Jobs.Types` an einen dieser Handler Mail : Monadically constructing MIME emails diff --git a/templates/help.hamlet b/templates/help.hamlet index 532e588cb..6d4b32bca 100644 --- a/templates/help.hamlet +++ b/templates/help.hamlet @@ -1,5 +1,4 @@ - -Bitte beschreiben Sie Ihr Problem: +_{MsgHelpIntroduction}

^{formWidget} From bd260d1a38e0c76596a3549ceb12f10dab75b18f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Oct 2018 21:26:17 +0200 Subject: [PATCH 3/7] Cleanup --- src/Handler/Home.hs | 10 +++++----- templates/home.hamlet | 8 +------- templates/homeUser.hamlet | 8 +++----- templates/versionHistory.hamlet | 8 ++++---- 4 files changed, 13 insertions(+), 21 deletions(-) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 2b3fce6d3..3ba5bab0a 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -117,10 +117,10 @@ homeAnonymous = do , dbtStyle = def , dbtIdent = "upcomingdeadlines" :: Text } - let features = $(widgetFile "featureList") - addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" + -- let features = $(widgetFile "featureList") + -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" defaultLayout $ do - $(widgetFile "dsgvDisclaimer") + -- $(widgetFile "dsgvDisclaimer") $(widgetFile "home") homeUser :: Key User -> Handler Html @@ -218,11 +218,11 @@ homeUser uid = do , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtIdent = "upcomingdeadlines" :: Text } - addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." + -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." defaultLayout $ do -- setTitle "Willkommen zum Uni2work Test!" $(widgetFile "homeUser") - $(widgetFile "dsgvDisclaimer") + -- $(widgetFile "dsgvDisclaimer") getVersionR :: Handler TypedContent diff --git a/templates/home.hamlet b/templates/home.hamlet index 8f5c3bafb..3995b864f 100644 --- a/templates/home.hamlet +++ b/templates/home.hamlet @@ -1,11 +1,5 @@
- -

+

Kurse mit offener Registrierung
^{courseTable} - -

- Re-Implementierung von UniWorX - - ^{features} diff --git a/templates/homeUser.hamlet b/templates/homeUser.hamlet index c82ea98ef..479d27ab9 100644 --- a/templates/homeUser.hamlet +++ b/templates/homeUser.hamlet @@ -1,13 +1,10 @@
-

- Re-Implementierung von UniWorX - -
-

+

Anstehende Übungsblätter
^{sheetTable} + diff --git a/templates/versionHistory.hamlet b/templates/versionHistory.hamlet index 859356ca5..bee7bee3e 100644 --- a/templates/versionHistory.hamlet +++ b/templates/versionHistory.hamlet @@ -10,11 +10,11 @@ Bekannte Bugs
  • - Umlaute in Benutzernamen werden durch externes LDAP-Plugin entfernt + Login ist u.U. anders als im alten System, z.B. @campus.lmu.de statt @lmu.de
  • - Auswahlbox "alle markieren" fehlt noch + Favicon ist default des Frameworks
  • - Tabellen über mehrere Seiten müssen vor Seitenwechsel manuell sortiert werden + Format von Bewertungsdateien ist provisorisch

    @@ -26,7 +26,7 @@

    Impressum -
      +
      • Dr Steffen Jost
      • From 353e958755e9ef3eba9d4761584889211dffb764 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 21 Oct 2018 12:08:01 +0200 Subject: [PATCH 4/7] Display pseudonyms & anonymise submission page Fixes #118 --- messages/uniworx/de.msg | 1 + src/Handler/Corrections.hs | 27 +++++++++++++++++++-------- templates/submission.hamlet | 2 +- 3 files changed, 21 insertions(+), 9 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2835d3210..71ab9a2b1 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -258,6 +258,7 @@ RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist +Pseudonyms: Pseudonyme FileTitle: Dateiname FileModified: Letzte Änderung diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 1db0c9b95..904a283d7 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -91,7 +91,7 @@ sheetIs :: Key Sheet -> CorrectionsWhere sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid -type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId User) +type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym)) colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) @@ -143,13 +143,15 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp tid = course ^. _3 ssh = course ^. _4 link cid = CourseR tid ssh csh $ CUserR cid - cell = listCell (Map.toList users) $ \(userId, User{..}) -> do - anchorCellM (link <$> encrypt userId) (nameWidget userDisplayName userSurname) + cell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) -> + anchorCellM (link <$> encrypt userId) $ case mPseudo of + Nothing -> nameWidget userDisplayName userSurname + Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review pseudonymText p})|] in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let - cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) + cell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) @@ -171,6 +173,12 @@ colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } -> maybe mempty timeCell submissionRatingTime +colPseudonyms :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let + lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo -> + cell [whamlet|#{review pseudonymText pseudo}|] + in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] + type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) @@ -191,14 +199,16 @@ makeCorrectionsTable whereClause colChoices psValidator = do ) return (submission, sheet, crse, corrector) dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData - dbtProj = traverse $ \(submission@(Entity sId _), sheet, (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do - submittors <- lift . E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do + dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do + submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do + E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) + E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId E.orderBy [E.asc $ user E.^. UserId] - return user + return (user, pseudonym E.?. SheetPseudonymPseudonym) let - submittorMap = foldr (\(Entity userId user) -> Map.insert userId user) Map.empty submittors + submittorMap = foldr (\((Entity userId user, E.Value pseudo)) -> Map.insert userId (user, pseudo)) Map.empty submittors return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap) dbTable psValidator $ DBTable { dbtSQLQuery @@ -383,6 +393,7 @@ postCorrectionsR = do , colTerm , colCourse , colSheet + , colPseudonyms , colSubmissionLink , colAssigned , colRating diff --git a/templates/submission.hamlet b/templates/submission.hamlet index aeaf9ca2f..c9686bd3b 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -13,7 +13,7 @@ $maybe cID <- mcid

        _{MsgSubmissionNoUploadExpected} - $if not (null lastEdits) + $if maySubmit && not (null lastEdits)

        _{MsgLastEdits}
          $forall (mbName,time) <- lastEdits From 72e0af26189981a4a1f091d8f32e6d9f251d0300 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 21 Oct 2018 12:09:23 +0200 Subject: [PATCH 5/7] Hotfix #212 --- templates/standalone/modal.lucius | 2 ++ 1 file changed, 2 insertions(+) diff --git a/templates/standalone/modal.lucius b/templates/standalone/modal.lucius index 589083ece..e14dbad72 100644 --- a/templates/standalone/modal.lucius +++ b/templates/standalone/modal.lucius @@ -16,11 +16,13 @@ overflow: auto; opacity: 0; transition: all .15s ease; + pointer-events: none; &.modal--open { opacity: 1; z-index: 200; transform: translate(-50%, -50%) scale(1, 1); + pointer-events: all; } } From d663586516b910970c2787da760b40fc310be2c7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 22 Oct 2018 10:34:38 +0200 Subject: [PATCH 6/7] CorrectionsGradeR --- messages/uniworx/de.msg | 2 + routes | 7 ++- src/Foundation.hs | 31 ++++++++++ src/Handler/Corrections.hs | 85 +++++++++++++++++++++++++-- src/Handler/Utils/Table/Pagination.hs | 11 +++- templates/corrections-grade.hamlet | 5 ++ 6 files changed, 132 insertions(+), 9 deletions(-) create mode 100644 templates/corrections-grade.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 71ab9a2b1..3c4ef4358 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -258,6 +258,7 @@ RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist +ColumnRatingPointsDone: Punktzahl/Abgeschlossen Pseudonyms: Pseudonyme FileTitle: Dateiname @@ -386,6 +387,7 @@ SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert: SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben: +CorrGrade: Korrekturen eintragen UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht! diff --git a/routes b/routes index dbe76f4d9..e2572e8ba 100644 --- a/routes +++ b/routes @@ -85,9 +85,10 @@ !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector -/corrections CorrectionsR GET POST !corrector !lecturer -/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer -/corrections/create CorrectionsCreateR GET POST !corrector !lecturer +/submissions CorrectionsR GET POST !corrector !lecturer +/submissions/upload CorrectionsUploadR GET POST !corrector !lecturer +/submissions/create CorrectionsCreateR GET POST !corrector !lecturer +/submissions/grade CorrectionsGradeR GET POST !corrector !lecturer /msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDisReadANDauthentication diff --git a/src/Foundation.hs b/src/Foundation.hs index 1cdf8cfb2..95459077c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1122,6 +1122,35 @@ pageActions (CSheetR tid ssh csh shn SCorrR) = } ] pageActions (CorrectionsR) = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Korrekturen hochladen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsUploadR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + , PageActionPrime $ MenuItem + { menuItemLabel = "Abgaben erstellen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsCreateR + , menuItemModal = True + , menuItemAccessCallback' = runDB $ do + uid <- liftHandlerT requireAuthId + [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + return E.countRows + return $ (count :: Int) /= 0 + } + , PageActionPrime $ MenuItem + { menuItemLabel = "Korrekturen eintragen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsGradeR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CorrectionsGradeR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrekturen hochladen" , menuItemIcon = Nothing @@ -1237,6 +1266,8 @@ pageHeading CorrectionsUploadR = Just $ i18nHeading MsgCorrUpload pageHeading CorrectionsCreateR = Just $ i18nHeading MsgCorrCreate +pageHeading CorrectionsGradeR + = Just $ i18nHeading MsgCorrGrade pageHeading (MessageR _) = Just $ i18nHeading MsgSystemMessageHeading diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 904a283d7..78ad460c8 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -69,6 +69,8 @@ import qualified Data.CaseInsensitive as CI import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Trans.RWS (RWST) + import Control.Monad.Trans.State (State, StateT(..), runState) import qualified Control.Monad.State.Class as State @@ -90,6 +92,9 @@ courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid sheetIs :: Key Sheet -> CorrectionsWhere sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid +submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere +submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode + type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym)) @@ -179,13 +184,25 @@ colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_ cell [whamlet|#{review pseudonymText pseudo}|] in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] +colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), a)))) +colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone & cellTooltip MsgRatingPointsDone) $ formCell + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of + NotGraded -> over (_1.mapped) ((_1 .~) . fmap Left) . over _2 fvInput <$> mopt checkBoxField "" (Just . Just $ isJust submissionRatingPoints) + _other -> over (_1.mapped) ((_1 .~) . fmap Right) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints) + ) + +colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Text)))) +colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_2 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment)) type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) - => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) -makeCorrectionsTable whereClause colChoices psValidator = do + => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x) +makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy @@ -209,10 +226,10 @@ makeCorrectionsTable whereClause colChoices psValidator = do return (user, pseudonym E.?. SheetPseudonymPseudonym) let submittorMap = foldr (\((Entity userId user, E.Value pseudo)) -> Map.insert userId (user, pseudo)) Map.empty submittors - return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap) + dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap) dbTable psValidator $ DBTable { dbtSQLQuery - , dbtColonnade = colChoices + , dbtColonnade , dbtProj , dbtSorting = Map.fromList [ ( "term" @@ -230,6 +247,9 @@ makeCorrectionsTable whereClause colChoices psValidator = do , ( "rating" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints ) + , ( "ratingtime" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime + ) ] , dbtFilter = Map.fromList [ ( "term" @@ -277,7 +297,7 @@ data ActionCorrectionsData = CorrDownloadData correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do - tableForm <- makeCorrectionsTable whereClause displayColumns psValidator + tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf (actionRes, action) <- multiAction actions Nothing @@ -602,6 +622,7 @@ postCorrectionsCreateR = do FormMissing -> return () FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess (sid, pss) -> do + now <- liftIO getCurrentTime runDB $ do Sheet{..} <- get404 sid (sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) @@ -643,6 +664,7 @@ postCorrectionsCreateR = do | otherwise -> do subId <- insert submission + void . insert $ SubmissionEdit uid now subId insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId @@ -655,12 +677,14 @@ postCorrectionsCreateR = do case (groups :: [E.Value SubmissionGroupId]) of [x] -> do subId <- insert submission + void . insert $ SubmissionEdit uid now subId insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } [] -> do subId <- insert submission + void . insert $ SubmissionEdit uid now subId insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId @@ -671,17 +695,20 @@ postCorrectionsCreateR = do | [SheetPseudonym{sheetPseudonymUser}] <- spGroup -> do subId <- insert submission + void . insert $ SubmissionEdit uid now subId insert_ SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } | otherwise -> do subId <- insert submission + void . insert $ SubmissionEdit uid now subId insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc + redirect CorrectionsGradeR defaultLayout $ do @@ -701,3 +728,51 @@ postCorrectionsCreateR = do [] -> return $ Right valid textFromList :: [[Pseudonym]] -> Textarea textFromList = Textarea . Text.unlines . map (Text.intercalate ", " . map (review pseudonymText)) + +getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html +getCorrectionsGradeR = postCorrectionsGradeR +postCorrectionsGradeR = do + uid <- requireAuthId + let whereClause = ratedBy uid + displayColumns = mconcat -- should match getSSubsR for consistent UX + [ dbRow + , colTerm + , colCourse + , colSheet + , colPseudonyms + , colSubmissionLink + , colRated + , colPointsField + , colCommentField + ] -- Continue here + psValidator = def + & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), Maybe Text))) + unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } -> (bool (Right <$> submissionRatingPoints) (Just . Left $ isJust submissionRatingPoints) $ sheetType == NotGraded, submissionRatingComment) + + tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do + cID <- encrypt subId + void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True + return i + (((fmap unFormResult -> tableRes), table), tableEncoding) <- runFormPost tableForm + + case tableRes of + FormMissing -> return () + FormFailure errs -> forM_ errs $ addMessage Error . toHtml + FormSuccess resMap -> do + now <- liftIO getCurrentTime + subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (mPoints, mComment)) -> do + let mPoints' = either (bool Nothing $ return 0) return =<< mPoints + Submission{..} <- get404 subId + if + | submissionRatingPoints /= mPoints' || submissionRatingComment /= mComment + -> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints' + , SubmissionRatingComment =. mComment + , SubmissionRatingBy =. Just uid + , SubmissionRatingTime =. now <$ (void mPoints' <|> void mComment) + ] + | otherwise -> return $ Nothing + subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission] + unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet") + + defaultLayout $ do + $(widgetFile "corrections-grade") diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 3e017472c..d4fe59a22 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -35,7 +35,7 @@ module Handler.Utils.Table.Pagination , widgetColonnade, formColonnade, dbColonnade , cell, textCell, stringCell, i18nCell , anchorCell, anchorCell', anchorCellM, anchorCellM' - , tickmarkCell + , tickmarkCell, cellTooltip , listCell , formCell, DBFormResult, getDBFormResult , dbRow, dbSelect @@ -499,6 +499,15 @@ tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a tickmarkCell True = textCell (tickmark :: Text) tickmarkCell False = mempty +cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a +cellTooltip msg cell = cell & cellContents.mapped %~ (<> tipWdgt) + where + tipWdgt = [whamlet| +
          +
          +
          _{msg} + |] + anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a anchorCell = anchorCellM . return diff --git a/templates/corrections-grade.hamlet b/templates/corrections-grade.hamlet new file mode 100644 index 000000000..f68d51e69 --- /dev/null +++ b/templates/corrections-grade.hamlet @@ -0,0 +1,5 @@ +
          + + ^{table} +