Error Handling für SinkSubmission

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
 

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" <>)

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 $

src/Handler/Submission.hs

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

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

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

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