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
+          res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
-          {-case res of
+          case res of
-            (Left _) -> addMessageI Success MsgRatingFilesUpdated
+            Nothing  -> return () -- ErrorMessages are already added by msgSubmissionErrors
-            (Right RatingNotExpected) -> addMessageI Error MsgRatingNotExpected
+            (Just _) -> do
-            (Right other) -> throw other-}
+              addMessageI Success MsgRatingFilesUpdated
-
+              redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
-          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
+      mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
-      if
+      case mbSubs of
-        | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
+        Nothing -> return ()
-        | otherwise -> do
+        (Just subs)
-            subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
+          | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
-            mr <- (toHtml .) <$> getMessageRender
+          | otherwise -> do
-            addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
+              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
 

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

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