fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(course-visibility): major course-util refactor

Browse Source 
- refactor Utils.Course and usages
- check for open allocation registration in courseIsVisible
- remove isAssociated from favourites (not needed anymore)
This commit is contained in:
Sarah Vaupel 2020-08-05 21:08:02 +02:00
parent 06c4e0c2c3
commit c1eb558871
9 changed files with 135 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
src/Foundation.hs
View File

@ -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

20
src/Handler/Allocation/List.hs
View File

@ -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))

16
src/Handler/Allocation/Show.hs
View File

@ -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

4
src/Handler/Course/List.hs
View File

@ -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

15
src/Handler/Course/Show.hs
View File

@ -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

4
src/Handler/Term.hs
View File

@ -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

127
src/Utils/Course.hs
View File

@ -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

6
templates/course.hamlet
View File

@ -127,15 +127,15 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
$if mayEdit
<dt .deflist__dt>
$if isJust courseVisFrom && isNothing courseVisTo
$if isJust courseVisibleFrom && isNothing courseVisibleTo
_{MsgCourseVisibleFrom}
$else
_{MsgCourseVisibility}
\ #{iconInvisible}
<dd .deflist__dd>
<p>
$maybe visFrom <- courseVisFrom
^{formatTimeRangeW SelFormatDateTime visFrom courseVisTo}
$maybe visFrom <- courseVisibleFrom
^{formatTimeRangeW SelFormatDateTime visFrom courseVisibleTo}
$nothing
_{MsgCourseInvisible}

4
templates/widgets/asidenav/asidenav.hamlet
View File

@ -21,13 +21,13 @@ $newline never
<h3 .asidenav__box-subtitle>
_{favReason}
<ul .asidenav__list.list--iconless>
$forall (course@Course{courseShorthand, courseName}, courseRoute, mPageActions, _, mayEdit) <- favouriteTermReason tid favReason
$forall (Course{courseShorthand, courseName}, courseRoute, mPageActions, _, mayEdit, isVisible) <- favouriteTermReason tid favReason
<li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
<a .asidenav__link-wrapper href=@{courseRoute}>
<div .asidenav__link-shorthand>#{courseShorthand}
<div .asidenav__link-label>
#{courseName}
$if mayEdit && not (courseIsVisible' now course)
$if mayEdit && not isVisible
\ #{iconInvisible}
<div .asidenav__nested-list-wrapper>
$maybe pageActions <- mPageActions