YesodJobDB, cleanup

Fixes #204

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

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 :: (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 = case route2ap r of
+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 :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
-evalAccess r w = case route2ap r of
+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

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 (rated && isNothing submissionRatingTime) $ do
-
+              $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
-          when notify $
+              queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub 
-            queueJob' . 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
+          runDBJobs . runConduit $ transPipe (lift . lift) fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
-          traverse (writeJobCtl . JobCtlPerform) mjId
 
           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
+      subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
-      forM_ jobs $ writeJobCtl . JobCtlPerform
       if
         | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
         | otherwise -> do

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

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
+              -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId
-            | otherwise -> return Nothing
+            | 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)))
+              (Map SubmissionId (ResumableSink SubmissionContent (YesodJobDB UniWorX) SubmissionId))
-              (YesodDB UniWorX)
+              (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

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