-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.News where import Import hiding (maximum, minimum, minimumBy) import Handler.Utils import Handler.Utils.News import Handler.SystemMessage import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.List as C (consume, mapMaybeM) import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.Lift as C import qualified Data.HashMap.Strict as HashMap import Handler.Utils.Exam (showExamOccurrenceRoom) getNewsR :: Handler Html getNewsR = do muid <- maybeAuthId defaultLayout $ do setTitleI MsgNewsHeading newsSystemMessages when (is _Nothing muid) $ notificationWidget NotificationBroad Info $(i18nWidgetFile "pitch") case muid of Just uid -> do newsUpcomingExams uid newsUpcomingSheets uid Nothing -> $(i18nWidgetFile "unauth-news") newsSystemMessages :: Widget newsSystemMessages = do now <- liftIO getCurrentTime showHidden <- isJust <$> lookupGetParam (toPathPiece GetHidden) let tellShown smId = liftHandler $ do cID <- encrypt smId :: Handler CryptoUUIDSystemMessage tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $ HashMap.singleton cID mempty{ userSystemMessageShown = Just now } mkHideForm smId SystemMessage{..} = liftHandler $ do cID <- encrypt smId hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide (btnView, btnEnctype) <- generateFormPost . buttonForm' $ bool [BtnSystemMessageHide] [BtnSystemMessageUnhide] hidden return $ wrapForm btnView def { formSubmit = FormNoSubmit , formEncoding = btnEnctype , formAction = Just . SomeRoute $ MessageHideR cID , formAttrs = [("class", "form--inline")] } checkHidden (smId, sm@SystemMessage{..}, trans) = do hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide tell $ Any hidden return $ guardOn (not hidden || showHidden) (smId, sm, trans, hidden) (messages', Any anyHidden) <- liftHandler . runDB $ do volatileClusterConfig <- selectList [] [] runConduit . C.runWriterLC $ transPipe lift (selectKeys [] []) .| C.filterM (lift . hasReadAccessTo . MessageR <=< encrypt) .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId) .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo && all (\(k,v) -> (k,v) `elem` ((\VolatileClusterConfig{..} -> (volatileClusterConfigSetting, volatileClusterConfigValue)) . entityVal <$> volatileClusterConfig)) (Set.toList systemMessageOnVolatileClusterSettings)) .| C.mapMaybeM checkHidden .| C.iterM (\(smId, _, _, _) -> tellShown smId) .| C.mapM (\(smId, sm@SystemMessage{..}, trans, hidden) -> (sm, trans, hidden,,) <$> formatTime SelFormatDateTime (maybe id max systemMessageFrom systemMessageLastChanged) <*> mkHideForm smId sm) .| C.consume let messages = sortOn (\(SystemMessage{..}, _, _, _, _) -> (Down systemMessageManualPriority, Down $ maybe id max systemMessageFrom systemMessageLastChanged, systemMessageSeverity)) messages' hiddenUrl <- toTextUrl (NewsR, [(toPathPiece GetHidden, "")]) unless (not anyHidden && null messages) $(widgetFile "news/system-messages") newsUpcomingSheets :: UserId -> Widget newsUpcomingSheets uid = do cTime <- liftIO getCurrentTime let noActiveToCutoff = toMidnight . addGregorianDurationRollOver (scaleCalendarDiffDays (-1) calendarMonth) $ utctDay cTime let tableData :: E.LeftOuterJoin (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet))) (E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) , E.SqlExpr (E.Value SchoolId) , E.SqlExpr (E.Value CourseShorthand) , E.SqlExpr (E.Value SheetName) , E.SqlExpr (E.Value (Maybe UTCTime)) , E.SqlExpr (E.Value (Maybe SubmissionId))) tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do E.on $ submission E.?. SubmissionId E.==. subuser E.?. SubmissionUserSubmission E.&&. E.just (E.val uid) E.==. subuser E.?. SubmissionUserUser E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId) E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse let showSheetNoActiveTo = E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetActiveFrom) E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetVisibleFrom) E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetHintFrom) E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom) E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.&&. E.maybe showSheetNoActiveTo (E.>=. E.val cTime) (sheet E.^. SheetActiveTo) return ( course E.^. CourseTerm , course E.^. CourseSchool , course E.^. CourseShorthand , sheet E.^. SheetName , sheet E.^. SheetActiveTo , submission E.?. SubmissionId ) colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term) , E.Value SchoolId , E.Value CourseShorthand , E.Value SheetName , E.Value (Maybe UTCTime) , E.Value (Maybe SubmissionId) )) (DBCell Handler ()) colonnade = mconcat [ -- dbRow -- TOOD: sortable (Just "term") (textCell MsgTableTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } -> sortable (Just "term") (i18nCell MsgTableTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } -> textCell $ toMessage tid , sortable (Just "school") (i18nCell MsgTableCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } -> textCell $ toMessage ssh , sortable (Just "course") (i18nCell MsgTableCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } -> anchorCell (CourseR tid ssh csh CShowR) csh , sortable (Just "sheet") (i18nCell MsgTableSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } -> anchorCell (CSheetR tid ssh csh shn SShowR) shn , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value mDeadline, _) } -> maybe mempty (cell . formatTimeW SelFormatDateTime) mDeadline , sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } -> case mbsid of Nothing -> cell $ do let submitRoute = CSheetR tid ssh csh shn SubmissionNewR whenM (hasWriteAccessTo submitRoute) $ modal [whamlet|_{MsgSubmissionNew}|] . Left $ SomeRoute submitRoute (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR) (hasTickmark True) ] let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"] & forceFilter "may-access" (Any True) sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable { dbtSQLQuery = tableData , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId , dbtColonnade = colonnade , dbtProj = dbtProjFilteredPostId , dbtSorting = Map.fromList [ ( "term" , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm ) , ( "school" , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool ) , ( "course" , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand ) , ( "sheet" , SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName ) , ( "deadline" , SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo ) , ( "done" , SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` _ `E.LeftOuterJoin` (subm `E.InnerJoin` _)) -> E.isNothing $ subm E.?. SubmissionId ) ] , dbtFilter = mconcat [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} -> let (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) = dbrOutput :: ( E.Value (Key Term) , E.Value SchoolId , E.Value CourseShorthand , E.Value SheetName , E.Value (Maybe UTCTime) , E.Value (Maybe SubmissionId) ) in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn SShowR) :: DB Bool ] , dbtFilterUI = mempty , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = SomeMessage MsgNoUpcomingSheetDeadlines } , dbtParams = def , dbtIdent = "upcoming-sheets" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing , dbtExtraReps = [] } $(widgetFile "news/upcomingSheets") newsUpcomingExams :: UserId -> Widget newsUpcomingExams uid = do now <- liftIO getCurrentTime ((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do User {userWarningDays} <- get404 uid let fortnight = addUTCTime userWarningDays now let -- code copied and slightly adapted from Handler.Course.getCShowR: examDBTable = DBTable{..} where -- for ease of refactoring: queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) lensCourse = _1 lensExam = _2 lensRegister = _3 . _Just lensOccurrence = _4 . _Just lensShowRoom = _5 . _Value dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId) E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId) E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid) E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.where_ $ E.exists $ E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight) E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now) E.&&. E.isNothing (register E.?. ExamRegistrationId) startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight) E.&&. exam E.^. ExamStart E.>=. E.just (E.val now) E.&&. E.isJust (register E.?. ExamRegistrationId) startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight) E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now) E.&&. E.isJust (register E.?. ExamRegistrationId) earliestOccurrence = E.subSelectMaybe $ E.from $ \occ -> do E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now return $ E.min_ $ occ E.^. ExamOccurrenceStart startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId) E.&&. earliestOccurrence E.<=. E.just (E.val fortnight) -- E.&&. earliestOccurrence E.>=. E.just (E.val now) E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest let showRoom = showExamOccurrenceRoom (E.val uid) occurrence E.||. E.maybe E.false E.not_ (occurrence E.?. ExamOccurrenceRoomHidden) return (course, exam, register, occurrence, showRoom) dbtRowKey = queryExam >>> (E.^. ExamId) dbtProj = dbtProjFilteredPostId dbtColonnade = dbColonnade $ mconcat [ sortable (Just "term") (i18nCell MsgTableTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> msgCell courseTerm , sortable (Just "school") (i18nCell MsgTableCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> msgCell courseSchool , sortable (Just "course") (i18nCell MsgTableCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand) -- continue here , sortable (Just "name") (i18nCell MsgTableExamName) $ \DBRow{ dbrOutput } -> do let Entity _ Exam{..} = view lensExam dbrOutput Entity _ Course{..} = view lensCourse dbrOutput indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName , sortable (Just "register-from") (i18nCell MsgTableExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , sortable (Just "register-to") (i18nCell MsgTableExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , sortable (Just "time") (i18nCell MsgTableExamTime) $ \DBRow{ dbrOutput } -> if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput -> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd | Entity _ Exam{..} <- view lensExam dbrOutput , Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd | otherwise -> mempty {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems. Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers. , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do let Entity eId Exam{..} = view lensExam dbrOutput Entity _ Course{..} = view lensCourse dbrOutput mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True isRegistered <- existsBy $ UniqueExamRegistration eId uid if | mayRegister -> do (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered return $ wrapForm examRegisterForm def { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR , formEncoding = examRegisterEnctype , formSubmit = FormNoSubmit } | isRegistered -> return [whamlet|_{MsgNewsExamRegistered}|] | otherwise -> return mempty -} , sortable (Just "registered") (i18nCell MsgTableExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do let Entity _ Exam{..} = view lensExam dbrOutput Entity _ Course{..} = view lensCourse dbrOutput mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True let isRegistered = has lensRegister dbrOutput label = bool MsgNewsExamNotRegistered MsgNewsExamRegistered isRegistered examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl | otherwise -> return [whamlet|_{label}|] , sortable (toNothingS "occurrence") (i18nCell MsgTableExamOccurrence) $ \DBRow{ dbrOutput } -> if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput -> if | view lensShowRoom dbrOutput -> maybe (i18nCell MsgNewsExamOccurrenceRoomIsUnset) roomReferenceCell examOccurrenceRoom | otherwise -> i18nCell MsgNewsExamOccurrenceRoomIsHidden & addCellClass ("explanation" :: Text) | otherwise -> mempty ] dbtSorting = Map.fromList [ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName)) , ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm )) , ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool )) , ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand )) , ("name", SortColumn $ queryExam >>> (E.^. ExamName )) , ("time", SortColumn $ queryExam >>> (E.^. ExamStart )) , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom )) , ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo )) , ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom )) , ("registered", SortColumn $ queryExam >>> (\exam -> E.exists $ E.from $ \registration -> do E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId )) ] dbtFilter = mconcat [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} -> let Entity _ Exam{..} = view lensExam dbrOutput Entity _ Course{..} = view lensCourse dbrOutput in (==b) <$> hasReadAccessTo (CExamR courseTerm courseSchool courseShorthand examName EShowR) :: DB Bool ] dbtFilterUI = const mempty dbtStyle = def dbtParams = def dbtIdent :: Text dbtIdent = "exams" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] examDBTableValidator = def & defaultSorting [SortAscBy "time"] & forceFilter "may-access" (Any True) (, userWarningDays) <$> dbTable examDBTableValidator examDBTable $(widgetFile "news/upcomingExams")