Better error messages for submission uploads

messages/de.msg

@@ -174,6 +174,7 @@ UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den
 CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
 
 CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
+NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
 
 RatingBy: Korrigiert von
 AchievedBonusPoints: Erreichte Bonuspunkte
@@ -222,4 +223,5 @@ LastEdits: Letzte Änderungen
 EditedBy name@Text time@Text: Durch #{name} um #{time}
 LastEdit: Letzte Änderung
 
-SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
+SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
+SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.

src/Handler/Corrections.hs

@@ -14,6 +14,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module Handler.Corrections where
 
@@ -439,9 +440,13 @@ postCorrectionsUploadR = do
     FormSuccess files -> do
       uid <- requireAuthId
       subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
-      subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
-      mr <- (toHtml .) <$> getMessageRender
-      addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
+      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)
+        
 
   defaultLayout $ do
     $(widgetFile "corrections-upload")

src/Handler/Utils/Submission.hs

@@ -24,6 +24,7 @@ module Handler.Utils.Submission
   ) where
 
 import Import hiding ((.=), joinPath)
+import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
 import Control.Lens
 import Control.Lens.Extras (is)
@@ -31,6 +32,7 @@ import Utils.Lens
 
 import Control.Monad.State hiding (forM_, mapM_,foldM)
 import Control.Monad.Writer (MonadWriter(..))
+import Control.Monad.RWS.Lazy (RWST)
 import qualified Control.Monad.Random as Rand
 
 import Data.Maybe
@@ -64,6 +66,8 @@ import System.FilePath.Glob
 
 import Text.Hamlet (ihamletFile)
 
+import qualified Control.Monad.Catch as E (Handler(..))
+
 
 data AssignSubmissionException = NoCorrectorsByProportion
   deriving (Typeable, Show)
@@ -228,7 +232,9 @@ extractRatingsMsg :: ( MonadHandler m
                      , MonadLogger m
                      ) => Conduit File m SubmissionContent
 extractRatingsMsg = do
-  ignored <- filterSubmission `fuseUpstream` Rating.extractRatings
+  ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
+  let ignored :: Set (Either CryptoFileNameSubmission FilePath)
+      ignored = Right `Set.map` ignored'
   mr <- (toHtml . ) <$> getMessageRender
   addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
 
@@ -439,7 +445,9 @@ sinkMultiSubmission userId isUpdate = do
   let
     feed :: SubmissionId
          -> SubmissionContent
-         -> StateT
+         -> RWST
+              ()
+              _
               (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
               (YesodDB UniWorX)
               ()
@@ -449,8 +457,9 @@ sinkMultiSubmission userId isUpdate = do
         Just sink -> return sink
         Nothing -> do
           lift $ do
-            Submission{..} <- get404 sId
             cID <- encrypt sId
+            $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID 
+            Submission{..} <- get404 sId
             Sheet{..} <- get404 submissionSheet
             Course{..} <- get404 sheetCourse
             authRes <- evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
@@ -463,30 +472,45 @@ sinkMultiSubmission userId isUpdate = do
       case sink' of
         Left _ -> error "sinkSubmission returned prematurely"
         Right nSink -> modify $ Map.insert sId nSink
-  sinks <- execStateLC Map.empty . awaitForever $ \case
+  (sinks, ignored) <- execRWSLC () Map.empty . awaitForever $ \case
     v@(Right (sId, _)) -> do
       cID <- encrypt sId
-      handle (throwM . SubmissionSinkException cID Nothing) $
-        lift $ feed sId v
+      $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID
+      lift (feed sId v) `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ]
     (Left f@File{..})  -> do
       let
-        tryDecrypt :: FilePath -> _ (Either SomeException SubmissionId)
-        tryDecrypt (CI.mk -> ciphertext) = try $ decrypt (CryptoID{..} :: CryptoFileNameSubmission)
-        acc (Just cID, fp) segment = return (Just cID, fp ++ [segment])
+        acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath])
+        acc (Just sId, fp) segment = return (Just sId, fp ++ [segment])
         acc (Nothing , fp) segment = do
-          msId <- tryDecrypt segment
-          return . either (const id) (set _1 . Just) msId $ (Nothing, fp)
+          let
+            tryDecrypt ciphertext = do
+              sId <- decrypt (CryptoID (CI.mk segment) :: CryptoFileNameSubmission)
+              Just sId <$ get404 sId
+          msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
+          return (msId, fp)
       (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
-      $logDebugS "sinkMultiSubmission" $ tshow (splitDirectories fileTitle, msId, fileTitle')
       case msId of
-        Nothing -> $logDebugS "sinkMultiSubmission" "Dropped"
+        Nothing -> do
+          $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileTitle, msId, fileTitle')
         Just sId -> do
+          $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle')
           cID <- encrypt sId
           handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
             lift . feed sId $ Left f{ fileTitle = fileTitle' }
+  when (not $ null ignored) $ do
+    mr <- (toHtml .) <$> getMessageRender
+    addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
   fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
     cID <- encrypt sId
-    handle (throwM . SubmissionSinkException cID Nothing) . void $ closeResumableSink sink
+    handle (throwM . SubmissionSinkException cID Nothing) $
+      void $ closeResumableSink sink
+  where
+    handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a)
+    handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident)
+    handleHCError _ e = throwM e
+    handleCryptoID :: CryptoIDError -> _ (Maybe a)
+    handleCryptoID _ = return Nothing
+    
 
 submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB ()
 submissionMatchesSheet tid csh shn cid = do

templates/messages/submissionFilesIgnored.hamlet

@@ -1,4 +1,9 @@
 _{MsgSubmissionFilesIgnored}
-<ul style="font-family: monospace">
-  $forall fileTitle <- ignored
-    <li>#{fileTitle}
+<ul>
+  $forall ident <- ignored
+    $case ident
+      $of Right fileTitle
+        <li style="font-family: monospace">#{fileTitle}
+      $of Left cID
+        <li>Bewertungsdatei für <span style="font-family: monospace">#{toPathPiece cID}</span>
+