Further work on correction tables

messages/de.msg

@@ -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.

src/Foundation.hs

@@ -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

src/Handler/Corrections.hs

@@ -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)
+colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
-        $ \DBRow{ dbrOutput=(submission, _, _) } ->
+  DBRow{ dbrOutput = (_, _, _, Nothing) } -> cell mempty
-          textCell $ display $ submissionRatingBy $ entityVal submission
+  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))
+  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 _
-                                            (E.SqlExpr (Entity Sheet )))
+      tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
-                               (E.SqlExpr (Entity Submission))
+        E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
-                    -> E.SqlQuery _
-      tableData (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_ $ 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
+    FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
-      addMessage "danger" $ "Setting correctors not implemented yet" -- TODO
+      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 :: CourseId -> ActionCorrections'
-assignAction = ( CorrSetCorrector
+assignAction cId = ( CorrSetCorrector
-               , return (pure undefined, mempty) -- TODO
+                   , 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
+  Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh
-  let whereClause = courseIs $ entityKey cid
+  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
     ]

templates/messages/submissionsAlreadyAssigned.hamlet

@@ -0,0 +1,5 @@
+_{MsgSubmissionsAlreadyAssigned}
+
+<ul>
+  $forall (cID, _) <- alreadyAssigned'
+    <li><pre>#{toPathPiece cID}