feat(submission): add correction to sub-show-r

frontend/src/app.sass

@@ -343,11 +343,21 @@ input[type="button"].btn-info:not(.btn-link):hover,
     .table__td
       background-color: rgba(0, 0, 0, 0.03)
 
+  &.table--vertical
+    .table__row:not(.no-stripe):not(.table__row--sum):nth-child(even)
+      .table__th
+        background-color: rgba(0, 0, 0, 0.03)
+
 .table--hover
   .table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):not(.table__row--foot):hover
     .table__td
       background-color: rgba(0, 0, 0, 0.07)
 
+  &.table--vertical
+    .table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):not(.table__row--foot):hover
+      .table__th
+        background-color: rgba(0, 0, 0, 0.07)
+
 .table__row--sum td.table__td::before
   content: 'Σ'
   font-weight: bold

src/Handler/Corrections.hs

@@ -856,8 +856,7 @@ postCorrectionR tid ssh csh shn cid = do
             addMessageI Success MsgRatingFilesUpdated
             redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
-      let sheetTypeDesc = mr sheetType
-          heading = MsgCorrectionHead tid ssh csh shn cid
+      let heading = MsgCorrectionHead tid ssh csh shn cid
           headingWgt = [whamlet|
               $newline never
               _{heading}
@@ -877,12 +876,9 @@ getCorrectionUserR tid ssh csh shn cid = do
   results <- runDB $ correctionData tid ssh csh shn sub
 
   case results of
-    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do
-      mr <- getMessageRender
+    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] ->
       let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
-          sheetTypeDesc = mr sheetType
-      defaultLayout $
-        $(widgetFile "correction-user")
+       in defaultLayout $(widgetFile "correction-user")
     _ -> notFound
 
 

src/Handler/Submission.hs

@@ -1,6 +1,16 @@
 {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-uni-patterns #-}
 
-module Handler.Submission where
+module Handler.Submission
+  ( getSubmissionNewR, postSubmissionNewR
+  , getSubShowR, postSubShowR
+  , getSubmissionOwnR
+  , getSInviteR, postSInviteR
+  , getSubDownloadR
+  , getSubArchiveR
+  , getSubDelR, postSubDelR
+  , getCorrectionsDownloadR
+  , getSubAssignR, postSubAssignR
+  ) where
 
 import Import
 
@@ -32,6 +42,7 @@ import qualified Data.Set as Set
 import Data.Map ((!), (!?))
 import qualified Data.Map as Map
 -- import Data.Bifunctor
+import qualified Data.Text as Text
 
 import Text.Blaze (Markup)
 import Data.Aeson hiding (Result(..))
@@ -320,7 +331,7 @@ submissionHelper tid ssh csh shn mcid = do
   msmid     <- traverse decrypt mcid
   actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute
 
-  (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner)  <- runDB $ do
+  (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner, msubmission, corrector)  <- runDB $ do
     csheet@(Entity shid Sheet{..})  <- fetchSheet tid ssh csh shn
     maySubmit  <- (== Authorized) <$> evalAccessDB actionUrl True
     isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
@@ -365,6 +376,7 @@ submissionHelper tid ssh csh shn mcid = do
                , maySubmit
                , isLecturer
                , not isLecturer
+               , Nothing, Nothing
                )
       (Nothing, RegisteredGroups) -> do
         buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do
@@ -393,12 +405,14 @@ submissionHelper tid ssh csh shn mcid = do
                , maySubmit
                , isLecturer
                , not isLecturer
+               , Nothing, Nothing
                )
-      (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer)
+      (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing)
       (Just smid, _) -> do
         void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
 
-        shid' <- submissionSheet <$> get404 smid
+        sub@Submission{..} <- get404 smid
+        let shid' = submissionSheet
         unless (shid == shid') $
           invalidArgsI [MsgSubmissionWrongSheet]
         -- fetch buddies from current submission
@@ -427,7 +441,10 @@ submissionHelper tid ssh csh shn mcid = do
                               else E.nothing
               return (userName, submissionEdit E.^. SubmissionEditTime)
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
-        return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner)
+
+        corrector <- fmap join $ traverse getEntity submissionRatingBy
+  
+        return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
   -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
   -- Therefore we do not restrict upload behaviour in any way in that case
   ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
@@ -643,6 +660,14 @@ submissionHelper tid ssh csh shn mcid = do
         }
   mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
 
+
+  showCorrection <- fmap (fromMaybe False) . for mcid $ \cid -> hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
+
+  let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) ->
+        let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
+         in $(widgetFile "correction-user")
+        
+
   defaultLayout $ do
     setTitleI $ MsgSubmissionEditHead tid ssh csh shn
     let urlArchive  cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected

templates/correction-user.hamlet

@@ -1,5 +1,5 @@
 <div .scrolltable>
-  <table .table .table--striped .table--hover .table--vertical>
+  <table .table .table--striped .table--vertical>
     <tr .table__row>
       <th .table__th>_{MsgSubmission}
       <td .table__td>#{cid}
@@ -17,11 +17,11 @@
         $case grading 
           $of Points{..}
             <tr .table__row>
-              <th .table__th>#{sheetTypeDesc}
+              <th .table__th>_{sheetType}
               <td .table__td>_{MsgAchievedOf points maxPoints}
           $of PassPoints{..}
             <tr .table__row>
-              <th .table__th>#{sheetTypeDesc}
+              <th .table__th>_{sheetType}
               <td .table__td>
                 $if fromMaybe False (gradingPassed grading points)
                   _{MsgPassed}
@@ -32,7 +32,7 @@
               <td .table__td>_{MsgPassAchievedOf points passingPoints maxPoints}
           $of PassBinary
             <tr .table__row>
-              <th .table__th>#{sheetTypeDesc}
+              <th .table__th>_{sheetType}
               <td .table__td>
                 $if fromMaybe False (gradingPassed grading points)
                   _{MsgPassed}

templates/submission.hamlet

@@ -1,5 +1,10 @@
 $newline never
 $maybe cID <- mcid
+  $maybe wdgt <- correctionWdgt
+    <section>
+      <h2>_{MsgRating}
+      ^{wdgt}
+  
   <section>
     $case sheetSubmissionMode
       $of SubmissionMode False Nothing
@@ -15,7 +20,6 @@ $maybe cID <- mcid
           )
 
         $maybe fileTable <- mFileTable
-          <h3>_{MsgSubmissionFiles}
           ^{fileTable}
 
     $if maySubmit && not (null lastEdits)