Error Handling für SinkSubmission

2018-12-12 12:05:22 +01:00 · 2018-12-12 12:05:22 +01:00 · 306fb351ad
commit 306fb351ad
parent 30a5aff70e
7 changed files with 72 additions and 44 deletions
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@ -234,7 +234,7 @@ CorrUploadField: Korrekturen
 CorrUpload: Korrekturen hochladen
 CorrSetCorrector: Korrektor zuweisen
 CorrAutoSetCorrector: Korrekturen verteilen
-NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
+NatField name@Text: #{name} muss eine natürliche Zahl sein!
 JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure}

 SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
@ -295,6 +295,13 @@ RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl
 RatingNotExpected: Keine Bewertungen erlaubt
 RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein

+SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} kommt mehrfach im Zip-Archiv vor
+SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden.
+SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber keine Bewertung der Abgabe möglich.
+SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen!
+
+MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufgetreten: #{error}
+
 NoTableContent: Kein Tabelleninhalt
 NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter

--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@ -199,6 +199,7 @@ embedRenderMessage ''UniWorX ''StudyFieldType id
 embedRenderMessage ''UniWorX ''SheetFileType id
 embedRenderMessage ''UniWorX ''CorrectorState id
 embedRenderMessage ''UniWorX ''RatingException id
+embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
 embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
 embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
 embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@ -580,13 +580,12 @@ postCorrectionR tid ssh csh shn cid = do
        FormSuccess fileUploads -> do
          uid <- requireAuthId

-          void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
-          {-case res of
-            (Left _) -> addMessageI Success MsgRatingFilesUpdated
-            (Right RatingNotExpected) -> addMessageI Error MsgRatingNotExpected
-            (Right other) -> throw other-}
-
-          redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
+          res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
+          case res of
+            Nothing  -> return () -- ErrorMessages are already added by msgSubmissionErrors
+            (Just _) -> do
+              addMessageI Success MsgRatingFilesUpdated
+              redirect $ CSubmissionR tid ssh csh shn cid CorrectionR

      mr <- getMessageRender
      let sheetTypeDesc = mr sheetType
@ -621,13 +620,15 @@ postCorrectionsUploadR = do
    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
    FormSuccess files -> do
      uid <- requireAuthId
-      subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
-      if
-        | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
-        | otherwise -> do
-            subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
-            mr <- (toHtml .) <$> getMessageRender
-            addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
+      mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
+      case mbSubs of
+        Nothing -> return ()
+        (Just subs)
+          | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
+          | otherwise -> do
+              subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
+              mr <- (toHtml .) <$> getMessageRender
+              addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)


  defaultLayout $
@ -671,7 +672,7 @@ postCorrectionsCreateR = do
    FormMissing -> return ()
    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
    FormSuccess (sid, (pss, invalids)) -> do
-      allDone <- fmap getAll . execWriterT $ do 
+      allDone <- fmap getAll . execWriterT $ do
        forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
        tell . All $ null invalids

--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@ -4,7 +4,7 @@ import Import

 import Jobs

-- import Yesod.Form.Bootstrap3  
+-- import Yesod.Form.Bootstrap3

 import Handler.Utils
 import Handler.Utils.Submission
@ -55,7 +55,7 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsu
        (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
    flip (renderAForm FormStandard) html $ (,)
      <$> fileUploadForm
-      <*> ( (:|) 
+      <*> ( (:|)
        -- #227 Part I: change aforced to areq if the user is the lecturer or an admin (lecturer can upload for students)
        <$> aforced ciField (fslpI (MsgSubmissionMember 1) "user@campus.lmu.de" ) self
        <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
@ -66,7 +66,7 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsu
      <*  submitButton
  where
    (groupNr, editableBuddies)
-      | Arbitrary{..} <- grouping = (maxParticipants, True) 
+      | Arbitrary{..} <- grouping = (maxParticipants, True)
      | RegisteredGroups <- grouping = (fromIntegral $ length buddies, False)
      | otherwise = (0, False)

@ -140,7 +140,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
            redirect $ CSubmissionR tid ssh csh shn cID SubShowR
      (Just smid) -> do
        void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
-        
+
        shid' <- submissionSheet <$> get404 smid
        unless (shid == shid') $
          invalidArgsI [MsgSubmissionWrongSheet]
@ -169,7 +169,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
            forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
        return (csheet,buddies,lastEdits)
  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
-  mCID <- runDBJobs $ do
+  mCID <- (fmap join) . msgSubmissionErrors . runDBJobs $ do
    res' <- case res of
      FormMissing              -> return   FormMissing
      (FormFailure failmsgs)   -> return $ FormFailure failmsgs
@ -193,7 +193,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
                     E.&&. submission E.^. SubmissionSheet E.==. E.val shid
                case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3
                  Nothing   -> return ()
-                  Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid 
+                  Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
                return $ E.countRows E.>. E.val (0 :: Int64)
            return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))

@ -252,7 +252,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
        return $ Just cID
      (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml)
      _other -> return Nothing
-  
+
  case mCID of
    Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
    Nothing  -> return ()
@ -281,7 +281,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
              Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
            in timeCell 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 :: ((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
@ -349,7 +349,7 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat

      case results of
        [Entity _ File{ fileContent = Just c, fileTitle }] -> do
-          whenM downloadFiles $ 
+          whenM downloadFiles $
            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
          return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
        [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
@ -359,13 +359,13 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat

 getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
 getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
-  when (sfType == SubmissionCorrected) $ 
+  when (sfType == SubmissionCorrected) $
    guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False

  let filename
        | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
        | otherwise = ZIPArchiveName $ toPathPiece cID
-  
+
  addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
  respondSourceDB "application/zip" $ do
    submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@ -5,6 +5,7 @@ module Handler.Utils.Submission
  , submissionFileSource, submissionFileQuery
  , submissionMultiArchive
  , SubmissionSinkException(..)
+  , msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB!
  , sinkSubmission, sinkMultiSubmission
  , submissionMatchesSheet
  ) where
@ -267,14 +268,6 @@ instance Monoid SubmissionSinkState where
  mempty = memptydefault
  mappend = mappenddefault

-data SubmissionSinkException = DuplicateFileTitle FilePath
-                             | DuplicateRating
-                             | RatingWithoutUpdate
-                             | ForeignRating CryptoFileNameSubmission
-  deriving (Typeable, Show)
-
-instance Exception SubmissionSinkException
-
 submissionBlacklist :: [Pattern]
 submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")

@ -311,6 +304,18 @@ extractRatingsMsg = do
    mr <- (toHtml . ) <$> getMessageRender
    addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)

+-- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
+msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
+msgSubmissionErrors = flip catches
+    [ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: RatingException)
+    , E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException)
+    , E.Handler $ \(SubmissionSinkException sinkId _ sinkEx) -> do
+        mr <- getMessageRender
+        addMessageI Error $ MsgMultiSinkException (toPathPiece sinkId) (mr sinkEx)
+        return Nothing
+    ] . fmap Just
+
+
 sinkSubmission :: UserId
               -> Either SheetId SubmissionId
               -> Bool -- ^ Is this a correction
@ -510,15 +515,6 @@ sinkSubmission userId mExists isUpdate = do
              -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId
            | otherwise -> return ()

-data SubmissionMultiSinkException
-  = SubmissionSinkException
-    { _submissionSinkId :: CryptoFileNameSubmission
-    , _submissionSinkFedFile :: Maybe FilePath
-    , _submissionSinkException :: SubmissionSinkException
-    }
-  deriving (Typeable, Show)
-
-instance Exception SubmissionMultiSinkException

 sinkMultiSubmission :: UserId
                    -> Bool {-^ Are these corrections -}
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@ -8,6 +8,7 @@ import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
 import Model.Rating           as Import
+import Model.Submission       as Import
 import Settings               as Import
 import Settings.StaticFiles   as Import
 import Yesod.Auth             as Import
--- a/src/Model/Submission.hs
+++ b/src/Model/Submission.hs
@ -0,0 +1,22 @@
+module Model.Submission where
+
+import ClassyPrelude.Yesod
+import CryptoID
+
+data SubmissionSinkException = DuplicateFileTitle FilePath
+                             | DuplicateRating
+                             | RatingWithoutUpdate
+                             | ForeignRating CryptoFileNameSubmission
+  deriving (Typeable, Show)
+
+instance Exception SubmissionSinkException
+
+data SubmissionMultiSinkException
+  = SubmissionSinkException
+    { _submissionSinkId :: CryptoFileNameSubmission
+    , _submissionSinkFedFile :: Maybe FilePath
+    , _submissionSinkException :: SubmissionSinkException
+    }
+  deriving (Typeable, Show)
+
+instance Exception SubmissionMultiSinkException