Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

This commit is contained in:
Gregor Kleen 2018-10-24 18:01:23 +02:00
commit c24370b7cc
18 changed files with 197 additions and 31 deletions

6
.vscode/tasks.json vendored
View File

@ -6,7 +6,11 @@
{
"label": "echo",
"type": "shell",
"command": "echo Hello"
"command": "echo Hello",
"group": {
"kind": "build",
"isDefault": true
}
}
]
}

View File

@ -83,6 +83,10 @@ The following Description applies to Ubuntu or similar.
ldap: https://wiki.ubuntuusers.de/OpenLDAP_ab_Precise/
Instead of run.sh, use:
stack build --flag uniworx:dev --flag uniworx:library-only
***
# PostgreSQL

View File

@ -24,6 +24,8 @@ job-flush-interval: "_env:JOB_FLUSH:30"
job-cron-interval: "_env:CRON_INTERVAL:60"
job-stale-threshold: 300
notification-rate-limit: 3600
notification-collate-delay: 300
notification-expiration: 259201
log-settings:
log-detailed: "_env:DETAILED_LOGGING:false"

View File

@ -16,7 +16,7 @@ WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
SummerTermShort year@Integer: SoSe #{display year}
WinterTermShort year@Integer: WiSe #{display year}/#{display $ mod (succ year) 100}
PSLimitNonPositive: “pagesize” muss größer als null sein
Page n@Int64: #{display n}
Page num@Int64: #{display num}
TermsHeading: Semesterübersicht
TermCurrent: Aktuelles Semester
@ -131,7 +131,7 @@ SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
CorrectionHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur
SubmissionMember g@Int: Mitabgebende(r) ##{display g}
SubmissionMember n@Int: Mitabgebende(r) ##{display n}
SubmissionArchive: Zip-Archiv der Abgabedatei(en)
SubmissionFile: Datei zur Abgabe
SubmissionFiles: Abgegebene Dateien
@ -203,7 +203,7 @@ ImpressumHeading: Impressum
SystemMessageHeading: Uni2Work Statusmeldung
SystemMessageListHeading: Uni2Work Statusmeldungen
NumCourses n@Int64: #{display n} Kurse
NumCourses num@Int64: #{display num} Kurse
CloseAlert: Schliessen
Name: Name
@ -343,8 +343,11 @@ MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{co
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.
MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden
MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze.
MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfristt für #{sheetName} in #{csh} abgelaufen
MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet.
MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} Abgaben wurden Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt.
MailSubjectSupport: Supportanfrage
@ -371,7 +374,9 @@ 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
NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
NotificationCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
CorrCreate: Abgaben erstellen
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
@ -399,6 +404,7 @@ HelpEMail: E-Mail
HelpRequest: Supportanfrage / Verbesserungsvorschlag
HelpProblemPage: Problematische Seite
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.
HelpSent: Ihre Supportanfrage wurde weitergeleitet.
SystemMessageFrom: Sichtbar ab
SystemMessageTo: Sichtbar bis

View File

@ -255,8 +255,9 @@ instance RenderMessage UniWorX NotificationTrigger where
NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded
NTSubmissionRated -> MsgNotificationTriggerSubmissionRated
NTSheetActive -> MsgNotificationTriggerSheetActive
NTSheetInactive -> MsgNotificationTriggerSheetInactive
NTSheetSoonInactive -> MsgNotificationTriggerSheetSoonInactive
NTSheetInactive -> MsgNotificationTriggerSheetInactive
NTCorrectionsAssigned -> MsgNotificationCorrectionsAssigned
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)

View File

@ -297,7 +297,9 @@ postHelpR = do
, jHelpRequest = hfRequest
, jRequestTime = now
, jReferer = hfReferer }
redirect $ HelpR
-- redirect $ HelpR
addMessageI Success MsgHelpSent
return ()
{-selectRep $ do
provideJson ()
provideRep (redirect $ HelpR :: Handler Html) -}

View File

@ -85,8 +85,7 @@ data SheetForm = SheetForm
{ sfName :: SheetName
, sfDescription :: Maybe Html
, sfType :: SheetType
, sfGrouping :: SheetGroup
, sfMarkingText :: Maybe Html
, sfGrouping :: SheetGroup
, sfVisibleFrom :: Maybe UTCTime
, sfActiveFrom :: UTCTime
, sfActiveTo :: UTCTime
@ -98,6 +97,7 @@ data SheetForm = SheetForm
, sfSolutionFrom :: Maybe UTCTime
, sfSolutionF :: Maybe (Source Handler (Either FileId File))
, sfMarkingF :: Maybe (Source Handler (Either FileId File))
, sfMarkingText :: Maybe Html
-- Keine SheetId im Formular!
}
@ -120,8 +120,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
<$> areq ciField (fslI MsgSheetName) (sfName <$> template)
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
<*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
& setTooltip MsgSheetVisibleFromTip)
((sfVisibleFrom <$> template) <|> pure (Just ctime))
@ -141,6 +140,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
<* submitButton
return $ case result of
FormSuccess sheetResult
@ -159,7 +159,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
] ]
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid ssh csh = do
getSheetListR tid ssh csh = do
muid <- maybeAuthId
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
let
@ -419,8 +419,7 @@ getSheetNewR tid ssh csh = do
{ sfName = stepTextCounterCI sheetName
, sfDescription = sheetDescription
, sfType = sheetType
, sfGrouping = sheetGrouping
, sfMarkingText = sheetMarkingText
, sfGrouping = sheetGrouping
, sfVisibleFrom = addOneWeek <$> sheetVisibleFrom
, sfActiveFrom = addOneWeek sheetActiveFrom
, sfActiveTo = addOneWeek sheetActiveTo
@ -432,6 +431,7 @@ getSheetNewR tid ssh csh = do
, sfSolutionFrom = addOneWeek <$> sheetSolutionFrom
, sfSolutionF = Nothing
, sfMarkingF = Nothing
, sfMarkingText = sheetMarkingText
}
_other -> Nothing
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
@ -454,8 +454,7 @@ getSEditR tid ssh csh shn = do
{ sfName = sheetName
, sfDescription = sheetDescription
, sfType = sheetType
, sfGrouping = sheetGrouping
, sfMarkingText = sheetMarkingText
, sfGrouping = sheetGrouping
, sfVisibleFrom = sheetVisibleFrom
, sfActiveFrom = sheetActiveFrom
, sfActiveTo = sheetActiveTo
@ -467,6 +466,7 @@ getSEditR tid ssh csh shn = do
, sfSolutionFrom = sheetSolutionFrom
, sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
, sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
, sfMarkingText = sheetMarkingText
}
let action newSheet = do
replaceRes <- myReplaceUnique sid $ newSheet

View File

@ -1,6 +1,9 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, FlexibleContexts
, MultiWayIf
, NamedFieldPuns
, TypeFamilies
#-}
module Jobs.Crontab
@ -12,6 +15,10 @@ import Import
import qualified Data.HashMap.Strict as HashMap
import Jobs.Types
import Data.Maybe (fromJust)
import qualified Data.Map as Map
import Data.Semigroup (Max(..))
import Data.Time
import Data.Time.Zones
@ -57,11 +64,43 @@ determineCrontab = execWriterT $ do
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
}
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
(JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
, cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
}
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
sheetSubmissions <- lift $ collateSubmissions <$>
selectList [SubmissionRatingBy !=. Nothing, SubmissionSheet ==. nSheet] []
tell $ flip Map.foldMapWithKey sheetSubmissions $
\nUser (Max mbTime) -> if
| Just time <- mbTime -> HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } )
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay time
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
| otherwise -> mempty
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
-- | Partial function: Submission must not have Nothing at ratingBy
collateSubmissions :: [Entity Submission] -> Map UserId (Max (Maybe UTCTime))
collateSubmissions = Map.fromListWith (<>) . fmap procCorrector
where
procCorrector :: Entity Submission -> (UserId , (Max (Maybe UTCTime)))
procCorrector = (,) <$> fromJust . submissionRatingBy . entityVal
<*> Max . submissionRatingAssigned . entityVal

View File

@ -36,12 +36,18 @@ determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from
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
determineNotificationCandidates NotificationSheetSoonInactive{..} = 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` lecturer `E.InnerJoin` sheet) -> do
E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationCorrectionsAssigned{..} = selectList [UserId ==. nUser] []
classifyNotification :: Notification -> DB NotificationTrigger
classifyNotification NotificationSubmissionRated{..} = do
Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission
@ -49,6 +55,8 @@ classifyNotification NotificationSubmissionRated{..} = do
NotGraded -> NTSubmissionRated
_other -> NTSubmissionRatedGraded
classifyNotification NotificationSheetActive{} = return NTSheetActive
classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive
classifyNotification NotificationSheetInactive{} = return NTSheetInactive
classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned

View File

@ -15,6 +15,7 @@ import Jobs.Types
import Jobs.Handler.SendNotification.SubmissionRated
import Jobs.Handler.SendNotification.SheetActive
import Jobs.Handler.SendNotification.SheetInactive
import Jobs.Handler.SendNotification.CorrectionsAssigned
dispatchJobSendNotification :: UserId -> Notification -> Handler ()

View File

@ -0,0 +1,41 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, TemplateHaskell
, OverloadedStrings
#-}
module Jobs.Handler.SendNotification.CorrectionsAssigned
( dispatchNotificationCorrectionsAssigned
) where
import Import
import Utils.Lens
import Handler.Utils.Mail
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Handler ()
dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
(Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
nbrSubs <- count [ SubmissionSheet ==. nSheet
, SubmissionRatingBy ==. Just nUser
, SubmissionRatingTime ==. Nothing
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
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/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

View File

@ -6,7 +6,8 @@
#-}
module Jobs.Handler.SendNotification.SheetInactive
( dispatchNotificationSheetInactive
( dispatchNotificationSheetSoonInactive
, dispatchNotificationSheetInactive
) where
import Import
@ -17,6 +18,24 @@ import Handler.Utils.Mail
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
dispatchNotificationSheetSoonInactive :: SheetId -> UserId -> Handler ()
dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
setSubjectI $ MsgMailSubjectSheetSoonInactive 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/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
@ -34,3 +53,4 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
addAlternatives $ do
providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

View File

@ -24,11 +24,13 @@ 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 }
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }
| NotificationSheetSoonInactive { nSheet :: SheetId }
| NotificationSheetInactive { nSheet :: SheetId }
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Hashable Job

View File

@ -487,7 +487,9 @@ derivePersistFieldJSON ''Value
data NotificationTrigger = NTSubmissionRatedGraded
| NTSubmissionRated
| NTSheetActive
| NTSheetSoonInactive
| NTSheetInactive
| NTCorrectionsAssigned
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe NotificationTrigger
@ -515,7 +517,9 @@ instance Default NotificationSettings where
NTSubmissionRatedGraded -> True
NTSubmissionRated -> False
NTSheetActive -> True
NTSheetInactive -> False
NTSheetSoonInactive -> False
NTSheetInactive -> True
NTCorrectionsAssigned -> True
instance ToJSON NotificationSettings where
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF

View File

@ -89,6 +89,8 @@ data AppSettings = AppSettings
, appJobCronInterval :: NominalDiffTime
, appJobStaleThreshold :: NominalDiffTime
, appNotificationRateLimit :: NominalDiffTime
, appNotificationCollateDelay :: NominalDiffTime
, appNotificationExpiration :: NominalDiffTime
, appInitialLogSettings :: LogSettings
@ -293,6 +295,8 @@ instance FromJSON AppSettings where
appJobCronInterval <- o .: "job-cron-interval"
appJobStaleThreshold <- o .: "job-stale-threshold"
appNotificationRateLimit <- o .: "notification-rate-limit"
appNotificationCollateDelay <- o .: "notification-collate-delay"
appNotificationExpiration <- o .: "notification-expiration"
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
appMutableStatic <- o .:? "mutable-static" .!= defaultDev

View File

@ -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>
_{MsgMailCorrectionsAssignedIntro (CI.original courseName) termDesc sheetName nbrSubs}
<p>
<a href=@{CorrectionsR}>
_{MsgCorrectionsTitle}

View File

@ -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>
_{MsgMailSheetSoonInactiveIntro (CI.original courseName) termDesc sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn SShowR}>
#{sheetName}

View File

@ -5,12 +5,6 @@ $maybe descr <- sheetDescription sheet
<p>
#{descr}
$maybe marking <- sheetMarkingText sheet
<section>
<h2>_{MsgSheetMarking}
<p>
#{marking}
<section>
<dl .deflist>
<dt .deflist__dt>_{MsgSheetActiveFrom}