Prettify single submission view

messages/de.msg

@@ -146,14 +146,22 @@ CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht aut
 
 CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
 
-RatingBy: Korrigiert von:
+RatingBy: Korrigiert von
-AchievedBonusPoints: Erreichte Bonuspunkte:
+AchievedBonusPoints: Erreichte Bonuspunkte
-AchievedNormalPoints: Erreichte Punkte:
+AchievedNormalPoints: Erreichte Punkte
-AchievedPassPoints: Erreichte Punkte:
+AchievedPassPoints: Erreichte Punkte
 AchievedOf achieved@Points possible@Points: #{display achieved} von #{display possible}
 PassAchievedOf points@Points passingPoints@Points maxPoints@Points: #{display points} von #{display maxPoints} (Bestanden ab #{display passingPoints})
-PassedResult: Ergebnis:
+PassedResult: Ergebnis
 Passed: Bestanden
 NotPassed: Nicht bestanden
-RatingTime: Korrigiert:
+RatingTime: Korrigiert
-RatingComment: Kommentar:
+RatingComment: Kommentar
+
+RatingPoints: Punkte
+PointsNotPositive: Punktzahl darf nicht negativ sein
+
+FileTitle: Dateiname
+FileModified: Letzte Änderung
+
+FileCorrected: Korrigiert

package.yaml

@@ -82,6 +82,7 @@ dependencies:
 - lens
 - MonadRandom
 - email-validate
+- scientific
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Handler/Corrections.hs

@@ -343,28 +343,48 @@ postSSubsR tid csh shn = do
     , autoAssignAction shid
     ]
 
+correctionData tid 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.^. 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 -> Text -> Text -> CryptoFileNameSubmission -> Handler Html
 getCorrectionR tid csh shn cid = do
   mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True
   bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid
-postCorrectionR tid csh shn cid = undefined
+postCorrectionR tid csh shn cid = do
+  sub <- decrypt cid
+
+  results <- runDB $ correctionData tid csh shn sub
+
+  case results of
+    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
+      let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
+
+      now <- liftIO getCurrentTime
+      ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ Rating'
+        <$> aopt pointsField (fslI MsgRatingPoints) (Just $ submissionRatingPoints)
+        <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment)) 
+        <* submitButton
+
+      defaultLayout $ do
+        let userCorrection = $(widgetFile "correction-user")
+        $(widgetFile "correction")
+    _ -> notFound
 getCorrectionUserR tid csh shn cid = do
   sub <- decrypt cid
   
-  results <- runDB . E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
+  results <- runDB $ correctionData tid csh shn sub
-    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.^. 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)
 
   case results of
-    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, Just (Entity _ User{..}))] -> do
+    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do
       let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
       
       defaultLayout $ do

src/Handler/Submission.hs

@@ -14,6 +14,7 @@
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module Handler.Submission where
 
@@ -38,6 +39,7 @@ import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction)
 
 import qualified Data.Conduit.List as Conduit
 import Data.Conduit.ResumableSink
@@ -50,7 +52,7 @@ import Data.Bifunctor
 
 import System.FilePath
 
-import Colonnade hiding (bool)
+import Colonnade hiding (bool, fromMaybe)
 import qualified Yesod.Colonnade as Yesod
 import qualified Text.Blaze.Html5.Attributes as HA
 
@@ -238,24 +240,54 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
   -- Maybe construct a table to display uploaded archive files
   let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
       colonnadeFiles cid = mconcat
-        -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
+        [ sortable (Just "path") (textCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
-        [ sortable (Just "path") "Dateiname" $ \input@(_, Entity _ File{..}) -> case isNothing fileContent of
+              Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr)
-            False -> anchorCell (\(Entity _ SubmissionFile{..}, Entity _ File{..}) -> CSubmissionR tid csh shn cid $ SubDownloadR (isUpdateSubmissionFileType submissionFileIsUpdate) fileTitle)
+              origIsFile = fmap (isJust . fileContent . entityVal . snd) mOrig
-                                (\(_, Entity _ File{..}) -> str2widget fileTitle)
+              corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
-                                input
+              Just isFile = origIsFile <|> corrIsFile
-            True -> textCell $ addTrailingPathSeparator fileTitle 
+            in if
-        , sortable (Just "time") "Modifikation" $ \(_, Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
+              | Just True <- origIsFile -> anchorCell (\() -> CSubmissionR tid csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
+                                                      (\() -> [whamlet|#{fileTitle'}|])
+                                                      ()
+              | otherwise               -> textCell $ bool (<> "/") id isFile fileTitle'
+        , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of
+            Nothing -> cell mempty
+            Just (_, Entity _ File{..})
+              | isJust fileContent -> anchorCell (\() -> CSubmissionR tid csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
+                                                 (\() -> [whamlet|_{MsgFileCorrected}|])
+                                                 ()
+              | otherwise -> textCell MsgFileCorrected
+        , sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
+              origTime = fileModified . entityVal . snd <$> mOrig
+              corrTime = fileModified . entityVal . snd <$> mCorr
+              Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
+            in textCell $ display fileTime
         ]
+      coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File))   
+      coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md)
+      submissionFiles :: _ -> _ -> E.SqlQuery _
+      submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do
+        E.on $ f2 E.?. FileId E.==. sf2 E.?. SubmissionFileFile
+        E.on $ f1 E.?. FileTitle E.==. f2 E.?. FileTitle
+         E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission
+         E.&&. f1 E.?. FileId E.!=. f2 E.?. FileId
+        E.on $ f1 E.?. FileId E.==. sf1 E.?. SubmissionFileFile
+
+        E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate))
+             E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True)  E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate))
+             E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid))
+
+        return ((sf1, f1), (sf2, f2))
       smid2ArchiveTable (smid,cid) = DBTable
-        { dbtSQLQuery = submissionFileQuery smid
+        { dbtSQLQuery = submissionFiles smid
         , dbtColonnade = colonnadeFiles cid
         , dbtAttrs = tableDefault
         , dbtIdent = "files" :: Text
         , dbtSorting =  [ ( "path"
-                          , SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileTitle
+                          , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
                           )
                         , ( "time"
-                          , SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileModified
+                          , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
                           )
                         ]
         , dbtFilter = []

src/Handler/Utils/Form.hs

@@ -48,11 +48,15 @@ import qualified Data.Map as Map
 
 import Control.Monad.Writer.Class
 
+import Data.Scientific (Scientific)
+import Data.Ratio
+import Text.Read (readMaybe)
+
 ------------------------------------------------
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
 
-data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrectionsUpload
+data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
 
@@ -262,6 +266,19 @@ posIntField d = checkBool (>= 1) (T.append  d " muss eine positive Zahl sein.")
 minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
 minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
 
+pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points
+pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
+  where
+    fieldEnctype = UrlEncoded
+    fieldView theId name attrs val isReq
+      = [whamlet|
+          $newline never
+          <input id=#{theId} name=#{name} *{attrs} type=number step="0.01" :isReq:required value=#{either id tshow val}>
+        |]
+    fieldParse = parseHelper $ \t -> do
+      sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
+      return . fromRational $ round (sci * 100) % 100
+
 --termField: see Utils.Term
 
 schoolField :: Field Handler SchoolId

templates/correction-user.hamlet

@@ -3,9 +3,10 @@
     <tr .table__row>
       <th .table__th> _{MsgSubmission}
       <td .table__td> #{display cid}
-    <tr .table__row>
+    $maybe Entity _ User{..} <- corrector
-      <th .table__th> _{MsgRatingBy}
+      <tr .table__row>
-      <td .table__td> #{display userDisplayName}
+        <th .table__th> _{MsgRatingBy}
+        <td .table__td> #{display userDisplayName}
     $maybe time <- submissionRatingTime
       <tr .table__row>
         <th .table__th> _{MsgRatingTime}

templates/correction.hamlet

@@ -0,0 +1,6 @@
+^{userCorrection}
+
+<hr>
+  
+<form method=post enctype=#{corrEncoding}>
+  ^{corrForm}