Further work on correction tables
This commit is contained in:
Gregor Kleen
parent
0241e046ca
commit
b334df4939
@ -124,3 +124,8 @@ SelectColumn: Auswahl
|
||||
CorrDownload: Herunterladen
|
||||
CorrSetCorrector: Korrektor zuweisen
|
||||
NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
|
||||
|
||||
SubmissionsAlreadyAssigned: Folgende Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
|
||||
UpdatedAssignedCorrectors num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt.
|
||||
NoCorrector: Kein Korrektor
|
||||
RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
|
||||
@ -629,6 +629,12 @@ pageActions (CourseR tid csh CShowR) =
|
||||
return (sheets,lecturer)
|
||||
or2M (return lecturer) $ anyM sheets sheetRouteAccess
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgaben"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid csh CourseCorrectionsR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionSecondary $ MenuItem
|
||||
{ menuItemLabel = "Neues Übungsblatt anlegen"
|
||||
, menuItemIcon = Nothing
|
||||
|
||||
@ -1,9 +1,9 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE MultiWayIf, LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
@ -48,6 +48,11 @@ import Control.Lens
|
||||
|
||||
import Web.PathPieces
|
||||
|
||||
import Text.Hamlet (ihamletFile)
|
||||
import Text.Blaze.Html (preEscapedToHtml)
|
||||
|
||||
import Database.Persist.Sql (updateWhereCount)
|
||||
|
||||
|
||||
|
||||
type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
|
||||
@ -61,24 +66,24 @@ courseIs :: Key Course -> CorrectionsWhere
|
||||
courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
|
||||
|
||||
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)))
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User))
|
||||
|
||||
colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
$ \DBRow{ dbrOutput=(_, _, course) } ->
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _) } ->
|
||||
-- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester
|
||||
textCell $ termToText $ unTermKey $ E.unValue $ course ^. _3 -- kurze Semsterkürzel
|
||||
|
||||
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
||||
$ \DBRow{ dbrOutput=(_, _, course) } -> cell $
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _) } -> cell $
|
||||
let tid = E.unValue $ course ^. _3
|
||||
csh = E.unValue $ course ^. _2
|
||||
in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
|
||||
|
||||
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
|
||||
$ \DBRow{ dbrOutput=(_, sheet, course) } -> cell $
|
||||
$ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $
|
||||
let tid = E.unValue $ course ^. _3
|
||||
csh = E.unValue $ course ^. _2
|
||||
shn = sheetName $ entityVal sheet
|
||||
@ -86,13 +91,13 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
|
||||
-- textCell $ sheetName $ entityVal sheet
|
||||
|
||||
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector)
|
||||
$ \DBRow{ dbrOutput=(submission, _, _) } ->
|
||||
textCell $ display $ submissionRatingBy $ entityVal submission
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||||
DBRow{ dbrOutput = (_, _, _, Nothing) } -> cell mempty
|
||||
DBRow{ dbrOutput = (_, _, _, Just corr) } -> textCell . display . userDisplayName $ entityVal corr
|
||||
|
||||
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{ dbrOutput=(submission, sheet, course) } -> cell $ do
|
||||
$ \DBRow{ dbrOutput=(submission, sheet, course, _) } -> cell $ do
|
||||
let tid = E.unValue $ course ^. _3
|
||||
csh = E.unValue $ course ^. _2
|
||||
shn = sheetName $ entityVal sheet
|
||||
@ -100,16 +105,14 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
[whamlet|<a href=@{CSheetR tid csh shn (SubmissionR cid)}>#{display cid}|]
|
||||
|
||||
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
|
||||
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _) } -> encrypt subId
|
||||
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId
|
||||
|
||||
makeCorrectionsTable :: ( IsDBTable m x, DBOutput CorrectionTableData r', ToSortable h, Functor h )
|
||||
=> _ -> Colonnade h r' (DBCell m x) -> Handler (DBResult m x)
|
||||
makeCorrectionsTable whereClause colChoices = do
|
||||
let tableData :: E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity Course))
|
||||
(E.SqlExpr (Entity Sheet )))
|
||||
(E.SqlExpr (Entity Submission))
|
||||
-> E.SqlQuery _
|
||||
tableData (course `E.InnerJoin` sheet `E.InnerJoin` submission) = do
|
||||
let tableData :: (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) -> E.SqlQuery _
|
||||
tableData ((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 (course,sheet,submission)
|
||||
@ -118,15 +121,15 @@ makeCorrectionsTable whereClause colChoices = do
|
||||
, course E.^. CourseTerm
|
||||
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
|
||||
)
|
||||
return (submission, sheet, crse)
|
||||
return (submission, sheet, crse, corrector)
|
||||
dbTable def $ DBTable
|
||||
{ dbtSQLQuery = tableData
|
||||
, dbtColonnade = colChoices
|
||||
, dbtSorting = [ ( "term"
|
||||
, SortColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) -> course E.^. CourseTerm
|
||||
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
||||
)
|
||||
, ( "course"
|
||||
, SortColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) -> course E.^. CourseShorthand
|
||||
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
|
||||
)
|
||||
-- TODO
|
||||
]
|
||||
@ -152,7 +155,7 @@ instance RenderMessage UniWorX ActionCorrections where
|
||||
renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
|
||||
|
||||
data ActionCorrectionsData = CorrDownloadData
|
||||
| CorrSetCorrectorData UserId
|
||||
| CorrSetCorrectorData (Maybe UserId)
|
||||
|
||||
correctionsR :: _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Widget)) -> Handler TypedContent
|
||||
correctionsR whereClause (formColonnade -> displayColumns) actions = do
|
||||
@ -167,11 +170,31 @@ correctionsR whereClause (formColonnade -> displayColumns) actions = do
|
||||
FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs
|
||||
FormMissing -> return ()
|
||||
FormSuccess (CorrDownloadData, subs) -> do
|
||||
(Set.fromList -> ids) <- forM (Set.toList subs) decrypt
|
||||
ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
|
||||
addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\""
|
||||
sendResponse =<< submissionMultiArchive ids
|
||||
FormSuccess (CorrSetCorrectorData uid, subs) -> do
|
||||
addMessage "danger" $ "Setting correctors not implemented yet" -- TODO
|
||||
FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
runDB $ do
|
||||
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
|
||||
when (not $ null alreadyAssigned) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
|
||||
addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
||||
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
|
||||
when (not $ null unassigned) $ do
|
||||
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid]
|
||||
addMessageI "success" $ MsgUpdatedAssignedCorrectors num
|
||||
redirect currentRoute
|
||||
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
runDB $ do
|
||||
num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingPoints =. Nothing
|
||||
, SubmissionRatingComment =. Nothing
|
||||
, SubmissionRatingBy =. Nothing
|
||||
, SubmissionRatingTime =. Nothing
|
||||
]
|
||||
addMessageI "success" $ MsgRemovedCorrections num
|
||||
redirect currentRoute
|
||||
|
||||
fmap toTypedContent . defaultLayout $ do
|
||||
@ -186,10 +209,26 @@ downloadAction = ( CorrDownload
|
||||
, return (pure CorrDownloadData, mempty)
|
||||
)
|
||||
|
||||
assignAction :: ActionCorrections'
|
||||
assignAction = ( CorrSetCorrector
|
||||
, return (pure undefined, mempty) -- TODO
|
||||
)
|
||||
assignAction :: CourseId -> ActionCorrections'
|
||||
assignAction cId = ( CorrSetCorrector
|
||||
, do
|
||||
correctors <- liftHandlerT . 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_ $ course E.^. CourseId E.==. E.val cId
|
||||
|
||||
return user
|
||||
|
||||
mr <- getMessageRender
|
||||
|
||||
correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey
|
||||
|
||||
($ mempty) . renderAForm FormStandard . wFormToAForm $ do
|
||||
cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
|
||||
fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
|
||||
)
|
||||
|
||||
getCorrectionsR, postCorrectionsR :: Handler TypedContent
|
||||
getCorrectionsR = postCorrectionsR
|
||||
@ -211,8 +250,8 @@ postCorrectionsR = do
|
||||
getCourseCorrectionsR, postCourseCorrectionsR :: TermId -> Text -> Handler TypedContent
|
||||
getCourseCorrectionsR = postCourseCorrectionsR
|
||||
postCourseCorrectionsR tid csh = do
|
||||
cid <- runDB $ getBy404 $ CourseTermShort tid csh
|
||||
let whereClause = courseIs $ entityKey cid
|
||||
Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh
|
||||
let whereClause = courseIs cid
|
||||
colonnade = mconcat
|
||||
[ colSelect
|
||||
, dbRow
|
||||
@ -222,5 +261,5 @@ postCourseCorrectionsR tid csh = do
|
||||
] -- Continue here
|
||||
correctionsR whereClause colonnade $ Map.fromList
|
||||
[ downloadAction
|
||||
, assignAction
|
||||
, assignAction cid
|
||||
]
|
||||
|
||||
5
templates/messages/submissionsAlreadyAssigned.hamlet
Normal file
5
templates/messages/submissionsAlreadyAssigned.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
_{MsgSubmissionsAlreadyAssigned}
|
||||
|
||||
<ul>
|
||||
$forall (cID, _) <- alreadyAssigned'
|
||||
<li><pre>#{toPathPiece cID}
|
||||
Loading…
Reference in New Issue
Block a user