From c1eb5588717f2a02df2348375e62bc98e385296b Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Wed, 5 Aug 2020 21:08:02 +0200 Subject: [PATCH] refactor(course-visibility): major course-util refactor - refactor Utils.Course and usages - check for open allocation registration in courseIsVisible - remove isAssociated from favourites (not needed anymore) --- src/Foundation.hs | 36 +++--- src/Handler/Allocation/List.hs | 20 +--- src/Handler/Allocation/Show.hs | 16 +-- src/Handler/Course/List.hs | 4 +- src/Handler/Course/Show.hs | 15 +-- src/Handler/Term.hs | 4 +- src/Utils/Course.hs | 127 +++++++++++++++------ templates/course.hamlet | 6 +- templates/widgets/asidenav/asidenav.hamlet | 4 +- 9 files changed, 135 insertions(+), 97 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 4912f7e01..4aa5a3e9c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -74,7 +74,7 @@ import Handler.Utils.ExamOffice.Course import Handler.Utils.Profile import Handler.Utils.Routes import Handler.Utils.Memcached -import Utils.Course (courseIsVisible') +import Utils.Course (courseIsVisible) import Utils.Form import Utils.Sheet import Utils.SystemMessage @@ -987,10 +987,14 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid (cid,) <$> MaybeT (get allocationCourseAllocation) tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do + CourseR tid ssh csh _ -> exceptT return return $ do now <- liftIO getCurrentTime - Entity _cid course <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh - guard $ courseIsVisible' now course + courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do + 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.&&. courseIsVisible now course Nothing + guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) return Authorized r -> $unsupportedAuthPredicate AuthCourseTime r tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of @@ -2023,6 +2027,7 @@ siteLayout' headingOverride widget = do E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor + courseVisible = courseIsVisible now course Nothing reason = E.case_ [ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent @@ -2031,16 +2036,13 @@ siteLayout' headingOverride widget = do E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent - return (course, reason, isAssociated) + return (course, reason, courseVisible) - favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, isAssociated) -> do + favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR - return (course, reason, isAssociated, mayEdit) + return (course, reason, courseVisible, mayEdit) - -- remove invisible courses - let favCourses = favCourses' - & filter (\(Entity _ Course{..}, _, E.Value isAssociated, mayEdit) -> mayEdit || isAssociated || NTop courseVisibleFrom <= NTop (Just now) && NTop (Just now) <= NTop courseVisibleTo) - & map (\(course, reason, _, mayEdit) -> (course, reason, mayEdit)) + let favCourses = favCourses' & filter (\(_, _, courseVisible, _) -> courseVisible) return ( favCourses , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid @@ -2048,9 +2050,9 @@ siteLayout' headingOverride widget = do ) let favouriteTerms :: [TermIdentifier] - favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites' + favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites' - favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, mayEdit) + favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, mayEdit, courseVisible) -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR favouriteReason = fromMaybe FavouriteCurrent mFavourite in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do @@ -2072,7 +2074,7 @@ siteLayout' headingOverride widget = do $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." return items $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items) - return (c, courseRoute, items, favouriteReason, mayEdit) + return (c, courseRoute, items, favouriteReason, mayEdit, courseVisible) nav'' <- mconcat <$> sequence [ defaultLinks @@ -2104,10 +2106,10 @@ siteLayout' headingOverride widget = do navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs highlightNav = (||) <$> navForceActive <*> highlight - favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool)] + favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool)] favouriteTermReason tid favReason' = favourites - & filter (\(Course{..}, _, _, favReason, _) -> unTermKey courseTerm == tid && favReason == favReason') - & sortOn (\(Course{..}, _, _, _, _) -> courseName) + & filter (\(Course{..}, _, _, favReason, _, _) -> unTermKey courseTerm == tid && favReason == favReason') + & sortOn (\(Course{..}, _, _, _, _, _) -> courseName) -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index 497879edd..cc19d1968 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -6,7 +6,7 @@ module Handler.Allocation.List import Import -import Utils.Course (mayViewCourse') +import Utils.Course (mayViewCourse) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -33,22 +33,8 @@ countCourses muid ata now addWhere allocation = E.subSelectCount . E.from $ \all E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId E.&&. E.exists (E.from $ \course -> E.where_ $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse - E.&&. (mayViewCourse' muid ata now course - E.||. E.exists (E.from $ \courseApplication -> E.where_ $ - courseApplication E.^. CourseApplicationCourse E.==. course E.^. CourseId - E.&&. E.just (courseApplication E.^. CourseApplicationUser) E.==. E.val muid - E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId) - ) - E.||. (E.isJust (allocation E.^. AllocationRegisterFrom) - E.&&. allocation E.^. AllocationRegisterFrom E.<=. E.val (Just now) - E.&&. E.maybe - (E.val True) - (\registerTo -> E.val now E.<=. registerTo) - (allocation E.^. AllocationRegisterTo) - ) - ) - ) - E.&&. addWhere allocationCourse + E.&&. mayViewCourse muid ata now course (Just (allocation E.^. AllocationId)) + ) E.&&. addWhere allocationCourse queryAvailable :: Maybe UserId -> AuthTagActive -> UTCTime -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 79bb19110..cb36c0ac5 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -30,6 +30,8 @@ getAShowR tid ssh ash = do resultHasTemplate = _3 . _Value resultIsRegistered :: Simple Field4 a (E.Value Bool) => Lens' a Bool resultIsRegistered = _4 . _Value + resultCourseVisible :: Simple Field5 a (E.Value Bool) => Lens' a Bool + resultCourseVisible = _5 . _Value (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do alloc@(Entity aId Allocation{allocationSchool,allocationRegisterFrom,allocationRegisterTo}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash @@ -44,7 +46,7 @@ getAShowR tid ssh ash = do E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId - E.&&. (mayViewCourse' muid ata now course + E.&&. (mayViewCourse muid ata now course (Just $ E.val aId) E.||. E.isJust (courseApplication E.?. CourseApplicationId) E.||. (E.isJust (E.val allocationRegisterFrom) E.&&. E.val allocationRegisterFrom E.<=. E.val (Just now) @@ -56,7 +58,7 @@ getAShowR tid ssh ash = do E.orderBy [E.asc $ course E.^. CourseName] let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId - return (course, courseApplication, hasTemplate, E.not_ . E.isNothing $ registration E.?. CourseParticipantId) + return (course, courseApplication, hasTemplate, E.not_ . E.isNothing $ registration E.?. CourseParticipantId, courseIsVisible now course (Just (E.val aId))) registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId @@ -87,11 +89,11 @@ getAShowR tid ssh ash = do setTitleI shortTitle let courseWidgets = flip map courses $ \cEntry -> do - let Entity cid c@Course{..} = cEntry ^. resultCourse - hasApplicationTemplate = cEntry ^. resultHasTemplate - mApp = cEntry ^? resultCourseApplication - isRegistered = cEntry ^. resultIsRegistered - courseVisible = courseIsVisible' now c + let Entity cid Course{..} = cEntry ^. resultCourse + hasApplicationTemplate = cEntry ^. resultHasTemplate + mApp = cEntry ^? resultCourseApplication + isRegistered = cEntry ^. resultIsRegistered + courseVisible = cEntry ^. resultCourseVisible cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index c7a1bf551..a996fc3e5 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -76,14 +76,14 @@ makeCourseTable whereClause colChoices psValidator = do E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId let participants = course2Participants qin let registered = course2Registered muid ata qin - let mayView = mayViewCourse' muid ata now course + let mayView = mayViewCourse muid ata now course Nothing E.where_ $ whereClause (course, participants, registered, mayView) return (course, participants, registered, school) 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 - isEditorQuery course user = E.where_ $ mayEditCourse muid ata course + isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course E.&&. E.just (user E.^. UserId) E.==. E.val muid dbtProj :: DBRow _ -> DB CourseTableData dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 57c7e3b80..a9f618015 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -27,8 +27,9 @@ import Handler.Exam.List (mkExamTable) getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup) <- runDB . maybeT notFound $ do - [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] + now <- liftIO getCurrentTime + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup) <- 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 @@ -43,7 +44,7 @@ getCShowR tid ssh csh = do 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,school E.^. SchoolName, numParticipants, participant) + return (course, courseIsVisible now course Nothing, 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 @@ -105,7 +106,7 @@ getCShowR tid ssh csh = do return $ submissionGroup E.^. SubmissionGroupName let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup' - return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup) + return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) mDereg' @@ -211,8 +212,6 @@ getCShowR tid ssh csh = do (Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course - now <- liftIO getCurrentTime - let visibleNews = any (view _3) news showNewsFiles fs = and [ not $ null fs @@ -220,9 +219,7 @@ getCShowR tid ssh csh = do , all (notElem pathSeparator . view _2) fs ] hiddenEventNotes = all (\(_,CourseEvent{..}) -> is _Nothing courseEventNote) events - courseVisFrom = courseVisibleFrom course - courseVisTo = courseVisibleTo course - courseVisible = courseIsVisible' now course + 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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index e8843d17a..e77c7a3c1 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -6,7 +6,7 @@ module Handler.Term import Import -import Utils.Course (mayViewCourse') +import Utils.Course (mayViewCourse) import Handler.Utils @@ -74,7 +74,7 @@ getTermShowR = do where dbtSQLQuery term = return (term, courseCount) where courseCount = E.subSelectCount . E.from $ \course -> E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm - E.&&. mayViewCourse' muid ata now course + E.&&. mayViewCourse muid ata now course Nothing dbtRowKey = (E.^. TermId) dbtProj = return . dbrOutput dbtColonnade = widgetColonnade $ mconcat diff --git a/src/Utils/Course.hs b/src/Utils/Course.hs index 18c3db230..316a10006 100644 --- a/src/Utils/Course.hs +++ b/src/Utils/Course.hs @@ -1,7 +1,11 @@ module Utils.Course ( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse' - , isCourseLecturer, isCourseTutor, isCourseCorrector, isCourseParticipant, isCourseAssociated + , isSchoolAdmin, isSchoolAdminLike + , isCourseLecturer, isCourseTutor, isCourseCorrector + , isCourseParticipant, isCourseApplicant + , isCourseAssociated , courseIsVisible, courseIsVisible' + , courseAllocationRegistrationOpen , numCourseParticipants ) where @@ -11,35 +15,56 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> Entity Course -> E.SqlExpr (E.Value Bool) -mayViewCourse muid ata now c@(Entity cid course) = - mayEditCourse muid ata c - E.||. isCourseAssociated muid ata (E.val cid) - E.||. E.val (courseIsVisible' now course) +mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +mayViewCourse muid ata now course maid = + isSchoolAdminLike muid ata (course E.^. CourseSchool) + E.||. mayEditCourse muid ata course + E.||. isCourseAssociated muid ata (course E.^. CourseId) maid + E.||. courseIsVisible now course maid -mayViewCourse' :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) -mayViewCourse' muid ata now course = - mayEditCourse' muid ata course - E.||. isCourseAssociated muid ata (course E.^. CourseId) - E.||. courseIsVisible now course +mayViewCourse' :: Maybe UserId -> AuthTagActive -> UTCTime -> Entity Course -> Maybe AllocationId -> E.SqlExpr (E.Value Bool) +mayViewCourse' muid ata now c@(Entity cid Course{courseSchool}) maid = + isSchoolAdminLike muid ata (E.val courseSchool) + E.||. mayEditCourse' muid ata c + E.||. isCourseAssociated muid ata (E.val cid) (E.val <$> maid) + E.||. courseIsVisible' now c maid -mayEditCourse :: Maybe UserId -> AuthTagActive -> Entity Course -> E.SqlExpr (E.Value Bool) -mayEditCourse muid ata@AuthTagActive{..} (Entity cid Course{..}) = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do + +mayEditCourse :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +mayEditCourse muid ata course = + isSchoolAdmin muid ata (course E.^. CourseSchool) + E.||. isCourseLecturer muid ata (course E.^. CourseId) + +mayEditCourse' :: Maybe UserId -> AuthTagActive -> Entity Course -> E.SqlExpr (E.Value Bool) +mayEditCourse' muid ata (Entity cid Course{..}) = + isSchoolAdmin muid ata (E.val courseSchool) + E.||. isCourseLecturer muid ata (E.val cid) + + +isSchoolAdmin :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value SchoolId) -> E.SqlExpr (E.Value Bool) +isSchoolAdmin muid AuthTagActive{..} ssh = E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do + E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser + E.where_ $ E.just (user E.^. UserId) E.==. E.val muid + E.&&. userFunction E.^. UserFunctionSchool E.==. ssh + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin + E.&&. E.val (authTagIsActive AuthAdmin) + +-- TODO: find better name +isSchoolAdminLike :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value SchoolId) -> E.SqlExpr (E.Value Bool) +isSchoolAdminLike muid ata@AuthTagActive{..} ssh = + isSchoolAdmin muid ata ssh + E.||. (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser E.where_ $ E.just (user E.^. UserId) E.==. E.val muid - E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin - E.&&. userFunction E.^. UserFunctionSchool E.==. E.val courseSchool - E.&&. E.val (authTagIsActive AuthAdmin) - ) E.||. isCourseLecturer muid ata (E.val cid) - -mayEditCourse' :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) -mayEditCourse' muid ata@AuthTagActive{..} course = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do - E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser - E.where_ $ E.just (user E.^. UserId) E.==. E.val muid - E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin - E.&&. userFunction E.^. UserFunctionSchool E.==. course E.^. CourseSchool - E.&&. E.val (authTagIsActive AuthAdmin) - ) E.||. isCourseLecturer muid ata (course E.^. CourseId) + E.&&. userFunction E.^. UserFunctionSchool E.==. ssh + E.&&. ( (userFunction E.^. UserFunctionFunction E.==. E.val SchoolEvaluation + E.&&. E.val (authTagIsActive AuthEvaluation)) + E.||. (userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice + E.&&. E.val (authTagIsActive AuthExamOffice)) + E.||. (userFunction E.^. UserFunctionFunction E.==. E.val SchoolAllocation + E.&&. E.val (authTagIsActive AuthAllocationAdmin)) + ) + ) isCourseLecturer :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) isCourseLecturer muid AuthTagActive{..} cid = E.exists . E.from $ \(user `E.InnerJoin` lecturer) -> do @@ -69,26 +94,52 @@ isCourseParticipant muid AuthTagActive{..} cid = E.exists . E.from $ \coursePart E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.&&. E.val (authTagIsActive AuthCourseRegistered) -- TODO is this the auth tag I want here? -isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) -isCourseAssociated muid ata cid = +isCourseApplicant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +isCourseApplicant muid AuthTagActive{..} cid maid = E.exists . E.from $ \courseApplication -> E.where_ $ + E.just (courseApplication E.^. CourseApplicationUser) E.==. E.val muid + E.&&. courseApplication E.^. CourseApplicationCourse E.==. cid + E.&&. E.val (authTagIsActive AuthApplicant) + E.&&. maybe (E.val True) + (\aid -> E.just aid E.==. courseApplication E.^. CourseApplicationAllocation) + maid + +isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +isCourseAssociated muid ata cid maid = isCourseLecturer muid ata cid E.||. isCourseTutor muid ata cid E.||. isCourseCorrector muid ata cid E.||. isCourseParticipant muid ata cid + E.||. isCourseApplicant muid ata cid maid -courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) -courseIsVisible now course = - E.isJust (course E.^. CourseVisibleFrom) - E.&&. course E.^. CourseVisibleFrom E.<=. E.val (Just now) - E.&&. E.maybe - (E.val True) - (\visibleTo -> E.val now E.<=. visibleTo) - (course E.^. CourseVisibleTo) -courseIsVisible' :: UTCTime -> Course -> Bool -courseIsVisible' now Course{..} = NTop courseVisibleFrom <= now' && now' <= NTop courseVisibleTo +courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +courseIsVisible now course maid = + (E.maybe (E.val False) (\visibleFrom -> visibleFrom E.<=. E.val now) (course E.^. CourseVisibleFrom) + E.&&. E.maybe (E.val True) (\visibleTo -> E.val now E.<=. visibleTo) (course E.^. CourseVisibleTo) + ) E.||. courseAllocationRegistrationOpen now (course E.^. CourseId) maid + +courseIsVisible' :: UTCTime -> Entity Course -> Maybe AllocationId -> E.SqlExpr (E.Value Bool) +courseIsVisible' now (Entity cid Course{..}) maid = + E.val (NTop courseVisibleFrom <= now' && now' <= NTop courseVisibleTo) + E.||. courseAllocationRegistrationOpen now (E.val cid) (E.val <$> maid) where now' = NTop $ Just now + +courseAllocationRegistrationOpen :: UTCTime -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +courseAllocationRegistrationOpen now cid maid = E.exists . E.from $ \(allocationCourse `E.InnerJoin` allocation) -> do + E.on $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. cid + E.&&. E.maybe + (E.val False) + (\registerFrom -> registerFrom E.<=. E.val now) + (allocation E.^. AllocationRegisterFrom) + E.&&. E.maybe + (E.val True) + (\registerTo -> E.val now E.<=. registerTo) + (allocation E.^. AllocationRegisterTo) + E.&&. maybe (E.val True) (\aid -> aid E.==. allocation E.^. AllocationId) maid + + numCourseParticipants :: E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Int) numCourseParticipants cid = E.subSelectCount . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. cid diff --git a/templates/course.hamlet b/templates/course.hamlet index 1e18a8a48..9448eb41f 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -127,15 +127,15 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) $if mayEdit
- $if isJust courseVisFrom && isNothing courseVisTo + $if isJust courseVisibleFrom && isNothing courseVisibleTo _{MsgCourseVisibleFrom} $else _{MsgCourseVisibility} \ #{iconInvisible}

- $maybe visFrom <- courseVisFrom - ^{formatTimeRangeW SelFormatDateTime visFrom courseVisTo} + $maybe visFrom <- courseVisibleFrom + ^{formatTimeRangeW SelFormatDateTime visFrom courseVisibleTo} $nothing _{MsgCourseInvisible} diff --git a/templates/widgets/asidenav/asidenav.hamlet b/templates/widgets/asidenav/asidenav.hamlet index fcbfe4b98..3ea880cac 100644 --- a/templates/widgets/asidenav/asidenav.hamlet +++ b/templates/widgets/asidenav/asidenav.hamlet @@ -21,13 +21,13 @@ $newline never

_{favReason}