749 lines
45 KiB
Haskell
749 lines
45 KiB
Haskell
module Handler.Submission.List
|
|
( getCorrectionsR, postCorrectionsR
|
|
, getCCorrectionsR, postCCorrectionsR
|
|
, getSSubsR, postSSubsR
|
|
, correctionsR'
|
|
, restrictAnonymous, restrictCorrector
|
|
, 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
|
|
, ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction
|
|
) where
|
|
|
|
import Import hiding (link)
|
|
|
|
import Handler.Utils hiding (colSchool)
|
|
import Handler.Utils.Submission
|
|
import Handler.Utils.SheetType
|
|
import Handler.Utils.Delete
|
|
|
|
import Data.List as List (foldr)
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map.Strict as Map
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Database.Esqueleto.Utils.TH
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.Internal.Internal as IE (From)
|
|
|
|
import Text.Hamlet (ihamletFile)
|
|
|
|
import Database.Persist.Sql (updateWhereCount)
|
|
|
|
import Data.List (genericLength)
|
|
|
|
|
|
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
|
|
|
|
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)
|
|
|
|
querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission)
|
|
querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
|
|
|
|
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)
|
|
|
|
courseIs :: CourseId -> CorrectionTableWhere
|
|
courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid
|
|
|
|
sheetIs :: Key Sheet -> CorrectionTableWhere
|
|
sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
|
|
|
|
userIs :: Key User -> CorrectionTableWhere
|
|
userIs uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = 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 MsgTerm)
|
|
$ \DBRow{ dbrOutput } ->
|
|
textCell $ termToText $ unTermKey $ dbrOutput ^. _3 . _3 -- kurze Semsterkürzel
|
|
|
|
colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
|
|
$ \DBRow{ dbrOutput } -> let course = dbrOutput ^. _3 in
|
|
anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|]
|
|
|
|
colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
|
$ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _, _, _) } -> courseCellCL (tid,sid,csh)
|
|
|
|
colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \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}|]
|
|
|
|
colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
|
DBRow{ dbrOutput = (_, _, _, Nothing , _, _, _, _) } -> cell mempty
|
|
DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _, _, _) } -> userCell userDisplayName userSurname
|
|
|
|
colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colSubmissionLink = sortable (Just "submission") (i18nCell MsgSubmission)
|
|
$ \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)
|
|
|
|
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
|
|
|
|
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
|
|
|
|
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \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
|
|
|
|
colSGroups :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colSGroups = sortable (Just "submittors-group") (i18nCell MsgSubmissionGroup) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, _, _, _, users, _, hasAccess) } ->
|
|
let protoCell = listCell (nubOn (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
|
|
|
|
colRating :: forall m a. IsDBTable m (a, SheetTypeSummary SqlBackendKey) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary SqlBackendKey))
|
|
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _, _, _) } ->
|
|
let csh = course ^. _2
|
|
tid = course ^. _3
|
|
ssh = course ^. _4
|
|
-- shn = sheetName
|
|
|
|
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
|
|
]
|
|
|
|
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
|
|
|
|
colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } ->
|
|
maybe mempty dateTimeCell submissionRatingTime
|
|
|
|
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")]
|
|
|
|
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))
|
|
|
|
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)
|
|
)
|
|
|
|
colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
|
|
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{sheetCourse, sheetType}, _, _, _, _, _, _) } -> cell $ do
|
|
sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
|
|
tr <- getTranslate
|
|
toWidget $ sheetTypeDesc tr
|
|
|
|
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))
|
|
|
|
colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colLastEdit = sortable (Just "last-edit") (i18nCell MsgLastEdit) $
|
|
\DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _, _, _) } -> maybe mempty dateTimeCell mbLastEdit
|
|
|
|
|
|
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)
|
|
)
|
|
dbtProj :: DBRow _ -> DB CorrectionTableData
|
|
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> 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
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
|
|
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
|
let submissionGroup' = E.subSelectMaybe . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
|
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
|
|
return . E.just $ submissionGroup E.^. SubmissionGroupName
|
|
return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup')
|
|
let
|
|
submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors
|
|
nonAnonymousAccess <- or2M
|
|
(return $ not sheetAnonymousCorrection)
|
|
(hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
|
|
cid <- encrypt sId
|
|
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess)
|
|
dbTable psValidator DBTable
|
|
{ dbtSQLQuery
|
|
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
|
|
, 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` _) ->
|
|
[ 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)
|
|
)
|
|
]
|
|
, 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 $ \(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'
|
|
)
|
|
]
|
|
, dbtFilterUI = fromMaybe mempty dbtFilterUI
|
|
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI }
|
|
, dbtParams
|
|
, dbtIdent = "corrections" :: Text
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
, dbtExtraReps = []
|
|
}
|
|
|
|
data ActionCorrections = CorrDownload
|
|
| CorrSetCorrector
|
|
| CorrAutoSetCorrector
|
|
| CorrDelete
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
|
|
|
instance Universe ActionCorrections
|
|
instance Finite ActionCorrections
|
|
|
|
nullaryPathPiece ''ActionCorrections $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''ActionCorrections id
|
|
|
|
data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous
|
|
| CorrSetCorrectorData (Maybe UserId)
|
|
| CorrAutoSetCorrectorData SheetId
|
|
| CorrDeleteData
|
|
|
|
correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
|
|
correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
|
|
(table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI psValidator actions
|
|
|
|
fmap toTypedContent . defaultLayout $ do
|
|
setTitleI MsgCourseCorrectionsTitle
|
|
$(widgetFile "corrections")
|
|
|
|
correctionsR' :: _ -> _ -> _ -> _ -> 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
|
|
|
|
postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords)
|
|
{ drAbort = SomeRoute currentRoute
|
|
, drSuccess = SomeRoute currentRoute
|
|
}
|
|
|
|
((actionRes', statistics), table) <- runDB $
|
|
makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional = \frag -> do
|
|
(actionRes, action) <- multiActionM actions "" Nothing mempty
|
|
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = _1
|
|
, dbParamsFormIdent = def
|
|
}
|
|
-- -- Similar Query for Statistics over alle possible Table elements (not just the ones shown)
|
|
-- gradingSummary <- do
|
|
-- let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime)
|
|
-- points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints
|
|
-- -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn []
|
|
-- return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points
|
|
-- let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
|
|
-- return (tableRes, statistics)
|
|
|
|
let actionRes = actionRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
|
<&> _1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
|
auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
|
|
|
|
formResult actionRes $ \case
|
|
(CorrDownloadData nonAnonymous, subs) -> do
|
|
ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
|
|
MsgRenderer mr <- getMsgRenderer
|
|
setContentDisposition' $ Just ((addExtension `on` unpack) (mr MsgSubmissionArchiveName) extensionZip)
|
|
sendResponse =<< submissionMultiArchive nonAnonymous ids
|
|
(CorrSetCorrectorData (Just uid), subs') -> do
|
|
subs <- mapM decrypt $ Set.toList subs'
|
|
now <- liftIO getCurrentTime
|
|
runDB $ do
|
|
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
|
|
unless (null alreadyAssigned) $ do
|
|
mr <- (toHtml . ) <$> getMessageRender
|
|
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
|
|
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
|
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
|
|
(unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
|
|
unless (null unassignedUnauth) $ do
|
|
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
|
|
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
|
|
let numUnassignedUnauth = fromIntegral $ length unassignedUnauth'
|
|
trigger = [whamlet|_{MsgSubmissionsAssignUnauthorized numUnassignedUnauth}|]
|
|
content = Right $(widgetFile "messages/submissionsAssignUnauthorized")
|
|
addMessageModal Warning trigger content
|
|
unless (null unassignedAuth) $ do
|
|
let sIds = Set.toList unassignedAuth
|
|
num <- updateWhereCount [SubmissionId <-. sIds]
|
|
[ SubmissionRatingBy =. Just uid
|
|
, SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
|
|
]
|
|
addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num
|
|
auditAllSubEdit sIds
|
|
selfCorrectors <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do
|
|
E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission
|
|
E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs
|
|
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser)
|
|
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
|
when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors
|
|
redirect currentRoute
|
|
(CorrSetCorrectorData Nothing, subs') -> do -- delete corrections
|
|
subs <- mapM decrypt $ Set.toList subs'
|
|
runDB $ do
|
|
num <- updateWhereCount [SubmissionId <-. subs]
|
|
[ SubmissionRatingBy =. Nothing
|
|
, SubmissionRatingAssigned =. Nothing
|
|
, SubmissionRatingTime =. Nothing
|
|
-- , SubmissionRatingPoints =. Nothing -- Kept for easy reassignment by 2nd corrector
|
|
-- , SubmissionRatingComment =. Nothing -- Kept for easy reassignment by 2nd corrector
|
|
]
|
|
addMessageI Success $ MsgRemovedCorrections num
|
|
auditAllSubEdit subs
|
|
redirect currentRoute
|
|
(CorrAutoSetCorrectorData shid, subs') -> do
|
|
subs <- mapM decrypt $ Set.toList subs'
|
|
let
|
|
assignExceptions :: AssignSubmissionException -> Handler ()
|
|
assignExceptions NoCorrectors = addMessageI Error MsgAssignSubmissionExceptionNoCorrectors
|
|
assignExceptions NoCorrectorsByProportion = addMessageI Error MsgAssignSubmissionExceptionNoCorrectorsByProportion
|
|
assignExceptions (SubmissionsNotFound subIds) = do
|
|
subCIDs <- mapM encrypt . Set.toList $ toNullable subIds :: Handler [CryptoFileNameSubmission]
|
|
let errorModal = msgModal
|
|
[whamlet|_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)}|]
|
|
(Right $(widgetFile "messages/submissionsAssignNotFound"))
|
|
addMessageWidget Error errorModal
|
|
|
|
handle assignExceptions . runDB $ do
|
|
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
|
|
unless (null alreadyAssigned) $ do
|
|
mr <- (toHtml . ) <$> getMessageRender
|
|
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
|
|
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
|
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
|
|
(unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
|
|
unless (null unassignedUnauth) $ do
|
|
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
|
|
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
|
|
let numUnassignedUnauth = fromIntegral $ length unassignedUnauth'
|
|
trigger = [whamlet|_{MsgSubmissionsAssignUnauthorized numUnassignedUnauth}|]
|
|
content = Right $(widgetFile "messages/submissionsAssignUnauthorized")
|
|
addMessageModal Warning trigger content
|
|
unless (null unassignedAuth) $ do
|
|
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassignedAuth)
|
|
unless (null assigned) $
|
|
addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
|
|
unless (null stillUnassigned) $ do
|
|
mr <- (toHtml . ) <$> getMessageRender
|
|
unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> encrypt sid :: DB CryptoFileNameSubmission
|
|
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
|
|
redirect currentRoute
|
|
(CorrDeleteData, subs) -> do
|
|
subs' <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
|
|
getDeleteR (submissionDeleteRoute subs')
|
|
{ drAbort = SomeRoute currentRoute
|
|
, drSuccess = SomeRoute currentRoute
|
|
}
|
|
|
|
return (table, statistics)
|
|
|
|
where
|
|
authorizedToAssign :: SubmissionId -> DB Bool
|
|
authorizedToAssign sId = do
|
|
(E.Value tid, E.Value ssh, E.Value csh, E.Value shn) <- maybe notFound return . listToMaybe <=<
|
|
E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do
|
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.where_ $ submission E.^. SubmissionId E.==. E.val sId
|
|
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, sheet E.^. SheetName)
|
|
cID <- encrypt sId
|
|
let route = CSubmissionR tid ssh csh shn cID SubAssignR
|
|
(== Authorized) <$> evalAccessDB route True
|
|
|
|
restrictAnonymous :: PSValidator m x -> PSValidator m x
|
|
restrictAnonymous = restrictFilter (\k _ -> k /= "user-matriclenumber")
|
|
. restrictFilter (\k _ -> k /= "user-name-email")
|
|
. restrictFilter (\k _ -> k /= "submission-group")
|
|
. restrictSorting (\k _ -> k /= "last-edit")
|
|
|
|
restrictCorrector :: PSValidator m x -> PSValidator m x
|
|
restrictCorrector = restrictFilter (\k _ -> k /= "corrector")
|
|
. restrictFilter (\k _ -> k /= "corrector-name-email")
|
|
. restrictSorting (\k _ -> k /= "corrector")
|
|
|
|
type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData)
|
|
|
|
downloadAction, deleteAction :: ActionCorrections'
|
|
downloadAction = ( CorrDownload
|
|
, CorrDownloadData <$> apopt (selectField optionsFinite) (fslI MsgCorrDownloadAnonymous & setTooltip MsgCorrDownloadAnonymousTip) (Just SubmissionDownloadAnonymous)
|
|
)
|
|
deleteAction = ( CorrDelete
|
|
, pure CorrDeleteData
|
|
)
|
|
|
|
assignAction :: Either CourseId SheetId -> ActionCorrections'
|
|
assignAction selId = ( CorrSetCorrector
|
|
, wFormToAForm $ do
|
|
correctors <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
|
|
E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
|
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
|
|
E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
|
|
|
|
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
|
|
|
E.distinct $ return user
|
|
|
|
correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey
|
|
|
|
cId <- wopt (selectFieldList correctors' :: Field (HandlerFor UniWorX) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing
|
|
fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
|
|
)
|
|
|
|
autoAssignAction :: SheetId -> ActionCorrections'
|
|
autoAssignAction shid = ( CorrAutoSetCorrector
|
|
, pure $ CorrAutoSetCorrectorData shid
|
|
)
|
|
|
|
|
|
getCorrectionsR, postCorrectionsR :: Handler TypedContent
|
|
getCorrectionsR = postCorrectionsR
|
|
postCorrectionsR = do
|
|
uid <- requireAuthId
|
|
let whereClause = ratedBy uid
|
|
colonnade = mconcat
|
|
[ colSelect
|
|
, colSchool
|
|
, colTerm
|
|
, colCourse
|
|
, colSheet
|
|
, colSMatrikel
|
|
, colSubmittors
|
|
, colSGroups
|
|
, colPseudonyms
|
|
, colSubmissionLink
|
|
, colAssigned
|
|
, colRating
|
|
, colRated
|
|
] -- Continue here
|
|
filterUI = Just $ \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse)
|
|
, prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm)
|
|
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
|
|
, Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
|
|
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
|
|
, prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission)
|
|
]
|
|
courseOptions = runDB $ do
|
|
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
|
|
termOptions = runDB $ do
|
|
courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
|
|
schoolOptions = runDB $ do
|
|
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
|
|
|
|
psValidator = def
|
|
& restrictCorrector
|
|
& restrictAnonymous
|
|
& defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ]
|
|
-- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN
|
|
correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
|
|
[ downloadAction
|
|
]
|
|
|
|
getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
|
getCCorrectionsR = postCCorrectionsR
|
|
postCCorrectionsR tid ssh csh = do
|
|
Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
let whereClause = courseIs cid
|
|
colonnade = mconcat -- should match getSSubsR for consistent UX
|
|
[ colSelect
|
|
, colSheet
|
|
, colSMatrikel
|
|
, colSubmittors
|
|
, colSGroups
|
|
, colSubmissionLink
|
|
, colLastEdit
|
|
, colRating
|
|
, colRated
|
|
, colCorrector
|
|
, colAssigned
|
|
] -- Continue here
|
|
filterUI = Just $ \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers)
|
|
, prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr)
|
|
-- "pseudonym" TODO DB only stores Word24
|
|
, Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
|
|
, prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
|
|
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector)
|
|
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
|
|
, prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
|
|
, prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission)
|
|
]
|
|
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
|
|
correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
|
|
[ downloadAction
|
|
, assignAction (Left cid)
|
|
, deleteAction
|
|
]
|
|
|
|
getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
|
getSSubsR = postSSubsR
|
|
postSSubsR tid ssh csh shn = do
|
|
shid <- runDB $ fetchSheetId tid ssh csh shn
|
|
let whereClause = sheetIs shid
|
|
colonnade = mconcat -- should match getCCorrectionsR for consistent UX
|
|
[ colSelect
|
|
, colSMatrikel
|
|
, colSubmittors
|
|
, colSubmissionLink
|
|
, colLastEdit
|
|
, colRating
|
|
, colRated
|
|
, colCorrector
|
|
, colAssigned
|
|
]
|
|
filterUI = Just $ \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers)
|
|
, prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr)
|
|
, prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
|
|
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector)
|
|
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
|
|
, prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
|
|
, prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission)
|
|
-- "pseudonym" TODO DB only stores Word24
|
|
]
|
|
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
|
|
correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
|
|
[ downloadAction
|
|
, assignAction (Right shid)
|
|
, autoAssignAction shid
|
|
, deleteAction
|
|
]
|