fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

NotificationSheetInactive

Browse Source
This commit is contained in:
SJost 2018-10-24 14:59:46 +02:00
parent 445ddb8ca6
commit 3b96d96838
11 changed files with 84 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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
}
}
]
}

10
messages/uniworx/de.msg
View File

@ -343,9 +343,10 @@ 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: Dia Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet.
MailSubjectSupport: Supportanfrage
SheetTypeBonus: Bonus
@ -371,7 +372,8 @@ 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
CorrCreate: Abgaben erstellen
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"

8
src/Foundation.hs
View File

@ -255,8 +255,8 @@ instance RenderMessage UniWorX NotificationTrigger where
NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded
NTSubmissionRated -> MsgNotificationTriggerSubmissionRated
NTSheetActive -> MsgNotificationTriggerSheetActive
NTSheetInactive -> MsgNotificationTriggerSheetInactive
NTSheetSoonInactive -> MsgNotificationTriggerSheetSoonInactive
NTSheetInactive -> MsgNotificationTriggerSheetInactive
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
@ -877,7 +877,7 @@ defaultLinks = -- Define the menu items of the header.
{ menuItemLabel = "Hilfe"
, menuItemIcon = Just "question"
, menuItemRoute = HelpR
, menuItemModal = False -- True -- TODO: Does not work yet, issue #212
, menuItemModal = True -- TODO: Does not work yet, issue #212
, menuItemAccessCallback' = return True
}
, NavbarRight $ MenuItem
@ -891,7 +891,7 @@ defaultLinks = -- Define the menu items of the header.
{ menuItemLabel = "Login"
, menuItemIcon = Just "sign-in-alt"
, menuItemRoute = AuthR LoginR
, menuItemModal = False -- True -- TODO: Does not work yet, issue #212
, menuItemModal = True -- TODO: Does not work yet, issue #212
, menuItemAccessCallback' = isNothing <$> maybeAuthPair
}
, NavbarSecondary $ MenuItem

18
src/Handler/Sheet.hs
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

9
src/Jobs/Crontab.hs
View File

@ -54,10 +54,17 @@ determineCrontab = execWriterT $ do
, cronRateLimit = appNotificationRateLimit
}
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
(JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
}
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
}
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs

11
src/Jobs/Handler/QueueNotification.hs
View File

@ -36,12 +36,17 @@ 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
classifyNotification :: Notification -> DB NotificationTrigger
classifyNotification NotificationSubmissionRated{..} = do
Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission
@ -49,6 +54,8 @@ classifyNotification NotificationSubmissionRated{..} = do
NotGraded -> NTSubmissionRated
_other -> NTSubmissionRatedGraded
classifyNotification NotificationSheetActive{} = return NTSheetActive
classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive
classifyNotification NotificationSheetInactive{} = return NTSheetInactive

22
src/Jobs/Handler/SendNotification/SheetInactive.hs
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))

3
src/Jobs/Types.hs
View File

@ -24,10 +24,11 @@ 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 }
deriving (Eq, Ord, Show, Read, Generic, Typeable)

4
src/Model/Types.hs
View File

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

17
templates/mail/sheetSoonInactive.hamlet Normal file
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}

6
templates/sheetShow.hamlet
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}