Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

.vscode/tasks.json

@@ -28,8 +28,20 @@
         "focus": false,
         "panel": "dedicated",
         "showReuseMessage": false
-      },
+      }      
-      "problemMatcher": []
+    },
+    {
+      "label": "test",
+      "type": "shell",
+      "command": "./test.sh",
+      "group": "test",
+      "presentation": {
+        "echo": true,
+        "reveal": "always",
+        "focus": true,
+        "panel": "dedicated",
+        "showReuseMessage": false
+      }
     }
   ]
 }

ChangeLog.md

@@ -1,3 +1,10 @@
+  * Version 09.11.2018
+
+    Bugfix: Zahlreiche Knöpfe/Formulare funktionieren wieder bei eingeschaltetem Javascript
+
+    Verschiedene Verbesserungen für Korrektoren
+
+
   * Version 19.10.2018
 
     Benutzer können sich in der Testphase komplett selbst löschen

messages/uniworx/de.msg

@@ -274,6 +274,16 @@ RatingUpdated: Korrektur gespeichert
 RatingDeleted: Korrektur zurückgesetzt
 RatingFilesUpdated: Korrigierte Dateien überschrieben
 
+RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc}
+RatingMissingSeparator: Could not split rating header from comments
+RatingMultiple: Encountered multiple point values in rating
+RatingInvalid parseErr@String: Failed to parse rating point value #{parseErr}
+RatingFileIsDirectory: We do not expect this to, it's included for totality
+RatingNegative: Rating points must be non-negative
+RatingExceedsMax: Rating point must not exceed maximum points
+RatingNotExpected: Rating not expected
+RatingBinaryExpected: Rating must be 0 or 1
+
 NoTableContent: Kein Tabelleninhalt
 NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
 

src/Foundation.hs

@@ -220,14 +220,16 @@ embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>)
 embedRenderMessage ''UniWorX ''StudyFieldType id
 embedRenderMessage ''UniWorX ''SheetFileType id
 embedRenderMessage ''UniWorX ''CorrectorState id
+embedRenderMessage ''UniWorX ''RatingException id
 embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
-embedRenderMessage ''UniWorX ''SheetType ("SheetType" <>)
 
-newtype SheetTypeComplete = SheetTypeComplete SheetType 
+newtype SheetTypeHeader = SheetTypeHeader SheetType
-instance RenderMessage UniWorX (SheetTypeComplete) where
+embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
-  renderMessage foundation ls (SheetTypeComplete sheetType) = case sheetType of
+
-      NotGraded -> mr NotGraded
+instance RenderMessage UniWorX (SheetType) where
-      other -> mr (grading other) <> ", " <> mr other
+  renderMessage foundation ls sheetType = case sheetType of
+      NotGraded -> mr $ SheetTypeHeader NotGraded
+      other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
     where 
       mr :: RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls

src/Handler/Corrections.hs

@@ -500,26 +500,31 @@ postCorrectionR tid ssh csh shn cid = do
       case corrResult of
         FormMissing -> return ()
         FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
-        FormSuccess (rated, ratingPoints', ratingComment') -> do
+        FormSuccess (rated, ratingPoints', ratingComment') 
-          runDBJobs $ do
+          | errs <- validateRating sheetType Rating'
-            uid <- liftHandlerT requireAuthId
+                      { ratingPoints=ratingPoints'
-            now <- liftIO getCurrentTime
+                      , ratingComment=ratingComment'
-          
+                      , ratingTime=Nothing
-            update sub [ SubmissionRatingBy      =. (uid <$ guard rated)
+                      }
--- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
+            -> mapM_ (addMessageI Error) errs
---                        , SubmissionRatingAssigned +=. (Just now) -- TODO: Should submissionRatingAssigned change here if userId changes?
+          | otherwise -> do
-                       , SubmissionRatingTime    =. (now <$ guard rated)
+            runDBJobs $ do
-                       , SubmissionRatingPoints  =. ratingPoints'
+              uid <- liftHandlerT requireAuthId
-                       , SubmissionRatingComment =. ratingComment'
+              now <- liftIO getCurrentTime
-                       ]
+            
+              update sub  [ SubmissionRatingBy      =. Just uid
+                          , SubmissionRatingTime    =. (now <$ guard rated)
+                          , SubmissionRatingPoints  =. ratingPoints'
+                          , SubmissionRatingComment =. ratingComment'
+                          ]
 
-            addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
+              addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
 
-            when (rated && isNothing submissionRatingTime) $ do
+              when (rated && isNothing submissionRatingTime) $ do
-              $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
+                $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
-              queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub 
+                queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub 
 
-          redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
+            redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       case uploadResult of
         FormMissing -> return ()

src/Handler/Sheet.hs

@@ -162,7 +162,7 @@ getSheetListR tid ssh csh = do
       , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
           $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
       , sortable Nothing (i18nCell MsgSheetType)
-          $ \(Entity _ Sheet{..}, _, _) -> i18nCell $ SheetTypeComplete sheetType
+          $ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType
       , sortable Nothing (i18nCell MsgSubmission)
           $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
               Nothing -> mempty

src/Handler/Utils/Rating.hs

@@ -2,6 +2,7 @@
 
 module Handler.Utils.Rating
   ( Rating(..), Rating'(..)
+  , validateRating
   , getRating
   , formatRating
   , ratingFile
@@ -15,12 +16,10 @@ module Handler.Utils.Rating
 
 import Import
 
-
 import Text.PrettyPrint.Leijen.Text hiding ((<$>))
 
 import Control.Monad.Trans.Maybe
 
-import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import Data.Text.Encoding.Error (UnicodeException(..))
@@ -35,9 +34,6 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
 
 import Text.Read (readEither)
 
-import GHC.Generics (Generic)
-import Data.Typeable (Typeable)
-
 import System.FilePath
 import qualified System.FilePath.Cryptographic as FilePath (decrypt)
 
@@ -61,29 +57,19 @@ instance Pretty SheetGrading where
   pretty PassBinary     = pretty ( "Bestanden (1) /  Nicht bestanden (0)" :: String )
 
 
-data Rating = Rating
+validateRating :: SheetType -> Rating' -> [RatingException]
-  { ratingCourseName :: CourseName
+validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
-  , ratingSheetName :: SheetName
+  | rp < 0 
-  , ratingCorrectorName :: Maybe Text
+    = [RatingNegative] 
-  , ratingSheetType :: SheetType
+  | NotGraded <- ratingSheetType 
-  , ratingValues :: Rating'
+    = [RatingNotExpected]
-  } deriving (Read, Show, Eq, Generic, Typeable)
+  | (Just maxPoints ) <- ratingSheetType ^?  _grading . _maxPoints
-
+  , rp > maxPoints 
-data Rating' = Rating'
+    = [RatingExceedsMax]
-  { ratingPoints :: Maybe Points
+  | (Just PassBinary) <- ratingSheetType ^? _grading
-  , ratingComment :: Maybe Text
+  , not (rp == 0 || rp == 1)
-  , ratingTime :: Maybe UTCTime
+    = [RatingBinaryExpected]
-  } deriving (Read, Show, Eq, Generic, Typeable)
+validateRating _ _ = []
-
-data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
-                     | RatingMissingSeparator -- ^ Could not split rating header from comments
-                     | RatingMultiple -- ^ Encountered multiple point values in rating
-                     | RatingInvalid String -- ^ Failed to parse rating point value
-                     | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
-  deriving (Show, Eq, Generic, Typeable)
-
-instance Exception RatingException
-
 
 getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
 getRating submissionId = runMaybeT $ do

src/Handler/Utils/Submission.hs

@@ -395,7 +395,7 @@ sinkSubmission userId mExists isUpdate = do
           touchSubmission
           lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
   
-      Right (submissionId', Rating'{..}) -> do
+      Right (submissionId', r'@Rating'{..}) -> do
         $logDebugS "sinkSubmission" $ tshow submissionId'
 
         unless (submissionId' == submissionId) $ do
@@ -417,9 +417,12 @@ sinkSubmission userId mExists isUpdate = do
         -- 'ratingTime' is ignored for consistency with 'File's:
         -- 
         -- 'fileModified' is simply stored and never inspected while
-        -- 'submissionChanged' is always set to @now@.
+        -- 'submissionChanged' is always set to @now@.          
-
         when anyChanges $ do
+
+          Sheet{..} <- lift $ getJust submissionSheet
+          mapM_ throwM $ validateRating sheetType r' 
+                  
           touchSubmission
           lift $ update submissionId
             [ SubmissionRatingPoints =. ratingPoints

src/Handler/Utils/Table/Cells.hs

@@ -83,9 +83,6 @@ sheetCell crse shn =
       link= CSheetR tid ssh csh shn SShowR
   in anchorCell link $ display2widget shn
 
-sheetTypeCell :: IsDBTable m a => SheetType -> DBCell m a
-sheetTypeCell sheetType = i18nCell $ SheetTypeComplete sheetType
-
 submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a
 submissionCell crse shn sid =
   let tid = crse ^. _1

src/Import/NoFoundation.hs

@@ -7,6 +7,7 @@ import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJS
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
+import Model.Rating           as Import
 import Settings               as Import
 import Settings.StaticFiles   as Import
 import Yesod.Auth             as Import
@@ -37,6 +38,7 @@ import GHC.Generics           as Import (Generic)
 
 import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (NonEmpty(..))
+import Data.Text.Encoding.Error    as Import(UnicodeException(..))
 
 import Control.Monad.Morph    as Import (MFunctor(..))
 

src/Model/Rating.hs

@@ -0,0 +1,37 @@
+module Model.Rating where
+
+import ClassyPrelude.Yesod
+import Model
+
+-- import Data.Text (Text)
+import Data.Text.Encoding.Error (UnicodeException(..))
+import GHC.Generics (Generic)
+import Data.Typeable (Typeable)
+
+
+data Rating = Rating
+  { ratingCourseName :: CourseName
+  , ratingSheetName :: SheetName
+  , ratingCorrectorName :: Maybe Text
+  , ratingSheetType :: SheetType
+  , ratingValues :: Rating'
+  } deriving (Read, Show, Eq, Generic, Typeable)
+
+data Rating' = Rating'
+  { ratingPoints :: Maybe Points
+  , ratingComment :: Maybe Text
+  , ratingTime :: Maybe UTCTime
+  } deriving (Read, Show, Eq, Generic, Typeable)
+
+data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
+                     | RatingMissingSeparator -- ^ Could not split rating header from comments
+                     | RatingMultiple -- ^ Encountered multiple point values in rating
+                     | RatingInvalid String -- ^ Failed to parse rating point value
+                     | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
+                     | RatingNegative -- ^ Rating points must be non-negative
+                     | RatingExceedsMax -- ^ Rating point must not exceed maximum points
+                     | RatingNotExpected -- ^ Rating not expected
+                     | RatingBinaryExpected -- ^ Rating must be 0 or 1
+  deriving (Show, Eq, Generic, Typeable)
+
+instance Exception RatingException

src/index.md

@@ -97,6 +97,9 @@ CryptoID
 Model.Migration
   : Manuelle Datenbank-Migration
 
+Model.Rating
+  : Types for Submission Ratings that the Database does not depend on, but needed in Foundation
+
 Jobs
   : `handleJobs` worker thread handling background jobs
     `JobQueueException`

templates/sheetShow.hamlet

@@ -18,7 +18,7 @@ $maybe descr <- sheetDescription sheet
       <dt .deflist__dt>_{MsgSheetSolutionFrom}
       <dd .deflist__dd>#{solution}
     <dt .deflist__dt>_{MsgSheetType}
-    <dd .deflist__dd>_{SheetTypeComplete (sheetType sheet)}
+    <dd .deflist__dd>_{sheetType sheet}
     $if CorrectorSubmissions == sheetSubmissionMode sheet
       <dt .deflist__dt>_{MsgSheetPseudonym}
       <dd .deflist__dd #pseudonym>