From de39686d89f6ec410bc50eaca058082dc727547d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 17 Jun 2021 17:08:21 +0200 Subject: [PATCH] feat(course-list): filter by allocation Fixes #715 --- .../courses/courses/de-de-formal.msg | 3 + .../categories/courses/courses/en-eu.msg | 5 +- src/Database/Esqueleto/Utils.hs | 23 ++ src/Foundation/Authorization.hs | 2 +- src/Foundation/SiteLayout.hs | 7 +- src/Handler/Allocation/List.hs | 2 +- src/Handler/Allocation/Show.hs | 4 +- src/Handler/Course/List.hs | 334 +++++++++++------- src/Handler/Course/Register.hs | 32 +- src/Handler/Course/Show.hs | 13 +- src/Handler/Term.hs | 7 +- src/Handler/Utils/Table/Pagination.hs | 4 +- src/Utils/Course.hs | 18 +- 13 files changed, 293 insertions(+), 161 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 7995196d3..ad7163be6 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -6,6 +6,9 @@ FilterRegistered: Angemeldet FilterCourseSearch: Volltext-Suche FilterCourseRegistered: Registriert FilterCourseRegisterOpen: Anmeldung möglich +FilterCourseAllocation: Zentralanmeldung +FilterCourseAllocationNone: Keine Zentralanmeldung +FilterCourseAllocationOption tid@TermId ssh@SchoolId aname@AllocationName !ident-ok: #{toPathPiece tid} #{ssh} #{aname} CourseRegistered: Angemeldet CourseRegistration: Anmeldung CourseDescription: Beschreibung diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 1fc50974b..031c397d8 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -6,6 +6,9 @@ FilterRegistered: Enrolled FilterCourseSearch: Text search FilterCourseRegistered: Registered FilterCourseRegisterOpen: Enrolment is allowed +FilterCourseAllocation: Central allocation +FilterCourseAllocationNone: No allocation +FilterCourseAllocationOption tid ssh aname: #{toPathPiece tid} #{ssh} #{aname} CourseRegistered: Enrolled CourseRegistration: Enrolment CourseDescription: Description @@ -274,4 +277,4 @@ MailSubjectLecturerInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitation to LecturerInvitationAccepted lType csh: You were registered as #{lType} for #{csh} CourseExamRegistrationTime: Registered since CourseParticipantStateIsActiveFilter: View -CourseApply: Apply for course \ No newline at end of file +CourseApply: Apply for course diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index e61ab16bf..3daa8b813 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -11,6 +11,7 @@ module Database.Esqueleto.Utils , any, all , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith + , mkExactFilterLast, mkExactFilterLastWith , mkContainsFilter, mkContainsFilterWith , mkExistsFilter , anyFilter, allFilter @@ -58,6 +59,8 @@ import Data.Time.Clock (NominalDiffTime) import qualified Data.Text.Lazy.Builder as Text.Builder +import Data.Monoid (Last(..)) + {-# ANN any ("HLint: ignore Use any" :: String) #-} {-# ANN all ("HLint: ignore Use all" :: String) #-} @@ -217,6 +220,26 @@ mkExactFilterWith cast lenslike row criterias | Set.null criterias = true | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias) +-- | generic filter creation for dbTable +-- Given a lens-like function, make filter for exact matches against last element of a collection +mkExactFilterLast :: (PersistField a) + => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Last a -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkExactFilterLast = mkExactFilterLastWith id + +-- | like `mkExactFilerLast` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter` +mkExactFilterLastWith :: (PersistField b) + => (a -> b) -- ^ type conversion + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Last a -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkExactFilterLastWith cast lenslike row criterias + | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit) + | otherwise = true + -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements -- (Keep Set here to ensure that there are no duplicates) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index a4ca5385a..912007db1 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -1144,7 +1144,7 @@ tagAccessPredicate AuthCourseTime = APDB $ \_ _ _mAuthId route _ -> case route o 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 + E.&&. courseIsVisible now course E.nothing guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) return Authorized r -> $unsupportedAuthPredicate AuthCourseTime r diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 07bc6f744..c8e2955db 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -154,9 +154,12 @@ siteLayout' overrideHeading widget = do (favourites', (title, parents), nav', contentHeadline, mmsgs, maxFavouriteTerms, currentTheme, storedReasonAndToggleRoute) <- do (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs, storedReasonAndToggleRoute) <- runDB $ do - favCourses'' <- withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + favCourses'' <- withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.LeftOuterJoin` allocation `E.LeftOuterJoin` courseFavourite) -> do E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) + E.on . E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. E.just (allocationCourse E.^. AllocationCourseAllocation) E.==. allocation E.?. AllocationId let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId isCurrent @@ -185,7 +188,7 @@ siteLayout' overrideHeading 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 + courseVisible = courseIsVisible now course $ allocation E.?. AllocationId reason = E.case_ [ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index 1dcc6a715..a70a39d56 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -33,7 +33,7 @@ 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 (Just (allocation E.^. AllocationId)) + E.&&. mayViewCourse muid ata now course (E.just $ allocation E.^. AllocationId) ) E.&&. addWhere allocationCourse queryAvailable :: Maybe UserId -> AuthTagActive -> UTCTime diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 6c66de6cf..881bb2b4b 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -82,7 +82,7 @@ postAShowR tid ssh ash = do E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId E.&&. ( E.isJust (courseApplication E.?. CourseApplicationId) - E.||. mayViewCourse muid ata now course (Just $ E.val aId) + E.||. mayViewCourse muid ata now course (E.justVal aId) ) E.orderBy [E.asc $ course E.^. CourseName] let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> @@ -105,7 +105,7 @@ postAShowR tid ssh ash = do , courseApplication , hasTemplate , E.not_ . E.isNothing $ registration E.?. CourseParticipantId - , courseIsVisible now course . Just $ E.val aId + , courseIsVisible now course $ E.justVal aId , allocationCourse , participantCount , (ratingsCount, vetosCount) diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index cccd6401e..edc5f6ad7 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.Course.List ( makeCourseTable , getCourseListR @@ -15,70 +17,175 @@ import Utils.Form -- import Utils.DB import Handler.Utils hiding (colSchoolShort) -import qualified Data.Set as Set -import qualified Data.Map as Map - import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as Text +import qualified Data.Set as Set + + +type CourseTableData = DBRow + ( Entity Course + , Bool -- isRegistered + , Entity School + , [Entity User] + , Maybe (Entity Allocation) + , 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 + +resultAllocation :: Traversal' CourseTableData (Entity Allocation) +resultAllocation = _dbrOutput . _5 . _Just + +resultMayEditCourse :: Lens' CourseTableData Bool +resultMayEditCourse = _dbrOutput . _6 + + +type CourseTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation)) + +queryCourse :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity Course)) +queryCourse = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 1) + +querySchool :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity School)) +querySchool = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 1) + +queryAllocation :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Maybe (Entity Allocation))) +queryAllocation = to $(E.sqlLOJproj 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 + allocation <- view queryAllocation + + return $ mayViewCourse muid ata now course (allocation E.?. AllocationId) + +queryIsEditor :: Maybe UserId + -> AuthTagActive + -> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool)) +queryIsEditor muid ata = queryCourse . to (mayEditCourse muid ata) --- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. -type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User], Maybe (Entity Allocation), Bool) colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgFilterCourse) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _, _) } -> + $ \(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 - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _, _) } -> + $ \(view resultCourse -> Entity _ Course{..}) -> case courseDescription of Nothing -> mempty (Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr) colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCShort = sortable (Just "cshort") (i18nCell MsgFilterCourseShort) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _, _) } -> + $ \(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) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _, _) } -> + $ \(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) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _, _, _) } -> - anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|] +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) - $ \DBRow{ dbrOutput=(_, _, registered, _, _, _, _) } -> tickmarkCell registered +colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered tickmarkCell -type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School) -course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int) -course2Participants (course `E.InnerJoin` _school) = numCourseParticipants $ course E.^. CourseId +data AllocationSearch + = AllocationSearchNoAllocation + | AllocationSearchMatch TermId SchoolId AllocationShorthand + deriving (Eq, Ord, Read, Show, Generic, Typeable) -course2Registered :: Maybe UserId -> AuthTagActive -> CourseTableExpr -> E.SqlExpr (E.Value Bool) -course2Registered muid ata (course `E.InnerJoin` _school) = isCourseParticipant muid ata $ course E.^. CourseId +instance PathPiece AllocationSearch where + toPathPiece AllocationSearchNoAllocation = "no-allocation" + toPathPiece (AllocationSearchMatch tid ssh ash) = pathPieceJoined "-" # [toPathPiece tid, toPathPiece ssh, toPathPiece ash] + fromPathPiece t + | CI.mk (Text.strip t) == "no-allocation" = pure AllocationSearchNoAllocation + | Just [tid, ssh, ash] <- t ^? pathPieceJoined "-" + = AllocationSearchMatch <$> fromPathPiece tid <*> fromPathPiece ssh <*> fromPathPiece ash + | otherwise = mzero + + +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) -makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) ) - => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget -makeCourseTable whereClause colChoices psValidator = do muid <- lift maybeAuthId now <- liftIO getCurrentTime ata <- getSessionActiveAuthTags + + MsgRenderer mr <- getMsgRenderer + let allocSearchNoAllocOption = Option + { optionDisplay = mr MsgFilterCourseAllocationNone + , optionInternalValue + , optionExternalValue = toPathPiece optionInternalValue + } + where optionInternalValue = AllocationSearchNoAllocation + allocationSearchOptions <- mkOptionList . (allocSearchNoAllocOption :) <$> do + allocs <- E.select . E.from $ \allocation -> do + E.orderBy [ E.desc $ allocation E.^. AllocationTerm + , E.asc $ allocation E.^. AllocationSchool + , E.asc $ allocation E.^. AllocationName + ] + return ( allocation E.^. AllocationTerm, allocation E.^. AllocationSchool, allocation E.^. AllocationShorthand + , allocation E.^. AllocationName + ) + return . flip map allocs $ \(E.Value tid, E.Value ssh, E.Value ash, E.Value aname) + -> let optionInternalValue = AllocationSearchMatch tid ssh ash + in Option + { optionDisplay = mr $ MsgFilterCourseAllocationOption tid ssh aname + , optionInternalValue + , optionExternalValue = toPathPiece optionInternalValue + } + let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _ - dbtSQLQuery qin@(course `E.InnerJoin` school) = 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 Nothing - E.where_ $ whereClause (course, participants, registered, mayView) - return (course, participants, registered, school) + dbtSQLQuery = runReaderT $ do + course <- view queryCourse + school <- view querySchool + allocation <- view queryAllocation + + lift . E.on . E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocation E.?. AllocationId E.==. E.just (allocationCourse E.^. AllocationCourseAllocation) + lift . E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId + + registered <- view $ queryIsRegistered muid ata + isEditor <- view $ queryIsEditor muid ata + + return (course, registered, school, allocation, isEditor) lecturerQuery cid (user `E.InnerJoin` lecturer) = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ cid E.==. lecturer E.^. LecturerCourse @@ -88,110 +195,86 @@ makeCourseTable whereClause colChoices psValidator = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ cid E.==. lecturer E.^. LecturerCourse return user - isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course - E.&&. E.just (user E.^. UserId) E.==. E.val muid dbtProj :: _ CourseTableData - dbtProj = dbtProjSimple $ \(course, E.Value participants, E.Value registered, school) -> do + dbtProj = dbtProjSimple $ \(course, E.Value registered, school, allocation, E.Value isEditor) -> do lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course - courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course) - >>= traverse (getJustEntity . allocationCourseAllocation . entityVal) - isEditorList <- E.select $ E.from $ isEditorQuery course - return (course, participants, registered, school, lecturerList, courseAlloc, not $ null isEditorList) - snd <$> dbTable psValidator DBTable + return (course, registered, school, lecturerList, allocation, isEditor) + + dbTableWidget' psValidator DBTable { dbtSQLQuery - , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId + , dbtRowKey = views queryCourse (E.^. CourseId) , dbtColonnade = colChoices , dbtProj - , dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here - [ ( "course", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName) - , ( "cshort", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand) - , ( "term" , SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm) - , ( "school", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName) - , ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand) - , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom) - , ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo) - , ( "members", SortColumn course2Participants ) - , ( "registered", SortColumn $ course2Registered muid ata) - ] - , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here - [ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias) - ) - , ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias) - ) - , ( "term" , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias) - ) --- , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if --- | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) --- | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias) --- ) - , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) -> - emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?! - ) - , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias) - ) - , ( "lecturer", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> E.exists $ E.from $ \t -> do - user <- isCourseAdminQuery (course E.^. CourseId) t - E.where_ $ E.any (E.hasInfix (user E.^. UserDisplayName) . E.val) (criterias :: Set.Set Text) - ) - , ( "openregistration", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Bool) of - Nothing -> E.val True - Just b -> 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 - alloc allocation = do - E.where_ . E.exists . E.from $ \allocationCourse -> - E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId - return allocation - allocOpen allocation = ( E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterFrom) - E.&&. E.maybe E.true (\t -> E.val now E.<=. t) (allocation E.^. AllocationRegisterTo) - ) - E.||. ( courseOpen - E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterByCourse) - ) - in (E.==. E.val b) $ ( courseOpen - E.&&. E.not_ (E.exists . void $ E.from alloc) - ) - E.||. E.exists (E.from $ E.where_ . allocOpen <=< alloc) - ) - , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> course2Registered muid ata tExpr E.==. E.val needle - ) - , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) 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.%)) - ) - ] + , 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 + allocation <- view queryAllocation + + 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 + allocOpen = ( E.maybe E.false (\f -> f E.<=. E.val now) (E.joinV $ allocation E.?. AllocationRegisterFrom) + E.&&. E.maybe E.true (\t -> E.val now E.<=. t) (E.joinV $ allocation E.?. AllocationRegisterTo) + ) + E.||. ( courseOpen + E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (E.joinV $ allocation E.?. AllocationRegisterByCourse) + ) + + return $ ( courseOpen + E.&&. E.isNothing (allocation E.?. AllocationId) + ) + E.||. ( allocOpen + E.&&. E.isJust (allocation E.?. AllocationId) + ) + , 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 "allocation" . FilterColumn $ \row (criteria :: Set AllocationSearch) -> if + | Set.null criteria -> E.true + | otherwise -> flip E.any criteria $ \case + AllocationSearchNoAllocation -> E.isNothing $ view queryAllocation row E.?. AllocationId + AllocationSearchMatch tid ssh ash + -> view queryAllocation row E.?. AllocationTerm E.==. E.justVal tid + E.&&. view queryAllocation row E.?. AllocationSchool E.==. E.justVal ssh + E.&&. view queryAllocation row E.?. AllocationShorthand E.==. E.justVal ash + ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes - [ Just $ prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm) - , Just $ prismAForm (singletonFilter "schoolshort" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool) - , Just $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer) - , Just $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgFilterCourseSearch) - , Just $ prismAForm (singletonFilter "openregistration" . maybePrism _PathPiece) mPrev $ fmap (\x -> if isJust x && not (fromJust x) then Nothing else x) . aopt checkBoxField (fslI MsgFilterCourseRegisterOpen) - , muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterCourseRegistered)) + [ 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 "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)) + , pure $ prismAForm (singletonFilter "allocation" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return allocationSearchOptions) (fslI MsgFilterCourseAllocation) ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout - , dbsTemplate = DBSTCourse - (_dbrOutput . _1) -- course - (_dbrOutput . _5) -- lecturer list - (_dbrOutput . _3) -- isRegistered - (_dbrOutput . _4) -- school - (_dbrOutput . _6 . _Just) -- allocation - (_dbrOutput . _7) -- mayEditCourse + , dbsTemplate = DBSTCourse resultCourse resultLecturers resultIsRegistered resultSchool resultAllocation resultMayEditCourse } , dbtParams = def , dbtIdent = "courses" :: Text @@ -211,10 +294,9 @@ getCourseListR = do , colCShort , maybe mempty (const colRegistered) muid ] - whereClause (_, _, _, mayView) = mayView validator = def & defaultSorting [SortDescBy "term",SortAscBy "course"] - coursesTable <- runDB $ makeCourseTable whereClause colonnade validator + coursesTable <- runDB $ makeCourseTable colonnade validator defaultLayout $ do setTitleI MsgCourseListTitle $(widgetFile "courses") diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 3affd85ee..cc210739f 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -139,16 +139,19 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do | otherwise -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles (prevAppFiles <$> application) - mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> E.where_ $ - course E.^. CourseId E.==. E.val cid - E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool) - E.||. mayEditCourse muid ata course - E.||. courseIsVisible now course Nothing - E.||. isCourseLecturer muid ata (course E.^. CourseId) - E.||. isCourseTutor muid ata (course E.^. CourseId) - E.||. isCourseSheetCorrector muid ata (course E.^. CourseId) - E.||. isCourseExamCorrector muid ata (course E.^. CourseId) - ) + mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \(course `E.LeftOuterJoin` allocation) -> do + E.on . E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. E.just (allocationCourse E.^. AllocationCourseAllocation) E.==. allocation E.?. AllocationId + E.where_ $ course E.^. CourseId E.==. E.val cid + E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool) + E.||. mayEditCourse muid ata course + E.||. courseIsVisible now course (allocation E.?. AllocationId) + E.||. isCourseLecturer muid ata (course E.^. CourseId) + E.||. isCourseTutor muid ata (course E.^. CourseId) + E.||. isCourseSheetCorrector muid ata (course E.^. CourseId) + E.||. isCourseExamCorrector muid ata (course E.^. CourseId) + ) mayReRegister <- liftHandler . runDB . courseMayReRegister $ Entity cid Course{..} @@ -270,9 +273,12 @@ postCRegisterR tid ssh csh = do muid <- maybeAuthId ata <- getSessionActiveAuthTags now <- liftIO getCurrentTime - courseVisible <- runDB . E.selectExists . E.from $ \c -> E.where_ $ - c E.^. CourseId E.==. E.val cid - E.&&. mayViewCourse muid ata now c Nothing + courseVisible <- runDB . E.selectExists . E.from $ \(course' `E.LeftOuterJoin` allocation) -> do + E.on . E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course' E.^. CourseId + E.&&. E.just (allocationCourse E.^. AllocationCourseAllocation) E.==. allocation E.?. AllocationId + E.where_ $ course' E.^. CourseId E.==. E.val cid + E.&&. mayViewCourse muid ata now course' (allocation E.?. AllocationId) redirect $ bool NewsR (CourseR tid ssh csh CShowR) courseVisible deleteApplications :: UserId -> CourseId -> DB () diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index fe82235bf..647be20d3 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -33,10 +33,13 @@ getCShowR tid ssh csh = do (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ - \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do + \((school `E.InnerJoin` course) `E.LeftOuterJoin` allocation `E.LeftOuterJoin` participant) -> do E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser E.&&. participant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) + E.on . E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. E.just (allocationCourse E.^. AllocationCourseAllocation) E.==. allocation E.?. AllocationId E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh @@ -46,7 +49,13 @@ 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, courseIsVisible now course Nothing, school E.^. SchoolName, numParticipants, participant, courseAllocationRegistrationOpen now (course E.^. CourseId) Nothing) + return ( course + , courseIsVisible now course $ allocation E.?. AllocationId + , school E.^. SchoolName + , numParticipants + , participant + , courseAllocationRegistrationOpen now (course E.^. CourseId) $ allocation E.?. AllocationId + ) 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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index c815162be..6115c4db6 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -73,9 +73,12 @@ getTermShowR = do table <- runDB $ let termDBTable = DBTable{..} where dbtSQLQuery term = return (term, courseCount, isActive) - where courseCount = E.subSelectCount . E.from $ \course -> + where courseCount = E.subSelectCount . E.from $ \(course `E.LeftOuterJoin` allocation) -> do + E.on . E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. E.just (allocationCourse E.^. AllocationCourseAllocation) E.==. allocation E.?. AllocationId E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm - E.&&. mayViewCourse muid ata now course Nothing + E.&&. mayViewCourse muid ata now course (allocation E.?. AllocationId) isActive = termIsActiveE (E.val now) (E.val muid) (term E.^. TermId) dbtRowKey = (E.^. TermId) dbtProj = dbrOutput <$> dbtProjId diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 8bd4b33fc..79963d8b0 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -579,7 +579,7 @@ data DBStyle r = DBStyle data DBSTemplateMode r = DBSTDefault { dbstmNumber :: Int64 -> Bool, dbstmShowNumber :: Int64 -> Bool } | DBSTCourse (Lens' r (Entity Course)) -- course - (Lens' r [Entity User]) -- lecturers + (Traversal' r (Entity User)) -- lecturers (Lens' r Bool) -- isRegistered (Lens' r (Entity School)) -- school (Traversal' r (Entity Allocation)) -- allocation @@ -1510,7 +1510,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db DBSTCourse c l r s a e -> do wRows <- forM rows $ \row' -> let Course{..} = row' ^. c . _entityVal - lecturerUsers = row' ^. l + lecturerUsers = row' ^.. l courseLecturers = userSurname . entityVal <$> lecturerUsers isRegistered = row' ^. r mayEdit = row' ^. e diff --git a/src/Utils/Course.hs b/src/Utils/Course.hs index 23a270169..b88464516 100644 --- a/src/Utils/Course.hs +++ b/src/Utils/Course.hs @@ -15,7 +15,7 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value (Maybe AllocationId)) -> E.SqlExpr (E.Value Bool) mayViewCourse muid ata now course maid = isSchoolAdminLike muid ata (course E.^. CourseSchool) E.||. mayEditCourse muid ata course @@ -26,7 +26,7 @@ mayViewCourse' :: Maybe UserId -> AuthTagActive -> UTCTime -> Entity Course -> M 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.||. isCourseAssociated muid ata (E.val cid) (E.val maid) E.||. courseIsVisible' now c maid @@ -107,17 +107,17 @@ isCourseParticipant muid AuthTagActive{..} cid E.&&. E.val (authTagIsActive AuthCourseRegistered) | otherwise = E.false -isCourseApplicant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +isCourseApplicant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value (Maybe AllocationId)) -> E.SqlExpr (E.Value Bool) isCourseApplicant muid AuthTagActive{..} cid maid | Just uid <- muid, authTagIsActive AuthApplicant = E.exists . E.from $ \courseApplication -> E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid E.&&. courseApplication E.^. CourseApplicationCourse E.==. cid - E.&&. maybe E.true + E.&&. E.maybe E.true (\aid -> E.just aid E.==. courseApplication E.^. CourseApplicationAllocation) maid | otherwise = E.false -isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value (Maybe AllocationId)) -> E.SqlExpr (E.Value Bool) isCourseAssociated muid ata cid maid = isCourseLecturer muid ata cid E.||. isCourseTutor muid ata cid @@ -127,7 +127,7 @@ isCourseAssociated muid ata cid maid = E.||. isCourseApplicant muid ata cid maid -courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value (Maybe AllocationId)) -> E.SqlExpr (E.Value Bool) courseIsVisible now course maid = (E.maybe E.false (\visibleFrom -> visibleFrom E.<=. E.val now) (course E.^. CourseVisibleFrom) E.&&. E.maybe E.true (\visibleTo -> E.val now E.<=. visibleTo) (course E.^. CourseVisibleTo) @@ -136,11 +136,11 @@ courseIsVisible now course 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) + 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 :: UTCTime -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value (Maybe 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 @@ -152,7 +152,7 @@ courseAllocationRegistrationOpen now cid maid = E.exists . E.from $ \(allocation E.true (\registerTo -> E.val now E.<=. registerTo) (allocation E.^. AllocationRegisterTo) - E.&&. maybe E.true (\aid -> aid E.==. allocation E.^. AllocationId) maid + E.&&. E.maybe E.true (\aid -> aid E.==. allocation E.^. AllocationId) maid numCourseParticipants :: E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Int)