diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 51a8c4062..57cc1e542 100644 --- a/frontend/src/app.sass +++ b/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 diff --git a/frontend/src/utils/hide-columns/hide-columns.sass b/frontend/src/utils/hide-columns/hide-columns.sass index dd4658954..47ff2dd04 100644 --- a/frontend/src/utils/hide-columns/hide-columns.sass +++ b/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 diff --git a/src/Data/MonoTraversable/Instances.hs b/src/Data/MonoTraversable/Instances.hs new file mode 100644 index 000000000..13405c291 --- /dev/null +++ b/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 diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs index f07bdc979..34be34134 100644 --- a/src/Handler/Admin/StudyFeatures.hs +++ b/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 diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index 081734394..fc6d7e48a 100644 --- a/src/Handler/Allocation/List.hs +++ b/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) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 6c705a102..93f636d63 100644 --- a/src/Handler/Corrections.hs +++ b/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) -makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' dbtParams = do + => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x) +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 diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index e3abfe205..3c6835c06 100644 --- a/src/Handler/Course/Application/List.hs +++ b/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 = runReaderT $ do - 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 + dbtProj :: DBRow _ -> DB CourseApplicationsTableData + dbtProj = traverse $ return . over _3 E.unValue . over _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 diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index cc499243b..5e2b5ff77 100644 --- a/src/Handler/Course/List.hs +++ b/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 - courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course) + lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course + courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course) >>= traverse (getJustEntity . allocationCourseAllocation . entityVal) return (course, participants, registered, school, lecturerList, courseAlloc) snd <$> dbTable psValidator DBTable diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index e07eec99f..1c8a6cca4 100644 --- a/src/Handler/Course/Show.hs +++ b/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 - 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 + (Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course let visibleNews = any (view _3) news showNewsFiles fs = and diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 8229537d7..f4093afea 100644 --- a/src/Handler/Course/Users.hs +++ b/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 ] [] - exams' <- lift $ selectList [ ExamRegistrationUser ==. entityKey user ] [] + tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] [] + exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] [] let regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs index 8a8aef894..6b4dae091 100644 --- a/src/Handler/Exam/List.hs +++ b/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 -getCExamListR tid ssh csh = do - Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh +mkExamTable :: Entity Course -> DB (Any, Widget) +mkExamTable (Entity cid Course{..}) = do + 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 - guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR - return x + dbtProj = return 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 diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index c99867bc7..91e19c86c 100644 --- a/src/Handler/Exam/Users.hs +++ b/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 diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 31ccea8c4..b7c497762 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/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 diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 67e15438c..be99b1737 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/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 - guard =<< hasReadAccessTo (urlRoute $ examLink (entityVal course') (entityVal exam')) - + (Just exam', Just course', Nothing) -> (,,) <$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value) - (Nothing, Nothing, Just externalExam') -> do - guard =<< hasReadAccessTo (urlRoute $ externalExamLink (entityVal externalExam')) - + (Nothing, Nothing, Just 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 diff --git a/src/Handler/ExternalExam/List.hs b/src/Handler/ExternalExam/List.hs index ac8f6e0b2..edd02e199 100644 --- a/src/Handler/ExternalExam/List.hs +++ b/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 - guardM . hasReadAccessTo $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR - return x + dbtProj = return 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 diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index bf387f85c..8c962d53f 100644 --- a/src/Handler/Material.hs +++ b/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 = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->) + , dbtProj = return , 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 diff --git a/src/Handler/News.hs b/src/Handler/News.hs index e5eab1715..9ae8ec113 100644 --- a/src/Handler/News.hs +++ b/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, _, _) } - -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False) + , dbtProj = return , 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" - , FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if - | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) - ) - ] -} + , dbtFilter = mconcat + [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} -> + let (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) = dbrOutput :: ( E.Value (Key Term) + , 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 - let Entity _ Exam{..} = view lensExam dbrOutput - Entity _ Course{..} = view lensCourse dbrOutput - guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights - return r + dbtProj = return 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 diff --git a/src/Handler/School.hs b/src/Handler/School.hs index fa0ef7fe1..ba4ebdd22 100644 --- a/src/Handler/School.hs +++ b/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) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 2292320a0..137fa3c64 100644 --- a/src/Handler/Sheet.hs +++ b/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{..}, _, _, _) } - -> dbr <$ guardM (lift $ sheetFilter sheetName) + , dbtProj = return , 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) } - -> guardAuthorizedFor (CSheetR tid ssh csh shn $ SFileR fType fName) dbrOutput + , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType) , 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 diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 13ebabe6d..321b84310 100644 --- a/src/Handler/SystemMessage.hs +++ b/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) , .. diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 545a5bbe2..0545297cf 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/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 diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 61ed1ce07..3eee7527b 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/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) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index ab8e8ec95..7e4498fd9 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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) } - | SortColumns { getSortColumns :: t -> [SomeExprValue] } +data SortColumn t r' = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } + | 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 t (SortColumn e , SortAsc ) = pure . E.asc $ e t -sqlSortDirection t (SortColumn e , SortDesc) = pure . E.desc $ e t -sqlSortDirection t (SortColumns es, SortAsc ) = es t <&> \(SomeExprValue v) -> E.asc v -sqlSortDirection t (SortColumns es, SortDesc) = es t <&> \(SomeExprValue v) -> E.desc v +sqlSortDirection :: SortColumn t r' -> Maybe (SortDirection -> t -> [E.SqlExpr E.OrderBy]) +sqlSortDirection (SortColumn e ) = Just $ \case + SortAsc -> pure . E.asc . e + SortDesc -> pure . E.desc . e +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 f) = filterColumn' f +filterColumn :: FilterColumn t r' -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool)) +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' - where - (input, ($ []) -> is') = go (mempty, id) is0 - go acc [] = acc - go (acc, is3) (i:is2) - | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2 - | otherwise = go (acc, is3 . (i:)) is2 + filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is' + +class IsFilterProjected r' a where + filterProjected' :: a -> [Text] -> r' -> DB Bool + +instance IsFilterProjected r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where + 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 - , dbtCsvHeader :: Maybe exportData -> YesodDB UniWorX Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error - , dbtCsvDoEncode :: exportData -> ConduitT (k', r') csv (YesodDB UniWorX) () + { dbtCsvExportForm :: AForm DB exportData + , dbtCsvHeader :: Maybe exportData -> DB Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error + , 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' - , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction (YesodDB UniWorX) () + { dbtCsvRowKey :: csv -> MaybeT DB k' + , 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) - , dbtFilter :: Map FilterKey (FilterColumn t) + , dbtSorting :: Map SortingKey (SortColumn t r') + , 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") diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index ce0cdbadd..1a2c5eaff 100644 --- a/src/Import/NoModel.hs +++ b/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) diff --git a/src/Utils.hs b/src/Utils.hs index 1b8569546..5e2dc6069 100644 --- a/src/Utils.hs +++ b/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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index fa9bc59b9..db0e024d0 100644 --- a/src/Utils/Lens.hs +++ b/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 diff --git a/templates/course.hamlet b/templates/course.hamlet index f1a150b6c..151a3291a 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -169,6 +169,12 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
_{MsgCourseRegistration}
+
+ $maybe CourseParticipant{courseParticipantRegistration} <- registration + _{MsgRegisteredSince} + \ ^{formatTimeW SelFormatDateTime courseParticipantRegistration} + $nothing + _{MsgNotRegistered}
$if registrationOpen $# regForm is defined through templates/widgets/registerForm @@ -180,11 +186,6 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) $if isJust registration

_{MsgCourseRegistrationDeleteToEdit} - $maybe CourseParticipant{courseParticipantRegistration} <- registration - _{MsgRegisteredSince} - \ ^{formatTimeW SelFormatDateTime courseParticipantRegistration} - $nothing - _{MsgNotRegistered}

_{MsgCourseMaterial}
@@ -197,7 +198,10 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
^{examTable} $if not (null events) || mayCreateEvents -
_{MsgCourseEvents} +
+ _{MsgCourseEvents} + $if null events + \ #{iconInvisible}
diff --git a/templates/table/layout.hamlet b/templates/table/layout.hamlet index 82f69f464..03a38af29 100644 --- a/templates/table/layout.hamlet +++ b/templates/table/layout.hamlet @@ -14,7 +14,7 @@ $else
_{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