diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 35350c9fb..38273c400 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -244,6 +244,7 @@ RatingComment: Kommentar SubmissionUsers: Studenten Rating: Korrektur RatingPoints: Punkte +RatingDone: Bewertung fertiggestellt RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein diff --git a/src/Foundation.hs b/src/Foundation.hs index 9b31952a2..60bb47215 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -68,7 +68,7 @@ import qualified Database.Esqueleto as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Trans.Reader (runReader) +import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Catch (handleAll) @@ -494,14 +494,14 @@ route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK attrsAND = map splitAND $ Set.toList $ routeAttrs r splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" -evalAccessDB :: Route UniWorX -> Bool -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise -evalAccessDB r w = case route2ap r of +evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise +evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer (APHandler p) -> lift $ p r w (APDB p) -> p r w -evalAccess :: Route UniWorX -> Bool -> Handler AuthResult -evalAccess r w = case route2ap r of +evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess r w = liftHandlerT $ case route2ap r of (APPure p) -> runReader (p r w) <$> getMsgRenderer (APHandler p) -> p r w (APDB p) -> runDB $ p r w diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index e5e83648c..5d676b63f 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -450,9 +450,12 @@ postCorrectionR tid ssh csh shn cid = do case results of [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) + pointsForm = case sheetType of + NotGraded -> bool Nothing (Just 0) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) + _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints) ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,) - <$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints) + <$> pointsForm <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment)) <* submitButton @@ -464,11 +467,11 @@ postCorrectionR tid ssh csh shn cid = do FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess (ratingPoints, ratingComment) -> do - notify <- runDB $ do + runDBJobs $ do uid <- liftHandlerT requireAuthId now <- liftIO getCurrentTime - let rated = isJust $ void ratingPoints -- <|> void ratingComment -- Comment shouldn't cause rating + let rated = isJust ratingPoints -- <|> void ratingComment -- Comment shouldn't cause rating Submission{submissionRatingTime} <- getJust sub @@ -482,10 +485,9 @@ postCorrectionR tid ssh csh shn cid = do addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated - return $ rated && isNothing submissionRatingTime - - when notify $ - queueJob' . JobQueueNotification $ NotificationSubmissionRated sub + when (rated && isNothing submissionRatingTime) $ do + $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] + queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub redirect $ CSubmissionR tid ssh csh shn cid CorrectionR @@ -495,8 +497,7 @@ postCorrectionR tid ssh csh shn cid = do FormSuccess fileSource -> do uid <- requireAuthId - (_, mjId) <- runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True - traverse (writeJobCtl . JobCtlPerform) mjId + runDBJobs . runConduit $ transPipe (lift . lift) fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True addMessageI Success MsgRatingFilesUpdated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR @@ -531,8 +532,7 @@ postCorrectionsUploadR = do FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess files -> do uid <- requireAuthId - (subs, jobs) <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True - forM_ jobs $ writeJobCtl . JobCtlPerform + subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True if | null subs -> addMessageI Warning MsgNoCorrectionsUploaded | otherwise -> do diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 83064f530..b8f80cbee 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -20,6 +20,8 @@ module Handler.Submission where import Import hiding (joinPath) +import Jobs + -- import Yesod.Form.Bootstrap3 import Handler.Utils @@ -178,7 +180,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 buddies - mCID <- runDB $ do + mCID <- runDBJobs $ do res' <- case res of (FormMissing ) -> return $ FormMissing (FormFailure failmsgs) -> return $ FormFailure failmsgs @@ -233,7 +235,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do (Nothing, Just smid) -- no new files, existing submission partners updated -> return smid (Just files, _) -> -- new files - fmap fst . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False + runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False (Nothing, Nothing) -- new submission, no file upload requested -> insert Submission { submissionSheet = shid diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index a09e43ed2..9f67bf0e0 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -336,7 +336,7 @@ extractRatingsMsg = do sinkSubmission :: UserId -> Either SheetId SubmissionId -> Bool -- ^ Is this a correction - -> Sink SubmissionContent (YesodDB UniWorX) (SubmissionId, Maybe QueuedJobId) + -> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId -- ^ Replace the currently saved files for the given submission (either -- corrected files or original ones, depending on arguments) with the supplied -- 'SubmissionContent'. @@ -362,13 +362,13 @@ sinkSubmission userId mExists isUpdate = do return sId Right sId -> return sId - (,) <$> pure sId <*> sinkSubmission' sId isUpdate + sId <$ sinkSubmission' sId isUpdate where tell = modify . mappend sinkSubmission' :: SubmissionId -> Bool -- ^ Is this a correction - -> Sink SubmissionContent (YesodDB UniWorX) (Maybe QueuedJobId) + -> Sink SubmissionContent (YesodJobDB UniWorX) () sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case Left file@(File{..}) -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) @@ -466,7 +466,7 @@ sinkSubmission userId mExists isUpdate = do -- The check whether the new version matches the underlying file is -- more lenient, considering only filename and -content. - touchSubmission :: StateT SubmissionSinkState (YesodDB UniWorX) () + touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) () touchSubmission = do alreadyTouched <- gets $ getAny . sinkSubmissionTouched when (not alreadyTouched) $ do @@ -480,7 +480,7 @@ sinkSubmission userId mExists isUpdate = do -- TODO: Should submissionRatingAssigned change here if userId changes? tell $ mempty{ sinkSubmissionTouched = Any True } - finalize :: SubmissionSinkState -> YesodDB UniWorX (Maybe QueuedJobId) + finalize :: SubmissionSinkState -> YesodJobDB UniWorX () finalize SubmissionSinkState{..} = do missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId @@ -518,7 +518,7 @@ sinkSubmission userId mExists isUpdate = do if | isUpdate , not $ getAny sinkSeenRating - -> Nothing <$ update submissionId + -> update submissionId [ SubmissionRatingTime =. Nothing , SubmissionRatingPoints =. Nothing , SubmissionRatingBy =. Nothing @@ -526,8 +526,8 @@ sinkSubmission userId mExists isUpdate = do ] | isUpdate , getAny sinkSubmissionNotifyRating - -> fmap Just . queueJob . JobQueueNotification $ NotificationSubmissionRated submissionId - | otherwise -> return Nothing + -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId + | otherwise -> return () data SubmissionMultiSinkException = SubmissionSinkException @@ -541,7 +541,7 @@ instance Exception SubmissionMultiSinkException sinkMultiSubmission :: UserId -> Bool {-^ Are these corrections -} - -> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId, Set QueuedJobId) + -> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId) -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'. -- @@ -555,8 +555,8 @@ sinkMultiSubmission userId isUpdate = do -> RWST () _ - (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) (SubmissionId, Maybe QueuedJobId))) - (YesodDB UniWorX) + (Map SubmissionId (ResumableSink SubmissionContent (YesodJobDB UniWorX) SubmissionId)) + (YesodJobDB UniWorX) () feed sId val = do mSink <- gets $ Map.lookup sId @@ -605,7 +605,7 @@ sinkMultiSubmission userId isUpdate = do when (not $ null ignored) $ do mr <- (toHtml .) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) - lift . fmap (bimap Set.fromList (Set.fromList . catMaybes) . unzip) . forM (Map.toList sinks) $ \(sId, sink) -> do + lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do cID <- encrypt sId handle (throwM . SubmissionSinkException cID Nothing) $ closeResumableSink sink diff --git a/src/Jobs.hs b/src/Jobs.hs index c10c885a8..cdc14d86d 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -17,6 +17,8 @@ module Jobs ( module Types , writeJobCtl , queueJob, queueJob' + , YesodJobDB + , runDBJobs, queueDBJob , handleJobs ) where @@ -55,13 +57,15 @@ import Cron import qualified Data.HashMap.Strict as HashMap import Data.HashMap.Strict (HashMap) +import qualified Data.Set as Set + import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Foldable (foldrM) import Control.Monad.Trans.Reader (mapReaderT) -import Control.Monad.Trans.Writer (WriterT, execWriterT) +import Control.Monad.Trans.Writer (WriterT(..), execWriterT) import Control.Monad.Trans.State (StateT, evalStateT, mapStateT) import qualified Control.Monad.State.Class as State import Control.Monad.Writer.Class (MonadWriter(..)) @@ -331,6 +335,17 @@ queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m () -- ^ `queueJob` followed by `JobCtlPerform` queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform +type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO)) + +queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) () +queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton + +runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a +runDBJobs act = do + (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act + forM_ jIds $ writeJobCtl . JobCtlPerform + return ret + setSerializable :: DB a -> DB a setSerializable act = setSerializable' (0 :: Integer) where