refactor(dbtable): move haskell-land filtering to actual filter

frontend/src/app.sass

@@ -960,6 +960,9 @@ th, td
   justify-content: space-between
   margin-bottom: 15px
 
+  &:empty
+    margin: 0
+
 // TABLE FOOTER
 .table-footer
   display: flex
@@ -967,6 +970,9 @@ th, td
   justify-content: space-between
   margin-top: 15px
 
+  &:empty
+    margin: 0
+
 // PAGINATION
 .pagination
   margin-top: 20px
@@ -1193,3 +1199,6 @@ a.breadcrumbs__home
   text-align: right
 .text--center
   text-align: center
+
+.course__registration-status
+  margin-bottom: 12px

frontend/src/utils/hide-columns/hide-columns.sass

@@ -58,5 +58,8 @@
     display: block
     clear: both
 
+  &:empty
+    margin: 0
+
 .hide-columns--hidden-cell
   display: none

src/Data/MonoTraversable/Instances.hs

@@ -0,0 +1,38 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.MonoTraversable.Instances
+  () where
+
+import ClassyPrelude
+
+import Data.Monoid (Any(..), All(..))
+
+
+type instance Element Any = Bool
+type instance Element All = Bool
+
+instance MonoFunctor Any where
+  omap f = Any . f . getAny
+
+instance MonoFunctor All where
+  omap f = All . f . getAll
+
+instance MonoPointed Any where
+  opoint = Any
+  
+instance MonoPointed All where
+  opoint = All
+
+instance MonoFoldable Any where
+  ofoldMap f = f . getAny
+  ofoldr f x (Any b) = f b x
+  ofoldl' f x (Any b) = f x b
+  ofoldr1Ex _ = getAny
+  ofoldl1Ex' _ = getAny
+
+instance MonoFoldable All where
+  ofoldMap f = f . getAll
+  ofoldr f x (All b) = f b x
+  ofoldl' f x (All b) = f x b
+  ofoldr1Ex _ = getAll
+  ofoldl1Ex' _ = getAll

src/Handler/Admin/StudyFeatures.hs

@@ -356,13 +356,13 @@ postAdminFeaturesR = do
           dbtSQLQuery = return
           dbtRowKey = (E.^. StudyTermsKey)
           dbtProj field@(view _dbrOutput -> Entity fId _) = do
-            fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
+            fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
               E.where_ . E.exists . E.from $ \schoolTerms ->
                 E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
                      E.&&. schoolTerms E.^. SchoolTermsTerms  E.==. E.val fId 
               E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
               return $ school E.^. SchoolId
-            fieldParents <- fmap (setOf folded) . lift . E.select . E.from $ \terms -> do
+            fieldParents <- fmap (setOf folded) . E.select . E.from $ \terms -> do
               E.where_ . E.exists . E.from $ \subTerms ->
                 E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId
                      E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId

src/Handler/Allocation/List.hs

@@ -69,7 +69,7 @@ getAllocationListR = do
                     <*> view queryAvailable
                     <*> view (maybe (to . const $ E.val 0) queryApplied muid)
 
-    dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) AllocationTableData
+    dbtProj :: DBRow _ -> DB AllocationTableData
     dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue
 
     dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)

src/Handler/Corrections.hs

@@ -1,4 +1,14 @@
-module Handler.Corrections where
+module Handler.Corrections
+  ( getCorrectionsR, postCorrectionsR
+  , getCCorrectionsR, postCCorrectionsR
+  , getSSubsR, postSSubsR
+  , getCorrectionR, postCorrectionR
+  , getCorrectionsUploadR, postCorrectionsUploadR
+  , getCorrectionsCreateR, postCorrectionsCreateR
+  , getCorrectionsGradeR, postCorrectionsGradeR
+  , getCAssignR, postCAssignR
+  , getSAssignR, postSAssignR
+  ) where
 
 import Import hiding (link)
 -- import System.FilePath (takeFileName)
@@ -68,12 +78,6 @@ lastEditQuery submission = E.subSelectMaybe $ E.from $ \edit -> do
   E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
   return $ E.max_ $ edit E.^. SubmissionEditTime
 
-queryCourse :: CorrectionTableExpr -> E.SqlExpr (Entity Course)
-queryCourse = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
-
-querySheet :: CorrectionTableExpr -> E.SqlExpr (Entity Sheet)
-querySheet = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
-
 querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission)
 querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
 
@@ -116,11 +120,6 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row ->
               shn   = sheetName $ entityVal sheet
           in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|_{shn}|]
 
-colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $
-        i18nCell . sheetType <$> view (_dbrOutput . _2 . _entityVal)
-        -- \DBRow{ dbrOutput=(_, sheet, _, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
-
 colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
   DBRow{ dbrOutput = (_, _, _, Nothing  , _, _) } -> cell mempty
@@ -220,8 +219,8 @@ colLastEdit = sortable (Just "last-edit") (i18nCell MsgLastEdit) $
 
 
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> _ -> DBParams m x -> DB (DBResult m x)
+                     => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x)
-makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' dbtParams = do
+makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams = do
   let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
       dbtSQLQuery = correctionsTableQuery whereClause
           (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
@@ -232,9 +231,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
                         )
             in (submission, sheet, crse, corrector, lastEditQuery submission)
           )
-      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerFor UniWorX)) CorrectionTableData
+      dbtProj :: DBRow _ -> DB CorrectionTableData
       dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector,  E.Value mbLastEdit) -> do
-        submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
+        submittors <- E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
           E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
            E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
           E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
@@ -243,7 +242,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
           return (user, pseudonym E.?. SheetPseudonymPseudonym)
         let
           submittorMap = List.foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
-        dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap)
+        return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap)
   dbTable psValidator DBTable
     { dbtSQLQuery
     , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
@@ -420,7 +419,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
     }
 
   ((actionRes', statistics), table) <- runDB $
-    makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator return DBParamsForm
+    makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator DBParamsForm
       { dbParamsFormMethod = POST
       , dbParamsFormAction = Just $ SomeRoute currentRoute
       , dbParamsFormAttrs = []
@@ -1055,12 +1054,8 @@ postCorrectionsGradeR = do
       psValidator = def
         & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
       unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
-      dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do
-        cID <- encrypt subId
-        void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
-        return i
 
-  (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator dbtProj' $ def
+  (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def
     { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
     }
 
@@ -1099,9 +1094,6 @@ embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id
 instance Button UniWorX ButtonSubmissionsAssign where
   btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary]
 
--- | DEPRECATED use CorrectorInfo instead. Gather info about corrector assignment per sheet
-data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiCorrectorNr, saiUnassignedNr :: Int }
-
 getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCAssignR = postCAssignR
 postCAssignR tid ssh csh = do

src/Handler/Course/Application/List.hs

@@ -257,6 +257,7 @@ getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -
 getCApplicationsR = postCApplicationsR
 postCApplicationsR tid ssh csh = do
   (table, allocationsBounds, mayAccept) <- runDB $ do
+    now <- liftIO getCurrentTime
     Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
 
     csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh)
@@ -295,6 +296,8 @@ postCApplicationsR tid ssh csh = do
           E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
            E.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid
 
+          E.where_ $ E.maybe E.true (E.maybe E.false (E.<=. E.val now)) (allocation E.?. AllocationStaffAllocationFrom)
+
         return ( courseApplication
                , user
                , hasFiles
@@ -305,14 +308,8 @@ postCApplicationsR tid ssh csh = do
                , E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
                )
 
-      dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
+      dbtProj :: DBRow _ -> DB CourseApplicationsTableData
-      dbtProj = runReaderT $ do
+      dbtProj = traverse $ return . over _3 E.unValue . over _8 E.unValue
-        appId <- view $ _dbrOutput . _1 . _entityKey
-        cID <- encrypt appId
-        
-        guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
-
-        asks $ over (_dbrOutput . _3) E.unValue . over (_dbrOutput . _8) E.unValue
 
       dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
 
@@ -431,7 +428,6 @@ postCApplicationsR tid ssh csh = do
             CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
         , dbtCsvCoarsenActionClass = const DBCsvActionExisting
         , dbtCsvExecuteActions = do
-            now <- liftIO getCurrentTime
             C.mapM_ $ \case
               CourseApplicationsTableCsvSetFieldData{..} -> do
                 CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField

src/Handler/Course/List.hs

@@ -83,10 +83,10 @@ makeCourseTable whereClause colChoices psValidator = do
         E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
         E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
         return user
-      dbtProj :: DBRow _ -> MaybeT DB CourseTableData
+      dbtProj :: DBRow _ -> DB CourseTableData
       dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
-        lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
+        lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
-        courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course)
+        courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course)
                           >>= traverse (getJustEntity . allocationCourseAllocation . entityVal)
         return (course, participants, registered, school, lecturerList, courseAlloc)
   snd <$> dbTable psValidator DBTable

src/Handler/Course/Show.hs

@@ -20,6 +20,8 @@ import Handler.Course.Register
 
 import qualified Data.Conduit.List as C
 
+import Handler.Exam.List (mkExamTable)
+
 
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
@@ -188,73 +190,7 @@ getCShowR tid ssh csh = do
       & defaultSorting [SortAscBy "type", SortAscBy "name"]
   (Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
 
-  let
+  (Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course
-    examDBTable = DBTable{..}
-      where
-        dbtSQLQuery exam = do
-          E.where_ $ exam E.^. ExamCourse E.==. E.val cid
-          return exam
-        dbtRowKey = (E.^. ExamId)
-        dbtProj r@DBRow{ dbrOutput = Entity _ Exam{..} } = do
-          guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
-          return r
-        dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
-          , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
-          , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
-          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
-          , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
-              mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
-              isRegistered <- case mbAid of
-                Nothing  -> return False
-                Just uid -> existsBy $ UniqueExamRegistration eId uid
-              let label   = bool MsgExamNotRegistered MsgExamRegistered isRegistered
-                  examUrl = CExamR tid ssh csh examName EShowR
-              if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
-                 | otherwise   -> return [whamlet|_{label}|]
-          -- , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
-          --     mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
-          --     isRegistered <- case mbAid of
-          --       Nothing  -> return False
-          --       Just uid -> existsBy $ UniqueExamRegistration eId uid
-          --     if
-          --       | mayRegister -> do
-          --           (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
-          --           return $ wrapForm examRegisterForm def
-          --             { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
-          --             , formEncoding = examRegisterEnctype
-          --             , formSubmit = FormNoSubmit
-          --             }
-          --       | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
-          --       | otherwise -> return mempty
-          ]
-        dbtSorting = Map.fromList
-          [ ("name", SortColumn $ \exam -> exam E.^. ExamName )
-          , ("time", SortColumn $ \exam -> exam E.^. ExamStart )
-          , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
-          , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
-          , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
-          , ("registered", SortColumn $ \exam ->
-              case mbAid of
-                Nothing -> E.false
-                Just uid ->
-                  E.exists $ E.from $ \reg -> do
-                    E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
-                    E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
-            )
-          ]
-        dbtFilter = Map.empty
-        dbtFilterUI = const mempty
-        dbtStyle = def
-        dbtParams = def
-        dbtIdent :: Text
-        dbtIdent = "exams"
-        dbtCsvEncode = noCsvEncode
-        dbtCsvDecode = Nothing
-
-    examDBTableValidator = def
-      & defaultSorting [SortAscBy "time"]
-  (Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
 
   let visibleNews = any (view _3) news
       showNewsFiles fs = and

src/Handler/Course/Users.hs

@@ -299,8 +299,8 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
         dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
         dbtRowKey    = queryUser >>> (E.^. UserId)
         dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> do
-          tuts'' <- lift $ selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
+          tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
-          exams' <- lift $ selectList [ ExamRegistrationUser ==. entityKey user ] []
+          exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] []
           let
             regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
             tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials

src/Handler/Exam/List.hs

@@ -1,5 +1,6 @@
 module Handler.Exam.List
-  ( getCExamListR
+  ( mkExamTable
+  , getCExamListR
   ) where
 
 import Import
@@ -9,12 +10,16 @@ import Handler.Utils
 import qualified Data.Map as Map
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 
 
-getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+mkExamTable :: Entity Course -> DB (Any, Widget)
-getCExamListR tid ssh csh = do
+mkExamTable (Entity cid Course{..}) = do
-  Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+  let tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
   now <- liftIO getCurrentTime
+  mbAid <- maybeAuthId
   mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
 
   let
@@ -24,15 +29,22 @@ getCExamListR tid ssh csh = do
           E.where_ $ exam E.^. ExamCourse E.==. E.val cid
           return exam
         dbtRowKey = (E.^. ExamId)
-        dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do
+        dbtProj = return
-          guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
-          return x
         dbtColonnade = dbColonnade . mconcat $ catMaybes
-          [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName
+          [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
           , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
           , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
           , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
           , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
+          , Just . sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
+              mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
+              isRegistered <- case mbAid of
+                Nothing  -> return False
+                Just uid -> existsBy $ UniqueExamRegistration eId uid
+              let label   = bool MsgExamNotRegistered MsgExamRegistered isRegistered
+                  examUrl = CExamR tid ssh csh examName EShowR
+              if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
+                 | otherwise   -> return [whamlet|_{label}|]
           ]
         dbtSorting = Map.fromList
           [ ("name", SortColumn $ \exam -> exam E.^. ExamName )
@@ -40,8 +52,18 @@ getCExamListR tid ssh csh = do
           , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
           , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
           , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
+          , ("registered", SortColumn $ \exam ->
+              case mbAid of
+                Nothing -> E.false
+                Just uid ->
+                  E.exists $ E.from $ \reg -> do
+                    E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
+                    E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
+            )
           ]
-        dbtFilter = Map.empty
+        dbtFilter = singletonMap "may-read" . FilterProjected $
+          \(Any b) DBRow{ dbrOutput = Entity _ Exam{..} }
+           -> (== b) <$> hasReadAccessTo (CExamR tid ssh csh examName EShowR) :: DB Bool
         dbtFilterUI = const mempty
         dbtStyle = def
         dbtParams = def
@@ -52,7 +74,17 @@ getCExamListR tid ssh csh = do
 
     examDBTableValidator = def
       & defaultSorting [SortAscBy "time"]
-  ((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable
+      & forceFilter "may-read" (Any True)
+  
+  dbTable examDBTableValidator examDBTable
+
+
+getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCExamListR tid ssh csh = do
+  (Entity _ Course{..}, examTable) <- runDB $ do
+    c <- getBy404 $ TermSchoolCourseShort tid ssh csh
+    (_, examTable) <- mkExamTable c
+    return (c, examTable)
 
   siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
     setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading

src/Handler/Exam/Users.hs

@@ -485,10 +485,10 @@ postEUsersR tid ssh csh examn = do
               <*> getExamParts
               <*> view _9
             where
-              getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
+              getExamParts :: ReaderT _ DB (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
               getExamParts = do
                 uid <- view $ _2 . _entityKey
-                rawResults <- lift . lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do
+                rawResults <- lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do
                   E.on $ examPartResult E.?. ExamPartResultExamPart E.==. E.just (examPart E.^. ExamPartId)
                    E.&&. examPartResult E.?. ExamPartResultUser     E.==. E.just (E.val uid)
                   E.where_ $ examPart E.^. ExamPartExam E.==. E.val eid

src/Handler/ExamOffice/Exam.hs

@@ -276,16 +276,16 @@ postEGradesR tid ssh csh examn = do
             return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
           dbtRowKey = views queryExamResult (E.^. ExamResultId)
 
-          dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamUserTableData
+          dbtProj :: DBRow _ -> DB ExamUserTableData
           dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
             (,,,,,,,,)
               <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view (_8 . _Value)
               <*> getSynchronised
             where
-              getSynchronised :: ReaderT _ (MaybeT (YesodDB UniWorX)) [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
+              getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
               getSynchronised = do
                 resId <- view $ _1 . _entityKey
-                syncs <- lift . lift . E.select . E.from $ \(examOfficeResultSynced `E.InnerJoin` user) -> do
+                syncs <- lift . E.select . E.from $ \(examOfficeResultSynced `E.InnerJoin` user) -> do
                   E.on $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. user E.^. UserId
                   E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedResult E.==. E.val resId
                   return ( examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice

src/Handler/ExamOffice/Exams.hs

@@ -142,21 +142,17 @@ getEOExamsR = do
             return (exam, course, externalExam, synchronised, results)
           dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId))
 
-          dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamsTableData
+          dbtProj :: DBRow _ -> DB ExamsTableData
           dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
             exam <- view _1
             course <- view _2
             externalExam <- view _3
 
             case (exam, course, externalExam) of
-              (Just exam', Just course', Nothing) -> do
+              (Just exam', Just course', Nothing) ->
-                guard =<< hasReadAccessTo (urlRoute $ examLink (entityVal course') (entityVal exam'))
-    
                 (,,)
                   <$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value)
-              (Nothing, Nothing, Just externalExam') -> do
+              (Nothing, Nothing, Just externalExam') ->
-                guard =<< hasReadAccessTo (urlRoute $ externalExamLink (entityVal externalExam'))
-    
                 (,,)
                   <$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value)
               _other -> return $ error "Got exam & externalExam in same result"
@@ -216,7 +212,14 @@ getEOExamsR = do
             ]
 
           dbtFilter = mconcat
-            [
+            [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if
+                | Just exam <- r ^? resultExam . _entityVal
+                , Just course <- r ^? resultCourse . _entityVal
+                -> hasReadAccessTo . urlRoute $ examLink course exam
+                | Just eexam <- r ^? resultExternalExam . _entityVal
+                -> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool
+                | otherwise
+                -> return $ error "Got neither exam nor externalExam in result"
             ]
           dbtFilterUI = mconcat
             [
@@ -231,7 +234,9 @@ getEOExamsR = do
           dbtCsvEncode = noCsvEncode
           dbtCsvDecode = Nothing
 
-      examsDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"]
+      examsDBTableValidator = def
+        & defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"]
+        & forceFilter "may-access" (Any True)
 
     dbTableWidget' examsDBTableValidator examsDBTable
 

src/Handler/ExternalExam/List.hs

@@ -46,9 +46,7 @@ getEExamListR = do
 
           return (eexam, school)
         dbtRowKey = queryEExam >>> (E.^. ExternalExamId)
-        dbtProj x@(view resultEExam -> Entity _ ExternalExam{..}) = do
+        dbtProj = return
-          guardM . hasReadAccessTo $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR
-          return x
         dbtColonnade = widgetColonnade $ mconcat
           [ sortable (Just "term") (i18nCell MsgTerm) $ \(view resultEExam -> Entity _ ExternalExam{..}) -> i18nCell . ShortTermIdentifier $ unTermKey externalExamTerm
           , sortable (Just "school") (i18nCell MsgSchool) $ \(view resultSchool -> Entity _ School{..}) -> i18nCell schoolName
@@ -61,7 +59,10 @@ getEExamListR = do
           , ("course", SortColumn $ queryEExam >>> (E.^. ExternalExamCourseName))
           , ("name", SortColumn $ queryEExam >>> (E.^. ExternalExamExamName))
           ]
-        dbtFilter = Map.empty
+        dbtFilter = mconcat
+          [ singletonMap "may-access" . FilterProjected $ \(Any b) (view resultEExam -> Entity _ ExternalExam{..}) -> (==b) <$>
+              hasReadAccessTo (EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR) :: DB Bool
+          ]
         dbtFilterUI = const mempty
         dbtStyle = def
         dbtParams = def
@@ -71,6 +72,7 @@ getEExamListR = do
         dbtCsvDecode = Nothing
     examDBTableValidator = def
       & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "name"]
+      & forceFilter "may-access" (Any True)
 
   examTable <- runDB $ dbTableWidget' examDBTableValidator examDBTable
 

src/Handler/Material.hs

@@ -103,6 +103,7 @@ getMaterialListR tid ssh csh = do
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
     let row2material = view $ _dbrOutput . _1 . _entityVal
         psValidator  = def & defaultSorting [SortDescBy "last-edit"]
+                           & forceFilter "may-access" (Any True)
     dbTableWidget' psValidator DBTable
       { dbtIdent     = "material-list" :: Text
       , dbtStyle     = def
@@ -114,8 +115,7 @@ getMaterialListR tid ssh csh = do
                 E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
           return (material, filesNum)
       , dbtRowKey    = (E.^. MaterialId)
-      -- , dbtProj      = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
+      , dbtProj      = return
-      , dbtProj      = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->)
       , dbtColonnade = widgetColonnade $ mconcat
             [ -- dbRow,
               sortable (Just "type") (i18nCell MsgMaterialType)
@@ -141,7 +141,10 @@ getMaterialListR tid ssh csh = do
             , ( "visible-from" , SortColumn (E.^. MaterialVisibleFrom) )
             , ( "last-edit"    , SortColumn (E.^. MaterialLastEdit)    )
             ]
-      , dbtFilter    = mempty
+      , dbtFilter    = mconcat
+        [ singletonMap "may-access" . FilterProjected $ \(Any b) dbr 
+            -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool
+        ]
       , dbtFilterUI  = mempty
       , dbtCsvEncode  = noCsvEncode
       , dbtCsvDecode  = Nothing
@@ -205,7 +208,7 @@ getMShowR tid ssh csh mnm = do
             , colFilePathSimple   (view $ _dbrOutput . _1) matLink
             , materialModDateCol  (view $ _dbrOutput . _2)
             ]
-      , dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr
+      , dbtProj     = return
       , dbtStyle    = def
       , dbtParams   = def
       , dbtFilter   = mempty
@@ -219,6 +222,8 @@ getMShowR tid ssh csh mnm = do
       , dbtCsvDecode  = Nothing
       }
     return (matEnt,fileTable')
+  -- File table has no filtering by access, because we assume that
+  -- access rights to material and material-files are identical.
 
   let matLastEdit      = formatTimeW    SelFormatDateTime  $  materialLastEdit    material
   let matVisibleFromMB = visibleUTCTime SelFormatDateTime <$> materialVisibleFrom material

src/Handler/News.hs

@@ -86,12 +86,12 @@ newsUpcomingSheets uid = do
                                         (hasTickmark True)
         ]
   let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
+                      & forceFilter "may-access" (Any True)
   sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable
     { dbtSQLQuery  = tableData
     , dbtRowKey    = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
     , dbtColonnade = colonnade
-    , dbtProj      = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
+    , dbtProj      = return
-                        -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
     , dbtSorting   = Map.fromList
                       [ ( "term"
                         , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
@@ -112,12 +112,17 @@ newsUpcomingSheets uid = do
                         , SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` _ `E.LeftOuterJoin` (subm `E.InnerJoin` _)) -> E.isNothing $ subm E.?. SubmissionId
                         )
                       ]
-    , dbtFilter    =  mempty {- [ ( "term"
+    , dbtFilter    =  mconcat
-                        , FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
+          [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
-                            | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
+              let (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) = dbrOutput :: ( E.Value (Key Term)
-                            | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
+                                                                                            , E.Value SchoolId
-                        )
+                                                                                            , E.Value CourseShorthand
-                        ] -}
+                                                                                            , E.Value SheetName
+                                                                                            , E.Value (Maybe UTCTime)
+                                                                                            , E.Value (Maybe SubmissionId)
+                                                                                            )
+               in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn SShowR) :: DB Bool
+          ]
     , dbtFilterUI  = mempty
     , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
     , dbtParams    = def
@@ -172,11 +177,7 @@ newsUpcomingExams uid = do
             E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
             return (course, exam, register, occurrence)
           dbtRowKey = queryExam >>> (E.^. ExamId)
-          dbtProj r@DBRow{ dbrOutput } = do
+          dbtProj = return
-            let Entity _ Exam{..}   = view lensExam   dbrOutput
-                Entity _ Course{..} = view lensCourse dbrOutput
-            guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
-            return r
           dbtColonnade = dbColonnade $ mconcat
             [ sortable (Just "term") (i18nCell MsgTerm)           $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
                 msgCell courseTerm
@@ -245,7 +246,12 @@ newsUpcomingExams uid = do
                   E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
               ))
             ]
-          dbtFilter = Map.empty
+          dbtFilter = mconcat
+            [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
+                let Entity _ Exam{..}   = view lensExam   dbrOutput
+                    Entity _ Course{..} = view lensCourse dbrOutput
+                in (==b) <$> hasReadAccessTo (CExamR courseTerm courseSchool courseShorthand examName EShowR) :: DB Bool
+            ]
           dbtFilterUI = const mempty
           dbtStyle = def
           dbtParams = def
@@ -256,6 +262,7 @@ newsUpcomingExams uid = do
 
       examDBTableValidator = def
         & defaultSorting [SortAscBy "time"]
+        & forceFilter "may-access" (Any True)
 
     (, userWarningDays) <$> dbTable examDBTableValidator examDBTable
 

src/Handler/School.hs

@@ -19,7 +19,7 @@ getSchoolListR = do
     dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
     dbtSQLQuery = return
 
-    dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) (DBRow (Entity School))
+    dbtProj :: DBRow _ -> DB (DBRow (Entity School))
     dbtProj = return
 
     dbtRowKey = (E.^. SchoolId)

src/Handler/Sheet.hs

@@ -269,6 +269,7 @@ getSheetListR tid ssh csh = do
 
     psValidator = def
       & defaultSorting [SortDescBy "submission-until", SortDescBy "submission-since"]
+      & forceFilter "may-access" (Any True)
 
   (raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
       { dbtColonnade = sheetCol
@@ -282,8 +283,7 @@ getSheetListR tid ssh csh = do
                                 )
                           return (sheet, lastSheetEdit sheet, submission, existFiles)
       , dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
-      , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _, _) }
+      , dbtProj = return
-                    -> dbr <$ guardM (lift $ sheetFilter sheetName)
       , dbtSorting   = Map.fromList
         [ ( "name"
           , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
@@ -310,7 +310,11 @@ getSheetListR tid ssh csh = do
   --             (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
   --         )
         ]
-      , dbtFilter    = mempty
+      , dbtFilter    = mconcat
+        [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
+            let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
+             in (==b) <$> sheetFilter sheetName :: DB Bool
+        ]
       , dbtFilterUI  = mempty
       , dbtStyle     = def
       , dbtParams    = def
@@ -375,14 +379,18 @@ getSShowR tid ssh csh shn = do
         -- , colFileModification (view _2)
         ]
   let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
+                        & forceFilter "may-access" (Any True)
   (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery = fileData
     , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
     , dbtColonnade = colonnadeFiles
-    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
+    , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
-                   -> guardAuthorizedFor (CSheetR tid ssh csh shn $ SFileR fType fName) dbrOutput
     , dbtStyle = def
-    , dbtFilter = mempty
+    , dbtFilter = mconcat
+        [ singletonMap "may-access" . FilterProjected $ \(Any b) r ->
+            let (E.Value fName, _, E.Value fType) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
+             in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
+        ]
     , dbtFilterUI = mempty
     , dbtIdent = "files" :: Text
     , dbtSorting = Map.fromList

src/Handler/SystemMessage.hs

@@ -175,7 +175,7 @@ postMessageListR = do
             in cell . toWidget $ fromMaybe content summary
       ]
     dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
-      Just (_, smT) <- lift $ getSystemMessage appLanguages smId
+      smT <- (>>= view _2) <$> getSystemMessage appLanguages smId
       return DBRow
         { dbrOutput = (smE, smT)
         , ..

src/Handler/Utils/ExternalExam/Users.hs

@@ -194,16 +194,16 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
       return (result, user, isSynced)
     dbtRowKey = views queryResult (E.^. ExternalExamResultId)
 
-    dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExternalExamUserTableData
+    dbtProj :: DBRow _ -> DB ExternalExamUserTableData
     dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
       (,,,)
         <$> view _1 <*> view _2 <*> view (_3 . _Value)
         <*> getSynchronised
       where
-        getSynchronised :: ReaderT _ (MaybeT (YesodDB UniWorX)) [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
+        getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
         getSynchronised = do
           resId <- view $ _1 . _entityKey
-          syncs <- lift . lift . E.select . E.from $ \(examOfficeExternalResultSynced `E.InnerJoin` user) -> do
+          syncs <- lift . E.select . E.from $ \(examOfficeExternalResultSynced `E.InnerJoin` user) -> do
             E.on $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. user E.^. UserId
             E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedResult E.==. E.val resId
             return ( examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice

src/Handler/Utils/Table/Columns.hs

@@ -58,10 +58,10 @@ type OpticColonnade focus
     -> Colonnade h r' (DBCell m x)
 
 type OpticSortColumn' focus
-  = forall t sortingMap.
+  = forall t r' sortingMap.
        ( IsMap sortingMap
        , ContainerKey sortingMap ~ SortingKey
-       , MapValue sortingMap ~ SortColumn t
+       , MapValue sortingMap ~ SortColumn t r'
        )
     => (forall focus'. Getting focus' t focus)
     -> sortingMap
@@ -69,10 +69,10 @@ type OpticSortColumn' focus
 type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val))
 
 type OpticFilterColumn' t inp focus
-  = forall filterMap.
+  = forall r' filterMap.
        ( IsMap filterMap
        , ContainerKey filterMap ~ FilterKey
-       , MapValue filterMap ~ FilterColumn t
+       , MapValue filterMap ~ FilterColumn t r'
        , IsFilterColumn t (t -> inp -> E.SqlExpr (E.Value Bool))
        )
     => (forall focus'. Getting focus' t focus)
@@ -425,10 +425,10 @@ colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell Ms
   where conDTCell = ifCell condition dateTimeCell $ const mempty
 
 
-sortFilePath :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r)
+sortFilePath :: IsString s => (t -> E.SqlExpr (Entity File)) -> (s, SortColumn t r')
 sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle))
 
-sortFileModification :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r)
+sortFileModification :: IsString s => (t -> E.SqlExpr (Entity File)) -> (s, SortColumn t r')
 sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. FileModified))
 
 defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x
@@ -484,7 +484,7 @@ colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route
 colUserNameLink userLink = sortable (Just "user-name") (i18nCell MsgCourseMembers) (cellHasUserLink userLink)
 
 -- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
-sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
 sortUserName queryUser = ("user-name", SortColumns $ queryUser >>> \user ->
                                                        [ SomeExprValue $ user E.^. UserSurname
                                                        , SomeExprValue $ user E.^. UserDisplayName
@@ -492,13 +492,13 @@ sortUserName queryUser = ("user-name", SortColumns $ queryUser >>> \user ->
                          )
 
 -- | Alias for sortUserName for consistency, since column comes in two variants
-sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
 sortUserNameLink = sortUserName
 
-sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
 sortUserSurname queryUser = ("user-surname", SortColumn $ queryUser >>> (E.^. UserSurname))
 
-sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
 sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>> (E.^. UserDisplayName))
 
 defaultSortingByName :: PSValidator m x -> PSValidator m x
@@ -507,37 +507,37 @@ defaultSortingByName =
   defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter
 
 -- | Alias for sortUserName for consistency
-fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t)
+fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t r')
 fltrUserNameLink = fltrUserName
 
 fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
-  -> (d, FilterColumn t)
+  -> (d, FilterColumn t r')
 fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName )
   where
     queryName = queryUser >>> (E.^. UserDisplayName)
 
 fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
-  -> (d, FilterColumn t)
+  -> (d, FilterColumn t r')
 fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName )
   where
     queryName = queryUser >>> (E.^. UserDisplayName)
 
 fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
-  -> (d, FilterColumn t)
+  -> (d, FilterColumn t r')
 fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname))
 
 fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
-  -> (d, FilterColumn t)
+  -> (d, FilterColumn t r')
 fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName))
 
 -- | Search all names, i.e. DisplayName, Surname, EMail
 fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
    => (a -> E.SqlExpr (Entity User))
-   -> (d, FilterColumn t)
+   -> (d, FilterColumn t r')
 fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
     [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)
     , mkContainsFilter $ queryUser >>> (E.^. UserSurname)
@@ -579,14 +579,14 @@ fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation"
 colUserMatriclenr ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
 colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
 
-sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
+sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
 sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
 
 fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
                       , IsString d
                       )
                    => (a -> E.SqlExpr (Entity User))
-                   -> (d, FilterColumn t)
+                   -> (d, FilterColumn t r')
 fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer))
 
 fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
@@ -599,14 +599,14 @@ fltrUserMatriclenrUI mPrev =
 colUserEmail ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
 colUserEmail = sortable (Just "user-email") (i18nCell MsgEMail) cellHasEMail
 
-sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
+sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
 sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail))
 
 fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool))
                  , IsString d
                  )
               => (a -> E.SqlExpr (Entity User))
-              -> (d, FilterColumn t)
+              -> (d, FilterColumn t r')
 fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail))
 
 fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
@@ -724,14 +724,14 @@ fltrStudyFeaturesSemesterUI mPrev = prismAForm (singletonFilter "features-semest
 colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
 colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature
 
-sortFeaturesSemester :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (d, SortColumn t)
+sortFeaturesSemester :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (d, SortColumn t r')
 sortFeaturesSemester queryFeatures = ("features-semester", SortColumn $ queryFeatures >>> (E.?. StudyFeaturesSemester))
 
 fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool))
                         , IsString d
                         )
                      => (a -> E.SqlExpr (Maybe (Entity StudyFeatures)))
-                     -> (d, FilterColumn t)
+                     -> (d, FilterColumn t r')
 fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester))
 
 fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
@@ -742,14 +742,14 @@ fltrFeaturesSemesterUI mPrev =
 colField :: (IsDBTable m c, HasStudyTerms x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
 colField terms = sortable (Just "terms") (i18nCell MsgStudyTerm) $ maybe mempty cellHasField . firstOf terms
 
-sortField :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (d, SortColumn t)
+sortField :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (d, SortColumn t r')
 sortField queryTerms = ("terms", SortColumn $ queryTerms >>> (E.?. StudyTermsName))
 
 fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
              , IsString d
              )
           => (a -> E.SqlExpr (Maybe (Entity StudyTerms)))
-          -> (d, FilterColumn t)
+          -> (d, FilterColumn t r')
 fltrField queryFeatures = ( "terms"
                           , FilterColumn $ anyFilter
                             [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName)
@@ -766,14 +766,14 @@ fltrFieldUI mPrev =
 colDegreeShort :: (IsDBTable m c, HasStudyDegree x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
 colDegreeShort terms = sortable (Just "degree-short") (i18nCell MsgDegreeShort) $ maybe mempty cellHasDegreeShort . firstOf terms
 
-sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (d, SortColumn t)
+sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (d, SortColumn t r')
 sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand))
 
 fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
              , IsString d
              )
           => (a -> E.SqlExpr (Maybe (Entity StudyDegree)))
-          -> (d, FilterColumn t)
+          -> (d, FilterColumn t r')
 fltrDegree queryFeatures = ( "degree"
                           , FilterColumn $ anyFilter
                             [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName)

src/Handler/Utils/Table/Pagination.hs

@@ -26,6 +26,7 @@ module Handler.Utils.Table.Pagination
   , defaultPagesize
   , defaultFilter, defaultSorting
   , restrictFilter, restrictSorting
+  , forceFilter
   , ToSortable(..), Sortable(..)
   , dbTable
   , dbTableWidget, dbTableWidget'
@@ -145,8 +146,9 @@ dbFilterKey ident = toPathPiece . WithIdent ident
 
 data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }
   
-data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
+data SortColumn t r' = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
-                  | SortColumns { getSortColumns :: t -> [SomeExprValue] }
+                     | SortColumns { getSortColumns :: t -> [SomeExprValue] }
+                     | SortProjected { sortProjected :: r' -> r' -> Ordering }
 
 data SortDirection = SortAsc | SortDesc
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
@@ -157,11 +159,18 @@ instance Finite SortDirection
 nullaryPathPiece ''SortDirection $ camelToPathPiece' 1
 pathPieceJSON ''SortDirection
 
-sqlSortDirection :: t -> (SortColumn t, SortDirection) -> [E.SqlExpr E.OrderBy]
+sqlSortDirection :: SortColumn t r' -> Maybe (SortDirection -> t -> [E.SqlExpr E.OrderBy])
-sqlSortDirection t (SortColumn  e , SortAsc ) = pure . E.asc  $ e t
+sqlSortDirection (SortColumn  e ) = Just $ \case
-sqlSortDirection t (SortColumn  e , SortDesc) = pure . E.desc $ e t
+  SortAsc  -> pure . E.asc  . e
-sqlSortDirection t (SortColumns es, SortAsc ) = es t <&> \(SomeExprValue v) -> E.asc  v
+  SortDesc -> pure . E.desc . e
-sqlSortDirection t (SortColumns es, SortDesc) = es t <&> \(SomeExprValue v) -> E.desc v
+sqlSortDirection (SortColumns es) = Just $ \case
+  SortAsc  -> fmap (\(SomeExprValue v) -> E.asc  v) . es
+  SortDesc -> fmap (\(SomeExprValue v) -> E.desc v) . es
+sqlSortDirection  _               = Nothing
+
+sortDirectionProjected :: SortColumn t r' -> r' -> r' -> Ordering
+sortDirectionProjected SortProjected{..} = sortProjected
+sortDirectionProjected _                 = \_ _ -> EQ
 
 
 data SortingSetting = SortingSetting
@@ -188,10 +197,16 @@ pattern SortDescBy :: SortingKey -> SortingSetting
 pattern SortDescBy key = SortingSetting key SortDesc
 
 
-data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a
+data FilterColumn t r' = forall a. IsFilterColumn t a => FilterColumn a
+                       | forall a. IsFilterProjected r' a => FilterProjected a
 
-filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
+filterColumn :: FilterColumn t r' -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
-filterColumn (FilterColumn f) = filterColumn' f
+filterColumn (FilterColumn f) = Just $ filterColumn' f
+filterColumn  _               = Nothing
+
+filterProjected :: FilterColumn t r' -> r' -> [Text] -> DB Bool
+filterProjected (FilterProjected f) = flip $ filterProjected' f
+filterProjected  _                  = \_ _ -> return True
 
 class IsFilterColumn t a where
   filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)
@@ -203,13 +218,22 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
   filterColumn' cont is' t = filterColumn' (cont t) is' t
 
 instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
-  filterColumn' cont is0 = filterColumn' (cont input) is'
+  filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
-    where
+  
-      (input, ($ []) -> is') = go (mempty, id) is0
+class IsFilterProjected r' a where
-      go acc [] = acc
+  filterProjected' :: a -> [Text] -> r' -> DB Bool
-      go (acc, is3) (i:is2)
+
-        | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2
+instance IsFilterProjected r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where
-        | otherwise = go (acc, is3 . (i:)) is2
+  filterProjected' fin _ _ = fin
+
+instance IsFilterProjected r' Bool where
+  filterProjected' fin _ _ = return fin
+
+instance IsFilterProjected r' cont => IsFilterProjected r' (r' -> cont) where
+  filterProjected' cont is' r = filterProjected' (cont r) is' r
+
+instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected r' cont, MonoPointed l, Monoid l) => IsFilterProjected r' (l -> cont) where
+  filterProjected' cont is' = filterProjected' (cont $ is' ^. mono' _PathPiece) is'
 
 
 data PagesizeLimit = PagesizeLimit !Int64 | PagesizeAll
@@ -447,6 +471,16 @@ restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> ov
   where
     restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
 
+forceFilter :: ( MonoFoldable mono
+               , MonoPointed mono
+               , Monoid mono
+               , PathPiece (Element mono)
+               )
+            => FilterKey -> mono -> PSValidator m x -> PSValidator m x
+forceFilter key args (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 inject $ f dbTable' ps
+  where
+    inject p = p { psFilter = psFilter p <> Map.singleton key (review monoPathPieces args) }
+
 restrictSorting :: (SortingKey -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
 restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
   where
@@ -520,9 +554,9 @@ data DBTCsvEncode r' k' csv = forall exportData.
   , DBTableKey k'
   , Typeable exportData
   ) => DBTCsvEncode
-  { dbtCsvExportForm   :: AForm (YesodDB UniWorX) exportData
+  { dbtCsvExportForm   :: AForm DB exportData
-  , dbtCsvHeader       :: Maybe exportData -> YesodDB UniWorX Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error
+  , dbtCsvHeader       :: Maybe exportData -> DB Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error
-  , dbtCsvDoEncode     :: exportData -> ConduitT (k', r') csv (YesodDB UniWorX) ()
+  , dbtCsvDoEncode     :: exportData -> ConduitT (k', r') csv DB ()
   , dbtCsvName         :: FilePath
   , dbtCsvNoExportData :: Maybe (AnIso' exportData ())
   }
@@ -535,14 +569,14 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException
   , Ord csvActionClass
   , Exception csvException
   ) => DBTCsvDecode
-  { dbtCsvRowKey :: csv -> MaybeT (YesodDB UniWorX) k'
+  { dbtCsvRowKey :: csv -> MaybeT DB k'
-  , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction (YesodDB UniWorX) ()
+  , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction DB ()
   , dbtCsvClassifyAction :: csvAction -> csvActionClass
   , dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
   , dbtCsvExecuteActions :: ConduitT csvAction Void (YesodJobDB UniWorX) route
   , dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
   , dbtCsvRenderActionClass :: csvActionClass -> Widget
-  , dbtCsvRenderException :: csvException -> YesodDB UniWorX Text
+  , dbtCsvRenderException :: csvException -> DB Text
   }
 
 data DBTable m x = forall a r r' h i t k k' csv.
@@ -553,10 +587,10 @@ data DBTable m x = forall a r r' h i t k k' csv.
   ) => DBTable
   { dbtSQLQuery :: t -> E.SqlQuery a
   , dbtRowKey :: t -> k                 -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
-  , dbtProj :: DBRow r -> MaybeT (YesodDB UniWorX) r'
+  , dbtProj :: DBRow r -> DB r'
   , dbtColonnade :: Colonnade h r' (DBCell m x)
-  , dbtSorting :: Map SortingKey (SortColumn t)
+  , dbtSorting :: Map SortingKey (SortColumn t r')
-  , dbtFilter :: Map FilterKey (FilterColumn t)
+  , dbtFilter :: Map FilterKey (FilterColumn t r')
   , dbtFilterUI :: DBFilterUI
   , dbtStyle :: DBStyle r'
   , dbtParams :: DBParams m x
@@ -565,7 +599,7 @@ data DBTable m x = forall a r r' h i t k k' csv.
   , dbtIdent :: i
   }
 
-type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text])
 
 noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
 noCsvEncode = Nothing
@@ -589,7 +623,7 @@ simpleCsvEncodeM :: forall fp r' k' csv.
                     , DBTableKey k'
                     , Textual fp
                     )
-                 => fp -> ReaderT r' (YesodDB UniWorX) csv -> Maybe (DBTCsvEncode r' k' csv)
+                 => fp -> ReaderT r' DB csv -> Maybe (DBTCsvEncode r' k' csv)
 simpleCsvEncodeM fName f = Just DBTCsvEncode
   { dbtCsvExportForm   = pure ()
   , dbtCsvDoEncode     = \() -> C.mapM (runReaderT f . view _2)
@@ -938,29 +972,45 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       Just csvColExplanations'' -> modal [whamlet|_{MsgCsvColumnsExplanationsLabel}|] $ Right $(widgetFile "table/csv-column-explanations")
       Nothing -> mempty
 
+    psFilter' = imap (\key args -> (, args) $ Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) psFilter
+
+    sortSql :: Maybe (_ -> [E.SqlExpr E.OrderBy])
+    sortSql = do
+      sqlSorting <- mapM (\(c, d) -> (, d) <$> sqlSortDirection c) psSorting'
+      return $ \t -> concatMap (\(f, d) -> f d t) sqlSorting
+
+    filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool)))
+    filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter'
+
+    selectPagesize = is _Just sortSql
+                  && all (is _Just) filterSql
+
+    psLimit' = bool PagesizeAll psLimit selectPagesize
+     
 
   rows' <- E.select . E.from $ \t -> do
     res <- dbtSQLQuery t
-    E.orderBy $ concatMap (sqlSortDirection t) psSorting'
+    whenIsJust sortSql $ \mkSorting ->
+      E.orderBy $ mkSorting t
     case csvMode of
       FormSuccess DBCsvExport{} -> return ()
       FormSuccess DBCsvImport{} -> return ()
       _other -> do
         case previousKeys of
           Nothing
-            | PagesizeLimit l <- psLimit
+            | PagesizeLimit l <- psLimit'
               -> do
                 E.limit l
                 E.offset (psPage * l)
           Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
           _other  -> return ()
-        Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter
+        Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql
     return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
 
   let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v
       firstRow :: Int64
       firstRow
-        | PagesizeLimit l <- psLimit
+        | PagesizeLimit l <- psLimit'
         = succ (psPage * l)
         | otherwise
         = 1
@@ -970,7 +1020,20 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
         | otherwise
         = id
 
-  (currentKeys, rows) <- fmap unzip . mapMaybeM' dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
+      allFilterProjected r' = lift $ getAll <$> foldMapM (\(f, args) -> All <$> filterProjected f r' args) psFilter'
+
+      sortProjected
+        | is _Just previousKeys
+        = id
+        | otherwise
+        = sortBy $ concatMap (\(c, d) (_, r) (_, r') -> adjustOrder d $ sortDirectionProjected c r r') psSorting'
+        where
+          adjustOrder SortAsc  x  = x
+          adjustOrder SortDesc LT = GT
+          adjustOrder SortDesc EQ = EQ
+          adjustOrder SortDesc GT = LT
+
+  (currentKeys, rows) <- fmap (unzip . sortProjected) . mapMaybeM' (assertMM allFilterProjected . lift . dbtProj) . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
 
 
   formResult csvMode $ \case
@@ -988,10 +1051,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                           , ..
                           } :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do
         let existing = Map.fromList $ zip currentKeys rows
-            sourceDiff :: ConduitT () (DBCsvDiff r' csv k') (StateT (Map k' csv) (YesodDB UniWorX)) ()
+            sourceDiff :: ConduitT () (DBCsvDiff r' csv k') (StateT (Map k' csv) DB) ()
             sourceDiff = do
               let
-                toDiff :: csv -> StateT (Map k' csv) (YesodDB UniWorX) (DBCsvDiff r' csv k')
+                toDiff :: csv -> StateT (Map k' csv) DB (DBCsvDiff r' csv k')
                 toDiff row = do
                   rowKey <- lift $
                     handle (throwM . (DBCsvException (toNamedRecord row) :: Text -> DBCsvException k') <=< dbtCsvRenderException) . runMaybeT $ dbtCsvRowKey row
@@ -1017,7 +1080,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
             importCsv = do
               let
-                dbtCsvComputeActions' :: ConduitT (DBCsvDiff r' csv k') Void (YesodDB UniWorX) (Map csvActionClass (Set csvAction))
+                dbtCsvComputeActions' :: ConduitT (DBCsvDiff r' csv k') Void DB (Map csvActionClass (Set csvAction))
                 dbtCsvComputeActions' = do
                   let innerAct = awaitForever $ \x
                         -> let doHandle
@@ -1152,7 +1215,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
             return $(widgetFile "table/colonnade")
 
     pageCount
-      | PagesizeLimit l <- psLimit
+      | PagesizeLimit l <- psLimit'
       = max 1 . ceiling $ rowCount % l
       | otherwise
       = 1
@@ -1166,6 +1229,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       , formSubmit = FormAutoSubmit
       , formAnchor = Just $ wIdent "pagesize-form"
       }
+    showPagesizeWdgt = toEnum (fromIntegral rowCount) > minimum (pagesizeOptions referencePagesize)
+                    && selectPagesize
 
     csvWdgt = $(widgetFile "table/csv-transcode")
 

src/Import/NoModel.hs

@@ -154,6 +154,7 @@ import Data.Bool.Instances as Import ()
 import Data.Encoding.Instances as Import ()
 import Prometheus.Instances as Import ()
 import Yesod.Form.Fields.Instances as Import ()
+import Data.MonoTraversable.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256)
 

src/Utils.hs

@@ -621,6 +621,12 @@ guardM f = guard =<< f
 assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
 assertM f x = x >>= assertM' f
 
+assertMM :: MonadPlus m => (a -> m Bool) -> m a -> m a
+assertMM f x = do
+  x' <- x
+  guardM $ f x'
+  return x'
+
 assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m ()
 assertM_ f x = guard . f =<< x
 

src/Utils/Lens.hs

@@ -248,3 +248,37 @@ instance HasHttpManager s Manager => Yesod.HasHttpManager s where
 
 class HasJSONWebKeySet s a | s -> a where
   jsonWebKeySet :: Lens' s a
+
+---------------
+-- PathPiece --
+---------------
+
+mono :: forall mono mono'.
+        ( MonoPointed mono
+        , MonoFoldable mono
+        , Monoid mono
+        , MonoPointed mono'
+        , MonoFoldable mono'
+        , Monoid mono'
+        ) => Prism' (Element mono) (Element mono') -> Iso' mono mono'
+mono p = iso (view $ mono' p) (view . mono' $ re p)
+
+mono' :: forall mono mono'.
+         ( MonoFoldable mono
+         , MonoPointed mono'
+         , Monoid mono'
+         )
+      => Getting (First (Element mono')) (Element mono) (Element mono')
+      -> Getter mono mono'
+mono' p' = to $ foldMap (maybe mempty opoint . preview p')
+
+monoPathPieces :: ( PathPiece (Element mono')
+                  , MonoPointed mono'
+                  , Monoid mono'
+                  , MonoFoldable mono'
+                  , Element mono ~ Text
+                  , MonoFoldable mono
+                  , MonoPointed mono
+                  , Monoid mono
+                  ) => Iso' mono mono'
+monoPathPieces = mono _PathPiece

templates/course.hamlet

@@ -169,6 +169,12 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
     <dt .deflist__dt>
       _{MsgCourseRegistration}
     <dd .deflist__dd>
+      <div .course__registration-status>
+        $maybe CourseParticipant{courseParticipantRegistration} <- registration
+          _{MsgRegisteredSince}
+          \ ^{formatTimeW SelFormatDateTime courseParticipantRegistration}
+        $nothing
+          _{MsgNotRegistered}
       <div .course__registration>
         $if registrationOpen
           $# regForm is defined through templates/widgets/registerForm
@@ -180,11 +186,6 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
             $if isJust registration
               <p>
                 _{MsgCourseRegistrationDeleteToEdit}
-        $maybe CourseParticipant{courseParticipantRegistration} <- registration
-          _{MsgRegisteredSince}
-          \ ^{formatTimeW SelFormatDateTime courseParticipantRegistration}
-        $nothing
-          _{MsgNotRegistered}
   <dt .deflist__dt>
     _{MsgCourseMaterial}
   <dd .deflist__dd>
@@ -197,7 +198,10 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
     <dd .deflist__dd>
       ^{examTable}
   $if not (null events) || mayCreateEvents
-    <dt .deflist__dt>_{MsgCourseEvents}
+    <dt .deflist__dt>
+      _{MsgCourseEvents}
+      $if null events
+        \ #{iconInvisible}
     <dd .deflist__dd>
       <div .scrolltable .scrolltable--bordered>
         <table .table .table--striped .table--hover>

templates/table/layout.hamlet

@@ -14,7 +14,7 @@ $else
       <div .table__row-count>
         _{MsgRowCount rowCount}
     $# Since the current pagesize is always a member of pagesizeOptions we don't need to check `pageCount > 1`
-    $if toEnum (fromIntegral rowCount) > minimum (pagesizeOptions referencePagesize)
+    $if showPagesizeWdgt
       ^{pagesizeWdgt'}
 
   $if pageCount > 1