-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Course.Show ( getCShowR ) where import Import import Utils.Course import Utils.Form import Handler.Utils import Handler.Utils.Course import Handler.Utils.Tutorial import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Handler.Course.Register import Handler.Exam.List (mkExamTable) getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId now <- liftIO getCurrentTime (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,administrators,correctors,tutors,news,events,submissionGroup,_mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial),courseQualifications) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser E.&&. participant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh E.limit 1 -- we know that there is at most one match, but we tell the DB this info too let numParticipants :: E.SqlExpr (E.Value Int) numParticipants = E.subSelectCount . E.from $ \part -> E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. part E.^. CourseParticipantState E.==. E.val CourseParticipantActive return ( course , courseIsVisible now course , school E.^. SchoolName , numParticipants , participant ) staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] return ( lecturer E.^. LecturerType , user E.^. UserDisplayEmail, user E.^. UserDisplayName, user E.^. UserSurname) let (administrators', regularStaff) = partition ((==) CourseAdministrator . view _1) $ map (\(E.Value lecType, E.Value lecName, E.Value lecSurn, E.Value lecMail) -> (lecType,(lecName,lecSurn,lecMail))) staff (lecturers', assistants') = partition ((==) CourseLecturer . view _1) regularStaff (administrators, lecturers, assistants) = (view _2 <$> administrators', view _2 <$> lecturers', view _2 <$> assistants') correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] return ( user E.^. UserDisplayEmail, user E.^. UserDisplayName, user E.^. UserSurname ) tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] return ( user E.^. UserDisplayEmail, user E.^. UserDisplayName, user E.^. UserSurname ) news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ] cTime <- NTop . Just <$> liftIO getCurrentTime news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews guardM . lift . lift . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR let visible = cTime >= NTop courseNewsVisibleFrom files' <- lift . lift . E.select . E.from $ \newsFile -> do E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId return (E.isNothing $ newsFile E.^. CourseNewsFileContent, newsFile E.^. CourseNewsFileTitle) let files'' = files' & over (mapped . _1) E.unValue & over (mapped . _2) E.unValue lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit mayEditNews <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR mayDelete <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl . CNewsR tid ssh csh cID $ CNFileR fPath archiveUrl <- lift . lift . toTextUrl $ CNewsR tid ssh csh cID CNArchiveR return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete, archiveUrl) events' <- fmap (sortOn $ courseEventTime . entityVal . view _1) . lift . E.select . E.from $ \courseEvent -> do E.where_ $ courseEvent E.^. CourseEventCourse E.==. E.val cid let showRoom = maybe E.false (flip showCourseEventRoom courseEvent . E.val) mbAid E.||. E.not_ (courseEvent E.^. CourseEventRoomHidden) return (courseEvent, showRoom) events <- mapM (\(Entity evId ev, E.Value showRoom) -> (, ev, showRoom) <$> encrypt evId) events' hasSubmissionGroups <- lift . E.selectExists . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup) -> do E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid submissionGroup' <- lift . for mbAid $ \uid -> fmap (listToMaybe . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup) -> do E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid return $ submissionGroup E.^. SubmissionGroupName let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup' mayReRegister <- lift . courseMayReRegister $ Entity cid course mayViewSheets <- lift . hasReadAccessTo $ CourseR tid ssh csh SheetListR sheets <- lift . E.select . E.from $ \sheet -> do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return $ sheet E.^. SheetName mayViewAnySheet <- lift . anyM sheets $ \(E.Value shn) -> hasReadAccessTo $ CSheetR tid ssh csh shn SShowR mayViewMaterials <- lift . hasReadAccessTo $ CourseR tid ssh csh MaterialListR materials <- lift . E.select . E.from $ \material -> do E.where_ $ material E.^. MaterialCourse E.==. E.val cid return $ material E.^. MaterialName mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR courseQualifications <- lift $ getCourseQualifications cid return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,administrators,correctors,tutors,news,events,submissionGroup,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), courseQualifications) mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course regForm <- if | is _Just mbAid -> do (courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course) (regWidget, regEnctype) <- generateFormPost $ renderAForm FormStandard courseRegisterForm' return $ wrapForm' regButton regWidget def { formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR , formEncoding = regEnctype , formSubmit = FormSubmit } | otherwise -> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR MsgRenderer mr <- getMsgRenderer let tutorialDBTable = DBTable{..} where resultTutorial :: Lens' (DBRow (Entity Tutorial, Bool)) (Entity Tutorial) resultTutorial = _dbrOutput . _1 resultShowRoom = _dbrOutput . _2 dbtSQLQuery tutorial = do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid let showRoom = maybe E.false (flip showTutorialRoom tutorial . E.val) mbAid E.||. E.not_ (tutorial E.^. TutorialRoomHidden) return (tutorial, showRoom) dbtRowKey = (E.^. TutorialId) dbtProj = over (_dbrOutput . _2) E.unValue <$> dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType , sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] , sortable (Just "tutors") (i18nCell MsgTableTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid return (user E.^. UserDisplayEmail, user E.^. UserDisplayName, user E.^. UserSurname) return [whamlet| $newline never
    $forall tutor <- tutTutors
  • ^{nameEmailWidget' tutor} |] , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if | res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text) , sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo , sortable (Just "deregister-until") (i18nCell MsgTableTutorialDeregisterUntil) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialDeregisterUntil , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \(view resultTutorial -> Entity tutid Tutorial{..}) -> case tutorialCapacity of Nothing -> mempty Just tutorialCapacity' -> sqlCell $ do freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select $ let numParticipants :: E.SqlExpr (E.Value Int) numParticipants = E.subSelectCount . E.from $ \participant -> E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid in return $ E.val tutorialCapacity' E.-. numParticipants return . toWidget $ tshow freeCapacity , sortable Nothing (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgTableActionsHead)) $ \(view resultTutorial -> Entity tutId Tutorial{..}) -> sqlCell $ do mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True isRegistered <- case mbAid of Nothing -> return False Just uid -> existsBy $ UniqueTutorialParticipant tutId uid if | mayRegister -> do (tutRegisterForm, tutRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered return $ wrapForm tutRegisterForm def { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR , formEncoding = tutRegisterEnctype , formSubmit = FormNoSubmit } | isRegistered -> return [whamlet|_{MsgTutorialRegistered}|] | otherwise -> return mempty ] dbtSorting = Map.fromList [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType ) , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName ) , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom ) , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo ) , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil ) , ( "tutors" , SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial return . E.min_ $ user E.^. UserSurname ) ] dbtFilter = Map.empty dbtFilterUI = const mempty dbtStyle = def dbtParams = def dbtIdent :: Text dbtIdent = "tutorials" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] tutorialDBTableValidator = def & defaultSorting [SortAscBy "type", SortDescBy "name"] (Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable (Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course let visibleNews = any (view _3) news showNewsFiles fs = and [ not $ null fs , length fs <= 3 , all (views (_1 . _2) $ notElem pathSeparator) fs ] hiddenEventNotes = all (\(_,CourseEvent{..},_) -> is _Nothing courseEventNote) events Course{courseVisibleFrom,courseVisibleTo} = course mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR let heading = [whamlet| $newline never ^{courseName course} $if not courseVisible && mayEdit \ #{iconInvisible} |] siteLayout heading $ do setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course")