1186 lines
66 KiB
Haskell
1186 lines
66 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
|
|
|
module Handler.Submission.List
|
|
( getCorrectionsR, postCorrectionsR
|
|
, getCCorrectionsR, postCCorrectionsR
|
|
, getSSubsR, postSSubsR
|
|
, correctionsR'
|
|
, restrictAnonymous, restrictCorrector
|
|
, ratedBy, courseIs, sheetIs, userIs
|
|
, resultSubmission
|
|
, colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups, colAuthorshipStatementState
|
|
, filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym, filterUIAuthorshipStatementState
|
|
, makeCorrectionsTable
|
|
, CorrectionTableData, CorrectionTableWhere
|
|
, ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction
|
|
, CorrectionTableCsvQualification(..), CorrectionTableCsvSettings(..)
|
|
) where
|
|
|
|
import Import hiding (link)
|
|
|
|
import Handler.Utils hiding (colSchool)
|
|
import Handler.Utils.Submission
|
|
import Handler.Utils.SheetType
|
|
import Handler.Utils.Delete
|
|
|
|
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.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import Text.Hamlet (ihamletFile)
|
|
|
|
import Database.Persist.Sql (updateWhereCount)
|
|
|
|
import Data.List (genericLength)
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
|
|
|
|
data CorrectionTableFilterProj = CorrectionTableFilterProj
|
|
{ corrProjFilterSubmission :: Maybe (Set [CI Char])
|
|
, corrProjFilterPseudonym :: Maybe (Set [CI Char])
|
|
, corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState
|
|
}
|
|
|
|
instance Default CorrectionTableFilterProj where
|
|
def = CorrectionTableFilterProj
|
|
{ corrProjFilterSubmission = Nothing
|
|
, corrProjFilterPseudonym = Nothing
|
|
, corrProjFilterAuthorshipStatementState = Last Nothing
|
|
}
|
|
|
|
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 = forall m. MonadReader CorrectionTableExpr m => m (E.SqlExpr (E.Value Bool))
|
|
type CorrectionTableCourseData = (CourseName, CourseShorthand, TermId, SchoolId)
|
|
type CorrectionTableUserData = (User, Maybe Pseudonym, Maybe SubmissionGroupName, Maybe AuthorshipStatementSubmissionState)
|
|
type CorrectionTableData = DBRow ( Entity Submission
|
|
, Entity Sheet
|
|
, CorrectionTableCourseData
|
|
, Maybe (Entity User)
|
|
, Maybe UTCTime
|
|
, Map UserId CorrectionTableUserData
|
|
, CryptoFileNameSubmission
|
|
, Bool {- Access to non-anonymous submission data -}
|
|
, Maybe AuthorshipStatementSubmissionState
|
|
)
|
|
|
|
|
|
queryCourse :: Getter CorrectionTableExpr (E.SqlExpr (Entity Course))
|
|
queryCourse = to $ $(sqlIJproj 3 1) . $(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
|
|
|
|
resultUserAuthorshipStatementState :: Traversal' CorrectionTableUserData AuthorshipStatementSubmissionState
|
|
resultUserAuthorshipStatementState = _4 . _Just
|
|
|
|
resultCryptoID :: Lens' CorrectionTableData CryptoFileNameSubmission
|
|
resultCryptoID = _dbrOutput . _7
|
|
|
|
resultNonAnonymousAccess :: Lens' CorrectionTableData Bool
|
|
resultNonAnonymousAccess = _dbrOutput . _8
|
|
|
|
resultASState :: Lens' CorrectionTableData (Maybe AuthorshipStatementSubmissionState)
|
|
resultASState = _dbrOutput . _9
|
|
|
|
|
|
data CorrectionTableCsv = CorrectionTableCsv
|
|
{ csvCorrectionTerm :: Maybe TermIdentifier
|
|
, csvCorrectionSchool :: Maybe SchoolShorthand
|
|
, csvCorrectionCourse :: Maybe CourseShorthand
|
|
, csvCorrectionSheet :: Maybe SheetName
|
|
, csvCorrectionSubmission :: Maybe (CI Text)
|
|
, csvCorrectionLastEdit :: Maybe UTCTime
|
|
, csvCorrectionSurname :: Maybe [Maybe UserSurname]
|
|
, csvCorrectionFirstName :: Maybe [Maybe UserFirstName]
|
|
, csvCorrectionName :: Maybe [Maybe UserDisplayName]
|
|
, csvCorrectionMatriculation :: Maybe [Maybe UserMatriculation]
|
|
, csvCorrectionEmail :: Maybe [Maybe UserEmail]
|
|
, csvCorrectionPseudonym :: Maybe [Maybe Pseudonym]
|
|
, csvCorrectionSubmissionGroup :: Maybe [Maybe SubmissionGroupName]
|
|
, csvCorrectionAuthorshipStatementState :: Maybe [Maybe AuthorshipStatementSubmissionState]
|
|
, csvCorrectionAssigned :: Maybe UTCTime
|
|
, csvCorrectionCorrectorName :: Maybe UserDisplayName
|
|
, csvCorrectionCorrectorEmail :: Maybe UserEmail
|
|
, csvCorrectionRatingDone :: Maybe Bool
|
|
, csvCorrectionRatedAt :: Maybe UTCTime
|
|
, csvCorrectionRatingPoints :: Maybe Points
|
|
, csvCorrectionRatingComment :: Maybe Text
|
|
} deriving (Generic)
|
|
makeLenses_ ''CorrectionTableCsv
|
|
|
|
correctionTableCsvOptions :: Csv.Options
|
|
correctionTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 }
|
|
|
|
instance Csv.ToNamedRecord CorrectionTableCsv where
|
|
toNamedRecord CorrectionTableCsv{..} = Csv.namedRecord
|
|
[ "term" Csv..= csvCorrectionTerm
|
|
, "school" Csv..= csvCorrectionSchool
|
|
, "course" Csv..= csvCorrectionCourse
|
|
, "sheet" Csv..= csvCorrectionSheet
|
|
, "submission" Csv..= csvCorrectionSubmission
|
|
, "last-edit" Csv..= csvCorrectionLastEdit
|
|
, "surname" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionSurname
|
|
, "first-name" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionFirstName
|
|
, "name" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionName
|
|
, "matriculation" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionMatriculation
|
|
, "email" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionEmail
|
|
, "pseudonym" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionPseudonym
|
|
, "submission-group" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionSubmissionGroup
|
|
, "authorship-statement-state" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionAuthorshipStatementState
|
|
, "assigned" Csv..= csvCorrectionAssigned
|
|
, "corrector-name" Csv..= csvCorrectionCorrectorName
|
|
, "corrector-email" Csv..= csvCorrectionCorrectorEmail
|
|
, "rating-done" Csv..= csvCorrectionRatingDone
|
|
, "rated-at" Csv..= csvCorrectionRatedAt
|
|
, "rating-points" Csv..= csvCorrectionRatingPoints
|
|
, "rating-comment" Csv..= csvCorrectionRatingComment
|
|
]
|
|
where
|
|
mkEmpty = \case
|
|
[Nothing] -> []
|
|
x -> x
|
|
|
|
instance Csv.DefaultOrdered CorrectionTableCsv where
|
|
headerOrder = Csv.genericHeaderOrder correctionTableCsvOptions
|
|
|
|
instance Csv.FromNamedRecord CorrectionTableCsv where
|
|
parseNamedRecord csv
|
|
= CorrectionTableCsv
|
|
<$> csv .:?? "term"
|
|
<*> csv .:?? "school"
|
|
<*> csv .:?? "course"
|
|
<*> csv .:?? "sheet"
|
|
<*> csv .:?? "submission"
|
|
<*> csv .:?? "last-edit"
|
|
<*> fmap (fmap unCsvSemicolonList) (csv .:?? "surname")
|
|
<*> fmap (fmap unCsvSemicolonList) (csv .:?? "first-name")
|
|
<*> fmap (fmap unCsvSemicolonList) (csv .:?? "name")
|
|
<*> fmap (fmap unCsvSemicolonList) (csv .:?? "matriculation")
|
|
<*> fmap (fmap unCsvSemicolonList) (csv .:?? "email")
|
|
<*> fmap (fmap unCsvSemicolonList) (csv .:?? "pseudonym")
|
|
<*> fmap (fmap unCsvSemicolonList) (csv .:?? "submission-group")
|
|
<*> fmap (fmap unCsvSemicolonList) (csv .:?? "authorship-statement-state")
|
|
<*> csv .:?? "assigned"
|
|
<*> csv .:?? "corrector-name"
|
|
<*> csv .:?? "corrector-email"
|
|
<*> csv .:?? "rating-done"
|
|
<*> csv .:?? "rated-at"
|
|
<*> csv .:?? "rating-points"
|
|
<*> csv .:?? "rating-comment"
|
|
|
|
instance CsvColumnsExplained CorrectionTableCsv where
|
|
csvColumnsExplanations = genericCsvColumnsExplanations correctionTableCsvOptions $ Map.fromList
|
|
[ ('csvCorrectionTerm , MsgCsvColumnCorrectionTerm)
|
|
, ('csvCorrectionSchool , MsgCsvColumnCorrectionSchool)
|
|
, ('csvCorrectionCourse , MsgCsvColumnCorrectionCourse)
|
|
, ('csvCorrectionSheet , MsgCsvColumnCorrectionSheet)
|
|
, ('csvCorrectionSubmission , MsgCsvColumnCorrectionSubmission)
|
|
, ('csvCorrectionLastEdit , MsgCsvColumnCorrectionLastEdit)
|
|
, ('csvCorrectionSurname , MsgCsvColumnCorrectionSurname)
|
|
, ('csvCorrectionFirstName , MsgCsvColumnCorrectionFirstName)
|
|
, ('csvCorrectionName , MsgCsvColumnCorrectionName)
|
|
, ('csvCorrectionMatriculation , MsgCsvColumnCorrectionMatriculation)
|
|
, ('csvCorrectionEmail , MsgCsvColumnCorrectionEmail)
|
|
, ('csvCorrectionPseudonym , MsgCsvColumnCorrectionPseudonym)
|
|
, ('csvCorrectionSubmissionGroup, MsgCsvColumnCorrectionSubmissionGroup)
|
|
, ('csvCorrectionAuthorshipStatementState, MsgCsvColumnCorrectionAuthorshipStatementState)
|
|
, ('csvCorrectionAssigned , MsgCsvColumnCorrectionAssigned)
|
|
, ('csvCorrectionCorrectorName , MsgCsvColumnCorrectionCorrectorName)
|
|
, ('csvCorrectionCorrectorEmail , MsgCsvColumnCorrectionCorrectorEmail)
|
|
, ('csvCorrectionRatingDone , MsgCsvColumnCorrectionRatingDone)
|
|
, ('csvCorrectionRatedAt , MsgCsvColumnCorrectionRatedAt)
|
|
, ('csvCorrectionRatingPoints , MsgCsvColumnCorrectionRatingPoints)
|
|
, ('csvCorrectionRatingComment , MsgCsvColumnCorrectionRatingComment)
|
|
]
|
|
|
|
data CorrectionTableCsvQualification
|
|
= CorrectionTableCsvNoQualification
|
|
| CorrectionTableCsvQualifySheet
|
|
| CorrectionTableCsvQualifyCourse
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
correctionTableCsvHeader :: Bool -- ^ @showCorrector@
|
|
-> CorrectionTableCsvQualification -> Csv.Header
|
|
correctionTableCsvHeader showCorrector qual = Csv.header $ catMaybes
|
|
[ guardOn (qual >= CorrectionTableCsvQualifyCourse) "term"
|
|
, guardOn (qual >= CorrectionTableCsvQualifyCourse) "school"
|
|
, guardOn (qual >= CorrectionTableCsvQualifyCourse) "course"
|
|
, guardOn (qual >= CorrectionTableCsvQualifySheet) "sheet"
|
|
, pure "submission"
|
|
, pure "last-edit"
|
|
, pure "surname"
|
|
, pure "first-name"
|
|
, pure "name"
|
|
, pure "matriculation"
|
|
, pure "email"
|
|
, pure "pseudonym"
|
|
, pure "submission-group"
|
|
, pure "authorship-statement-state"
|
|
, pure "assigned"
|
|
, guardOn showCorrector "corrector-name"
|
|
, guardOn showCorrector "corrector-email"
|
|
, pure "rating-done"
|
|
, pure "rated-at"
|
|
, pure "rating-points"
|
|
, pure "rating-comment"
|
|
]
|
|
|
|
data CorrectionTableCsvSettings = forall filename sheetName.
|
|
( RenderMessage UniWorX filename, RenderMessage UniWorX sheetName
|
|
) => CorrectionTableCsvSettings
|
|
{ cTableCsvQualification :: CorrectionTableCsvQualification
|
|
, cTableCsvName :: filename
|
|
, cTableCsvSheetName :: sheetName
|
|
, cTableShowCorrector :: Bool
|
|
}
|
|
|
|
newtype CorrectionTableCsvExportData = CorrectionTableCsvExportData
|
|
{ csvCorrectionSingleSubmittors :: Bool
|
|
} deriving (Eq, Ord, Read, Show, Generic)
|
|
instance Default CorrectionTableCsvExportData where
|
|
def = CorrectionTableCsvExportData False
|
|
|
|
data CorrectionTableJson = CorrectionTableJson
|
|
{ jsonCorrectionTerm :: TermIdentifier
|
|
, jsonCorrectionSchool :: SchoolShorthand
|
|
, jsonCorrectionCourse :: CourseShorthand
|
|
, jsonCorrectionSheet :: SheetName
|
|
, jsonCorrectionLastEdit :: Maybe UTCTime
|
|
, jsonCorrectionSubmittors :: Maybe [CorrectionTableSubmittorJson]
|
|
, jsonCorrectionAssigned :: Maybe UTCTime
|
|
, jsonCorrectionCorrectorName :: Maybe UserDisplayName
|
|
, jsonCorrectionCorrectorEmail :: Maybe UserEmail
|
|
, jsonCorrectionRatingDone :: Bool
|
|
, jsonCorrectionRatedAt :: Maybe UTCTime
|
|
, jsonCorrectionRatingPoints :: Maybe Points
|
|
, jsonCorrectionRatingComment :: Maybe Text
|
|
} deriving (Generic)
|
|
|
|
data CorrectionTableSubmittorJson = CorrectionTableSubmittorJson
|
|
{ jsonCorrectionSurname :: UserSurname
|
|
, jsonCorrectionFirstName :: UserFirstName
|
|
, jsonCorrectionName :: UserDisplayName
|
|
, jsonCorrectionMatriculation :: Maybe UserMatriculation
|
|
, jsonCorrectionEmail :: UserEmail
|
|
, jsonCorrectionPseudonym :: Maybe Pseudonym
|
|
, jsonCorrectionSubmissionGroup :: Maybe SubmissionGroupName
|
|
, jsonCorrectionAuthorshipStatementState :: Maybe AuthorshipStatementSubmissionState
|
|
} deriving (Generic)
|
|
|
|
deriveToJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 2
|
|
} ''CorrectionTableSubmittorJson
|
|
|
|
deriveToJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 2
|
|
} ''CorrectionTableJson
|
|
|
|
-- Where Clauses
|
|
ratedBy :: UserId -> CorrectionTableWhere
|
|
ratedBy uid = views querySubmission $ (E.==. E.justVal uid) . (E.^. SubmissionRatingBy)
|
|
|
|
courseIs :: CourseId -> CorrectionTableWhere
|
|
courseIs cid = views queryCourse $ (E.==. E.val cid) . (E.^. CourseId)
|
|
|
|
sheetIs :: Key Sheet -> CorrectionTableWhere
|
|
sheetIs shid = views querySheet $ (E.==. E.val shid) . (E.^. SheetId)
|
|
|
|
userIs :: Key User -> CorrectionTableWhere
|
|
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) . views (resultCourseTerm . _TermId) $ textCell . termToText
|
|
|
|
colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
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) $ views ($(multifocusG 3) resultCourseTerm resultCourseSchool resultCourseShorthand) courseCellCL
|
|
|
|
colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
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) $ \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) $ \x ->
|
|
let tid = x ^. resultCourseTerm
|
|
ssh = x ^. resultCourseSchool
|
|
csh = x ^. resultCourseShorthand
|
|
shn = x ^. resultSheet . _entityVal . _sheetName
|
|
subCID = x ^. resultCryptoID
|
|
in anchorCell (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 $ views resultCryptoID return
|
|
|
|
|
|
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
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) $ \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) $ \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 a'. (IsDBTable m a, a ~ (a', SheetTypeSummary SqlBackendKey)) => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colRating = colRating' _2
|
|
|
|
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) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell
|
|
|
|
colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
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) $ \x ->
|
|
let protoCell = listCell (sort $ x ^.. resultSubmittors . resultUserPseudonym . re _PseudonymText) wgtCell
|
|
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
|
|
|
colRatedField :: a' ~ (Bool, a, b) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData)))
|
|
colRatedField = colRatedField' _1
|
|
|
|
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 :: 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
|
|
toWidget . sheetTypeDesc =<< getTranslate
|
|
|
|
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) $ \x -> maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^? resultLastEdit) dateTimeCell
|
|
|
|
colAuthorshipStatementState :: forall m a. IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
|
colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmissionUserAuthorshipStatementState) $ \x ->
|
|
let heatC :: AuthorshipStatementSubmissionState -> DBCell m a -> DBCell m a
|
|
heatC s c
|
|
= c
|
|
& cellAttrs %~ addAttrsClass "heated"
|
|
& cellAttrs <>~ pure ("style", [st|--hotness: #{tshow (boolHeat (s /= ASExists))}|])
|
|
tid = x ^. resultCourseTerm
|
|
ssh = x ^. resultCourseSchool
|
|
csh = x ^. resultCourseShorthand
|
|
shn = x ^. resultSheet . _entityVal . _sheetName
|
|
cID = x ^. resultCryptoID
|
|
|
|
asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR
|
|
in maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget))
|
|
|
|
|
|
filterUICourse :: Handler (OptionList Text) -> DBFilterUI
|
|
filterUICourse courseOptions = flip (prismAForm $ singletonFilter "course") $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse)
|
|
|
|
filterUITerm :: Handler (OptionList Text) -> DBFilterUI
|
|
filterUITerm termOptions = flip (prismAForm $ singletonFilter "term") $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTableTerm)
|
|
|
|
filterUISchool :: Handler (OptionList Text) -> DBFilterUI
|
|
filterUISchool schoolOptions = flip (prismAForm $ singletonFilter "school") $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool)
|
|
|
|
filterUISheetSearch :: DBFilterUI
|
|
filterUISheetSearch mPrev = singletonMap "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
|
|
|
|
filterUIIsRated :: DBFilterUI
|
|
filterUIIsRated = flip (prismAForm $ singletonFilter "israted" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime)
|
|
|
|
filterUISubmission :: DBFilterUI
|
|
filterUISubmission = flip (prismAForm $ singletonFilter "submission") $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
|
|
|
|
filterUIPseudonym :: DBFilterUI
|
|
filterUIPseudonym = flip (prismAForm $ singletonFilter "pseudonym") $ aopt (lift `hoistField` textField) (fslI MsgSubmissionPseudonym)
|
|
|
|
filterUIUserNameEmail :: DBFilterUI
|
|
filterUIUserNameEmail = flip (prismAForm $ singletonFilter "user-name-email") $ aopt textField (fslI MsgTableCourseMembers)
|
|
|
|
filterUIUserMatrikelnummer :: DBFilterUI
|
|
filterUIUserMatrikelnummer = flip (prismAForm $ singletonFilter "user-matriclenumber") $ aopt textField (fslI MsgTableMatrikelNr)
|
|
|
|
filterUICorrectorNameEmail :: DBFilterUI
|
|
filterUICorrectorNameEmail = flip (prismAForm $ singletonFilter "corrector-name-email") $ aopt textField (fslI MsgTableCorrector)
|
|
|
|
filterUIIsAssigned :: DBFilterUI
|
|
filterUIIsAssigned = flip (prismAForm $ singletonFilter "isassigned" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector)
|
|
|
|
filterUISubmissionGroup :: DBFilterUI
|
|
filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submission-group") $ aopt textField (fslI MsgTableSubmissionGroup)
|
|
|
|
filterUIRating :: DBFilterUI
|
|
filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathPiece) $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
|
|
|
|
filterUIComment :: DBFilterUI
|
|
filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
|
|
|
|
filterUIAuthorshipStatementState :: DBFilterUI
|
|
filterUIAuthorshipStatementState = flip (prismAForm $ singletonFilter "as-state" . maybePrism _PathPiece) $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) optionsFinite :: Field _ AuthorshipStatementSubmissionState) (fslI MsgSubmissionUserAuthorshipStatementState)
|
|
|
|
|
|
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
|
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> Maybe CorrectionTableCsvSettings -> PSValidator m x -> DBParams m x -> DB (DBResult m x)
|
|
makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' mCSVSettings psValidator dbtParams
|
|
= 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
|
|
forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria ->
|
|
let haystack = map CI.mk . unpack $ toPathPiece cid
|
|
in guard $ any (`isInfixOf` haystack) criteria
|
|
|
|
|
|
submittors <- lift . lift . 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')
|
|
|
|
mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet
|
|
(submittorMap, fmap getMax -> asState) <- runWriterT . flip foldMapM submittors $ \(Entity userId user, E.Value pseudo, E.Value sGroup) -> do
|
|
asState <- for mASDefinition $ \_ -> lift . lift . lift $ getUserAuthorshipStatement mASDefinition sId userId
|
|
tell $ Max <$> asState
|
|
return $ Map.singleton userId (user, pseudo, sGroup, asState)
|
|
|
|
forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion ->
|
|
guard $ asState == Just criterion
|
|
|
|
forMM_ (view $ _dbtProjFilter . _corrProjFilterPseudonym) $ \criteria ->
|
|
let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap
|
|
in guard $ any (\haystack -> any (`isInfixOf` haystack) criteria) haystacks
|
|
|
|
nonAnonymousAccess <- lift . lift $ or2M
|
|
(return $ not sheetAnonymousCorrection)
|
|
(hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
|
|
|
|
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess, asState)
|
|
dbtRowKey = views querySubmission (E.^. SubmissionId)
|
|
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))
|
|
]
|
|
, 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 "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) 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 $ views resultCryptoID toPathPiece
|
|
, singletonMap "as-state" . SortProjected . comparing $ view resultASState
|
|
]
|
|
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.mkContainsFilterWith Just (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 ?~)
|
|
, singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~)
|
|
, singletonMap "as-state" $ FilterProjected (_corrProjFilterAuthorshipStatementState <>~)
|
|
]
|
|
dbtFilterUI = fromMaybe mempty dbtFilterUI'
|
|
dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' }
|
|
dbtIdent = "corrections" :: Text
|
|
dbtCsvEncode = do
|
|
CorrectionTableCsvSettings{..} <- mCSVSettings
|
|
return DBTCsvEncode
|
|
{ dbtCsvExportForm = CorrectionTableCsvExportData
|
|
<$> apopt checkBoxField (fslI MsgCorrectionCsvSingleSubmittors & setTooltip MsgCorrectionCsvSingleSubmittorsTip) (Just $ csvCorrectionSingleSubmittors def)
|
|
, dbtCsvNoExportData = Nothing
|
|
, dbtCsvDoEncode = \CorrectionTableCsvExportData{..} -> awaitForever $ \(_, row) -> runReaderC row $ do
|
|
submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) . toListOf resultSubmittors
|
|
forM_ (bool pure (map pure) csvCorrectionSingleSubmittors submittors) $ \submittors' -> transPipe (withReaderT (, submittors')) $ do
|
|
let guardNonAnonymous = runMaybeT . guardMOnM (view $ _1 . resultNonAnonymousAccess) . MaybeT
|
|
yieldM $ CorrectionTableCsv
|
|
<$> preview (_1 . resultCourseTerm . _TermId)
|
|
<*> preview (_1 . resultCourseSchool . _SchoolId)
|
|
<*> preview (_1 . resultCourseShorthand)
|
|
<*> preview (_1 . resultSheet . _entityVal . _sheetName)
|
|
<*> preview (_1 . resultCryptoID . re (_CI . _PathPiece))
|
|
<*> guardNonAnonymous (preview $ _1 . resultLastEdit)
|
|
<*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userSurname . re _Just))
|
|
<*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userFirstName . re _Just))
|
|
<*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userDisplayName . re _Just))
|
|
<*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userMatrikelnummer))
|
|
<*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userEmail . re _Just))
|
|
<*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserPseudonym))
|
|
<*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserSubmissionGroup))
|
|
<*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserAuthorshipStatementState))
|
|
<*> preview (_1 . resultSubmission . _entityVal . _submissionRatingAssigned . _Just)
|
|
<*> preview (_1 . resultCorrector . _entityVal . _userDisplayName)
|
|
<*> preview (_1 . resultCorrector . _entityVal . _userEmail)
|
|
<*> preview (_1 . resultSubmission . _entityVal . to submissionRatingDone)
|
|
<*> preview (_1 . resultSubmission . _entityVal . _submissionRatingTime . _Just)
|
|
<*> preview (_1 . resultSubmission . _entityVal . _submissionRatingPoints . _Just)
|
|
<*> preview (_1 . resultSubmission . _entityVal . _submissionRatingComment . _Just)
|
|
, dbtCsvName = cTableCsvName, dbtCsvSheetName = cTableCsvSheetName
|
|
, dbtCsvHeader = \_ -> return $ correctionTableCsvHeader cTableShowCorrector cTableCsvQualification
|
|
, dbtCsvExampleData = Nothing
|
|
}
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = maybe id (\CorrectionTableCsvSettings{..} -> withCsvExtraRep cTableCsvSheetName (def :: CorrectionTableCsvExportData) dbtCsvEncode) mCSVSettings
|
|
[ DBTExtraRep $ toPrettyJSON <$> repCorrectionJson, DBTExtraRep $ toYAML <$> repCorrectionJson
|
|
]
|
|
|
|
repCorrectionJson :: ConduitT (E.Value SubmissionId, CorrectionTableData) Void DB (Map CryptoFileNameSubmission CorrectionTableJson)
|
|
repCorrectionJson = C.foldMap $ \(_, res) -> Map.singleton (res ^. resultCryptoID) $ mkCorrectionTableJson res
|
|
where
|
|
mkCorrectionTableJson :: CorrectionTableData -> CorrectionTableJson
|
|
mkCorrectionTableJson res' = flip runReader res' $ do
|
|
let guardNonAnonymous :: Reader CorrectionTableData (Maybe a) -> Reader CorrectionTableData (Maybe a)
|
|
guardNonAnonymous = runMaybeT . guardMOnM (view resultNonAnonymousAccess) . MaybeT
|
|
mkCorrectionTableSubmittorJson :: Reader CorrectionTableData (Maybe [CorrectionTableSubmittorJson])
|
|
mkCorrectionTableSubmittorJson = Just <$> do
|
|
submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) . toListOf resultSubmittors
|
|
forM submittors $ \submittor -> lift . flip runReaderT submittor $
|
|
CorrectionTableSubmittorJson
|
|
<$> view (resultUserUser . _userSurname)
|
|
<*> view (resultUserUser . _userFirstName)
|
|
<*> view (resultUserUser . _userDisplayName)
|
|
<*> view (resultUserUser . _userMatrikelnummer)
|
|
<*> view (resultUserUser . _userEmail)
|
|
<*> preview resultUserPseudonym
|
|
<*> preview resultUserSubmissionGroup
|
|
<*> preview resultUserAuthorshipStatementState
|
|
CorrectionTableJson
|
|
<$> view (resultCourseTerm . _TermId)
|
|
<*> view (resultCourseSchool . _SchoolId)
|
|
<*> view resultCourseShorthand
|
|
<*> view (resultSheet . _entityVal . _sheetName)
|
|
<*> guardNonAnonymous (preview resultLastEdit)
|
|
<*> guardNonAnonymous mkCorrectionTableSubmittorJson
|
|
<*> preview (resultSubmission . _entityVal . _submissionRatingAssigned . _Just)
|
|
<*> preview (resultCorrector . _entityVal . _userDisplayName)
|
|
<*> preview (resultCorrector . _entityVal . _userEmail)
|
|
<*> view (resultSubmission . _entityVal . to submissionRatingDone)
|
|
<*> preview (resultSubmission . _entityVal . _submissionRatingTime . _Just)
|
|
<*> preview (resultSubmission . _entityVal . _submissionRatingPoints . _Just)
|
|
<*> preview (resultSubmission . _entityVal . _submissionRatingComment . _Just)
|
|
in dbTable psValidator DBTable{..}
|
|
|
|
data ActionCorrections = CorrDownload
|
|
| CorrSetCorrector
|
|
| CorrAutoSetCorrector
|
|
| CorrSetCorrectionsDone
|
|
| 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 SubmissionFileType
|
|
| CorrSetCorrectorData (Maybe UserId)
|
|
| CorrAutoSetCorrectorData SheetId
|
|
| CorrSetCorrectionsDoneData Bool
|
|
| CorrDeleteData
|
|
|
|
correctionsR :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
|
|
correctionsR whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do
|
|
(table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions
|
|
|
|
fmap toTypedContent . defaultLayout $ do
|
|
setTitleI MsgCourseCorrectionsTitle
|
|
$(widgetFile "corrections")
|
|
|
|
correctionsR' :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey)
|
|
correctionsR' whereClause displayColumns dbtFilterUI csvSettings 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 csvSettings 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 sft, 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 sft 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
|
|
(CorrSetCorrectionsDoneData isDone, subs') -> do
|
|
now <- liftIO getCurrentTime
|
|
subs <- mapM decrypt $ Set.toList subs'
|
|
runDB $ do
|
|
_ <- updateWhere [SubmissionId <-. subs]
|
|
[SubmissionRatingTime =. bool Nothing (Just now) isDone]
|
|
addMessageI Success $ MsgSetCorrectionsDone isDone
|
|
auditAllSubEdit subs
|
|
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")
|
|
. restrictFilter (\k _ -> k /= "as-state")
|
|
. restrictSorting (\k _ -> k /= "submittors")
|
|
. restrictSorting (\k _ -> k /= "submittors-matriculation")
|
|
. restrictSorting (\k _ -> k /= "submittors-group")
|
|
. restrictSorting (\k _ -> k /= "last-edit")
|
|
. restrictSorting (\k _ -> k /= "as-state")
|
|
|
|
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)
|
|
<*> apopt (selectField optionsFinite) (fslI MsgCorrDownloadVersion) (Just SubmissionCorrected)
|
|
)
|
|
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 MsgTableCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing
|
|
fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
|
|
)
|
|
|
|
setCorrectionsDoneAction :: ActionCorrections'
|
|
setCorrectionsDoneAction = ( CorrSetCorrectionsDone
|
|
, CorrSetCorrectionsDoneData
|
|
<$> apopt checkBoxField (fslI MsgCorrSetCorrectionsDone) (Just True)
|
|
)
|
|
|
|
autoAssignAction :: SheetId -> ActionCorrections'
|
|
autoAssignAction shid = ( CorrAutoSetCorrector
|
|
, pure $ CorrAutoSetCorrectorData shid
|
|
)
|
|
|
|
|
|
getCorrectionsR, postCorrectionsR :: Handler TypedContent
|
|
getCorrectionsR = postCorrectionsR
|
|
postCorrectionsR = do
|
|
uid <- requireAuthId
|
|
let whereClause :: CorrectionTableWhere
|
|
whereClause = ratedBy uid
|
|
colonnade = mconcat
|
|
[ colSelect
|
|
, colSchool
|
|
, colTerm
|
|
, colCourse
|
|
, colSheet
|
|
, colSMatrikel
|
|
, colSubmittors
|
|
, colSGroups
|
|
, colPseudonyms
|
|
, colSubmissionLink
|
|
, colAssigned
|
|
, colRating
|
|
, colRated
|
|
]
|
|
filterUI = Just $ mconcat
|
|
[ filterUIPseudonym
|
|
, filterUICourse courseOptions
|
|
, filterUITerm termOptions
|
|
, filterUISchool schoolOptions
|
|
, filterUISheetSearch
|
|
, filterUIIsRated
|
|
, filterUISubmission
|
|
]
|
|
courseOptions = runDB $ do
|
|
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . courseShorthand . entityVal) courses
|
|
termOptions = runDB $ do
|
|
courses <- selectList [] [Desc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
optionsPairs . map (id &&& id) . nubOrd $ 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) . nubOrd $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
|
|
|
|
psValidator = def
|
|
& restrictCorrector
|
|
& restrictAnonymous
|
|
& defaultSorting [SortAscBy "assignedtime", SortDescBy "ratingtime"]
|
|
& defaultFilter (singletonMap "israted" [toPathPiece False])
|
|
|
|
csvSettings = Just CorrectionTableCsvSettings
|
|
{ cTableCsvQualification = CorrectionTableCsvQualifyCourse
|
|
, cTableCsvName = MsgCorrectionTableCsvNameCorrections
|
|
, cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCorrections
|
|
, cTableShowCorrector = False
|
|
}
|
|
correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList
|
|
[ downloadAction
|
|
]
|
|
|
|
getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
|
getCCorrectionsR = postCCorrectionsR
|
|
postCCorrectionsR tid ssh csh = do
|
|
(Entity cid _, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do
|
|
course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
doSubmissionGroups <- exists [SubmissionGroupCourse ==. cid]
|
|
doAuthorshipStatements <- runConduit $
|
|
(E.selectSource . E.from $ \sheet -> sheet <$ E.where_ (sheet E.^. SheetCourse E.==. E.val cid))
|
|
.| C.mapM getSheetAuthorshipStatement
|
|
.| C.map (is _Just)
|
|
.| C.or
|
|
return (course, doSubmissionGroups, doAuthorshipStatements)
|
|
let whereClause :: CorrectionTableWhere
|
|
whereClause = courseIs cid
|
|
colonnade = mconcat $ catMaybes -- should match getSSubsR for consistent UX
|
|
[ pure colSelect
|
|
, pure colSheet
|
|
, pure colSMatrikel
|
|
, pure colSubmittors
|
|
, guardOn doSubmissionGroups colSGroups
|
|
, pure colSubmissionLink
|
|
, pure colLastEdit
|
|
, guardOn doAuthorshipStatements colAuthorshipStatementState
|
|
, pure colRating
|
|
, pure colRated
|
|
, pure colCorrector
|
|
, pure colAssigned
|
|
] -- Continue here
|
|
filterUI = Just $ mconcat
|
|
[ filterUISheetSearch
|
|
, filterUIUserNameEmail
|
|
, filterUIUserMatrikelnummer
|
|
, filterUIPseudonym
|
|
, filterUISubmissionGroup
|
|
, filterUIAuthorshipStatementState
|
|
, filterUICorrectorNameEmail
|
|
, filterUIIsAssigned
|
|
, filterUIIsRated
|
|
, filterUISubmission
|
|
]
|
|
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
|
|
csvSettings = Just CorrectionTableCsvSettings
|
|
{ cTableCsvQualification = CorrectionTableCsvQualifySheet
|
|
, cTableCsvName = MsgCorrectionTableCsvNameCourseCorrections tid ssh csh
|
|
, cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseCorrections tid ssh csh
|
|
, cTableShowCorrector = True
|
|
}
|
|
correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList
|
|
[ downloadAction
|
|
, assignAction (Left cid)
|
|
, setCorrectionsDoneAction
|
|
, deleteAction
|
|
]
|
|
|
|
getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
|
getSSubsR = postSSubsR
|
|
postSSubsR tid ssh csh shn = do
|
|
(shid, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do
|
|
sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
|
doSubmissionGroups <- exists [SubmissionGroupCourse ==. sheetCourse]
|
|
doAuthorshipStatements <- is _Just <$> getSheetAuthorshipStatement sheet
|
|
return (shid, doSubmissionGroups, doAuthorshipStatements)
|
|
let whereClause :: CorrectionTableWhere
|
|
whereClause = sheetIs shid
|
|
colonnade = mconcat $ catMaybes -- should match getCCorrectionsR for consistent UX
|
|
[ pure colSelect
|
|
, pure colSMatrikel
|
|
, pure colSubmittors
|
|
, guardOn doSubmissionGroups colSGroups
|
|
, pure colSubmissionLink
|
|
, pure colLastEdit
|
|
, guardOn doAuthorshipStatements colAuthorshipStatementState
|
|
, pure colRating
|
|
, pure colRated
|
|
, pure colCorrector
|
|
, pure colAssigned
|
|
]
|
|
filterUI = Just $ mconcat
|
|
[ filterUIUserNameEmail
|
|
, filterUIUserMatrikelnummer
|
|
, filterUIPseudonym
|
|
, filterUISubmissionGroup
|
|
, filterUIAuthorshipStatementState
|
|
, filterUICorrectorNameEmail
|
|
, filterUIIsAssigned
|
|
, filterUIIsRated
|
|
, filterUISubmission
|
|
]
|
|
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
|
|
csvSettings = Just CorrectionTableCsvSettings
|
|
{ cTableCsvQualification = CorrectionTableCsvNoQualification
|
|
, cTableCsvName = MsgCorrectionTableCsvNameSheetCorrections tid ssh csh shn
|
|
, cTableCsvSheetName = MsgCorrectionTableCsvSheetNameSheetCorrections tid ssh csh shn
|
|
, cTableShowCorrector = True
|
|
}
|
|
correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList
|
|
[ downloadAction
|
|
, assignAction (Right shid)
|
|
, autoAssignAction shid
|
|
, setCorrectionsDoneAction
|
|
, deleteAction
|
|
]
|