From aa34d6636752efef8eb48e842ada4da7a8b6806f Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 22 Oct 2018 21:23:53 +0200 Subject: [PATCH 1/5] minor --- README.md | 4 ++++ src/Foundation.hs | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index be734df7b..e6b42fe4f 100644 --- a/README.md +++ b/README.md @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index e4233c5ed..29869d78a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -860,7 +860,7 @@ defaultLinks = -- Define the menu items of the header. { menuItemLabel = "Hilfe" , menuItemIcon = Just "question" , menuItemRoute = HelpR - , menuItemModal = True -- TODO: Does not work yet, issue #212 + , menuItemModal = False -- True -- TODO: Does not work yet, issue #212 , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem @@ -874,7 +874,7 @@ defaultLinks = -- Define the menu items of the header. { menuItemLabel = "Login" , menuItemIcon = Just "sign-in-alt" , menuItemRoute = AuthR LoginR - , menuItemModal = True -- TODO: Does not work yet, issue #212 + , menuItemModal = False -- True -- TODO: Does not work yet, issue #212 , menuItemAccessCallback' = isNothing <$> maybeAuthPair } , NavbarSecondary $ MenuItem From 445ddb8ca67a0defbd72b48a3169bead9d983e74 Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 22 Oct 2018 21:41:39 +0200 Subject: [PATCH 2/5] minor --- messages/uniworx/de.msg | 1 + src/Handler/Home.hs | 4 +++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 0d3bea8b7..2c30a1c50 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -399,6 +399,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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 3ba5bab0a..c0660967a 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -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) -} From 3b96d96838df20ea2ea897d31fc8dc2d33bd466e Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 24 Oct 2018 14:59:46 +0200 Subject: [PATCH 3/5] NotificationSheetInactive --- .vscode/tasks.json | 6 ++++- messages/uniworx/de.msg | 10 +++++---- src/Foundation.hs | 8 +++---- src/Handler/Sheet.hs | 18 +++++++-------- src/Jobs/Crontab.hs | 9 +++++++- src/Jobs/Handler/QueueNotification.hs | 11 ++++++++-- .../Handler/SendNotification/SheetInactive.hs | 22 ++++++++++++++++++- src/Jobs/Types.hs | 3 ++- src/Model/Types.hs | 4 +++- templates/mail/sheetSoonInactive.hamlet | 17 ++++++++++++++ templates/sheetShow.hamlet | 6 ----- 11 files changed, 84 insertions(+), 30 deletions(-) create mode 100644 templates/mail/sheetSoonInactive.hamlet diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 6c2838596..c5f9eaf8e 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -6,7 +6,11 @@ { "label": "echo", "type": "shell", - "command": "echo Hello" + "command": "echo Hello", + "group": { + "kind": "build", + "isDefault": true + } } ] } \ No newline at end of file diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2c30a1c50..a3cb7f570 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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}" diff --git a/src/Foundation.hs b/src/Foundation.hs index b625042b6..d0a98d10c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index d59de841d..e001b3a84 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 955c09ee4..0610e459b 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -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 diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 1767f7133..e37859e70 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -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 + diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs index 5caf09e0a..16f865167 100644 --- a/src/Jobs/Handler/SendNotification/SheetInactive.hs +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -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)) + \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 4d3bbb85f..c80ee9ecf 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b7b4fc76a..9ba9a8e43 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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 diff --git a/templates/mail/sheetSoonInactive.hamlet b/templates/mail/sheetSoonInactive.hamlet new file mode 100644 index 000000000..a198fd65c --- /dev/null +++ b/templates/mail/sheetSoonInactive.hamlet @@ -0,0 +1,17 @@ +$newline never +\ + + + +