From 460c62dfe50df425fb40417a3bef73e0bc8083a2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 20 Jul 2018 12:57:27 +0200 Subject: [PATCH] Better error messages for submission uploads --- messages/de.msg | 4 +- src/Handler/Corrections.hs | 11 ++-- src/Handler/Utils/Submission.hs | 52 ++++++++++++++----- .../messages/submissionFilesIgnored.hamlet | 11 ++-- 4 files changed, 57 insertions(+), 21 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index a5a17e6fa..de6d18014 100644 --- a/messages/de.msg +++ b/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: \ No newline at end of file +SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert: +SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}. \ No newline at end of file diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 87b132cd4..a3bd66f5a 100644 --- a/src/Handler/Corrections.hs +++ b/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") diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index b65705bd1..00ca2f06b 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 diff --git a/templates/messages/submissionFilesIgnored.hamlet b/templates/messages/submissionFilesIgnored.hamlet index 9c08b02dc..f02bed623 100644 --- a/templates/messages/submissionFilesIgnored.hamlet +++ b/templates/messages/submissionFilesIgnored.hamlet @@ -1,4 +1,9 @@ _{MsgSubmissionFilesIgnored} -