fraport/fradrive-old
Archived
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.Profile
import Handler.Utils.Routes import Handler.Utils.Routes
import Handler.Utils.Memcached import Handler.Utils.Memcached
import Utils.Course (courseIsVisible') import Utils.Course (courseIsVisible)
import Utils.Form import Utils.Form
import Utils.Sheet import Utils.Sheet
import Utils.SystemMessage import Utils.SystemMessage
@ -987,10 +987,14 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
(cid,) <$> MaybeT (get allocationCourseAllocation) (cid,) <$> MaybeT (get allocationCourseAllocation)
tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of 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 now <- liftIO getCurrentTime
Entity _cid course <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do
guard $ courseIsVisible' now course 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 return Authorized
r -> $unsupportedAuthPredicate AuthCourseTime r r -> $unsupportedAuthPredicate AuthCourseTime r
tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of 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.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid)
isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor
courseVisible = courseIsVisible now course Nothing
reason = E.case_ reason = E.case_
[ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent [ 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 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 mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
return (course, reason, isAssociated, mayEdit) return (course, reason, courseVisible, mayEdit)
-- remove invisible courses let favCourses = favCourses' & filter (\(_, _, courseVisible, _) -> courseVisible)
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))
return ( favCourses return ( favCourses
, maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
@ -2048,9 +2050,9 @@ siteLayout' headingOverride widget = do
) )
let favouriteTerms :: [TermIdentifier] 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 -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
favouriteReason = fromMaybe FavouriteCurrent mFavourite favouriteReason = fromMaybe FavouriteCurrent mFavourite
in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
@ -2072,7 +2074,7 @@ siteLayout' headingOverride widget = do
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done."
return items return items
$logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just 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 nav'' <- mconcat <$> sequence
[ defaultLinks [ defaultLinks
@ -2104,10 +2106,10 @@ siteLayout' headingOverride widget = do
navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav 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 highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
highlightNav = (||) <$> navForceActive <*> highlight 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 favouriteTermReason tid favReason' = favourites
& filter (\(Course{..}, _, _, favReason, _) -> unTermKey courseTerm == tid && favReason == favReason') & filter (\(Course{..}, _, _, favReason, _, _) -> unTermKey courseTerm == tid && favReason == favReason')
& sortOn (\(Course{..}, _, _, _, _) -> courseName) & sortOn (\(Course{..}, _, _, _, _, _) -> courseName)
-- We break up the default layout into two components: -- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and -- 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 Import
import Utils.Course (mayViewCourse') import Utils.Course (mayViewCourse)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils 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.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
E.&&. E.exists (E.from $ \course -> E.where_ $ E.&&. E.exists (E.from $ \course -> E.where_ $
course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
E.&&. (mayViewCourse' muid ata now course E.&&. mayViewCourse muid ata now course (Just (allocation E.^. AllocationId))
E.||. E.exists (E.from $ \courseApplication -> E.where_ $ ) E.&&. addWhere allocationCourse
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
queryAvailable :: Maybe UserId -> AuthTagActive -> UTCTime queryAvailable :: Maybe UserId -> AuthTagActive -> UTCTime
-> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) -> 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 resultHasTemplate = _3 . _Value
resultIsRegistered :: Simple Field4 a (E.Value Bool) => Lens' a Bool resultIsRegistered :: Simple Field4 a (E.Value Bool) => Lens' a Bool
resultIsRegistered = _4 . _Value 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 (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do
alloc@(Entity aId Allocation{allocationSchool,allocationRegisterFrom,allocationRegisterTo}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash 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.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId)
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId 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 (courseApplication E.?. CourseApplicationId)
E.||. (E.isJust (E.val allocationRegisterFrom) E.||. (E.isJust (E.val allocationRegisterFrom)
E.&&. E.val allocationRegisterFrom E.<=. E.val (Just now) 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] E.orderBy [E.asc $ course E.^. CourseName]
let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> let hasTemplate = E.exists . E.from $ \courseAppInstructionFile ->
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId 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 registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId
@ -87,11 +89,11 @@ getAShowR tid ssh ash = do
setTitleI shortTitle setTitleI shortTitle
let courseWidgets = flip map courses $ \cEntry -> do let courseWidgets = flip map courses $ \cEntry -> do
let Entity cid c@Course{..} = cEntry ^. resultCourse let Entity cid Course{..} = cEntry ^. resultCourse
hasApplicationTemplate = cEntry ^. resultHasTemplate hasApplicationTemplate = cEntry ^. resultHasTemplate
mApp = cEntry ^? resultCourseApplication mApp = cEntry ^? resultCourseApplication
isRegistered = cEntry ^. resultIsRegistered isRegistered = cEntry ^. resultIsRegistered
courseVisible = courseIsVisible' now c courseVisible = cEntry ^. resultCourseVisible
cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR 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 E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
let participants = course2Participants qin let participants = course2Participants qin
let registered = course2Registered muid ata 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) E.where_ $ whereClause (course, participants, registered, mayView)
return (course, participants, registered, school) return (course, participants, registered, school)
lecturerQuery cid (user `E.InnerJoin` lecturer) = do lecturerQuery cid (user `E.InnerJoin` lecturer) = do
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
return user 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 E.&&. E.just (user E.^. UserId) E.==. E.val muid
dbtProj :: DBRow _ -> DB CourseTableData dbtProj :: DBRow _ -> DB CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do 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 :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup) <- runDB . maybeT notFound $ do now <- liftIO getCurrentTime
[(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] (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 $ <- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse 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 -> numParticipants = E.subSelectCount . E.from $ \part ->
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. part E.^. CourseParticipantState E.==. E.val CourseParticipantActive 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 staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
@ -105,7 +106,7 @@ getCShowR tid ssh csh = do
return $ submissionGroup E.^. SubmissionGroupName return $ submissionGroup E.^. SubmissionGroupName
let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup' 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 let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
mDereg <- traverse (formatTime SelFormatDateTime) mDereg' mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
@ -211,8 +212,6 @@ getCShowR tid ssh csh = do
(Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course (Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course
now <- liftIO getCurrentTime
let visibleNews = any (view _3) news let visibleNews = any (view _3) news
showNewsFiles fs = and showNewsFiles fs = and
[ not $ null fs [ not $ null fs
@ -220,9 +219,7 @@ getCShowR tid ssh csh = do
, all (notElem pathSeparator . view _2) fs , all (notElem pathSeparator . view _2) fs
] ]
hiddenEventNotes = all (\(_,CourseEvent{..}) -> is _Nothing courseEventNote) events hiddenEventNotes = all (\(_,CourseEvent{..}) -> is _Nothing courseEventNote) events
courseVisFrom = courseVisibleFrom course Course{courseVisibleFrom,courseVisibleTo} = course
courseVisTo = courseVisibleTo course
courseVisible = courseIsVisible' now course
mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR
mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR
mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR

4
src/Handler/Term.hs
View File

@ -6,7 +6,7 @@ module Handler.Term
import Import import Import
import Utils.Course (mayViewCourse') import Utils.Course (mayViewCourse)
import Handler.Utils import Handler.Utils
@ -74,7 +74,7 @@ getTermShowR = do
where dbtSQLQuery term = return (term, courseCount) where dbtSQLQuery term = return (term, courseCount)
where courseCount = E.subSelectCount . E.from $ \course -> where courseCount = E.subSelectCount . E.from $ \course ->
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm 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) dbtRowKey = (E.^. TermId)
dbtProj = return . dbrOutput dbtProj = return . dbrOutput
dbtColonnade = widgetColonnade $ mconcat dbtColonnade = widgetColonnade $ mconcat

127
src/Utils/Course.hs
View File

@ -1,7 +1,11 @@
module Utils.Course module Utils.Course
( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse' ( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse'
, isCourseLecturer, isCourseTutor, isCourseCorrector, isCourseParticipant, isCourseAssociated , isSchoolAdmin, isSchoolAdminLike
, isCourseLecturer, isCourseTutor, isCourseCorrector
, isCourseParticipant, isCourseApplicant
, isCourseAssociated
, courseIsVisible, courseIsVisible' , courseIsVisible, courseIsVisible'
, courseAllocationRegistrationOpen
, numCourseParticipants , numCourseParticipants
) where ) where
@ -11,35 +15,56 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> Entity Course -> E.SqlExpr (E.Value Bool) mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool)
mayViewCourse muid ata now c@(Entity cid course) = mayViewCourse muid ata now course maid =
mayEditCourse muid ata c isSchoolAdminLike muid ata (course E.^. CourseSchool)
E.||. isCourseAssociated muid ata (E.val cid) E.||. mayEditCourse muid ata course
E.||. E.val (courseIsVisible' now 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' :: Maybe UserId -> AuthTagActive -> UTCTime -> Entity Course -> Maybe AllocationId -> E.SqlExpr (E.Value Bool)
mayViewCourse' muid ata now course = mayViewCourse' muid ata now c@(Entity cid Course{courseSchool}) maid =
mayEditCourse' muid ata course isSchoolAdminLike muid ata (E.val courseSchool)
E.||. isCourseAssociated muid ata (course E.^. CourseId) E.||. mayEditCourse' muid ata c
E.||. courseIsVisible now course 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.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
E.where_ $ E.just (user E.^. UserId) E.==. E.val muid E.where_ $ E.just (user E.^. UserId) E.==. E.val muid
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin E.&&. userFunction E.^. UserFunctionSchool E.==. ssh
E.&&. userFunction E.^. UserFunctionSchool E.==. E.val courseSchool E.&&. ( (userFunction E.^. UserFunctionFunction E.==. E.val SchoolEvaluation
E.&&. E.val (authTagIsActive AuthAdmin) E.&&. E.val (authTagIsActive AuthEvaluation))
) E.||. isCourseLecturer muid ata (E.val cid) E.||. (userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
E.&&. E.val (authTagIsActive AuthExamOffice))
mayEditCourse' :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) E.||. (userFunction E.^. UserFunctionFunction E.==. E.val SchoolAllocation
mayEditCourse' muid ata@AuthTagActive{..} course = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do E.&&. E.val (authTagIsActive AuthAllocationAdmin))
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)
isCourseLecturer :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) 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 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.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.&&. E.val (authTagIsActive AuthCourseRegistered) -- TODO is this the auth tag I want here? 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) isCourseApplicant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool)
isCourseAssociated muid ata cid = 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 isCourseLecturer muid ata cid
E.||. isCourseTutor muid ata cid E.||. isCourseTutor muid ata cid
E.||. isCourseCorrector muid ata cid E.||. isCourseCorrector muid ata cid
E.||. isCourseParticipant 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 :: UTCTime -> E.SqlExpr (Entity Course) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool)
courseIsVisible' now Course{..} = NTop courseVisibleFrom <= now' && now' <= NTop courseVisibleTo 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 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 :: E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Int)
numCourseParticipants cid = E.subSelectCount . E.from $ \courseParticipant -> numCourseParticipants cid = E.subSelectCount . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. cid 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 $if mayEdit
<dt .deflist__dt> <dt .deflist__dt>
$if isJust courseVisFrom && isNothing courseVisTo $if isJust courseVisibleFrom && isNothing courseVisibleTo
_{MsgCourseVisibleFrom} _{MsgCourseVisibleFrom}
$else $else
_{MsgCourseVisibility} _{MsgCourseVisibility}
\ #{iconInvisible} \ #{iconInvisible}
<dd .deflist__dd> <dd .deflist__dd>
<p> <p>
$maybe visFrom <- courseVisFrom $maybe visFrom <- courseVisibleFrom
^{formatTimeRangeW SelFormatDateTime visFrom courseVisTo} ^{formatTimeRangeW SelFormatDateTime visFrom courseVisibleTo}
$nothing $nothing
_{MsgCourseInvisible} _{MsgCourseInvisible}

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

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