fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

YesodJobDB, cleanup

Browse Source 
Fixes #204
This commit is contained in:
Gregor Kleen 2018-10-14 16:08:03 +02:00
parent d08166420d
commit 72f57e6595
6 changed files with 49 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/de.msg
View File

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

10
src/Foundation.hs
View File

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

22
src/Handler/Corrections.hs
View File

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

6
src/Handler/Submission.hs
View File

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

24
src/Handler/Utils/Submission.hs
View File

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

17
src/Jobs.hs
View File

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