module Handler.News where import Import import Handler.Utils import Handler.Utils.News import Handler.SystemMessage import qualified Data.Map as Map import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto 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 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 . runConduit . C.runWriterLC $ transPipe lift (selectKeys [] []) .| C.filterM (hasReadAccessTo . MessageR <=< encrypt) .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId) .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo) .| 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 $ 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 MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } -> sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } -> textCell $ toMessage tid , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } -> textCell $ toMessage ssh , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } -> anchorCell (CourseR tid ssh csh CShowR) csh , sortable (Just "sheet") (i18nCell MsgSheet) $ \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|_{MsgMenuSubmissionNew}|] . 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 = return , 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" . FilterProjected $ \(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 = MsgNoUpcomingSheetDeadlines } , dbtParams = def , dbtIdent = "upcoming-sheets" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing } $(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 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 return (course, exam, register, occurrence) dbtRowKey = queryExam >>> (E.^. ExamId) dbtProj = return dbtColonnade = dbColonnade $ mconcat [ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> msgCell courseTerm , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> msgCell courseSchool , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand) -- continue here , sortable (Just "name") (i18nCell MsgExamName) $ \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 MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , sortable (Just "time") (i18nCell MsgExamTime) $ \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|_{MsgExamRegistered}|] | otherwise -> return mempty -} , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \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 MsgExamNotRegistered MsgExamRegistered isRegistered examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl | otherwise -> return [whamlet|_{label}|] , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } -> if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput -> textCell examOccurrenceRoom | 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" . FilterProjected $ \(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 examDBTableValidator = def & defaultSorting [SortAscBy "time"] & forceFilter "may-access" (Any True) (, userWarningDays) <$> dbTable examDBTableValidator examDBTable $(widgetFile "news/upcomingExams")