refactor(dbtable): move haskell-land filtering to actual filter
This commit is contained in:
Gregor Kleen
parent
bb9b4f06ae
commit
17882868d2
@ -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
|
||||
|
||||
@ -58,5 +58,8 @@
|
||||
display: block
|
||||
clear: both
|
||||
|
||||
&:empty
|
||||
margin: 0
|
||||
|
||||
.hide-columns--hidden-cell
|
||||
display: none
|
||||
|
||||
38
src/Data/MonoTraversable/Instances.hs
Normal file
38
src/Data/MonoTraversable/Instances.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
, ..
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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")
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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>
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user