refactor(corrections-r): modernize
This commit is contained in:
Gregor Kleen
parent
ba2b63e754
commit
abdc2a8926
@ -121,6 +121,7 @@ dependencies:
|
||||
- http-types
|
||||
- jose-jwt
|
||||
- mono-traversable
|
||||
- mono-traversable-keys
|
||||
- lens-aeson
|
||||
- systemd
|
||||
- streaming-commons
|
||||
|
||||
@ -243,7 +243,8 @@ courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler W
|
||||
courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do
|
||||
guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR
|
||||
|
||||
let whereClause = (E.&&.) <$> courseIs cid <*> userIs uid
|
||||
let whereClause :: CorrectionTableWhere
|
||||
whereClause = (E.&&.) <$> courseIs cid <*> userIs uid
|
||||
colonnade = mconcat -- should match getSSubsR for consistent UX
|
||||
[ colSelect
|
||||
, colSheet
|
||||
|
||||
@ -19,7 +19,8 @@ getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
|
||||
getCorrectionsGradeR = postCorrectionsGradeR
|
||||
postCorrectionsGradeR = do
|
||||
uid <- requireAuthId
|
||||
let whereClause = ratedBy uid
|
||||
let whereClause :: CorrectionTableWhere
|
||||
whereClause = ratedBy uid
|
||||
displayColumns = mconcat -- should match getSSubsR for consistent UX
|
||||
[ -- dbRow,
|
||||
colSchool
|
||||
|
||||
@ -1,3 +1,6 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||
|
||||
module Handler.Submission.List
|
||||
( getCorrectionsR, postCorrectionsR
|
||||
, getCCorrectionsR, postCCorrectionsR
|
||||
@ -7,7 +10,7 @@ module Handler.Submission.List
|
||||
, ratedBy, courseIs, sheetIs, userIs
|
||||
, colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups
|
||||
, makeCorrectionsTable
|
||||
, CorrectionTableData
|
||||
, CorrectionTableData, CorrectionTableWhere
|
||||
, ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction
|
||||
) where
|
||||
|
||||
@ -28,7 +31,6 @@ import qualified Data.CaseInsensitive as CI
|
||||
import Database.Esqueleto.Utils.TH
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.Internal.Internal as IE (From)
|
||||
|
||||
import Text.Hamlet (ihamletFile)
|
||||
|
||||
@ -40,7 +42,7 @@ import Data.List (genericLength)
|
||||
newtype CorrectionTableFilterProj = CorrectionTableFilterProj
|
||||
{ corrProjFilterSubmission :: Maybe (Set [CI Char])
|
||||
}
|
||||
|
||||
|
||||
instance Default CorrectionTableFilterProj where
|
||||
def = CorrectionTableFilterProj
|
||||
{ corrProjFilterSubmission = Nothing
|
||||
@ -48,194 +50,270 @@ instance Default CorrectionTableFilterProj where
|
||||
|
||||
makeLenses_ ''CorrectionTableFilterProj
|
||||
|
||||
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym, Maybe SubmissionGroupName), CryptoFileNameSubmission, Bool {- Access to non-anonymous submission data -})
|
||||
|
||||
correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v
|
||||
correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
|
||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ whereClause t
|
||||
return $ returnStatement t
|
||||
type CorrectionTableExpr = ( E.SqlExpr (Entity Course)
|
||||
`E.InnerJoin` E.SqlExpr (Entity Sheet)
|
||||
`E.InnerJoin` E.SqlExpr (Entity Submission)
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
type CorrectionTableWhere = forall m. MonadReader CorrectionTableExpr m => m (E.SqlExpr (E.Value Bool))
|
||||
type CorrectionTableCourseData = (CourseName, CourseShorthand, TermId, SchoolId)
|
||||
type CorrectionTableUserData = (User, Maybe Pseudonym, Maybe SubmissionGroupName)
|
||||
type CorrectionTableData = DBRow ( Entity Submission
|
||||
, Entity Sheet
|
||||
, CorrectionTableCourseData
|
||||
, Maybe (Entity User)
|
||||
, Maybe UTCTime
|
||||
, Map UserId CorrectionTableUserData
|
||||
, CryptoFileNameSubmission
|
||||
, Bool {- Access to non-anonymous submission data -}
|
||||
)
|
||||
|
||||
lastEditQuery :: IE.From (E.SqlExpr (Entity SubmissionEdit))
|
||||
=> E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime))
|
||||
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)
|
||||
queryCourse :: Getter CorrectionTableExpr (E.SqlExpr (Entity Course))
|
||||
queryCourse = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
|
||||
|
||||
querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission)
|
||||
querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
|
||||
querySheet :: Getter CorrectionTableExpr (E.SqlExpr (Entity Sheet))
|
||||
querySheet = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
|
||||
|
||||
querySubmission :: Getter CorrectionTableExpr (E.SqlExpr (Entity Submission))
|
||||
querySubmission = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
|
||||
|
||||
queryCorrector :: Getter CorrectionTableExpr (E.SqlExpr (Maybe (Entity User)))
|
||||
queryCorrector = to $(sqlLOJproj 2 2)
|
||||
|
||||
queryLastEdit :: Getter CorrectionTableExpr (E.SqlExpr (E.Value (Maybe UTCTime)))
|
||||
queryLastEdit = querySubmission . submissionLastEdit
|
||||
where
|
||||
submissionLastEdit = to $ \submission -> E.subSelectMaybe . E.from $ \edit -> do
|
||||
E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
||||
return $ E.max_ $ edit E.^. SubmissionEditTime
|
||||
|
||||
|
||||
resultSubmission :: Lens' CorrectionTableData (Entity Submission)
|
||||
resultSubmission = _dbrOutput . _1
|
||||
|
||||
resultSheet :: Lens' CorrectionTableData (Entity Sheet)
|
||||
resultSheet = _dbrOutput . _2
|
||||
|
||||
resultCourseName :: Lens' CorrectionTableData CourseName
|
||||
resultCourseName = _dbrOutput . _3 . _1
|
||||
|
||||
resultCourseShorthand :: Lens' CorrectionTableData CourseShorthand
|
||||
resultCourseShorthand = _dbrOutput . _3 . _2
|
||||
|
||||
resultCourseTerm :: Lens' CorrectionTableData TermId
|
||||
resultCourseTerm = _dbrOutput . _3 . _3
|
||||
|
||||
resultCourseSchool :: Lens' CorrectionTableData SchoolId
|
||||
resultCourseSchool = _dbrOutput . _3 . _4
|
||||
|
||||
resultCorrector :: Traversal' CorrectionTableData (Entity User)
|
||||
resultCorrector = _dbrOutput . _4 . _Just
|
||||
|
||||
resultLastEdit :: Traversal' CorrectionTableData UTCTime
|
||||
resultLastEdit = _dbrOutput . _5 . _Just
|
||||
|
||||
resultSubmittors :: IndexedTraversal' UserId CorrectionTableData CorrectionTableUserData
|
||||
resultSubmittors = _dbrOutput . _6 . itraversed
|
||||
|
||||
resultUserUser :: Lens' CorrectionTableUserData User
|
||||
resultUserUser = _1
|
||||
|
||||
resultUserPseudonym :: Traversal' CorrectionTableUserData Pseudonym
|
||||
resultUserPseudonym = _2 . _Just
|
||||
|
||||
resultUserSubmissionGroup :: Traversal' CorrectionTableUserData SubmissionGroupName
|
||||
resultUserSubmissionGroup = _3 . _Just
|
||||
|
||||
resultCryptoID :: Lens' CorrectionTableData CryptoFileNameSubmission
|
||||
resultCryptoID = _dbrOutput . _7
|
||||
|
||||
resultNonAnonymousAccess :: Lens' CorrectionTableData Bool
|
||||
resultNonAnonymousAccess = _dbrOutput . _8
|
||||
|
||||
queryCorrector :: CorrectionTableExpr -> E.SqlExpr (Maybe (Entity User))
|
||||
queryCorrector = $(sqlLOJproj 2 2)
|
||||
|
||||
-- Where Clauses
|
||||
ratedBy :: UserId -> CorrectionTableWhere
|
||||
ratedBy uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
ratedBy uid = views querySubmission $ (E.==. E.justVal uid) . (E.^. SubmissionRatingBy)
|
||||
|
||||
courseIs :: CourseId -> CorrectionTableWhere
|
||||
courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid
|
||||
courseIs cid = views queryCourse $ (E.==. E.val cid) . (E.^. CourseId)
|
||||
|
||||
sheetIs :: Key Sheet -> CorrectionTableWhere
|
||||
sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
|
||||
sheetIs shid = views querySheet $ (E.==. E.val shid) . (E.^. SheetId)
|
||||
|
||||
userIs :: Key User -> CorrectionTableWhere
|
||||
userIs uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = E.exists . E.from $ \submissionUser ->
|
||||
userIs uid = views querySubmission $ \submission -> E.exists . E.from $ \submissionUser ->
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||
E.&&. submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
||||
|
||||
|
||||
-- Columns
|
||||
colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colTerm = sortable (Just "term") (i18nCell MsgTableTerm)
|
||||
$ \DBRow{ dbrOutput } ->
|
||||
textCell $ termToText $ unTermKey $ dbrOutput ^. _3 . _3 -- kurze Semsterkürzel
|
||||
colTerm = sortable (Just "term") (i18nCell MsgTableTerm) . views (resultCourseTerm . _TermId) $ textCell . termToText
|
||||
|
||||
colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSchool = sortable (Just "school") (i18nCell MsgTableCourseSchool)
|
||||
$ \DBRow{ dbrOutput } -> let course = dbrOutput ^. _3 in
|
||||
anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|]
|
||||
colSchool = sortable (Just "school") (i18nCell MsgTableCourseSchool) $ \x ->
|
||||
let tid = x ^. resultCourseTerm
|
||||
ssh = x ^. resultCourseSchool
|
||||
in anchorCell (TermSchoolCourseListR tid ssh)
|
||||
(ssh ^. _SchoolId)
|
||||
|
||||
colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colCourse = sortable (Just "course") (i18nCell MsgTableCourse)
|
||||
$ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _, _, _) } -> courseCellCL (tid,sid,csh)
|
||||
colCourse = sortable (Just "course") (i18nCell MsgTableCourse) $ views ($(multifocusG 3) resultCourseTerm resultCourseSchool resultCourseShorthand) courseCellCL
|
||||
|
||||
colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSheet = sortable (Just "sheet") (i18nCell MsgTableSheet) $ \row ->
|
||||
let sheet = row ^. _dbrOutput . _2
|
||||
course= row ^. _dbrOutput . _3
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
csh = course ^. _2
|
||||
shn = sheetName $ entityVal sheet
|
||||
in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|_{shn}|]
|
||||
colSheet = sortable (Just "sheet") (i18nCell MsgTableSheet) $ \x ->
|
||||
let tid = x ^. resultCourseTerm
|
||||
ssh = x ^. resultCourseSchool
|
||||
csh = x ^. resultCourseShorthand
|
||||
shn = x ^. resultSheet . _entityVal . _sheetName
|
||||
in anchorCell (CSheetR tid ssh csh shn SShowR) shn
|
||||
|
||||
colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgTableCorrector) $ \case
|
||||
DBRow{ dbrOutput = (_, _, _, Nothing , _, _, _, _) } -> cell mempty
|
||||
DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _, _, _) } -> userCell userDisplayName userSurname
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgTableCorrector) $ \x ->
|
||||
maybeCell (x ^? resultCorrector) $ \(Entity _ User{..}) -> userCell userDisplayName userSurname
|
||||
|
||||
colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission)
|
||||
$ \DBRow{ dbrOutput=(_, sheet, course, _, _,_, cid, _) } ->
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
shn = sheetName $ entityVal sheet
|
||||
in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn cid SubShowR) (toPathPiece cid)
|
||||
colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $ \x ->
|
||||
let tid = x ^. resultCourseTerm
|
||||
ssh = x ^. resultCourseSchool
|
||||
csh = x ^. resultCourseShorthand
|
||||
shn = x ^. resultSheet . _entityVal . _sheetName
|
||||
subCID = x ^. resultCryptoID
|
||||
in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID)
|
||||
|
||||
colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId))
|
||||
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid
|
||||
colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return
|
||||
|
||||
|
||||
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users, _, hasAccess) } ->
|
||||
let
|
||||
csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
link cid = CourseR tid ssh csh $ CUserR cid
|
||||
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo, _)) ->
|
||||
anchorCellCM $cacheIdentHere (link <$> encrypt userId) $ case mPseudo of
|
||||
Nothing -> nameWidget userDisplayName userSurname
|
||||
Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|]
|
||||
in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
| otherwise -> mempty
|
||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x ->
|
||||
let tid = x ^. resultCourseTerm
|
||||
ssh = x ^. resultCourseSchool
|
||||
csh = x ^. resultCourseShorthand
|
||||
link uCID = CourseR tid ssh csh $ CUserR uCID
|
||||
protoCell = listCell (sortOn (view $ _2 . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) $ itoListOf resultSubmittors x) $ \((encrypt -> mkUCID), u) ->
|
||||
let User{..} = u ^. resultUserUser
|
||||
mPseudo = u ^? resultUserPseudonym
|
||||
in anchorCellCM $cacheIdentHere (link <$> mkUCID) $
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe p <- mPseudo
|
||||
\ (#{review _PseudonymText p})
|
||||
|]
|
||||
in guardMonoid (x ^. resultNonAnonymousAccess) $
|
||||
protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput=(_, _, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
|
||||
let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{userMatrikelnummer}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, (_, matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr
|
||||
in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
| otherwise -> mempty
|
||||
colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgTableMatrikelNr) $ \x ->
|
||||
let protoCell = listCell (sort $ x ^.. resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) wgtCell
|
||||
in guardMonoid (x ^. resultNonAnonymousAccess) $
|
||||
protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colSGroups :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSGroups = sortable (Just "submittors-group") (i18nCell MsgTableSubmissionGroup) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, _, _, _, users, _, hasAccess) } ->
|
||||
let protoCell = listCell (nubOrdOn (view _2) . Map.toList $ Map.mapMaybe (view _3) users) $ \(_, sGroup) -> cell $ toWidget sGroup
|
||||
in if | hasAccess
|
||||
, is _RegisteredGroups sheetGrouping
|
||||
-> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
| otherwise
|
||||
-> mempty
|
||||
colSGroups = sortable (Just "submittors-group") (i18nCell MsgTableSubmissionGroup) $ \x ->
|
||||
let protoCell = listCell (setOf (resultSubmittors . resultUserSubmissionGroup) x) wgtCell
|
||||
in guardMonoid (x ^. resultNonAnonymousAccess) $
|
||||
protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colRating :: forall m a. IsDBTable m (a, SheetTypeSummary SqlBackendKey) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary SqlBackendKey))
|
||||
colRating = sortable (Just "rating") (i18nCell MsgTableRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _, _, _) } ->
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
-- shn = sheetName
|
||||
colRating :: forall m a a'. (IsDBTable m a, a ~ (a', SheetTypeSummary SqlBackendKey)) => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colRating = colRating' _2
|
||||
|
||||
mkRoute = do
|
||||
cid <- encrypt subId
|
||||
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
|
||||
in mconcat
|
||||
[ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating")
|
||||
, writerCell $ do
|
||||
let
|
||||
summary :: SheetTypeSummary SqlBackendKey
|
||||
summary = sheetTypeSum sheetType $ submissionRatingPoints <* guard (submissionRatingDone sub)
|
||||
scribe (_2 :: Lens' (a, SheetTypeSummary SqlBackendKey) (SheetTypeSummary SqlBackendKey)) summary
|
||||
]
|
||||
colRating' :: forall m a. IsDBTable m a => ASetter' a (SheetTypeSummary SqlBackendKey) -> Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colRating' l = sortable (Just "rating") (i18nCell MsgTableRating) $ \x ->
|
||||
let tid = x ^. resultCourseTerm
|
||||
ssh = x ^. resultCourseSchool
|
||||
csh = x ^. resultCourseShorthand
|
||||
shn = x ^. resultSheet . _entityVal . _sheetName
|
||||
cID = x ^. resultCryptoID
|
||||
sub@Submission{..} = x ^. resultSubmission . _entityVal
|
||||
Sheet{..} = x ^. resultSheet . _entityVal
|
||||
|
||||
mkRoute = return $ CSubmissionR tid ssh csh shn cID CorrectionR
|
||||
in mconcat
|
||||
[ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating")
|
||||
, writerCell $ do
|
||||
let summary :: SheetTypeSummary SqlBackendKey
|
||||
summary = sheetTypeSum sheetType $ submissionRatingPoints <* guard (submissionRatingDone sub)
|
||||
scribe l summary
|
||||
]
|
||||
|
||||
colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } ->
|
||||
maybe mempty dateTimeCell submissionRatingAssigned
|
||||
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell
|
||||
|
||||
colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } ->
|
||||
maybe mempty dateTimeCell submissionRatingTime
|
||||
colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingTime . _Just) dateTimeCell
|
||||
|
||||
colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users, _, _) } -> let
|
||||
lCell = listCell (catMaybes $ view (_2 . _2) <$> Map.toList users) $ \pseudo ->
|
||||
cell [whamlet|#{review _PseudonymText pseudo}|]
|
||||
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \x ->
|
||||
let protoCell = listCell (sort $ x ^.. resultSubmittors . resultUserPseudonym . re _PseudonymText) wgtCell
|
||||
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colRatedField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData)))
|
||||
colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
|
||||
colRatedField :: a' ~ (Bool, a, b) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData)))
|
||||
colRatedField = colRatedField' _1
|
||||
|
||||
colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
|
||||
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of
|
||||
NotGraded -> pure $ over (_1.mapped) (_2 .~) (FormSuccess Nothing, mempty)
|
||||
_other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
|
||||
colRatedField' :: ASetter' a Bool -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData)))
|
||||
colRatedField' l = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
|
||||
(views (resultSubmission . _entityKey) return)
|
||||
(\(views (resultSubmission . _entityVal) submissionRatingDone -> done) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
|
||||
|
||||
colPointsField :: a' ~ (a, Maybe Points, b) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData)))
|
||||
colPointsField = colPointsField' _2
|
||||
|
||||
colPointsField' :: ASetter' a (Maybe Points) -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData)))
|
||||
colPointsField' l = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
|
||||
(views (resultSubmission . _entityKey) return)
|
||||
(\(view $ $(multifocusG 2) (resultSubmission . _entityVal) (resultSheet . _entityVal) -> (Submission{..}, Sheet{..})) mkUnique -> case sheetType of
|
||||
NotGraded -> pure $ over (_1.mapped) (l .~) (FormSuccess Nothing, mempty)
|
||||
_other -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
|
||||
)
|
||||
|
||||
colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
|
||||
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgTableSheetType) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{sheetCourse, sheetType}, _, _, _, _, _, _) } -> cell $ do
|
||||
colMaxPointsField :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgTableSheetType) $ \x -> cell $ do
|
||||
let Sheet{..} = x ^. resultSheet . _entityVal
|
||||
sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
|
||||
tr <- getTranslate
|
||||
toWidget $ sheetTypeDesc tr
|
||||
toWidget . sheetTypeDesc =<< getTranslate
|
||||
|
||||
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
|
||||
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
|
||||
colCommentField :: a' ~ (a, b, Maybe Text) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData)))
|
||||
colCommentField = colCommentField' _3
|
||||
|
||||
colCommentField' :: ASetter' a (Maybe Text) -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData)))
|
||||
colCommentField' l = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
|
||||
(views (resultSubmission . _entityKey) return)
|
||||
(\(view (resultSubmission . _entityVal) -> Submission{..}) mkUnique -> over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
|
||||
|
||||
colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $
|
||||
\DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _, _, _) } -> maybe mempty dateTimeCell mbLastEdit
|
||||
colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (x ^? resultLastEdit) dateTimeCell
|
||||
|
||||
|
||||
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 dbtParams = do
|
||||
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery = correctionsTableQuery whereClause
|
||||
(\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
|
||||
let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName)
|
||||
, course E.^. CourseShorthand
|
||||
, course E.^. CourseTerm
|
||||
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
|
||||
)
|
||||
in (submission, sheet, crse, corrector, lastEditQuery submission)
|
||||
)
|
||||
let dbtSQLQuery = runReaderT $ do
|
||||
course <- view queryCourse
|
||||
sheet <- view querySheet
|
||||
submission <- view querySubmission
|
||||
corrector <- view queryCorrector
|
||||
|
||||
lift $ do
|
||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
|
||||
lastEdit <- view queryLastEdit
|
||||
|
||||
let crse = ( course E.^. CourseName
|
||||
, course E.^. CourseShorthand
|
||||
, course E.^. CourseTerm
|
||||
, course E.^. CourseSchool
|
||||
)
|
||||
|
||||
lift . E.where_ =<< whereClause
|
||||
|
||||
return (submission, sheet, crse, corrector, lastEdit)
|
||||
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
|
||||
(submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput
|
||||
cid <- encrypt sId
|
||||
@ -263,163 +341,77 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
|
||||
(hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
|
||||
|
||||
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess)
|
||||
dbtRowKey = views querySubmission (E.^. SubmissionId)
|
||||
dbTable psValidator DBTable
|
||||
{ dbtSQLQuery
|
||||
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
|
||||
, dbtRowKey
|
||||
, dbtColonnade
|
||||
, dbtProj
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "term"
|
||||
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
||||
)
|
||||
, ( "school"
|
||||
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseSchool
|
||||
)
|
||||
, ( "course"
|
||||
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
|
||||
)
|
||||
, ( "sheet"
|
||||
, SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
||||
)
|
||||
, ( "corrector"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
|
||||
)
|
||||
, ( "rating"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
|
||||
)
|
||||
, ( "sheet-type"
|
||||
, SortColumns $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) ->
|
||||
, dbtSorting = mconcat
|
||||
[ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm)
|
||||
, singletonMap "school" . SortColumn $ views queryCourse (E.^. CourseSchool)
|
||||
, singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseShorthand)
|
||||
, singletonMap "sheet" . SortColumn $ views querySheet (E.^. SheetName)
|
||||
, singletonMap "corrector" . SortColumns $ \x ->
|
||||
[ SomeExprValue (views queryCorrector (E.?. UserSurname) x)
|
||||
, SomeExprValue (views queryCorrector (E.?. UserDisplayName) x)
|
||||
]
|
||||
, singletonMap "rating" . SortColumn $ views querySubmission (E.^. SubmissionRatingPoints)
|
||||
, singletonMap "sheet-type" . SortColumns $ \(view querySheet -> sheet) ->
|
||||
[ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value))
|
||||
, SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value))
|
||||
, SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value))
|
||||
]
|
||||
)
|
||||
, ( "israted"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime
|
||||
)
|
||||
, ( "ratingtime"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime
|
||||
)
|
||||
, ( "assignedtime"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned
|
||||
)
|
||||
, ( "submittors"
|
||||
, SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap ((userSurname &&& userDisplayName) . view _1) $ Map.elems submittors
|
||||
)
|
||||
, ( "submittors-matriculation"
|
||||
, SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view $ _1 . _userMatrikelnummer) $ Map.elems submittors
|
||||
)
|
||||
, ( "submittors-group"
|
||||
, SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view _3) $ Map.elems submittors
|
||||
)
|
||||
, ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment
|
||||
)
|
||||
, ( "last-edit"
|
||||
, SortColumn $ \((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) -> lastEditQuery submission
|
||||
)
|
||||
, ( "submission"
|
||||
, SortProjected . comparing $ toPathPiece . view (_dbrOutput . _7)
|
||||
)
|
||||
, singletonMap "israted" . SortColumn $ views querySubmission $ E.not_ . E.isNothing . (E.^. SubmissionRatingTime)
|
||||
, singletonMap "ratingtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingTime)
|
||||
, singletonMap "assignedtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingAssigned)
|
||||
, singletonMap "submittors" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) x
|
||||
, singletonMap "submittors-matriculation" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) x
|
||||
, singletonMap "submittors-group" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserSubmissionGroup) x
|
||||
, singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done
|
||||
, singletonMap "last-edit" . SortColumn $ view queryLastEdit
|
||||
, singletonMap "submission" . SortProjected . comparing $ toPathPiece . view resultCryptoID
|
||||
]
|
||||
, dbtFilter = Map.fromList
|
||||
[ ( "term"
|
||||
, FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
|
||||
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
||||
)
|
||||
, ( "school"
|
||||
, FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) sids -> if
|
||||
| Set.null sids -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> course E.^. CourseSchool `E.in_` E.valList (Set.toList sids)
|
||||
)
|
||||
, ( "course"
|
||||
, FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
|
||||
| Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
|
||||
)
|
||||
, ( "sheet"
|
||||
, FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
|
||||
| Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
|
||||
)
|
||||
, ( "sheet-search"
|
||||
, FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> case getLast (shns :: Last (CI Text)) of
|
||||
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
Just needle -> sheet E.^. SheetName `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
|
||||
)
|
||||
, ( "corrector"
|
||||
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
|
||||
| Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
|
||||
E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
|
||||
)
|
||||
, ( "isassigned"
|
||||
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
|
||||
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
Just True -> E.isJust $ submission E.^. SubmissionRatingBy
|
||||
Just False-> E.isNothing $ submission E.^. SubmissionRatingBy
|
||||
)
|
||||
, ( "israted"
|
||||
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
|
||||
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
Just True -> E.isJust $ submission E.^. SubmissionRatingTime
|
||||
Just False-> E.isNothing $ submission E.^. SubmissionRatingTime
|
||||
)
|
||||
, ( "corrector-name-email" -- corrector filter does not work for text-filtering
|
||||
, FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserSurname)
|
||||
, E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserDisplayName)
|
||||
, E.mkContainsFilterWith (Just . CI.mk) $ queryCorrector >>> (E.?. UserEmail)
|
||||
]
|
||||
)
|
||||
, ( "user-name-email"
|
||||
, FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||
E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
||||
E.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter
|
||||
[ E.mkContainsFilter (E.^. UserSurname)
|
||||
, E.mkContainsFilter (E.^. UserDisplayName)
|
||||
, E.mkContainsFilterWith CI.mk (E.^. UserEmail)
|
||||
]
|
||||
)
|
||||
, ( "user-matriclenumber"
|
||||
, FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||
E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
||||
E.where_ $ (\f -> f user $ Set.singleton needle) $
|
||||
E.mkContainsFilter (E.^. UserMatrikelnummer)
|
||||
)
|
||||
, ( "submission-group"
|
||||
, FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.where_ $ queryCourse table E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
|
||||
E.where_ $ (\f -> f submissionGroup $ Set.singleton needle) $
|
||||
E.mkContainsFilter (E.^. SubmissionGroupName)
|
||||
)
|
||||
, ( "rating-visible"
|
||||
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
|
||||
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
Just True -> E.isJust $ submission E.^. SubmissionRatingTime
|
||||
Just False-> E.isNothing $ submission E.^. SubmissionRatingTime
|
||||
)
|
||||
, ( "rating"
|
||||
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) pts -> if
|
||||
| Set.null pts -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (\p -> p `E.in_` E.valList (Set.toList pts)) (submission E.^. SubmissionRatingPoints)
|
||||
)
|
||||
, ( "comment"
|
||||
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) comm -> case getLast (comm :: Last Text) of
|
||||
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment)
|
||||
)
|
||||
, ( "submission"
|
||||
, FilterProjected (_corrProjFilterSubmission ?~)
|
||||
-- , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
|
||||
-- let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
|
||||
-- criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||
-- in any (`isInfixOf` cid) criteria'
|
||||
)
|
||||
, dbtFilter = mconcat
|
||||
[ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm)
|
||||
, singletonMap "school" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseSchool)
|
||||
, singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand)
|
||||
, singletonMap "sheet" . FilterColumn . E.mkExactFilter $ views querySheet (E.^. SheetName)
|
||||
, singletonMap "sheet-search" . FilterColumn . E.mkContainsFilter $ views querySheet (E.^. SheetName)
|
||||
, singletonMap "corrector" . FilterColumn . E.mkExactFilterWith Just $ views queryCorrector (E.?. UserIdent)
|
||||
, singletonMap "isassigned" . FilterColumn . E.mkExactFilterLast $ views querySubmission (E.isJust . (E.^. SubmissionRatingBy))
|
||||
, singletonMap "israted" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone
|
||||
, singletonMap "corrector-name-email" . FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserSurname)
|
||||
, E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserDisplayName)
|
||||
, E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserEmail)
|
||||
, E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserIdent)
|
||||
, E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserDisplayEmail)
|
||||
]
|
||||
, singletonMap "user-name-email" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||
E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission
|
||||
E.where_ $ E.anyFilter
|
||||
[ E.mkContainsFilter (E.^. UserSurname)
|
||||
, E.mkContainsFilter (E.^. UserDisplayName)
|
||||
, E.mkContainsFilterWith CI.mk (E.^. UserEmail)
|
||||
, E.mkContainsFilterWith CI.mk (E.^. UserIdent)
|
||||
, E.mkContainsFilterWith CI.mk (E.^. UserDisplayEmail)
|
||||
] user (Set.singleton needle)
|
||||
, singletonMap "user-matriclenumber" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||
E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission
|
||||
E.where_ $ E.mkContainsFilter (E.^. UserMatrikelnummer) user (Set.singleton needle)
|
||||
, singletonMap "submission-group" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.where_ $ (row ^. queryCourse) E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
|
||||
E.&&. dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission
|
||||
E.where_ $ E.mkContainsFilter (E.^. SubmissionGroupName) submissionGroup (Set.singleton needle)
|
||||
, singletonMap "rating-visible" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone -- TODO: Identical with israted?
|
||||
, singletonMap "rating" . FilterColumn . E.mkExactFilterWith Just $ views querySubmission (E.^. SubmissionRatingPoints)
|
||||
, singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment)
|
||||
, singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~)
|
||||
]
|
||||
, dbtFilterUI = fromMaybe mempty dbtFilterUI
|
||||
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI }
|
||||
@ -447,7 +439,7 @@ data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous Submis
|
||||
| CorrAutoSetCorrectorData SheetId
|
||||
| CorrDeleteData
|
||||
|
||||
correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
|
||||
correctionsR :: CorrectionTableWhere -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
|
||||
correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
(table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI psValidator actions
|
||||
|
||||
@ -455,7 +447,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
setTitleI MsgCourseCorrectionsTitle
|
||||
$(widgetFile "corrections")
|
||||
|
||||
correctionsR' :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey)
|
||||
correctionsR' :: CorrectionTableWhere -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey)
|
||||
correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
|
||||
|
||||
@ -654,7 +646,8 @@ getCorrectionsR, postCorrectionsR :: Handler TypedContent
|
||||
getCorrectionsR = postCorrectionsR
|
||||
postCorrectionsR = do
|
||||
uid <- requireAuthId
|
||||
let whereClause = ratedBy uid
|
||||
let whereClause :: CorrectionTableWhere
|
||||
whereClause = ratedBy uid
|
||||
colonnade = mconcat
|
||||
[ colSelect
|
||||
, colSchool
|
||||
@ -701,7 +694,8 @@ getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand ->
|
||||
getCCorrectionsR = postCCorrectionsR
|
||||
postCCorrectionsR tid ssh csh = do
|
||||
Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let whereClause = courseIs cid
|
||||
let whereClause :: CorrectionTableWhere
|
||||
whereClause = courseIs cid
|
||||
colonnade = mconcat -- should match getSSubsR for consistent UX
|
||||
[ colSelect
|
||||
, colSheet
|
||||
@ -737,7 +731,8 @@ getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> H
|
||||
getSSubsR = postSSubsR
|
||||
postSSubsR tid ssh csh shn = do
|
||||
shid <- runDB $ fetchSheetId tid ssh csh shn
|
||||
let whereClause = sheetIs shid
|
||||
let whereClause :: CorrectionTableWhere
|
||||
whereClause = sheetIs shid
|
||||
colonnade = mconcat -- should match getCCorrectionsR for consistent UX
|
||||
[ colSelect
|
||||
, colSMatrikel
|
||||
|
||||
@ -45,7 +45,8 @@ module Handler.Utils.Table.Pagination
|
||||
, maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
|
||||
, anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
|
||||
, cellTooltip
|
||||
, listCell, listCell'
|
||||
, listCell, listCell', listCellOf, listCellOf'
|
||||
, ilistCell, ilistCell', ilistCellOf, ilistCellOf'
|
||||
, formCell, DBFormResult(..), getDBFormResult
|
||||
, dbSelect
|
||||
, (&)
|
||||
@ -1793,12 +1794,30 @@ listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCel
|
||||
listCell = listCell' . return
|
||||
|
||||
listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
|
||||
listCell' mkXS mkCell = review dbCell . ([], ) $ do
|
||||
listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell
|
||||
|
||||
ilistCell :: (IsDBTable m a, MonoFoldableWithKey mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
|
||||
ilistCell = ilistCell' . return
|
||||
|
||||
ilistCell' :: (IsDBTable m a, MonoFoldableWithKey mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
|
||||
ilistCell' mkXS mkCell = review dbCell . ([], ) $ do
|
||||
xs <- mkXS
|
||||
cells <- forM (toList xs) $
|
||||
\(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
|
||||
cells <- forM (otoKeyedList xs) $
|
||||
\(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
|
||||
return $(widgetFile "table/cell/list")
|
||||
|
||||
listCellOf :: IsDBTable m a' => Getting (Endo [a]) s a -> s -> (a -> DBCell m a') -> DBCell m a'
|
||||
listCellOf l x = listCell (x ^.. l)
|
||||
|
||||
listCellOf' :: IsDBTable m a' => Getting (Endo [a]) s a -> WriterT a' m s -> (a -> DBCell m a') -> DBCell m a'
|
||||
listCellOf' l mkX = listCell' (toListOf l <$> mkX)
|
||||
|
||||
ilistCellOf :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> s -> (i -> a -> DBCell m a') -> DBCell m a'
|
||||
ilistCellOf l x = listCell (itoListOf l x) . uncurry
|
||||
|
||||
ilistCellOf' :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> WriterT a' m s -> (i -> a -> DBCell m a') -> DBCell m a'
|
||||
ilistCellOf' l mkX = listCell' (itoListOf l <$> mkX) . uncurry
|
||||
|
||||
newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a))
|
||||
|
||||
instance Functor (DBFormResult i a) where
|
||||
|
||||
@ -24,6 +24,7 @@ import ClassyPrelude.Yesod as Import
|
||||
, authorizationCheck
|
||||
, mkMessage, mkMessageFor, mkMessageVariant
|
||||
, YesodBreadcrumbs(..)
|
||||
, MonoZip(..), ozipWith
|
||||
)
|
||||
|
||||
import UnliftIO.Async.Utils as Import
|
||||
@ -235,6 +236,8 @@ import Data.Scientific as Import (Scientific, formatScientific)
|
||||
|
||||
import Data.MultiSet as Import (MultiSet)
|
||||
|
||||
import Data.MonoTraversable.Keys as Import
|
||||
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user