feat(course-list): filter by allocation

Fixes #715

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

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
+CourseApply: Apply for course

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)

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

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

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

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)

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)
+colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgFilterCourseSchoolShort) $ \res
-          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _, _, _) } ->
+  -> let Entity _ Course{..} = res ^. resultCourse
-            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
+         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)
+colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered tickmarkCell
-          $ \DBRow{ dbrOutput=(_, _, registered, _, _, _, _) } -> tickmarkCell registered
 
-type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
 
-course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
+data AllocationSearch
-course2Participants (course `E.InnerJoin` _school) = numCourseParticipants $ course E.^. CourseId
+  = AllocationSearchNoAllocation
+  | AllocationSearchMatch TermId SchoolId AllocationShorthand
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
-course2Registered :: Maybe UserId -> AuthTagActive -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
+instance PathPiece AllocationSearch where
-course2Registered muid ata (course `E.InnerJoin` _school) = isCourseParticipant muid ata $ course E.^. CourseId
+  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
+      dbtSQLQuery = runReaderT $ do
-        E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
+        course <- view queryCourse
-        let participants = course2Participants qin
+        school <- view querySchool
-        let registered   = course2Registered muid ata qin
+        allocation <- view queryAllocation
-        let mayView      = mayViewCourse muid ata now course Nothing
+
-        E.where_ $ whereClause (course, participants, registered, mayView)
+        lift . E.on . E.exists . E.from $ \allocationCourse ->
-        return (course, participants, registered, school)
+          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)
+        return (course, registered, school, lecturerList, allocation, isEditor)
-                          >>= traverse (getJustEntity . allocationCourseAllocation . entityVal)
+  
-        isEditorList <- E.select $ E.from $ isEditorQuery course
+  dbTableWidget' psValidator DBTable
-        return (course, participants, registered, school, lecturerList, courseAlloc, not $ null isEditorList)
-  snd <$> dbTable 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
+    , dbtSorting = mconcat
-        [ ( "course",        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName)
+      [ singletonMap "course"         . SortColumn $ views queryCourse (E.^. CourseName)
-        , ( "cshort",        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand)
+      , singletonMap "cshort"         . SortColumn $ views queryCourse (E.^. CourseShorthand)
-        , ( "term"  ,        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm)
+      , singletonMap "term"           . SortColumn $ views queryCourse (E.^. CourseTerm)
-        , ( "school",        SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName)
+      , singletonMap "school"         . SortColumn $ views querySchool (E.^. SchoolName)
-        , ( "schoolshort",   SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
+      , singletonMap "schoolshort"    . SortColumn $ views querySchool (E.^. SchoolShorthand)
-        , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
+      , singletonMap "register-from"  . SortColumn $ views queryCourse (E.^. CourseRegisterFrom)
-        , ( "register-to",   SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
+      , singletonMap "register-to"    . SortColumn $ views queryCourse (E.^. CourseRegisterTo)
-        , ( "members",       SortColumn   course2Participants   )
+      , singletonMap "members"        . SortColumn $ view queryParticipants
-        , ( "registered",    SortColumn $ course2Registered muid ata)
+      , singletonMap "registered"     . SortColumn . view $ queryIsRegistered muid ata
-        ]
+      ]
-    , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
+    , dbtFilter = mconcat
-        [ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if
+      [ singletonMap "may-read" . FilterColumn $ \t (Any b) -> views (queryMayViewCourse muid ata now) (E.==. E.val b) t
-                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+      , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseName)
-                | otherwise          -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
+      , singletonMap "cshort" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand)
-          )
+      , singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm)
-        , ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
+      , singletonMap "school" . FilterColumn . E.mkExactFilter $ views querySchool (E.^. SchoolName)
-                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+      , singletonMap "schoolshort" . FilterColumn . E.mkExactFilter $ views querySchool (E.^. SchoolShorthand)
-                | otherwise          -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
+      , singletonMap "lecturer" . FilterColumn . E.mkExistsFilter $ \t (c :: Text) -> E.from $ \t' -> do
-          )
+          user <- isCourseAdminQuery (view queryCourse t E.^. CourseId) t'
-        , ( "term"  , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
+          E.where_ $ user E.^. UserDisplayName `E.hasInfix` E.val c
-                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+      , singletonMap "openregistration" . FilterColumn . E.mkExactFilterLast . runReader $ do
-                | otherwise          -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
+          course <- view queryCourse
-          )
+          allocation <- view queryAllocation
---         , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
+
---                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+          let regTo   = course E.^. CourseRegisterTo
---                 | otherwise          -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
+              regFrom = course E.^. CourseRegisterFrom
---           )
+              courseOpen = E.maybe E.false (\f -> f E.<=. E.val now) regFrom
-        , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) ->
+                     E.&&. E.maybe E.true  (\t -> E.val now E.<=. t) regTo
-              emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?!
+              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)
-        , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
+                          )
-                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                    E.||. (       courseOpen
-                | otherwise          -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
+                            E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (E.joinV $ allocation E.?. AllocationRegisterByCourse)
-          )
+                          )
-        , ( "lecturer", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
+
-                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+          return $ (       courseOpen
-                | otherwise          -> E.exists $ E.from $ \t -> do
+                     E.&&. E.isNothing (allocation E.?. AllocationId)
-                  user <- isCourseAdminQuery (course E.^. CourseId) t
+                   )
-                  E.where_ $ E.any (E.hasInfix (user E.^. UserDisplayName) . E.val) (criterias :: Set.Set Text)
+             E.||. (       allocOpen
-          )
+                     E.&&. E.isJust (allocation E.?. AllocationId)
-        , ( "openregistration", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Bool) of
+                   )
-              Nothing -> E.val True
+      , singletonMap "registered" . FilterColumn . E.mkExactFilterLast . view $ queryIsRegistered muid ata
-              Just b  -> let regTo   = course E.^. CourseRegisterTo
+      , singletonMap "search" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of
-                             regFrom = course E.^. CourseRegisterFrom
+          Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
-                             courseOpen = E.maybe E.false (\f -> f E.<=. E.val now) regFrom
+          Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
-                                    E.&&. E.maybe E.true  (\t -> E.val now E.<=. t) regTo
+                   E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
-                             alloc allocation = do
+                   E.||. (E.maybe (E.val mempty) (E.castString . esqueletoMarkupOutput) (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
-                               E.where_ . E.exists . E.from $ \allocationCourse ->
+      , singletonMap "allocation" . FilterColumn $ \row (criteria :: Set AllocationSearch) -> if
-                                 E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
+          | Set.null criteria -> E.true
-                               return allocation
+          | otherwise -> flip E.any criteria $ \case
-                             allocOpen allocation = (      E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterFrom)
+              AllocationSearchNoAllocation -> E.isNothing $ view queryAllocation row E.?. AllocationId
-                                                     E.&&. E.maybe E.true  (\t -> E.val now E.<=. t) (allocation E.^. AllocationRegisterTo)
+              AllocationSearchMatch tid ssh ash
-                                                    )
+                ->       view queryAllocation row E.?. AllocationTerm E.==. E.justVal tid
-                                              E.||. (      courseOpen
+                   E.&&. view queryAllocation row E.?. AllocationSchool E.==. E.justVal ssh
-                                                     E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterByCourse)
+                   E.&&. view queryAllocation row E.?. AllocationShorthand E.==. E.justVal ash
-                                                    )
+      ]
-                         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.%))
-          )
-        ]
     , dbtFilterUI = \mPrev -> mconcat $ catMaybes
-      [ Just  $ prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm)
+      [ pure $ 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)
+      , pure $ prismAForm (singletonFilter "schoolshort" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool)
-      , Just  $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer)
+      , pure $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer)
-      , Just  $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgFilterCourseSearch)
+      , pure $ 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)
+      , pure $ 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))
+      , 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
+      , dbsTemplate = DBSTCourse resultCourse resultLecturers resultIsRegistered resultSchool resultAllocation resultMayEditCourse
-                        (_dbrOutput . _1)         -- course
-                        (_dbrOutput . _5)         -- lecturer list
-                        (_dbrOutput . _3)         -- isRegistered
-                        (_dbrOutput . _4)         -- school
-                        (_dbrOutput . _6 . _Just) -- allocation
-                        (_dbrOutput . _7)         -- mayEditCourse
       }
     , 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")

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_ $
+    mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \(course `E.LeftOuterJoin` allocation) -> do
-      course E.^. CourseId E.==. E.val cid
+      E.on . E.exists . E.from $ \allocationCourse ->
-      E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool)
+        E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
-        E.||. mayEditCourse muid ata course
+             E.&&. E.just (allocationCourse E.^. AllocationCourseAllocation) E.==. allocation E.?. AllocationId
-        E.||. courseIsVisible now course Nothing
+      E.where_ $  course E.^. CourseId E.==. E.val cid
-        E.||. isCourseLecturer muid ata (course E.^. CourseId)
+           E.&&. (       isSchoolAdminLike muid ata (course E.^. CourseSchool)
-        E.||. isCourseTutor muid ata (course E.^. CourseId)
+                   E.||. mayEditCourse muid ata course
-        E.||. isCourseSheetCorrector muid ata (course E.^. CourseId)
+                   E.||. courseIsVisible now course (allocation E.?. AllocationId)
-        E.||. isCourseExamCorrector muid ata (course E.^. CourseId)
+                   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_ $
+  courseVisible <- runDB . E.selectExists . E.from $ \(course' `E.LeftOuterJoin` allocation) -> do
-    c E.^. CourseId E.==. E.val cid
+    E.on . E.exists . E.from $ \allocationCourse ->
-    E.&&. mayViewCourse muid ata now c Nothing
+      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 ()

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

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

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

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)