1322 lines
76 KiB
Haskell
1322 lines
76 KiB
Haskell
module Handler.Corrections where
|
||
|
||
import Import hiding (link)
|
||
-- import System.FilePath (takeFileName)
|
||
|
||
import Jobs
|
||
import Handler.Utils hiding (colSchool)
|
||
import Handler.Utils.Corrections
|
||
import Handler.Utils.Submission
|
||
import Handler.Utils.SheetType
|
||
import Handler.Utils.Delete
|
||
-- import Handler.Utils.Zip
|
||
|
||
import Data.List as List (foldl, foldr)
|
||
import qualified Data.Set as Set
|
||
import Data.Map.Strict ((!))
|
||
import qualified Data.Map.Strict as Map
|
||
|
||
import qualified Data.Text as Text
|
||
import qualified Data.CaseInsensitive as CI
|
||
|
||
-- import Data.Time
|
||
-- import Data.Function ((&))
|
||
--
|
||
-- import Colonnade hiding (fromMaybe, singleton, bool)
|
||
-- import Yesod.Colonnade
|
||
--
|
||
-- import qualified Data.UUID.Cryptographic as UUID
|
||
-- import qualified Data.Conduit.List as C
|
||
|
||
import Database.Esqueleto.Utils.TH
|
||
import qualified Database.Esqueleto as E
|
||
import qualified Database.Esqueleto.Utils as E
|
||
import qualified Database.Esqueleto.Internal.Language (From)
|
||
-- import qualified Database.Esqueleto.Internal.Sql as E
|
||
|
||
-- import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
||
|
||
-- import Network.Mime
|
||
|
||
import Text.Hamlet (ihamletFile)
|
||
|
||
import Database.Persist.Sql (updateWhereCount)
|
||
|
||
import Data.List (genericLength)
|
||
|
||
import qualified Control.Monad.State.Class as State
|
||
|
||
import qualified Data.Conduit.List as C
|
||
|
||
|
||
|
||
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))
|
||
|
||
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 :: Database.Esqueleto.Internal.Language.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)
|
||
|
||
querySheet :: CorrectionTableExpr -> E.SqlExpr (Entity Sheet)
|
||
querySheet = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
|
||
|
||
querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission)
|
||
querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
|
||
|
||
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
|
||
|
||
|
||
-- 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}|]
|
||
|
||
colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||
colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $
|
||
i18nCell . sheetType <$> view (_dbrOutput . _2 . _entityVal)
|
||
-- \DBRow{ dbrOutput=(_, sheet, _, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
|
||
|
||
colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||
DBRow{ dbrOutput = (_, _, _, Nothing , _, _) } -> cell mempty
|
||
DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _) } -> userCell userDisplayName userSurname
|
||
|
||
colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _,_) } ->
|
||
let csh = course ^. _2
|
||
tid = course ^. _3
|
||
ssh = course ^. _4
|
||
shn = sheetName $ entityVal sheet
|
||
mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice
|
||
mkRoute = do
|
||
cid <- mkCid
|
||
return $ CSubmissionR tid ssh csh shn cid SubShowR
|
||
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{cid}|])
|
||
|
||
colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
|
||
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> encrypt subId
|
||
|
||
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users) } -> 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)) ->
|
||
anchorCellM (link <$> encrypt userId) $ case mPseudo of
|
||
Nothing -> nameWidget userDisplayName userSurname
|
||
Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|]
|
||
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||
|
||
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let
|
||
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer)
|
||
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||
|
||
colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary))
|
||
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
|
||
mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
|
||
in mconcat
|
||
[ anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
|
||
, writerCell $ do
|
||
let
|
||
summary :: SheetTypeSummary
|
||
summary = sheetTypeSum sheetType $ submissionRatingPoints <* guard (submissionRatingDone sub)
|
||
scribe (_2 :: Lens' (a, SheetTypeSummary) SheetTypeSummary) 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 $ snd . snd <$> 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 fvInput <$> 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 -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
|
||
_other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
|
||
)
|
||
|
||
colMaxPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
|
||
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _) } -> sheetType)
|
||
|
||
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
|
||
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (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 fvInput <$> 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 dbtProj' 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 _ -> MaybeT (ReaderT SqlBackend (HandlerFor UniWorX)) CorrectionTableData
|
||
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do
|
||
submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
|
||
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]
|
||
return (user, pseudonym E.?. SheetPseudonymPseudonym)
|
||
let
|
||
submittorMap = List.foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
|
||
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap)
|
||
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"
|
||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) ->
|
||
E.subSelectUnsafe . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||
E.limit 1
|
||
return (user E.^. UserSurname)
|
||
)
|
||
, ( "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
|
||
)
|
||
]
|
||
, 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)
|
||
)
|
||
, ( "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)
|
||
)
|
||
]
|
||
, dbtFilterUI = fromMaybe mempty dbtFilterUI
|
||
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
|
||
, dbtParams
|
||
, dbtIdent = "corrections" :: Text
|
||
, dbtCsvEncode = noCsvEncode
|
||
, dbtCsvDecode = Nothing
|
||
}
|
||
|
||
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
|
||
| CorrSetCorrectorData (Maybe UserId)
|
||
| CorrAutoSetCorrectorData SheetId
|
||
| CorrDeleteData
|
||
|
||
correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
|
||
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 return 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' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||
& mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
||
auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
|
||
|
||
case actionRes of
|
||
FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs
|
||
FormMissing -> return ()
|
||
FormSuccess (CorrDownloadData, subs) -> do
|
||
ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
|
||
addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|]
|
||
sendResponse =<< submissionMultiArchive ids
|
||
FormSuccess (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
|
||
FormSuccess (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
|
||
FormSuccess (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
|
||
FormSuccess (CorrDeleteData, subs) -> do
|
||
subs' <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
|
||
getDeleteR (submissionDeleteRoute subs')
|
||
{ drAbort = SomeRoute currentRoute
|
||
, drSuccess = SomeRoute currentRoute
|
||
}
|
||
|
||
fmap toTypedContent . defaultLayout $ do
|
||
setTitleI MsgCourseCorrectionsTitle
|
||
$(widgetFile "corrections")
|
||
|
||
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
|
||
|
||
type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData)
|
||
|
||
downloadAction, deleteAction :: ActionCorrections'
|
||
downloadAction = ( CorrDownload
|
||
, pure CorrDownloadData
|
||
)
|
||
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
|
||
, dbRow -- very useful, since correction statistics are still missing.
|
||
, colSchool
|
||
, colTerm
|
||
, colCourse
|
||
, colSheet
|
||
, 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)
|
||
]
|
||
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
|
||
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||
& restrictSorting (\name _ -> name /= "corrector")
|
||
& 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
|
||
, dbRow
|
||
, colSheet
|
||
, colSMatrikel
|
||
, colSubmittors
|
||
, 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)
|
||
]
|
||
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
|
||
, dbRow
|
||
, 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)
|
||
-- "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
|
||
]
|
||
|
||
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
|
||
correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
|
||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||
E.&&. submission E.^. SubmissionId E.==. E.val sub
|
||
return (course, sheet, submission, corrector)
|
||
|
||
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||
getCorrectionR tid ssh csh shn cid = do
|
||
mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
|
||
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
|
||
postCorrectionR tid ssh csh shn cid = do
|
||
sub <- decrypt cid
|
||
|
||
results <- runDB $ correctionData tid ssh csh shn sub
|
||
|
||
MsgRenderer mr <- getMsgRenderer
|
||
case results of
|
||
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do
|
||
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
|
||
pointsForm = case sheetType of
|
||
NotGraded -> pure Nothing
|
||
_otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
|
||
(fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType)
|
||
(Just submissionRatingPoints)
|
||
|
||
((corrResult, corrForm'), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,)
|
||
<$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
|
||
<*> pointsForm
|
||
<*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
|
||
let corrForm = wrapForm' BtnSave corrForm' def
|
||
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||
, formEncoding = corrEncoding
|
||
}
|
||
|
||
((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
|
||
areq (zipFileField True Nothing) (fslI MsgRatingFiles) Nothing
|
||
let uploadForm = wrapForm uploadForm' def
|
||
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||
, formEncoding = uploadEncoding
|
||
}
|
||
|
||
formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do
|
||
uid <- liftHandler requireAuthId
|
||
now <- liftIO getCurrentTime
|
||
|
||
if
|
||
| errs <- validateRating sheetType Rating'
|
||
{ ratingPoints = ratingPoints'
|
||
, ratingComment = ratingComment'
|
||
, ratingTime = (now <$ guard rated)
|
||
}
|
||
, not $ null errs
|
||
-> mapM_ (addMessageI Error) errs
|
||
| otherwise -> do
|
||
runDBJobs $ do
|
||
update sub [ SubmissionRatingBy =. Just uid
|
||
, SubmissionRatingTime =. (now <$ guard rated)
|
||
, SubmissionRatingPoints =. ratingPoints'
|
||
, SubmissionRatingComment =. ratingComment'
|
||
]
|
||
|
||
addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
|
||
|
||
when (rated && isNothing submissionRatingTime) $ do
|
||
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
|
||
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
|
||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||
|
||
formResult uploadResult $ \fileUploads -> do
|
||
uid <- requireAuthId
|
||
|
||
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
||
case res of
|
||
Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors
|
||
(Just _) -> do
|
||
addMessageI Success MsgRatingFilesUpdated
|
||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||
|
||
let sheetTypeDesc = mr sheetType
|
||
heading = MsgCorrectionHead tid ssh csh shn cid
|
||
headingWgt = [whamlet|
|
||
$newline never
|
||
_{heading}
|
||
$if not (submissionRatingDone subm)
|
||
\ ^{isVisibleWidget False}
|
||
|]
|
||
siteLayout headingWgt $ do
|
||
setTitleI heading
|
||
let userCorrection = $(widgetFile "correction-user")
|
||
$(widgetFile "correction")
|
||
_ -> notFound
|
||
|
||
|
||
getCorrectionUserR tid ssh csh shn cid = do
|
||
sub <- decrypt cid
|
||
|
||
results <- runDB $ correctionData tid ssh csh shn sub
|
||
|
||
case results of
|
||
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do
|
||
mr <- getMessageRender
|
||
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
|
||
sheetTypeDesc = mr sheetType
|
||
defaultLayout $
|
||
$(widgetFile "correction-user")
|
||
_ -> notFound
|
||
|
||
|
||
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
|
||
getCorrectionsUploadR = postCorrectionsUploadR
|
||
postCorrectionsUploadR = do
|
||
((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
|
||
areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing
|
||
|
||
case uploadRes of
|
||
FormMissing -> return ()
|
||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||
FormSuccess files -> do
|
||
uid <- requireAuthId
|
||
mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkMultiSubmission uid True
|
||
case mbSubs of
|
||
Nothing -> return ()
|
||
(Just subs)
|
||
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
|
||
| otherwise -> do
|
||
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) $ Set.toList subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
|
||
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
|
||
content = Right $(widgetFile "messages/correctionsUploaded")
|
||
addMessageModal Success trigger content
|
||
|
||
let uploadForm = wrapForm upload def
|
||
{ formAction = Just $ SomeRoute CorrectionsUploadR
|
||
, formEncoding = uploadEncoding
|
||
}
|
||
|
||
maxUploadMB <- appMaximumContentLength <$> getsYesod appSettings'
|
||
|
||
defaultLayout $ do
|
||
let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions")
|
||
$(widgetFile "corrections-upload")
|
||
|
||
getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
|
||
getCorrectionsCreateR = postCorrectionsCreateR
|
||
postCorrectionsCreateR = do
|
||
uid <- requireAuthId
|
||
let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||
let
|
||
isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_
|
||
$ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
|
||
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||
isLecturer = E.exists . E.from $ \lecturer -> E.where_
|
||
$ lecturer E.^. LecturerUser E.==. E.val uid
|
||
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||
E.where_ $ isCorrector E.||. isLecturer
|
||
E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
|
||
return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName))
|
||
mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
|
||
mkOptList opts = do
|
||
opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts
|
||
MsgRenderer mr <- getMsgRenderer
|
||
return . mkOptionList $ do
|
||
(cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts'
|
||
let tid' = mr $ ShortTermIdentifier (unTermKey tid)
|
||
return Option
|
||
{ optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn
|
||
, optionInternalValue = sid
|
||
, optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet)
|
||
}
|
||
MsgRenderer mr <- getMsgRenderer
|
||
((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,)
|
||
<$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing
|
||
<*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms (mr MsgPseudonyms) & setTooltip MsgCorrectionPseudonymsTip) Nothing)
|
||
|
||
case pseudonymRes of
|
||
FormMissing -> return ()
|
||
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
||
FormSuccess (sid, (pss, invalids)) -> do
|
||
allDone <- fmap getAll . execWriterT $ do
|
||
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
|
||
tell . All $ null invalids
|
||
|
||
WriterT . runDBJobs . mapReaderT (mapWriterT $ fmap ((,) <$> ((,) <$> view (_1 . _1) <*> view _2) <*> view (_1 . _2)) . runWriterT) $ do
|
||
Sheet{..} <- get404 sid :: ReaderT SqlBackend (WriterT (Set QueuedJobId) (WriterT All (HandlerFor UniWorX))) Sheet
|
||
(sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
|
||
forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
|
||
lift . lift . tell . All $ null unknown
|
||
now <- liftIO getCurrentTime
|
||
let
|
||
sps' :: [[SheetPseudonym]]
|
||
duplicate :: Set Pseudonym
|
||
( sps'
|
||
, Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
|
||
) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
|
||
known <- State.gets $ Map.member sheetPseudonymPseudonym
|
||
State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
|
||
return $ bool (p :) id known ps
|
||
submissionPrototype = Submission
|
||
{ submissionSheet = sid
|
||
, submissionRatingPoints = Nothing
|
||
, submissionRatingComment = Nothing
|
||
, submissionRatingBy = Just uid
|
||
, submissionRatingAssigned = Just now
|
||
, submissionRatingTime = Nothing
|
||
}
|
||
unless (null duplicate) $
|
||
addMessageModal Warning [whamlet|_{MsgSheetDuplicatePseudonym}|] $ Right $(widgetFile "messages/submissionCreateDuplicates")
|
||
existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
||
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
||
E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
|
||
E.&&. submission E.^. SubmissionSheet E.==. E.val sid
|
||
return submissionUser
|
||
unless (null existingSubUsers) . mapReaderT lift $ do
|
||
(Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: _ CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
|
||
let trigger = [whamlet|_{MsgSheetCreateExisting}|]
|
||
content = Right $(widgetFile "messages/submissionCreateExisting")
|
||
addMessageModal Warning trigger content
|
||
let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
|
||
forM_ sps'' $ \spGroup
|
||
-> let
|
||
sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
|
||
in case sheetGrouping of
|
||
Arbitrary maxSize -> do
|
||
subId <- insert submissionPrototype
|
||
void . insert $ SubmissionEdit uid now subId
|
||
audit $ TransactionSubmissionEdit subId sid
|
||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||
{ submissionUserUser = sheetPseudonymUser
|
||
, submissionUserSubmission = subId
|
||
}
|
||
forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do
|
||
hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId
|
||
audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser
|
||
when (genericLength spGroup > maxSize) $
|
||
addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
|
||
RegisteredGroups -> do
|
||
let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup
|
||
groups <- E.select . E.from $ \submissionGroup -> do
|
||
E.where_ . E.exists . E.from $ \submissionGroupUser ->
|
||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
|
||
return $ submissionGroup E.^. SubmissionGroupId
|
||
groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do
|
||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups)
|
||
return $ submissionGroupUser E.^. SubmissionGroupUserUser
|
||
if
|
||
| [_] <- groups
|
||
, Map.keysSet spGroup' `Set.isSubsetOf` groupUsers
|
||
-> do
|
||
subId <- insert submissionPrototype
|
||
void . insert $ SubmissionEdit uid now subId
|
||
audit $ TransactionSubmissionEdit subId sid
|
||
insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser
|
||
{ submissionUserUser = sheetUser
|
||
, submissionUserSubmission = subId
|
||
}
|
||
forM_ groupUsers $ \subUid -> do
|
||
hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid subId
|
||
audit $ TransactionSubmissionUserEdit subId subUid
|
||
when (null groups) $
|
||
addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
|
||
| length groups < 2
|
||
-> do
|
||
forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do
|
||
addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym)
|
||
lift . lift . tell $ All False
|
||
| otherwise ->
|
||
addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
|
||
NoGroups -> do
|
||
subId <- insert submissionPrototype
|
||
void . insert $ SubmissionEdit uid now subId
|
||
audit $ TransactionSubmissionEdit subId sid
|
||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||
{ submissionUserUser = sheetPseudonymUser
|
||
, submissionUserSubmission = subId
|
||
}
|
||
forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do
|
||
hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId
|
||
audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser
|
||
when (length spGroup > 1) $
|
||
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
|
||
when allDone $
|
||
redirect CorrectionsGradeR
|
||
|
||
let pseudonymForm = wrapForm pseudonymWidget def
|
||
{ formAction = Just $ SomeRoute CorrectionsCreateR
|
||
, formEncoding = pseudonymEncoding
|
||
}
|
||
|
||
siteLayoutMsg MsgCorrCreate $ do
|
||
setTitleI MsgCorrCreate
|
||
$(widgetFile "corrections-create")
|
||
where
|
||
partitionEithers' :: [[Either a b]] -> ([[b]], [a])
|
||
partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
|
||
|
||
textToList :: Textarea -> ([[Pseudonym]], Map (Text, Text) [Pseudonym])
|
||
textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . map Text.strip . Text.lines . unTextarea -> ws)
|
||
= runWriter . fmap (mapMaybe sequence) $ mapM (\ws' -> mapM (toPseudonym ws') ws') ws
|
||
where
|
||
toPseudonym w' w
|
||
| Just res <- w ^? _PseudonymText = return $ Just res
|
||
| otherwise = Nothing <$ tell (Map.singleton (Text.intercalate ", " w', w) $ w ^.. pseudonymFragments . _PseudonymWords)
|
||
|
||
getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
|
||
getCorrectionsGradeR = postCorrectionsGradeR
|
||
postCorrectionsGradeR = do
|
||
uid <- requireAuthId
|
||
let whereClause = ratedBy uid
|
||
displayColumns = mconcat -- should match getSSubsR for consistent UX
|
||
[ -- dbRow,
|
||
colSchool
|
||
, colTerm
|
||
, colCourse
|
||
, colSheet
|
||
, colPseudonyms
|
||
, colSubmissionLink
|
||
, colRated
|
||
, colRatedField
|
||
, colPointsField
|
||
, colMaxPointsField
|
||
, colCommentField
|
||
] -- 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 "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
|
||
, prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
|
||
, Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
|
||
]
|
||
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
|
||
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
|
||
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
||
dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do
|
||
cID <- encrypt subId
|
||
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
|
||
return i
|
||
|
||
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator dbtProj' $ def
|
||
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
|
||
}
|
||
|
||
case tableRes of
|
||
FormMissing -> return ()
|
||
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
||
FormSuccess resMap -> do
|
||
now <- liftIO getCurrentTime
|
||
subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do
|
||
s@Submission{..} <- get404 subId
|
||
if
|
||
| submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s
|
||
-> do audit $ TransactionSubmissionEdit subId $ s ^. _submissionSheet
|
||
Just subId <$ update subId [ SubmissionRatingPoints =. mPoints
|
||
, SubmissionRatingComment =. mComment
|
||
, SubmissionRatingBy =. Just uid
|
||
, SubmissionRatingTime =. now <$ guard rated
|
||
]
|
||
| otherwise -> return Nothing
|
||
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
|
||
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
|
||
content = Right $(widgetFile "messages/correctionsUploaded")
|
||
unless (null subs') $ addMessageModal Success trigger content
|
||
|
||
siteLayoutMsg MsgCorrectionsGrade $ do
|
||
setTitleI MsgCorrectionsGrade
|
||
$(widgetFile "corrections-grade")
|
||
|
||
|
||
data ButtonSubmissionsAssign = BtnSubmissionsAssign
|
||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||
instance Universe ButtonSubmissionsAssign
|
||
instance Finite ButtonSubmissionsAssign
|
||
nullaryPathPiece ''ButtonSubmissionsAssign camelToPathPiece
|
||
embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id
|
||
instance Button UniWorX ButtonSubmissionsAssign where
|
||
btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary]
|
||
|
||
-- | DEPRECATED use CorrectorInfo instead. Gather info about corrector assignment per sheet
|
||
data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiCorrectorNr, saiUnassignedNr :: Int }
|
||
|
||
getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||
getCAssignR = postCAssignR
|
||
postCAssignR tid ssh csh = do
|
||
cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||
assignHandler tid ssh csh cid []
|
||
|
||
getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||
getSAssignR = postSAssignR
|
||
postSAssignR tid ssh csh shn = do
|
||
(shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn
|
||
assignHandler tid ssh csh cid [shid]
|
||
|
||
{- TODO: Feature:
|
||
make distivt buttons for each sheet, so that users see which sheet will be assigned.
|
||
Currently this information is available within the page heading!
|
||
|
||
Stub:
|
||
data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName
|
||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||
instance Button UniWorX ButtonCorrectionsAssign
|
||
-- Are those needed any more?
|
||
instance Universe ButtonCorrectionsAssign
|
||
instance Finite ButtonCorrectionsAssign
|
||
nullaryPathPiece ''ButtonCorrectionsAssign camelToPathPiece
|
||
embedRenderMessage ''UniWorX ''ButtonCorrectionsAssign id
|
||
instance Button UniWorX ButtonCorrectionsAssign where
|
||
btnClasses BtnCorrectionsAssign = [BCIsButton, BCPrimary]
|
||
-- use runButtonForm' instead later on
|
||
-}
|
||
|
||
assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html
|
||
assignHandler tid ssh csh cid assignSids = do
|
||
-- evaluate form first, since it affects DB action
|
||
(btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions
|
||
|
||
-- gather data
|
||
(orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
|
||
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||
nrParticipants <- count [CourseParticipantCourse ==. cid]
|
||
|
||
sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
|
||
let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList
|
||
sheets = entities2map sheetList
|
||
sheetIds = Map.keys sheets
|
||
groupsPossible :: Bool
|
||
groupsPossible =
|
||
let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups
|
||
in List.foldr foldFun False sheetList
|
||
assignSheetNames = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids
|
||
|
||
-- plan or assign unassigned submissions for given sheets
|
||
let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational))
|
||
buildA acc sid = maybeT (return acc) $ do
|
||
let shn = sheetName $ sheets ! sid
|
||
-- is sheet closed?
|
||
guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable
|
||
-- ask for assignment plan
|
||
let ignoreExceptions :: AssignSubmissionException -> DB (Map SubmissionId (Maybe UserId), Map UserId Rational) -- silently ignore errors, since we check all sheets and only care about sheets with unassigned corrections
|
||
ignoreExceptions NoCorrectors = return mempty
|
||
ignoreExceptions NoCorrectorsByProportion = return mempty
|
||
ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing
|
||
(plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing
|
||
guard $ not $ null plan -- only proceed if there is a plan for this sheet
|
||
-- implement assignment plan
|
||
status <- lift $ case btnResult of
|
||
Nothing -> return (Set.empty, Set.empty)
|
||
(Just BtnSubmissionsAssign) -> do
|
||
status@(sub_ok,sub_fail) <- writeSubmissionPlan plan
|
||
let nr_ok = olength sub_ok
|
||
nr_fail = olength sub_fail
|
||
alert_ok = toMaybe (nr_ok > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoAssigned nr_ok
|
||
alert_fail = toMaybe (nr_fail > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoFailed nr_fail
|
||
msg_status = bool Success Error $ nr_fail > 0
|
||
msg_header = SomeMessage $ shn <> ":"
|
||
when (nr_ok > 0 || nr_fail > 0) $
|
||
addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail]
|
||
return status
|
||
return $ Map.insert shn (status, countMapElems plan, deficit) acc
|
||
assignSids' <- if null assignSids -- assignAll; we distinguish assignSids' here avoid useless Alerts
|
||
then selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
|
||
else return assignSids
|
||
assignment <- foldM buildA Map.empty assignSids'
|
||
|
||
correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do
|
||
E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||
E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds
|
||
return (corrector, user)
|
||
let correctorMap' :: Map UserId (User, Map SheetName SheetCorrector)
|
||
correctorMap' = (\f -> foldl f Map.empty correctors)
|
||
(\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) ->
|
||
let shn = sheetName $ sheets ! sheetCorrectorSheet
|
||
in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc
|
||
)
|
||
-- Lecturers may correct without being enlisted SheetCorrectors, so fetch all names
|
||
act_correctors <- E.select . E.distinct . E.from $ \(submission `E.InnerJoin` user) -> do
|
||
E.on $ submission E.^. SubmissionRatingBy E.==. (E.just $ user E.^. UserId)
|
||
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
|
||
return (submission E.^. SubmissionSheet, user)
|
||
let correctorMap :: Map UserId (User, Map SheetName SheetCorrector)
|
||
correctorMap = (\f -> foldl f correctorMap' act_correctors)
|
||
(\acc (E.Value sheetCorrectorSheet, Entity uid user) ->
|
||
let shn = sheetName $ sheets ! sheetCorrectorSheet
|
||
scr = SheetCorrector uid sheetCorrectorSheet mempty CorrectorExcused
|
||
in Map.insertWith (\_new old -> old) uid (user, Map.singleton shn scr) acc -- keep already known correctors unchanged
|
||
)
|
||
|
||
submissions <- E.select . E.from $ \submission -> do
|
||
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
|
||
let numSubmittors = E.subSelectCount . E.from $ \subUser ->
|
||
E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
|
||
return (submission, numSubmittors)
|
||
-- prepare map
|
||
let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo)
|
||
infoMap = List.foldl (flip buildS) emptySheets submissions
|
||
|
||
-- ensure that all sheets are shown, including those without any submissions
|
||
emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) emptyCorrs m) Map.empty sheetIds
|
||
emptyCorrs = foldl (\m uid -> let cic = Just uid in
|
||
Map.insert cic mempty{ciCorrector=cic} m) Map.empty $ Map.keys correctorMap
|
||
|
||
|
||
buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo)
|
||
buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m =
|
||
let shnm = sheetName $ sheets ! submissionSheet
|
||
corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned
|
||
cinf = Map.singleton submissionRatingBy $ CorrectionInfo
|
||
{ ciSubmittors = fromIntegral nrSbmtrs
|
||
, ciSubmissions = 1
|
||
, ciAssigned = maybe 0 (const 1) submissionRatingBy -- only used in sheetMap
|
||
, ciCorrected = maybe 0 (const 1) submissionRatingTime
|
||
, ciCorrector = submissionRatingBy
|
||
, ciMin = corTime
|
||
, ciTot = corTime
|
||
, ciMax = corTime
|
||
}
|
||
in Map.insertWith (Map.unionWith (<>)) shnm cinf m
|
||
|
||
return (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
|
||
|
||
let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference
|
||
-- create aggregate maps
|
||
|
||
-- Always iterate over orderedSheetNames for consistent sorting!
|
||
sheetMap :: Map SheetName CorrectionInfo
|
||
sheetMap = Map.map fold infoMap
|
||
|
||
sheetLoad :: Map SheetName Load
|
||
sheetLoad = -- Map.unionsWith (<>) ((Map.filter () ) . snd) <$> Map.elems correctorMap)
|
||
let buildSL acc (_user,mSnSc) = Map.foldlWithKey buildL acc mSnSc
|
||
buildL acc s SheetCorrector{sheetCorrectorLoad=l, sheetCorrectorState=CorrectorNormal}
|
||
= Map.insertWith (<>) s l acc
|
||
buildL acc _ _ = acc
|
||
in Map.foldl buildSL Map.empty correctorMap
|
||
|
||
deficitMap :: Map UserId Rational
|
||
deficitMap = foldMap (view _3) assignment
|
||
|
||
corrMap :: Map (Maybe UserId) CorrectionInfo
|
||
corrMap = Map.unionsWith (<>) $ Map.elems infoMap
|
||
|
||
corrInfos :: [CorrectionInfo]
|
||
corrInfos = sortBy (compare `on` (byName . ciCorrector) ) $ Map.elems corrMap
|
||
where byName Nothing = Nothing
|
||
byName (Just uid) = Map.lookup uid correctorMap
|
||
corrMapSum :: CorrectionInfo
|
||
corrMapSum = fold corrMap
|
||
|
||
let -- whamlet convenience functions
|
||
-- avoid nestes hamlet $maybe with duplicated $nothing
|
||
getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector, Text)
|
||
getCorrector (Just uid)
|
||
| Just (User{..},loadMap) <- Map.lookup uid correctorMap
|
||
= (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName)
|
||
-- | Just (User{..} ) <- Map.lookup uid lecturerNames
|
||
-- = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases
|
||
getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty, mempty)
|
||
-- avoid nestes hamlet $maybe with duplicated $nothing
|
||
getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo
|
||
getCorrSheetStatus corr shn
|
||
| (Just smap) <- Map.lookup shn infoMap
|
||
= Map.lookup corr smap
|
||
getCorrSheetStatus _ _ = Nothing
|
||
-- avoid nestes hamlet $maybe with duplicated $nothing
|
||
getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int
|
||
getCorrNewAssignment corr shn
|
||
| (Just (_,cass,_)) <- Map.lookup shn assignment
|
||
= Map.lookup corr cass
|
||
getCorrNewAssignment _ _ = Nothing
|
||
-- avoid nestes hamlet $maybe with duplicated $nothing
|
||
getCorrDeficit :: Maybe UserId -> Maybe Rational
|
||
getCorrDeficit (Just uid) = Map.lookup uid deficitMap
|
||
getCorrDeficit _ = Nothing
|
||
|
||
getLoadSum :: SheetName -> Text
|
||
getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad
|
||
= showCompactCorrectorLoad load CorrectorNormal
|
||
getLoadSum _ = mempty
|
||
|
||
showDiffDays :: Maybe NominalDiffTime -> Text
|
||
showDiffDays = foldMap formatDiffDays
|
||
showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
|
||
showAvgsDays Nothing _ = mempty
|
||
showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n
|
||
let headingShort
|
||
| 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment
|
||
| otherwise = MsgMenuCorrectionsAssign
|
||
headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
|
||
|
||
unassignableSheets = filter (\shn -> Map.notMember shn assignment) assignSheetNames
|
||
unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets
|
||
|
||
siteLayoutMsg headingShort $ do
|
||
setTitleI headingLong
|
||
$(widgetFile "corrections-overview")
|
||
|
||
|
||
|