-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.Course.List ( makeCourseTable , getCourseListR , getTermCurrentR , getTermSchoolCourseListR , getTermCourseListR ) where import Import import Data.Maybe (fromJust) import Utils.Course import Utils.Form import Handler.Utils hiding (colSchoolShort) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E type CourseTableData = DBRow ( Entity Course , Bool -- isRegistered , Entity School , [Entity User] , Bool -- mayEditCourse ) resultCourse :: Lens' CourseTableData (Entity Course) resultCourse = _dbrOutput . _1 resultSchool :: Lens' CourseTableData (Entity School) resultSchool = _dbrOutput . _3 resultIsRegistered :: Lens' CourseTableData Bool resultIsRegistered = _dbrOutput . _2 resultLecturers :: Traversal' CourseTableData (Entity User) resultLecturers = _dbrOutput . _4 . traverse resultMayEditCourse :: Lens' CourseTableData Bool resultMayEditCourse = _dbrOutput . _5 type CourseTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)) queryCourse :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity Course)) queryCourse = to $(E.sqlIJproj 2 1) querySchool :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity School)) querySchool = to $(E.sqlIJproj 2 2) queryParticipants :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Int)) queryParticipants = queryCourse . to (E.^. CourseId) . to numCourseParticipants queryIsRegistered :: Maybe UserId -> AuthTagActive -> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool)) queryIsRegistered muid ata = queryCourse . to (E.^. CourseId) . to (isCourseParticipant muid ata) queryMayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -- ^ @now@ -> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool)) queryMayViewCourse muid ata now = to . runReader $ do course <- view queryCourse return $ mayViewCourse muid ata now course queryIsEditor :: Maybe UserId -> AuthTagActive -> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool)) queryIsEditor muid ata = queryCourse . to (mayEditCourse muid ata) colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view resultCourse -> Entity _ Course{..}) -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseName}|] colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colDescription = sortable Nothing mempty $ \(view resultCourse -> Entity _ Course{..}) -> maybeCell courseDescription modalCell colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCShort = sortable (Just "cshort") (i18nCell MsgFilterCourseShort) $ \(view resultCourse -> Entity _ Course{..}) -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|] colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgFilterTerm) $ \(view resultCourse -> Entity _ Course{..}) -> anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|] colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgFilterCourseSchoolShort) $ \res -> let Entity _ Course{..} = res ^. resultCourse Entity _ School{..} = res ^. resultSchool in anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|] colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered tickmarkCell makeCourseTable :: (ToSortable h, Functor h) => Colonnade h CourseTableData (DBCell Handler ()) -> PSValidator Handler () -> DB Widget makeCourseTable colChoices psValidator' = do let psValidator = psValidator' & forceFilter "may-read" (Any True) muid <- lift maybeAuthId now <- liftIO getCurrentTime ata <- getSessionActiveAuthTags let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _ dbtSQLQuery = runReaderT $ do course <- view queryCourse school <- view querySchool lift . E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId registered <- view $ queryIsRegistered muid ata isEditor <- view $ queryIsEditor muid ata return (course, registered, school, isEditor) lecturerQuery cid (user `E.InnerJoin` lecturer) = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer return user isCourseAdminQuery cid (user `E.InnerJoin` lecturer) = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ cid E.==. lecturer E.^. LecturerCourse return user dbtProj :: _ CourseTableData dbtProj = dbtProjSimple $ \(course, E.Value registered, school, E.Value isEditor) -> do lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course return (course, registered, school, lecturerList, isEditor) dbTableWidget' psValidator DBTable { dbtSQLQuery , dbtRowKey = views queryCourse (E.^. CourseId) , dbtColonnade = colChoices , dbtProj , dbtSorting = mconcat [ singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseName) , singletonMap "cshort" . SortColumn $ views queryCourse (E.^. CourseShorthand) , singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm) , singletonMap "school" . SortColumn $ views querySchool (E.^. SchoolName) , singletonMap "schoolshort" . SortColumn $ views querySchool (E.^. SchoolShorthand) , singletonMap "register-from" . SortColumn $ views queryCourse (E.^. CourseRegisterFrom) , singletonMap "register-to" . SortColumn $ views queryCourse (E.^. CourseRegisterTo) , singletonMap "members" . SortColumn $ view queryParticipants , singletonMap "registered" . SortColumn . view $ queryIsRegistered muid ata ] , dbtFilter = mconcat [ singletonMap "may-read" . FilterColumn $ \t (Any b) -> views (queryMayViewCourse muid ata now) (E.==. E.val b) t , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseName) , singletonMap "cshort" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand) , singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm) , singletonMap "school" . FilterColumn . E.mkExactFilter $ views querySchool (E.^. SchoolName) , singletonMap "schoolshort" . FilterColumn . E.mkExactFilter $ views querySchool (E.^. SchoolShorthand) , singletonMap "lecturer" . FilterColumn . E.mkExistsFilter $ \t (c :: Text) -> E.from $ \t' -> do user <- isCourseAdminQuery (view queryCourse t E.^. CourseId) t' E.where_ $ user E.^. UserDisplayName `E.hasInfix` E.val c , singletonMap "openregistration" . FilterColumn . E.mkExactFilterLast . runReader $ do course <- view queryCourse let regTo = course E.^. CourseRegisterTo regFrom = course E.^. CourseRegisterFrom courseOpen = E.maybe E.false (\f -> f E.<=. E.val now) regFrom E.&&. E.maybe E.true (\t -> E.val now E.<=. t) regTo return courseOpen , singletonMap "registered" . FilterColumn . E.mkExactFilterLast . view $ queryIsRegistered muid ata , singletonMap "search" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.maybe (E.val mempty) (E.castString . esqueletoMarkupOutput) (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) , singletonMap "search-shorthand" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) , singletonMap "search-title" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes [ pure $ prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm) , pure $ prismAForm (singletonFilter "schoolshort" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool) , pure $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer) , pure $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgFilterCourseSearch) , pure $ prismAForm (singletonFilter "search-shorthand") mPrev $ aopt textField (fslI MsgFilterCourseSearchShorthand) , pure $ prismAForm (singletonFilter "search-title") mPrev $ aopt textField (fslI MsgFilterCourseSearchTitle) , pure $ prismAForm (singletonFilter "openregistration" . maybePrism _PathPiece) mPrev $ fmap (\x -> if isJust x && not (fromJust x) then Nothing else x) . aopt checkBoxField (fslI MsgFilterCourseRegisterOpen) , guardOn (is _Just muid) $ prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterCourseRegistered)) ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout , dbsTemplate = DBSTCourse resultCourse resultLecturers resultIsRegistered resultSchool resultMayEditCourse } , dbtParams = def , dbtIdent = "courses" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing , dbtExtraReps = [] } getCourseListR :: Handler Html getCourseListR = do muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat [ colCourse -- colCourseDescr , colDescription , colSchoolShort , colTerm , colCShort , maybe mempty (const colRegistered) muid ] validator = def & defaultSorting [SortDescBy "term",SortAscBy "course"] coursesTable <- runDB $ makeCourseTable colonnade validator defaultLayout $ do setTitleI MsgCourseListTitle $(widgetFile "courses") getTermCurrentR :: Handler Html getTermCurrentR = maybeT notFound $ do currentTerm <- MaybeT $ runDB getCurrentTerm redirect (CourseListR, [("courses-term", toPathPiece currentTerm)]) getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html getTermSchoolCourseListR tid ssh = redirect (CourseListR, [("courses-term", toPathPiece tid), ("courses-schoolshort", toPathPiece ssh)]) getTermCourseListR :: TermId -> Handler Html getTermCourseListR tid = redirect (CourseListR, [("courses-term", toPathPiece tid)])