CorrectionsGradeR
This commit is contained in:
Gregor Kleen
parent
72e0af2618
commit
d663586516
@ -258,6 +258,7 @@ RatingPercent: Erreicht
|
||||
RatingFiles: Korrigierte Dateien
|
||||
PointsNotPositive: Punktzahl darf nicht negativ sein
|
||||
RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
|
||||
ColumnRatingPointsDone: Punktzahl/Abgeschlossen
|
||||
Pseudonyms: Pseudonyme
|
||||
|
||||
FileTitle: Dateiname
|
||||
@ -386,6 +387,7 @@ SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt
|
||||
SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert:
|
||||
SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben:
|
||||
|
||||
CorrGrade: Korrekturen eintragen
|
||||
|
||||
UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht!
|
||||
|
||||
|
||||
7
routes
7
routes
@ -85,9 +85,10 @@
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
|
||||
|
||||
/corrections CorrectionsR GET POST !corrector !lecturer
|
||||
/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||
/corrections/create CorrectionsCreateR GET POST !corrector !lecturer
|
||||
/submissions CorrectionsR GET POST !corrector !lecturer
|
||||
/submissions/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||
/submissions/create CorrectionsCreateR GET POST !corrector !lecturer
|
||||
/submissions/grade CorrectionsGradeR GET POST !corrector !lecturer
|
||||
|
||||
|
||||
/msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDisReadANDauthentication
|
||||
|
||||
@ -1122,6 +1122,35 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
|
||||
}
|
||||
]
|
||||
pageActions (CorrectionsR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrekturen hochladen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CorrectionsUploadR
|
||||
, menuItemModal = True
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgaben erstellen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CorrectionsCreateR
|
||||
, menuItemModal = True
|
||||
, menuItemAccessCallback' = runDB $ do
|
||||
uid <- liftHandlerT requireAuthId
|
||||
[E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
|
||||
return E.countRows
|
||||
return $ (count :: Int) /= 0
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrekturen eintragen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CorrectionsGradeR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CorrectionsGradeR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrekturen hochladen"
|
||||
, menuItemIcon = Nothing
|
||||
@ -1237,6 +1266,8 @@ pageHeading CorrectionsUploadR
|
||||
= Just $ i18nHeading MsgCorrUpload
|
||||
pageHeading CorrectionsCreateR
|
||||
= Just $ i18nHeading MsgCorrCreate
|
||||
pageHeading CorrectionsGradeR
|
||||
= Just $ i18nHeading MsgCorrGrade
|
||||
pageHeading (MessageR _)
|
||||
= Just $ i18nHeading MsgSystemMessageHeading
|
||||
|
||||
|
||||
@ -69,6 +69,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter)
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
import Control.Monad.Trans.State (State, StateT(..), runState)
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
@ -90,6 +92,9 @@ courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
|
||||
sheetIs :: Key Sheet -> CorrectionsWhere
|
||||
sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
|
||||
|
||||
submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere
|
||||
submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
|
||||
|
||||
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
|
||||
|
||||
@ -179,13 +184,25 @@ colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_
|
||||
cell [whamlet|#{review pseudonymText pseudo}|]
|
||||
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), a))))
|
||||
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone & cellTooltip MsgRatingPointsDone) $ formCell
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
|
||||
NotGraded -> over (_1.mapped) ((_1 .~) . fmap Left) . over _2 fvInput <$> mopt checkBoxField "" (Just . Just $ isJust submissionRatingPoints)
|
||||
_other -> over (_1.mapped) ((_1 .~) . fmap Right) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints)
|
||||
)
|
||||
|
||||
colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Text))))
|
||||
colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_2 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
|
||||
|
||||
|
||||
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))
|
||||
|
||||
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
||||
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
|
||||
makeCorrectionsTable whereClause colChoices psValidator = do
|
||||
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
|
||||
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
||||
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
|
||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||
@ -209,10 +226,10 @@ makeCorrectionsTable whereClause colChoices psValidator = do
|
||||
return (user, pseudonym E.?. SheetPseudonymPseudonym)
|
||||
let
|
||||
submittorMap = foldr (\((Entity userId user, E.Value pseudo)) -> Map.insert userId (user, pseudo)) Map.empty submittors
|
||||
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
|
||||
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
|
||||
dbTable psValidator $ DBTable
|
||||
{ dbtSQLQuery
|
||||
, dbtColonnade = colChoices
|
||||
, dbtColonnade
|
||||
, dbtProj
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "term"
|
||||
@ -230,6 +247,9 @@ makeCorrectionsTable whereClause colChoices psValidator = do
|
||||
, ( "rating"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
|
||||
)
|
||||
, ( "ratingtime"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime
|
||||
)
|
||||
]
|
||||
, dbtFilter = Map.fromList
|
||||
[ ( "term"
|
||||
@ -277,7 +297,7 @@ data ActionCorrectionsData = CorrDownloadData
|
||||
|
||||
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
|
||||
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
|
||||
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
|
||||
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return
|
||||
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
|
||||
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
|
||||
(actionRes, action) <- multiAction actions Nothing
|
||||
@ -602,6 +622,7 @@ postCorrectionsCreateR = do
|
||||
FormMissing -> return ()
|
||||
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
||||
FormSuccess (sid, pss) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ do
|
||||
Sheet{..} <- get404 sid
|
||||
(sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
|
||||
@ -643,6 +664,7 @@ postCorrectionsCreateR = do
|
||||
| otherwise
|
||||
-> do
|
||||
subId <- insert submission
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
@ -655,12 +677,14 @@ postCorrectionsCreateR = do
|
||||
case (groups :: [E.Value SubmissionGroupId]) of
|
||||
[x] -> do
|
||||
subId <- insert submission
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
[] -> do
|
||||
subId <- insert submission
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
@ -671,17 +695,20 @@ postCorrectionsCreateR = do
|
||||
| [SheetPseudonym{sheetPseudonymUser}] <- spGroup
|
||||
-> do
|
||||
subId <- insert submission
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insert_ SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
| otherwise -> do
|
||||
subId <- insert submission
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
|
||||
redirect CorrectionsGradeR
|
||||
|
||||
|
||||
defaultLayout $ do
|
||||
@ -701,3 +728,51 @@ postCorrectionsCreateR = do
|
||||
[] -> return $ Right valid
|
||||
textFromList :: [[Pseudonym]] -> Textarea
|
||||
textFromList = Textarea . Text.unlines . map (Text.intercalate ", " . map (review pseudonymText))
|
||||
|
||||
getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
|
||||
getCorrectionsGradeR = postCorrectionsGradeR
|
||||
postCorrectionsGradeR = do
|
||||
uid <- requireAuthId
|
||||
let whereClause = ratedBy uid
|
||||
displayColumns = mconcat -- should match getSSubsR for consistent UX
|
||||
[ dbRow
|
||||
, colTerm
|
||||
, colCourse
|
||||
, colSheet
|
||||
, colPseudonyms
|
||||
, colSubmissionLink
|
||||
, colRated
|
||||
, colPointsField
|
||||
, colCommentField
|
||||
] -- Continue here
|
||||
psValidator = def
|
||||
& defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), Maybe Text)))
|
||||
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } -> (bool (Right <$> submissionRatingPoints) (Just . Left $ isJust submissionRatingPoints) $ sheetType == NotGraded, submissionRatingComment)
|
||||
|
||||
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \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), tableEncoding) <- runFormPost tableForm
|
||||
|
||||
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, (mPoints, mComment)) -> do
|
||||
let mPoints' = either (bool Nothing $ return 0) return =<< mPoints
|
||||
Submission{..} <- get404 subId
|
||||
if
|
||||
| submissionRatingPoints /= mPoints' || submissionRatingComment /= mComment
|
||||
-> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints'
|
||||
, SubmissionRatingComment =. mComment
|
||||
, SubmissionRatingBy =. Just uid
|
||||
, SubmissionRatingTime =. now <$ (void mPoints' <|> void mComment)
|
||||
]
|
||||
| otherwise -> return $ Nothing
|
||||
subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission]
|
||||
unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet")
|
||||
|
||||
defaultLayout $ do
|
||||
$(widgetFile "corrections-grade")
|
||||
|
||||
@ -35,7 +35,7 @@ module Handler.Utils.Table.Pagination
|
||||
, widgetColonnade, formColonnade, dbColonnade
|
||||
, cell, textCell, stringCell, i18nCell
|
||||
, anchorCell, anchorCell', anchorCellM, anchorCellM'
|
||||
, tickmarkCell
|
||||
, tickmarkCell, cellTooltip
|
||||
, listCell
|
||||
, formCell, DBFormResult, getDBFormResult
|
||||
, dbRow, dbSelect
|
||||
@ -499,6 +499,15 @@ tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
|
||||
tickmarkCell True = textCell (tickmark :: Text)
|
||||
tickmarkCell False = mempty
|
||||
|
||||
cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
|
||||
cellTooltip msg cell = cell & cellContents.mapped %~ (<> tipWdgt)
|
||||
where
|
||||
tipWdgt = [whamlet|
|
||||
<div .js-tooltip>
|
||||
<div .tooltip__handle>
|
||||
<div .tooltip__content>_{msg}
|
||||
|]
|
||||
|
||||
|
||||
anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
|
||||
anchorCell = anchorCellM . return
|
||||
|
||||
5
templates/corrections-grade.hamlet
Normal file
5
templates/corrections-grade.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
<div .container>
|
||||
<form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}>
|
||||
^{table}
|
||||
<button type=submit>
|
||||
_{MsgBtnSubmit}
|
||||
Loading…
Reference in New Issue
Block a user